From 59310b22797034552c40d67293b7c77c92fc3d4a Mon Sep 17 00:00:00 2001 From: "Artem V. Ageev" Date: Wed, 15 Jan 2025 21:12:23 +0200 Subject: [PATCH 1/5] Rewrote CI to Pascal --- .github/dependabot.yml | 2 +- .github/workflows/make.pas | 201 ++ .github/workflows/make.yml | 21 +- .gitmodules | 3 - make.ps1 | 105 - make.sh | 80 - .../dev/metadarkstyle/metadarkstyle.lpk | 52 - .../dev/metadarkstyle/metadarkstyle.pas | 22 - .../src/CustomDark.darkstylecolors | 7 - .../dev/metadarkstyle/src/CustomDark.lrs | 5 - .../src/metadarkstyledsgnoptions.pas | 169 -- .../src/metadarkstyledsgnoptionsframe.lfm | 80 - .../src/metadarkstyledsgnoptionsframe.pas | 109 - .../src/registermetadarkstyledsgn.pas | 53 - .../dev/metadarkstyle/src/udarkstyle.pas | 297 -- .../metadarkstyle/src/udarkstyleparams.pas | 44 - .../metadarkstyle/src/udarkstyleschemes.pas | 228 -- .../src/udarkstyleschemesadditional.pas | 16 - .../src/udarkstyleschemesloader.pas | 511 ---- .../dev/metadarkstyle/src/uimport.pas | 150 - .../dev/metadarkstyle/src/umetadarkstyle.pas | 41 - .../metadarkstyle/src/uwin32widgetsetdark.pas | 2419 ----------------- use/metadarkstyle | 1 - 23 files changed, 220 insertions(+), 4396 deletions(-) create mode 100644 .github/workflows/make.pas delete mode 100644 .gitmodules delete mode 100644 make.ps1 delete mode 100644 make.sh delete mode 100644 peazip-sources/dev/metadarkstyle/metadarkstyle.lpk delete mode 100644 peazip-sources/dev/metadarkstyle/metadarkstyle.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/CustomDark.darkstylecolors delete mode 100644 peazip-sources/dev/metadarkstyle/src/CustomDark.lrs delete mode 100644 peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptions.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.lfm delete mode 100644 peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/registermetadarkstyledsgn.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/udarkstyle.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/udarkstyleparams.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/udarkstyleschemes.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/udarkstyleschemesadditional.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/udarkstyleschemesloader.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/uimport.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/umetadarkstyle.pas delete mode 100644 peazip-sources/dev/metadarkstyle/src/uwin32widgetsetdark.pas delete mode 160000 use/metadarkstyle diff --git a/.github/dependabot.yml b/.github/dependabot.yml index 23c4cb3b..64284b90 100644 --- a/.github/dependabot.yml +++ b/.github/dependabot.yml @@ -4,4 +4,4 @@ updates: - package-ecosystem: "github-actions" directory: "/" schedule: - interval: "weekly" + interval: "monthly" diff --git a/.github/workflows/make.pas b/.github/workflows/make.pas new file mode 100644 index 00000000..dbbdfce8 --- /dev/null +++ b/.github/workflows/make.pas @@ -0,0 +1,201 @@ +program Make; +{$mode objfpc}{$H+} + +uses + Classes, + SysUtils, + StrUtils, + FileUtil, + Zipper, + fphttpclient, + RegExpr, + openssl, + opensslsockets, + Process; + +const + Target: string = 'peazip-sources'; + Dependencies: array of string = ('Metadarkstyle'); + +type + Output = record + Code: boolean; + Output: ansistring; + end; + + function CheckModules: Output; + begin + if FileExists('.gitmodules') then + if RunCommand('git', ['submodule', 'update', '--init', '--recursive', + '--force', '--remote'], Result.Output) then + Writeln(stderr, #27'[33m', Result.Output, #27'[0m'); + end; + + function AddPackage(Path: string): Output; + begin + with TRegExpr.Create do + begin + Expression := + {$IFDEF MSWINDOWS} + '(cocoa|x11|_template)' + {$ELSE} + '(cocoa|gdi|_template)' + {$ENDIF} + ; + if not Exec(Path) and RunCommand('lazbuild', ['--add-package-link', Path], + Result.Output) then + Writeln(stderr, #27'[33m', 'added ', Path, #27'[0m'); + Free; + end; + end; + + function BuildProject(Path: string): Output; + var + Line: string; + begin + Write(stderr, #27'[33m', 'build from ', Path, #27'[0m'); + try + Result.Code := RunCommand('lazbuild', ['--build-all', '--recursive', + '--no-write-project', Path], Result.Output); + if Result.Code then + for Line in SplitString(Result.Output, LineEnding) do + begin + if ContainsStr(Line, 'Linking') then + begin + Result.Output := SplitString(Line, ' ')[2]; + Writeln(stderr, #27'[32m', ' to ', Result.Output, #27'[0m'); + break; + end; + end + else + begin + ExitCode += 1; + for Line in SplitString(Result.Output, LineEnding) do + with TRegExpr.Create do + begin + Expression := '(Fatal|Error):'; + if Exec(Line) then + begin + WriteLn(stderr); + Writeln(stderr, #27'[31m', Line, #27'[0m'); + end; + Free; + end; + end; + except + on E: Exception do + WriteLn(stderr, 'Error: ' + E.ClassName + #13#10 + E.Message); + end; + end; + + function RunTest(Path: string): Output; + var + Temp: string; + begin + Result := BuildProject(Path); + Temp:= Result.Output; + if Result.Code then + try + if not RunCommand(Temp, ['--all', '--format=plain', '--progress'], Result.Output) then + ExitCode += 1; + WriteLn(stderr, Result.Output); + except + on E: Exception do + WriteLn(stderr, 'Error: ' + E.ClassName + #13#10 + E.Message); + end; + end; + + function AddOPM(Each: string): string; + var + TempFile, Url: string; + Zip: TStream; + begin + Result := + {$IFDEF MSWINDOWS} + GetEnvironmentVariable('APPDATA') + '\.lazarus\onlinepackagemanager\packages\' + {$ELSE} + GetEnvironmentVariable('HOME') + '/.lazarus/onlinepackagemanager/packages/' + {$ENDIF} + + Each; + TempFile := GetTempFileName; + Url := 'https://packages.lazarus-ide.org/' + Each + '.zip'; + if not DirectoryExists(Result) then + begin + Zip := TFileStream.Create(TempFile, fmCreate or fmOpenWrite); + with TFPHttpClient.Create(nil) do + begin + try + AddHeader('User-Agent', 'Mozilla/5.0 (compatible; fpweb)'); + AllowRedirect := True; + Get(Url, Zip); + WriteLn(stderr, 'Download from ', Url, ' to ', TempFile); + finally + Free; + end; + end; + Zip.Free; + CreateDir(Result); + with TUnZipper.Create do + begin + try + FileName := TempFile; + OutputPath := Result; + Examine; + UnZipAllFiles; + WriteLn(stderr, 'Unzip from ', TempFile, ' to ', Result); + finally + Free; + end; + end; + DeleteFile(TempFile); + end; + end; + + procedure Main; + var + Each, Item: string; + List: TStringList; + begin + CheckModules; + InitSSLInterface; + for Each in Dependencies do + begin + List := FindAllFiles(AddOPM(Each), '*.lpk', True); + try + for Item in List do + AddPackage(Item); + finally + List.Free; + end; + end; + List := FindAllFiles(GetCurrentDir, '*.lpk', True); + try + for Each in List do + AddPackage(Each); + finally + List.Free; + end; + List := FindAllFiles(Target, '*.lpi', True); + try + for Each in List do + begin + if not ContainsStr(Each, 'dragdropfilesdll') then + if ContainsStr(ReadFileToString(ReplaceStr(Each, '.lpi', '.lpr')), + 'consoletestrunner') then + RunTest(Each) + else + BuildProject(Each); + end; + finally + List.Free; + end; + WriteLn(stderr); + if ExitCode <> 0 then + WriteLn(stderr, #27'[31m', 'Errors: ', ExitCode, #27'[0m') + else + WriteLn(stderr, #27'[32m', 'Errors: ', ExitCode, #27'[0m'); + end; + +begin + Main; +end. diff --git a/.github/workflows/make.yml b/.github/workflows/make.yml index d12f06a9..cc34f435 100644 --- a/.github/workflows/make.yml +++ b/.github/workflows/make.yml @@ -2,12 +2,13 @@ name: Make on: + schedule: + - cron: '0 0 1 * *' push: branches: - "**" pull_request: branches: - - sources - master - main @@ -33,9 +34,23 @@ jobs: - name: Build on Linux if: runner.os == 'Linux' shell: bash - run: bash make.sh build + run: | + set -xeuo pipefail + sudo bash -c 'apt-get update; apt-get install -y lazarus' >/dev/null + instantfpc -Fu/usr/lib/lazarus/*/components/lazutils .github/workflows/make.pas - name: Build on Windows if: runner.os == 'Windows' shell: powershell - run: pwsh -File make.ps1 build + run: | + New-Variable -Option Constant -Name VAR -Value @{ + Uri = 'https://fossies.org/windows/misc/lazarus-3.6-fpc-3.2.2-win64.exe' + OutFile = (New-TemporaryFile).FullName + '.exe' + } + Invoke-WebRequest @VAR + & $VAR.OutFile.Replace('Temp', 'Temp\.') /SP- /VERYSILENT /SUPPRESSMSGBOXES /NORESTART | Out-Null + $Env:PATH+=';C:\Lazarus' + $Env:PATH+=';C:\Lazarus\fpc\3.2.2\bin\x86_64-win64' + (Get-Command 'lazbuild').Source | Out-Host + (Get-Command 'instantfpc').Source | Out-Host + instantfpc '-FuC:\Lazarus\components\lazutils' .github/workflows/make.pas diff --git a/.gitmodules b/.gitmodules deleted file mode 100644 index d7de15c3..00000000 --- a/.gitmodules +++ /dev/null @@ -1,3 +0,0 @@ -[submodule "use/metadarkstyle"] - path = use/metadarkstyle - url = https://github.com/zamtmn/metadarkstyle.git diff --git a/make.ps1 b/make.ps1 deleted file mode 100644 index 8b70c38e..00000000 --- a/make.ps1 +++ /dev/null @@ -1,105 +0,0 @@ -#!/usr/bin/env pwsh -############################################################################################################## - -Function Show-Usage { - Return " -Usage: pwsh -File $($PSCommandPath) [OPTIONS] -Options: - build Build program -" -} - -Function Request-File { - ForEach ($REPLY in $args) { - $params = @{ - Uri = $REPLY - OutFile = (Split-Path -Path $REPLY -Leaf).Split('?')[0] - } - Invoke-WebRequest @params | Out-Null - Return $params.OutFile - } -} - -Function Install-Program { - While ($Input.MoveNext()) { - Switch ((Split-Path -Path $Input.Current -Leaf).Split('.')[-1]) { - 'msi' { - & msiexec /passive /package $Input.Current | Out-Host - } - 'exe' { - & ".\$($Input.Current)" /SP- /VERYSILENT /SUPPRESSMSGBOXES /NORESTART | Out-Host - } - } - Remove-Item $Input.Current - } -} - -Function Build-Project { - $VAR = @{ - Use = 'use' - Cmd = 'lazbuild' - Url = 'https://fossies.org/windows/misc/lazarus-3.6-fpc-3.2.2-win64.exe' - Path = "C:\Lazarus" - } - Try { - Get-Command $VAR.Cmd - } Catch { - "Install $($VAR.Path)" | Out-Host - Request-File $VAR.Url | Install-Program - $env:PATH+=";$($VAR.Path)" - Get-Command $VAR.Cmd - } - If (Test-Path -Path $($VAR.Use)) { - & git submodule update --init --recursive --force --remote | Out-Host - $COMPONENTS = "$($VAR.Use)\components.txt" - If (Test-Path -Path $COMPONENTS) { - 'Download packages:' | Out-Host - Get-Content -Path $COMPONENTS | ForEach-Object { - If ((! (& $VAR.Cmd --verbose-pkgsearch $_ )) && - (! (& $VAR.Cmd --add-package $_)) && - (! (Test-Path -Path "$($VAR.Use)\$($_)"))) { - " download package $($_)" | Out-Host - $OutFile = Request-File "https://packages.lazarus-ide.org/$($_).zip" - Expand-Archive -Path $OutFile -DestinationPath "$($VAR.Use)\$($_)" -Force - Remove-Item $OutFile - } - } - } - 'Add dependencies:' | Out-Host - Get-ChildItem -Filter '*.lpk' -Recurse -File –Path 'use'| Sort-Object | ForEach-Object { - " add dependence $($_)" | Out-Host - & $VAR.Cmd --add-package-link $_ | Out-Host - } - } - 'Build projects:' | Out-Host - Get-ChildItem -Filter '*.lpi' -Recurse -File –Path 'peazip-sources'| Sort-Object | ForEach-Object { - " build project $($_)" | Out-Host - If (! (& $VAR.Cmd --no-write-project --recursive $_)) { - & $VAR.Cmd --no-write-project --recursive $_ | Out-Host - $exitCode = $LastExitCode - Throw $exitCode - } - } - "Done!" | Out-Host -} - -Function Switch-Action { - $ErrorActionPreference = 'stop' - Set-PSDebug -Strict # -Trace 1 - Invoke-ScriptAnalyzer -EnableExit -Path $PSCommandPath - If ($args.count -gt 0) { - Switch ($args[0]) { - 'build' { - Build-Project - } - Default { - Show-Usage - } - } - } Else { - Show-Usage - } -} - -############################################################################################################## -Switch-Action @args | Out-Null diff --git a/make.sh b/make.sh deleted file mode 100644 index 8b090797..00000000 --- a/make.sh +++ /dev/null @@ -1,80 +0,0 @@ -#!/usr/bin/env bash - -function priv_clippit -( - cat <&2 - sudo apt-get update - sudo apt-get install -y lazarus{-ide-qt5,} - ;; - esac - fi - declare -r COMPONENTS='use/components.txt' - if [[ -d "${COMPONENTS%%/*}" ]]; then - if [[ -f '.gitmodules' ]]; then - git submodule update --init --recursive --force --remote - fi - if [[ -f "${COMPONENTS}" ]]; then - while read -r; do - if [[ -n "${REPLY}" ]] && - ! (lazbuild --verbose-pkgsearch "${REPLY}") && - ! (lazbuild --add-package "${REPLY}") && - ! [[ -d "${COMPONENTS%%/*}/${REPLY}" ]]; then - printf '\x1b[32m\tdownload package %s\x1b[0m\n' "${REPLY}" 1>&2 - declare -A VAR=( - [url]="https://packages.lazarus-ide.org/${REPLY}.zip" - [out]=$(mktemp) - ) - wget --quiet --output-document "${VAR[out]}" "${VAR[url]}" >/dev/null - unzip -o "${VAR[out]}" -d "${COMPONENTS%%/*}/${REPLY}" - rm --verbose "${VAR[out]}" - fi - done < "${COMPONENTS}" - fi - find "${COMPONENTS%%/*}" -type 'f' -name '*.lpk' -exec \ - lazbuild --add-package-link {} + - fi - printf '\x1b[32mBuild projects:\x1b[0m\n' 1>&2 - declare -i errors=0 - while read -r; do - declare -A VAR=( - [out]=$(mktemp) - ) - if (lazbuild --recursive --no-write-project --widgetset='qt5' --build-all "${REPLY}" > "${VAR[out]}"); then - printf '\x1b[32m\t[%s]\tbuild project\t%s\x1b[0m\n' "${?}" "${REPLY}" - grep --color='always' 'Linking' "${VAR[out]}" - else - printf '\x1b[31m\t[%s]\tbuild project\t%s\x1b[0m\n' "${?}" "${REPLY}" - grep --color='always' --extended-regexp '(Error|Fatal):' "${VAR[out]}" - ((errors+=1)) - fi 1>&2 - done < <(find 'peazip-sources' -type 'f' -name '*.lpi' | grep -vE '(backup|dragdropfilesdll|project_demo_lib)' | sort) - exit "${errors}" -) - -function priv_main -( - set -euo pipefail - if ((${#})); then - case ${1} in - build) priv_lazbuild ;; - *) priv_clippit ;; - esac - else - priv_clippit - fi -) - -priv_main "${@}" >/dev/null diff --git a/peazip-sources/dev/metadarkstyle/metadarkstyle.lpk b/peazip-sources/dev/metadarkstyle/metadarkstyle.lpk deleted file mode 100644 index ee4a1f10..00000000 --- a/peazip-sources/dev/metadarkstyle/metadarkstyle.lpk +++ /dev/null @@ -1,52 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/peazip-sources/dev/metadarkstyle/metadarkstyle.pas b/peazip-sources/dev/metadarkstyle/metadarkstyle.pas deleted file mode 100644 index 48d37e0b..00000000 --- a/peazip-sources/dev/metadarkstyle/metadarkstyle.pas +++ /dev/null @@ -1,22 +0,0 @@ -{ This file was automatically created by Lazarus. Do not edit! - This source is only used to compile and install the package. - } - -unit MetaDarkStyle; - -{$warn 5023 off : no warning about unused units} -interface - -uses - uMetaDarkStyle, uDarkStyleParams, uDarkStyleSchemesAdditional, - LazarusPackageIntf; - -implementation - -procedure Register; -begin -end; - -initialization - RegisterPackage('MetaDarkStyle', @Register); -end. diff --git a/peazip-sources/dev/metadarkstyle/src/CustomDark.darkstylecolors b/peazip-sources/dev/metadarkstyle/src/CustomDark.darkstylecolors deleted file mode 100644 index a0bf8483..00000000 --- a/peazip-sources/dev/metadarkstyle/src/CustomDark.darkstylecolors +++ /dev/null @@ -1,7 +0,0 @@ -begin - Scheme:=DefaultDark; - CustomDrawScrollbars:=true; - CustomDrawPushButtons:=true; - CustomDrawComboBoxs:=true; - CustomDrawTreeViews:=true; -end. \ No newline at end of file diff --git a/peazip-sources/dev/metadarkstyle/src/CustomDark.lrs b/peazip-sources/dev/metadarkstyle/src/CustomDark.lrs deleted file mode 100644 index 03008bc1..00000000 --- a/peazip-sources/dev/metadarkstyle/src/CustomDark.lrs +++ /dev/null @@ -1,5 +0,0 @@ -LazarusResources.Add('CustomDark','DARKSTYLECOLORS',[ - 'begin'#13#10' Scheme:=DefaultDark;'#13#10' CustomDrawScrollbars:=true;'#13 - +#10' CustomDrawPushButtons:=true;'#13#10' CustomDrawComboBoxs:=true;'#13#10 - +' CustomDrawTreeViews:=true;'#13#10'end.' -]); diff --git a/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptions.pas b/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptions.pas deleted file mode 100644 index db5f11c7..00000000 --- a/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptions.pas +++ /dev/null @@ -1,169 +0,0 @@ -unit MetaDarkStyleDSGNOptions; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, - LazConfigStorage, LazFileUtils, LazFileCache, - LCLProc, ComCtrls, Graphics, - BaseIDEIntf; - -const - amOptAllowDarkName='Allow dark'; - amOptForceDarkName='Force dark'; - amOptForceLightName='Force light'; -resourcestring - RSamOptAllowDarkName=amOptAllowDarkName; - RSamOptForceDarkName=amOptForceDarkName; - RSamOptForceLightName=amOptForceLightName; - -type - TAppModeOpt=(amOptAllowDark,amOptForceDark,amOptForceLight); - -const - AppModeOptStr:array[TAppModeOpt] of String=(amOptAllowDarkName,amOptForceDarkName,amOptForceLightName); - AppModeOptLocalizedStr:array[TAppModeOpt] of String=(RSamOptAllowDarkName,RSamOptForceDarkName,RSamOptForceLightName); - -type - - TMetaDarkStyleDSGNOptions=class - private - const - DefaultAppMode:TAppModeOpt=amOptAllowDark; - DefaultColorScheme:String='Dark'; - var - FAppMode:TAppModeOpt; - FColorScheme:String; - FChangeStamp:Integer; - FLastSavedChangeStamp:Integer; - procedure SetAppMode(AValue:TAppModeOpt); - procedure SetColorScheme(AValue:String); - function GetModified:Boolean; - procedure SetModified(AValue: Boolean); - function Str2AppModeOpt(str:string):TAppModeOpt; - public - constructor Create; - procedure SaveSafe; - procedure LoadSafe; - procedure SaveToFile(AFilename:String); - procedure LoadFromFile(AFilename:String); - procedure IncreaseChangeStamp; - public - property ChangeStamp:Integer read FChangeStamp; - property Modified:Boolean read GetModified write SetModified; - - property AppMode:TAppModeOpt read FAppMode write SetAppMode; - property ColorScheme:String read FColorScheme write SetColorScheme; - end; - -const - MetaDarkStyleDSGNFileName='metadarkstyledsgnoptions.xml'; - -var - MetaDarkStyleDSGNOpt: TMetaDarkStyleDSGNOptions = nil; - -implementation - -{ TDockedOptions } - -function TMetaDarkStyleDSGNOptions.GetModified:Boolean; -begin - Result:=FLastSavedChangeStamp<>FChangeStamp; -end; - -procedure TMetaDarkStyleDSGNOptions.SetModified(AValue:Boolean); -begin - if AValue then - IncreaseChangeStamp - else - FLastSavedChangeStamp:=FChangeStamp; -end; - -procedure TMetaDarkStyleDSGNOptions.SetAppMode(AValue:TAppModeOpt); -begin - if FAppMode=AValue then Exit; - FAppMode:=AValue; - IncreaseChangeStamp; -end; - -procedure TMetaDarkStyleDSGNOptions.SetColorScheme(AValue:String); -begin - if FColorScheme=AValue then Exit; - FColorScheme:=AValue; - IncreaseChangeStamp; -end; - -constructor TMetaDarkStyleDSGNOptions.Create; -begin - FAppMode:=DefaultAppMode; - FChangeStamp:=LUInvalidChangeStamp+1; - FLastSavedChangeStamp:=FChangeStamp; -end; - -procedure TMetaDarkStyleDSGNOptions.SaveSafe; -begin - try - SaveToFile(MetaDarkStyleDSGNFileName); - Modified:=False; - except - on E: Exception do - DebugLn(['Error: (lazarus) [TMetaDarkStyleDSGNOptions.SaveSafe] ', E.Message]); - end; -end; - -procedure TMetaDarkStyleDSGNOptions.LoadSafe; -begin - try - LoadFromFile(MetaDarkStyleDSGNFileName); - except - on E: Exception do - DebugLn(['Error: (lazarus) [TMetaDarkStyleDSGNOptions.LoadSafe] ', E.Message]); - end; - Modified:=False; -end; - -procedure TMetaDarkStyleDSGNOptions.SaveToFile(AFilename: String); -var - Cfg: TConfigStorage; -begin - Cfg:=GetIDEConfigStorage(AFilename,False); - try - Cfg.SetDeleteValue('AppMode/Value',AppModeOptStr[AppMode],AppModeOptStr[DefaultAppMode]); - Cfg.SetDeleteValue('ColorScheme/Value',ColorScheme,DefaultColorScheme); - finally - Cfg.Free; - end; -end; - -function TMetaDarkStyleDSGNOptions.Str2AppModeOpt(str:string):TAppModeOpt; -var - i:TAppModeOpt; -begin - for i:=low(AppModeOptStr) to high(AppModeOptStr) do - if AppModeOptStr[i]=str then - exit(i); - result:=DefaultAppMode; -end; - -procedure TMetaDarkStyleDSGNOptions.LoadFromFile(AFilename: String); -var - Cfg: TConfigStorage; -begin - Cfg := GetIDEConfigStorage(AFilename,True); - try - AppMode:= Str2AppModeOpt(Cfg.GetValue('AppMode/Value',AppModeOptStr[DefaultAppMode])); - ColorScheme:= Cfg.GetValue('ColorScheme/Value',DefaultColorScheme); - finally - Cfg.Free; - end; -end; - -procedure TMetaDarkStyleDSGNOptions.IncreaseChangeStamp; -begin - LUIncreaseChangeStamp(FChangeStamp); -end; - -end. - diff --git a/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.lfm b/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.lfm deleted file mode 100644 index 7ce56863..00000000 --- a/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.lfm +++ /dev/null @@ -1,80 +0,0 @@ -object DarkStyleDSGNOptionsFrame: TDarkStyleDSGNOptionsFrame - Left = 0 - Height = 360 - Top = 0 - Width = 480 - ClientHeight = 360 - ClientWidth = 480 - DesignTimePPI = 144 - ParentBackground = False - ParentFont = False - TabOrder = 0 - DesignLeft = 556 - DesignTop = 10 - object Label1: TLabel - AnchorSideLeft.Control = Owner - AnchorSideTop.Control = PAMComboBox - AnchorSideTop.Side = asrCenter - Left = 6 - Height = 25 - Top = 10 - Width = 265 - BorderSpacing.Left = 6 - BorderSpacing.Right = 6 - Caption = 'PreferredAppMode (Need restart)' - end - object PAMComboBox: TComboBox - AnchorSideLeft.Control = Label1 - AnchorSideLeft.Side = asrBottom - AnchorSideTop.Control = Owner - AnchorSideRight.Control = Owner - AnchorSideRight.Side = asrBottom - Left = 277 - Height = 33 - Top = 6 - Width = 197 - Anchors = [akTop, akLeft, akRight] - BorderSpacing.Top = 6 - BorderSpacing.Right = 6 - ItemHeight = 25 - Items.Strings = ( - 'Default' - 'AllowDark' - 'ForceDark' - 'ForceLight' - ) - ParentFont = False - Style = csDropDownList - TabOrder = 0 - end - object CSComboBox: TComboBox - AnchorSideLeft.Control = Label2 - AnchorSideLeft.Side = asrBottom - AnchorSideTop.Control = PAMComboBox - AnchorSideTop.Side = asrBottom - AnchorSideRight.Control = Owner - AnchorSideRight.Side = asrBottom - Left = 120 - Height = 33 - Top = 45 - Width = 354 - Anchors = [akTop, akLeft, akRight] - BorderSpacing.Top = 6 - BorderSpacing.Right = 6 - ItemHeight = 25 - Style = csDropDownList - TabOrder = 1 - end - object Label2: TLabel - AnchorSideLeft.Control = Owner - AnchorSideTop.Control = CSComboBox - AnchorSideTop.Side = asrCenter - Left = 6 - Height = 25 - Top = 49 - Width = 108 - BorderSpacing.Left = 6 - BorderSpacing.Right = 6 - Caption = 'Color scheme' - end -end diff --git a/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.pas b/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.pas deleted file mode 100644 index f067a2f6..00000000 --- a/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.pas +++ /dev/null @@ -1,109 +0,0 @@ -unit MetaDarkStyleDSGNOptionsFrame; - -{$mode ObjFPC}{$H+} - -interface - -uses - Classes, SysUtils, Forms, Controls, StdCtrls, - IDEOptionsIntf,IDEOptEditorIntf, - MetaDarkStyleDSGNOptions,uDarkStyleSchemes; - -resourceString - RSDarkStyleDSGNOptionsFrame='Dark style'; - - -type - - { TDarkStyleDSGNOptionsFrame } - - TDarkStyleDSGNOptionsFrame = class(TAbstractIDEOptionsEditor) - PAMComboBox: TComboBox; - CSComboBox: TComboBox; - Label1: TLabel; - Label2: TLabel; - private - - public - function GetTitle: String; override; - procedure Setup({%H-}ADialog: TAbstractOptionsEditorDialog); override; - procedure ReadSettings({%H-}AOptions: TAbstractIDEOptions); override; - procedure WriteSettings({%H-}AOptions: TAbstractIDEOptions); override; - procedure RestoreSettings({%H-}AOptions: TAbstractIDEOptions); override; - class function SupportedOptionsClass: TAbstractIDEOptionsClass; override; - end; - -implementation - -{$R *.lfm} - -function TDarkStyleDSGNOptionsFrame.GetTitle: String; -begin - result:=RSDarkStyleDSGNOptionsFrame; -end; - -procedure SchemeToComboSet(ASch:string;ACombo:TComboBox;curr:integer); -begin - if ASch=MetaDarkStyleDSGNOpt.ColorScheme then - ACombo.ItemIndex:=curr; -end; - -procedure TDarkStyleDSGNOptionsFrame.Setup({%H-}ADialog: TAbstractOptionsEditorDialog); -var - i:TAppModeOpt; - itr:TSchemes.TIterator; -begin - PAMComboBox.Items.Clear; - for i:=low(AppModeOptStr) to high(AppModeOptStr) do - PAMComboBox.Items.Add(AppModeOptLocalizedStr[i]); - CSComboBox.Items.Clear; - CSComboBox.Items.Add('Dark'); - CSComboBox.Items.Add('White'); - if Schemes<>nil then begin - itr:=Schemes.Min; - if itr<>nil then repeat - CSComboBox.Items.Add(itr.Data.Value.Name); - until not itr.Next; - itr.free; - end; -end; - -procedure TDarkStyleDSGNOptionsFrame.ReadSettings({%H-}AOptions: TAbstractIDEOptions); -begin - RestoreSettings(AOptions); -end; - -procedure TDarkStyleDSGNOptionsFrame.WriteSettings({%H-}AOptions: TAbstractIDEOptions); -begin - MetaDarkStyleDSGNOpt.AppMode:=TAppModeOpt(PAMComboBox.ItemIndex); - MetaDarkStyleDSGNOpt.ColorScheme:=CSComboBox.Items[CSComboBox.ItemIndex]; - if MetaDarkStyleDSGNOpt.Modified then - MetaDarkStyleDSGNOpt.SaveSafe; -end; - -procedure TDarkStyleDSGNOptionsFrame.RestoreSettings({%H-}AOptions: TAbstractIDEOptions); -var - itr:TSchemes.TIterator; - i:integer; -begin - PAMComboBox.ItemIndex:=ord(MetaDarkStyleDSGNOpt.AppMode); - SchemeToComboSet('Dark',CSComboBox,0); - SchemeToComboSet('White',CSComboBox,1); - if Schemes<>nil then begin - itr:=Schemes.Min; - i:=2; - if itr<>nil then repeat - SchemeToComboSet(itr.Data.Value.Name,CSComboBox,i); - inc(i); - until not itr.Next; - itr.free; - end; -end; - -class function TDarkStyleDSGNOptionsFrame.SupportedOptionsClass: TAbstractIDEOptionsClass; -begin - Result:=IDEEditorGroups.GetByIndex(GroupEnvironment)^.GroupClass; -end; - -end. - diff --git a/peazip-sources/dev/metadarkstyle/src/registermetadarkstyledsgn.pas b/peazip-sources/dev/metadarkstyle/src/registermetadarkstyledsgn.pas deleted file mode 100644 index 52705fd1..00000000 --- a/peazip-sources/dev/metadarkstyle/src/registermetadarkstyledsgn.pas +++ /dev/null @@ -1,53 +0,0 @@ -unit registerMetaDarkStyleDSGN; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, - IDEOptionsIntf, IDEOptEditorIntf, LazIDEIntf, lazconf, - uDarkStyleParams, uDarkStyleSchemes, uMetaDarkStyle, - MetaDarkStyleDSGNOptionsFrame, MetaDarkStyleDSGNOptions; - -var - MetaDarkStyleOptionsID: integer = 1000; - - -procedure Register; - -implementation - -function AppModeOpt2PreferredAppMode(am:TAppModeOpt):TPreferredAppMode; -begin - case am of - amOptAllowDark:result:=pamAllowDark; - amOptForceDark:result:=pamForceDark; - amOptForceLight:result:=pamForceLight; - end; -end; - -procedure SetDarkStyle; -begin - {$IF DEFINED(MSWINDOWS)} - LoadLResources; - LoadPath(GetPrimaryConfigPath+'/userschemes','*.'+DSColorsTypeName); - LoadPath(GetSecondaryConfigPath+'/userschemes','*.'+DSColorsTypeName); - MetaDarkStyleDSGNOpt:=TMetaDarkStyleDSGNOptions.Create; - MetaDarkStyleDSGNOpt.LoadSafe; - PreferredAppMode:=AppModeOpt2PreferredAppMode(MetaDarkStyleDSGNOpt.AppMode); - ApplyMetaDarkStyle(GetScheme(MetaDarkStyleDSGNOpt.ColorScheme)); - {$ENDIF} -end; - -procedure Register; -begin - MetaDarkStyleOptionsID:=RegisterIDEOptionsEditor(GroupEnvironment, - TDarkStyleDSGNOptionsFrame, - MetaDarkStyleOptionsID)^.Index; -end; - -initialization - AddBootHandler(libhEnvironmentOptionsLoaded,@SetDarkStyle); -end. - diff --git a/peazip-sources/dev/metadarkstyle/src/udarkstyle.pas b/peazip-sources/dev/metadarkstyle/src/udarkstyle.pas deleted file mode 100644 index 992b14d6..00000000 --- a/peazip-sources/dev/metadarkstyle/src/udarkstyle.pas +++ /dev/null @@ -1,297 +0,0 @@ -{ - Double Commander - ------------------------------------------------------------------------- - Dark mode support unit (Windows 10 + Qt5). - - Copyright (C) 2019-2021 Richard Yu - Copyright (C) 2019-2022 Alexander Koblov (alexx2000@mail.ru) - - Permission is hereby granted, free of charge, to any person obtaining a copy - of this software and associated documentation files (the "Software"), to deal - in the Software without restriction, including without limitation the rights - to use, copy, modify, merge, publish, distribute, sublicense, and/or sell - copies of the Software, and to permit persons to whom the Software is - furnished to do so, subject to the following conditions: - - The above copyright notice and this permission notice shall be included in all - copies or substantial portions of the Software. - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR - IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE - AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER - LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, - OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE - SOFTWARE. -} - -unit uDarkStyle; - -{$mode delphi} - -interface - -uses - Classes, SysUtils, Windows; - -var - g_buildNumber: DWORD = 0; - //g_darkModeEnabled: bool = false; - g_darkModeSupported: bool = false; - //gAppMode: integer = 1; - -{$IF DEFINED(LCLQT5) OR DEFINED(LCLQT6)} -procedure ApplyDarkStyle; -{$ENDIF} - -procedure RefreshTitleBarThemeColor(hWnd: HWND); -function AllowDarkModeForWindow(hWnd: HWND; allow: bool): bool; -procedure InitDarkMode; - -implementation - -uses - UxTheme, JwaWinUser, FileInfo, uDarkStyleParams - {$IF DEFINED(LCLQT5)} - ,Qt5 - {$ENDIF} - {$IF DEFINED(LCLQT6)} - ,Qt6 - {$ENDIF} - ; - -var - AppMode: TPreferredAppMode; - -var - RtlGetNtVersionNumbers: procedure(major, minor, build: LPDWORD); stdcall; - DwmSetWindowAttribute: function(hwnd: HWND; dwAttribute: DWORD; pvAttribute: Pointer; cbAttribute: DWORD): HRESULT; stdcall; - // 1809 17763 - _ShouldAppsUseDarkMode: function(): bool; stdcall; // ordinal 132 - _AllowDarkModeForWindow: function(hWnd: HWND; allow: bool): bool; stdcall; // ordinal 133 - _AllowDarkModeForApp: function(allow: bool): bool; stdcall; // ordinal 135, removed since 18334 - _RefreshImmersiveColorPolicyState: procedure(); stdcall; // ordinal 104 - _IsDarkModeAllowedForWindow: function(hWnd: HWND): bool; stdcall; // ordinal 137 - // Insider 18334 - _SetPreferredAppMode: function(appMode: TPreferredAppMode): TPreferredAppMode; stdcall; // ordinal 135, since 18334 - -function AllowDarkModeForWindow(hWnd: HWND; allow: bool): bool; -begin - if (g_darkModeSupported) then - Result:= _AllowDarkModeForWindow(hWnd, allow) - else - Result:= false; -end; - -function IsHighContrast(): bool; -var - highContrast: HIGHCONTRASTW; -begin - highContrast.cbSize:= SizeOf(HIGHCONTRASTW); - if (SystemParametersInfoW(SPI_GETHIGHCONTRAST, SizeOf(highContrast), @highContrast, 0)) then - Result:= (highContrast.dwFlags and HCF_HIGHCONTRASTON <> 0) - else - Result:= false; -end; - -function ShouldAppsUseDarkMode: Boolean; -var - bb:bool; -begin - bb:=_ShouldAppsUseDarkMode(); - Result:= (_ShouldAppsUseDarkMode() or (AppMode = pamForceDark)) and not IsHighContrast(); -end; - -procedure RefreshTitleBarThemeColor(hWnd: HWND); -const - DWMWA_USE_IMMERSIVE_DARK_MODE_OLD = 19; - DWMWA_USE_IMMERSIVE_DARK_MODE_NEW = 20; -var - dark: BOOL; - dwAttribute: DWORD; -begin - dark:= (_IsDarkModeAllowedForWindow(hWnd) and ShouldAppsUseDarkMode); - - if (Win32BuildNumber < 19041) then - dwAttribute:= DWMWA_USE_IMMERSIVE_DARK_MODE_OLD - else begin - dwAttribute:= DWMWA_USE_IMMERSIVE_DARK_MODE_NEW; - end; - - DwmSetWindowAttribute(hwnd, dwAttribute, @dark, SizeOf(dark)); -end; - -procedure AllowDarkModeForApp(allow: bool); -begin - if Assigned(_AllowDarkModeForApp) then - _AllowDarkModeForApp(allow) - else if Assigned(_SetPreferredAppMode) then - begin - if (allow) then - _SetPreferredAppMode(AppMode) - else - _SetPreferredAppMode(pamDefault); - end; -end; - -{$IF DEFINED(LCLQT5) OR DEFINED(LCLQT6)} -procedure ApplyDarkStyle; -const - StyleName: WideString = 'Fusion'; -var - AColor: TQColor; - APalette: QPaletteH; - - function QColor(R: Integer; G: Integer; B: Integer; A: Integer = 255): PQColor; - begin - Result:= @AColor; - QColor_fromRgb(Result, R, G, B, A); - end; - -begin - //g_darkModeEnabled:= True; - - QApplication_setStyle(QStyleFactory_create(@StyleName)); - - APalette:= QPalette_Create(); - - // Modify palette to dark - if (AppMode = pamForceDark) then - begin - // DarkMode Pallete - QPalette_setColor(APalette, QPaletteWindow, QColor(53, 53, 53)); - QPalette_setColor(APalette, QPaletteWindowText, QColor(255, 255, 255)); - QPalette_setColor(APalette, QPaletteDisabled, QPaletteWindowText, QColor(127, 127, 127)); - QPalette_setColor(APalette, QPaletteBase, QColor(42, 42, 42)); - QPalette_setColor(APalette, QPaletteAlternateBase, QColor(66, 66, 66)); - QPalette_setColor(APalette, QPaletteToolTipBase, QColor(255, 255, 255)); - QPalette_setColor(APalette, QPaletteToolTipText, QColor(53, 53, 53)); - QPalette_setColor(APalette, QPaletteText, QColor(255, 255, 255)); - QPalette_setColor(APalette, QPaletteDisabled, QPaletteText, QColor(127, 127, 127)); - QPalette_setColor(APalette, QPaletteDark, QColor(35, 35, 35)); - QPalette_setColor(APalette, QPaletteLight, QColor(66, 66, 66)); - QPalette_setColor(APalette, QPaletteShadow, QColor(20, 20, 20)); - QPalette_setColor(APalette, QPaletteButton, QColor(53, 53, 53)); - QPalette_setColor(APalette, QPaletteButtonText, QColor(255, 255, 255)); - QPalette_setColor(APalette, QPaletteDisabled, QPaletteButtonText, QColor(127, 127, 127)); - QPalette_setColor(APalette, QPaletteBrightText, QColor(255, 0, 0)); - QPalette_setColor(APalette, QPaletteLink, QColor(42, 130, 218)); - QPalette_setColor(APalette, QPaletteHighlight, QColor(42, 130, 218)); - QPalette_setColor(APalette, QPaletteDisabled, QPaletteHighlight, QColor(80, 80, 80)); - QPalette_setColor(APalette, QPaletteHighlightedText, QColor(255, 255, 255)); - QPalette_setColor(APalette, QPaletteDisabled, QPaletteHighlightedText, QColor(127, 127, 127)); - end - else - begin - // LightMode Pallete - QPalette_setColor(APalette, QPaletteWindow, QColor(240, 240, 240)); - QPalette_setColor(APalette, QPaletteWindowText, QColor(0, 0, 0)); - QPalette_setColor(APalette, QPaletteDisabled, QPaletteWindowText, QColor(127, 127, 127)); - QPalette_setColor(APalette, QPaletteBase, QColor(225, 225, 225)); - QPalette_setColor(APalette, QPaletteAlternateBase, QColor(255, 255, 255)); - QPalette_setColor(APalette, QPaletteToolTipBase, QColor(255, 255, 255)); - QPalette_setColor(APalette, QPaletteToolTipText, QColor(0, 0, 0)); - QPalette_setColor(APalette, QPaletteText, QColor(0, 0, 0)); - QPalette_setColor(APalette, QPaletteDisabled, QPaletteText, QColor(127, 127, 127)); - QPalette_setColor(APalette, QPaletteDark, QColor(200, 200, 200)); - QPalette_setColor(APalette, QPaletteLight, QColor(255, 255, 255)); - QPalette_setColor(APalette, QPaletteShadow, QColor(220, 220, 220)); - QPalette_setColor(APalette, QPaletteButton, QColor(240, 240, 240)); - QPalette_setColor(APalette, QPaletteButtonText, QColor(0, 0, 0)); - QPalette_setColor(APalette, QPaletteDisabled, QPaletteButtonText, QColor(127, 127, 127)); - QPalette_setColor(APalette, QPaletteBrightText, QColor(255, 0, 0)); - QPalette_setColor(APalette, QPaletteLink, QColor(42, 130, 218)); - QPalette_setColor(APalette, QPaletteHighlight, QColor(42, 130, 218)); - QPalette_setColor(APalette, QPaletteDisabled, QPaletteHighlight, QColor(200, 200, 200)); - QPalette_setColor(APalette, QPaletteHighlightedText, QColor(255, 255, 255)); - QPalette_setColor(APalette, QPaletteDisabled, QPaletteHighlightedText, QColor(127, 127, 127)); - end; - - QApplication_setPalette(APalette); -end; -{$ENDIF} - -const - LOAD_LIBRARY_SEARCH_SYSTEM32 = $800; - -function CheckBuildNumber(buildNumber: DWORD): Boolean; inline; -begin - Result := (buildNumber = 17763) or // Win 10: 1809 - (buildNumber = 18362) or // Win 10: 1903 & 1909 - (buildNumber = 19041) or // Win 10: 2004 & 20H2 & 21H1 & 21H2 - (buildNumber = 22000) or // Win 11: 21H2 - (buildNumber > 22000); // Win 11: Insider Preview -end; - -function GetBuildNumber(Instance: THandle): DWORD; -begin - try - with TVersionInfo.Create do - try - Load(Instance); - Result:= FixedInfo.FileVersion[2]; - finally - Free; - end; - except - Exit(0); - end; -end; - -procedure InitDarkMode(); -var - hUxtheme: HMODULE; - major, minor, build: DWORD; -begin - @RtlGetNtVersionNumbers := GetProcAddress(GetModuleHandleW('ntdll.dll'), 'RtlGetNtVersionNumbers'); - if Assigned(RtlGetNtVersionNumbers) then - begin - RtlGetNtVersionNumbers(@major, @minor, @build); - - if (major = 10) and (minor = 0) then - begin - hUxtheme := LoadLibraryExW('uxtheme.dll', 0, LOAD_LIBRARY_SEARCH_SYSTEM32); - if (hUxtheme <> 0) then - begin - g_buildNumber:= GetBuildNumber(hUxtheme); - - if CheckBuildNumber(g_buildNumber) then - begin - @_RefreshImmersiveColorPolicyState := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(104)); - @_ShouldAppsUseDarkMode := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(132)); - @_AllowDarkModeForWindow := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(133)); - - if (g_buildNumber < 18362) then - @_AllowDarkModeForApp := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(135)) - else - @_SetPreferredAppMode := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(135)); - - @_IsDarkModeAllowedForWindow := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(137)); - - @DwmSetWindowAttribute := GetProcAddress(LoadLibrary('dwmapi.dll'), 'DwmSetWindowAttribute'); - - if Assigned(_RefreshImmersiveColorPolicyState) and - Assigned(_ShouldAppsUseDarkMode) and - Assigned(_AllowDarkModeForWindow) and - (Assigned(_AllowDarkModeForApp) or Assigned(_SetPreferredAppMode)) and - Assigned(_IsDarkModeAllowedForWindow) then - begin - g_darkModeSupported := true; - AppMode := PreferredAppMode; - if AppMode <> pamForceLight then - begin - AllowDarkModeForApp(true); - _RefreshImmersiveColorPolicyState(); - IsDarkModeEnabled := ShouldAppsUseDarkMode; - if IsDarkModeEnabled then AppMode := pamForceDark; - end; - end; - end; - end; - end; - end; -end; - -initialization -end. - diff --git a/peazip-sources/dev/metadarkstyle/src/udarkstyleparams.pas b/peazip-sources/dev/metadarkstyle/src/udarkstyleparams.pas deleted file mode 100644 index 8dcd68c0..00000000 --- a/peazip-sources/dev/metadarkstyle/src/udarkstyleparams.pas +++ /dev/null @@ -1,44 +0,0 @@ -{ -@author(Andrey Zubarev ) -} - -unit uDarkStyleParams; - -interface - -uses - LCLType,Graphics,ComCtrls; - -type - TSysColors=array[0..COLOR_ENDCOLORS] of TColor; - TDrawControl=record - TreeViewDisableHideSelection:Boolean; - TreeViewExpandSignOverride:Boolean; - TreeViewExpandSignValue: TTreeViewExpandSignType; - CustomDrawScrollbars:Boolean; - CustomDrawPushButtons:Boolean; - CustomDrawComboBoxs:Boolean; - CustomDrawTreeViews:Boolean; - end; - - TDSColors=record - SysColor:TSysColors; - DrawControl:TDrawControl; - end; - - // Insider 18334 - TPreferredAppMode = - ( - pamDefault, - pamAllowDark, - pamForceDark, - pamForceLight - ); - -var - PreferredAppMode:TPreferredAppMode=pamForceLight; - IsDarkModeEnabled: Boolean = False; - -implementation - -end. diff --git a/peazip-sources/dev/metadarkstyle/src/udarkstyleschemes.pas b/peazip-sources/dev/metadarkstyle/src/udarkstyleschemes.pas deleted file mode 100644 index 5d1cf9d9..00000000 --- a/peazip-sources/dev/metadarkstyle/src/udarkstyleschemes.pas +++ /dev/null @@ -1,228 +0,0 @@ -{ -@author(Andrey Zubarev ) -} - -unit uDarkStyleSchemes; - -interface - -uses - SysUtils, - LCLType,LCLIntf,Graphics,Masks, - LResources,ComCtrls, - uDarkStyleParams, - gmap,gutil; - -const - DSColorsTypeName='DARKSTYLECOLORS'; - -type - TSchemeName=String; - PTSchemeData=^TSchemeData; - TSchemeData=record - Name:TSchemeName; - Data:TDSColors; - end; - TSchemeKey=String; - TSchemes=class(specialize TMap>) - function GetMutableValue(key:TSchemeKey):PTSchemeData; - end; - - -var - DefaultDark,DefaultWhite:TDSColors; - Schemes:TSchemes=nil; - -function GetScheme(AName:TSchemeName):TDSColors; -function GetSchemeMutable(AName:TSchemeName):PTSchemeData; -procedure AddScheme(AName:TSchemeName;AData:TDSColors); -procedure LoadLResources; -procedure LoadPath(APath,AMask:string); - -implementation -uses - uDarkStyleSchemesLoader; - -function TSchemes.GetMutableValue(key:TSchemeKey):PTSchemeData; -var - Pair:TPair; - Node:TMSet.PNode; -begin - Pair.Key:=key; - Node:=FSet.NFind(Pair); - if Node=nil then - result:=nil - else - result:=@Node^.Data.Value; -end; - -function SchameName2SchameID(AName:TSchemeName):TSchemeKey;inline; -begin - result:=UpperCase(AName); -end; - -function GetSchemeMutable(AName:TSchemeName):PTSchemeData; -begin - if Schemes=nil then - exit(nil); - result:=Schemes.GetMutableValue(SchameName2SchameID(AName)); -end; - -function GetScheme(AName:TSchemeName):TDSColors; -var - ps:PTSchemeData; - UCName:string; -begin - UCName:=UpperCase(AName); - if UCName='DARK' then - result:=DefaultDark - else if UCName='WHITE' then - result:=DefaultWhite - else begin - ps:=GetSchemeMutable(AName); - if ps=nil then - result:=DefaultDark - else - result:=ps^.Data; - end; -end; - -function CreateTSchemeData(AName:TSchemeName;AData:TDSColors):TSchemeData; -begin - result.Data:=AData; - result.Name:=AName; -end; - -procedure AddScheme(AName:TSchemeName;AData:TDSColors); -var - id:TSchemeKey; -begin - id:=SchameName2SchameID(AName); - if Schemes=nil then begin - Schemes:=TSchemes.Create; - Schemes.Insert(id,CreateTSchemeData(AName,AData)); - end else begin - if Schemes.GetMutableValue(id)=nil then - Schemes.Insert(id,CreateTSchemeData(AName,AData)); - end; -end; - -procedure LoadLResources; -var - r:TLResource; - DSC:TDSColors; - i:integer; -begin - for i:=0 to LazarusResources.Count-1 do begin - r:=LazarusResources.Items[i]; - if UpperCase(r.ValueType)=DSColorsTypeName then - if GetSchemeMutable(r.Value)=nil then - if ParseColors(r.Name,r.Value,DSC) then - AddScheme(r.Name,DSC); - end; -end; - -procedure LoadPath(APath,AMask:string); -var - DSC:TDSColors; - sr: TSearchRec; -begin - if FindFirst(APath+'/*',faAnyFile,sr) = 0 then begin - repeat - if (sr.Name <> '.') and (sr.Name <> '..') then begin - if MatchesMask(sr.Name,AMask) then - if ParseColorsFile(APath+'/'+sr.Name,DSC) then - AddScheme(ChangeFileExt(sr.Name,''),DSC); - end; - until FindNext(sr) <> 0; - FindClose(sr); - end; -end; - -procedure InitializeDefaultColors; -begin - DefaultDark.SysColor[COLOR_SCROLLBAR]:= RGBToColor(53, 53, 53); - DefaultDark.SysColor[COLOR_BACKGROUND]:= RGBToColor(53, 53, 53); - DefaultDark.SysColor[COLOR_ACTIVECAPTION]:= RGBToColor(42, 130, 218); - DefaultDark.SysColor[COLOR_INACTIVECAPTION]:= RGBToColor(53, 53, 53); - DefaultDark.SysColor[COLOR_MENU]:= RGBToColor(42, 42, 42); - DefaultDark.SysColor[COLOR_WINDOW]:= RGBToColor(42, 42, 42); - DefaultDark.SysColor[COLOR_WINDOWFRAME]:= RGBToColor(20, 20, 20); - DefaultDark.SysColor[COLOR_MENUTEXT]:= RGBToColor(245, 245, 245); - DefaultDark.SysColor[COLOR_WINDOWTEXT]:= RGBToColor(245, 245, 245); - DefaultDark.SysColor[COLOR_CAPTIONTEXT]:= RGBToColor(245, 245, 245); - DefaultDark.SysColor[COLOR_ACTIVEBORDER] := RGBToColor(53, 53, 53); - DefaultDark.SysColor[COLOR_INACTIVEBORDER]:= RGBToColor(53, 53, 53); - DefaultDark.SysColor[COLOR_APPWORKSPACE]:= RGBToColor(53, 53, 53); - DefaultDark.SysColor[COLOR_HIGHLIGHT]:= RGBToColor(42, 130, 218); - DefaultDark.SysColor[COLOR_HIGHLIGHTTEXT]:= RGBToColor(245, 245, 245); - DefaultDark.SysColor[COLOR_BTNFACE]:= RGBToColor(53, 53, 53); - DefaultDark.SysColor[COLOR_BTNSHADOW]:= RGBToColor(35, 35, 35); - DefaultDark.SysColor[COLOR_GRAYTEXT]:= RGBToColor(160, 160, 160); - DefaultDark.SysColor[COLOR_BTNTEXT]:= RGBToColor(245, 245, 245); - DefaultDark.SysColor[COLOR_INACTIVECAPTIONTEXT]:= RGBToColor(245, 245, 245); - DefaultDark.SysColor[COLOR_BTNHIGHLIGHT]:= RGBToColor(66, 66, 66); - DefaultDark.SysColor[COLOR_3DDKSHADOW]:= RGBToColor(20, 20, 20); - DefaultDark.SysColor[COLOR_3DLIGHT]:= RGBToColor(40, 40, 40); - DefaultDark.SysColor[COLOR_INFOTEXT]:= RGBToColor(53, 53, 53); - DefaultDark.SysColor[COLOR_INFOBK]:= RGBToColor(245, 245, 245); - DefaultDark.SysColor[COLOR_HOTLIGHT]:= RGBToColor(66, 66, 66); - DefaultDark.SysColor[COLOR_GRADIENTACTIVECAPTION]:= GetSysColor(COLOR_GRADIENTACTIVECAPTION); - DefaultDark.SysColor[COLOR_GRADIENTINACTIVECAPTION]:= GetSysColor(COLOR_GRADIENTINACTIVECAPTION); - DefaultDark.SysColor[COLOR_MENUHILIGHT]:= RGBToColor(66, 66, 66); - DefaultDark.SysColor[COLOR_MENUBAR]:= RGBToColor(42, 42, 42); - DefaultDark.SysColor[COLOR_FORM]:= RGBToColor(53, 53, 53); - DefaultDark.DrawControl.CustomDrawScrollbars:= False; - DefaultDark.DrawControl.TreeViewDisableHideSelection:= False; - DefaultDark.DrawControl.TreeViewExpandSignOverride:= False; - DefaultDark.DrawControl.TreeViewExpandSignValue:= tvestTheme; - DefaultDark.DrawControl.CustomDrawPushButtons:= False; - DefaultDark.DrawControl.CustomDrawComboBoxs:= False; - DefaultDark.DrawControl.CustomDrawTreeViews:= False; - - DefaultWhite.SysColor[COLOR_SCROLLBAR]:= GetSysColor(COLOR_SCROLLBAR); - DefaultWhite.SysColor[COLOR_BACKGROUND]:= GetSysColor(COLOR_BACKGROUND); - DefaultWhite.SysColor[COLOR_ACTIVECAPTION]:= GetSysColor(COLOR_ACTIVECAPTION); - DefaultWhite.SysColor[COLOR_INACTIVECAPTION]:= GetSysColor(COLOR_INACTIVECAPTION); - DefaultWhite.SysColor[COLOR_MENU]:= GetSysColor(COLOR_MENU); - DefaultWhite.SysColor[COLOR_WINDOW]:= GetSysColor(COLOR_WINDOW); - DefaultWhite.SysColor[COLOR_WINDOWFRAME]:= GetSysColor(COLOR_WINDOWFRAME); - DefaultWhite.SysColor[COLOR_MENUTEXT]:= GetSysColor(COLOR_MENUTEXT); - DefaultWhite.SysColor[COLOR_WINDOWTEXT]:= GetSysColor(COLOR_WINDOWTEXT); - DefaultWhite.SysColor[COLOR_CAPTIONTEXT]:= GetSysColor(COLOR_CAPTIONTEXT); - DefaultWhite.SysColor[COLOR_ACTIVEBORDER] := GetSysColor(COLOR_ACTIVEBORDER); - DefaultWhite.SysColor[COLOR_INACTIVEBORDER]:= GetSysColor(COLOR_INACTIVEBORDER); - DefaultWhite.SysColor[COLOR_APPWORKSPACE]:= GetSysColor(COLOR_APPWORKSPACE); - DefaultWhite.SysColor[COLOR_HIGHLIGHT]:= GetSysColor(COLOR_HIGHLIGHT); - DefaultWhite.SysColor[COLOR_HIGHLIGHTTEXT]:= GetSysColor(COLOR_HIGHLIGHTTEXT); - DefaultWhite.SysColor[COLOR_BTNFACE]:= GetSysColor(COLOR_BTNFACE); - DefaultWhite.SysColor[COLOR_BTNSHADOW]:= GetSysColor(COLOR_BTNSHADOW); - DefaultWhite.SysColor[COLOR_GRAYTEXT]:= GetSysColor(COLOR_GRAYTEXT); - DefaultWhite.SysColor[COLOR_BTNTEXT]:= GetSysColor(COLOR_BTNTEXT); - DefaultWhite.SysColor[COLOR_INACTIVECAPTIONTEXT]:= GetSysColor(COLOR_INACTIVECAPTIONTEXT); - DefaultWhite.SysColor[COLOR_BTNHIGHLIGHT]:= GetSysColor(COLOR_BTNHIGHLIGHT); - DefaultWhite.SysColor[COLOR_3DDKSHADOW]:= GetSysColor(COLOR_3DDKSHADOW); - DefaultWhite.SysColor[COLOR_3DLIGHT]:= GetSysColor(COLOR_3DLIGHT); - DefaultWhite.SysColor[COLOR_INFOTEXT]:= GetSysColor(COLOR_INFOTEXT); - DefaultWhite.SysColor[COLOR_INFOBK]:= GetSysColor(COLOR_INFOBK); - DefaultWhite.SysColor[COLOR_HOTLIGHT]:= GetSysColor(COLOR_HOTLIGHT); - DefaultWhite.SysColor[COLOR_GRADIENTACTIVECAPTION]:= GetSysColor(COLOR_GRADIENTACTIVECAPTION); - DefaultWhite.SysColor[COLOR_GRADIENTINACTIVECAPTION]:= GetSysColor(COLOR_GRADIENTINACTIVECAPTION); - DefaultWhite.SysColor[COLOR_MENUHILIGHT]:= GetSysColor(COLOR_MENUHILIGHT); - DefaultWhite.SysColor[COLOR_MENUBAR]:= GetSysColor(COLOR_MENUBAR); - DefaultWhite.SysColor[COLOR_FORM]:= GetSysColor(COLOR_FORM); - DefaultWhite.DrawControl.CustomDrawScrollbars:= True; - DefaultWhite.DrawControl.TreeViewDisableHideSelection:=False; - DefaultWhite.DrawControl.TreeViewExpandSignOverride:= False; - DefaultWhite.DrawControl.TreeViewExpandSignValue:= tvestTheme; - DefaultWhite.DrawControl.CustomDrawPushButtons:= True; - DefaultWhite.DrawControl.CustomDrawComboBoxs:= True; - DefaultWhite.DrawControl.CustomDrawTreeViews:= True; -end; - -initialization - InitializeDefaultColors; -finalization - if Schemes<>nil then - Schemes.Destroy; -end. diff --git a/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesadditional.pas b/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesadditional.pas deleted file mode 100644 index 0167879e..00000000 --- a/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesadditional.pas +++ /dev/null @@ -1,16 +0,0 @@ -{ -@author(Andrey Zubarev ) -} - -unit uDarkStyleSchemesAdditional; - -interface - -uses - LResources; - -implementation - -initialization -{$I CustomDark.lrs} -end. diff --git a/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesloader.pas b/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesloader.pas deleted file mode 100644 index 515360ba..00000000 --- a/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesloader.pas +++ /dev/null @@ -1,511 +0,0 @@ -{ -@author(Andrey Zubarev ) -} - -unit uDarkStyleSchemesLoader; - -interface - -uses - SysUtils,Classes,contnrs,bufstream, - LCLProc,LCLType,LCLIntf,Graphics,LCLVersion, - LResources,ComCtrls, - PScanner, PParser, PasTree, - uDarkStyleParams,uDarkStyleSchemes; - -function ParseColors(modulename,module:string;out DSC:TDSColors):Boolean;overload; -function ParseColors(modulename:string;module:TStream;out DSC:TDSColors):Boolean;overload; -function ParseColorsFile(AFile:string;out DSC:TDSColors):Boolean;overload; - -implementation - -type - TIdent=(IdUnknown, - IdColors, - IdScheme, - IdDefaultDark,IdDefaultWhite, - IdRGBToColor,IdGetSysColor, - IdTreeViewDisableHideSelection,IdTreeViewExpandSignOverride,IdTreeViewExpandSignValue, - IdtvestTheme,IdtvestPlusMinus,IdtvestArrow,IdtvestArrowFill,IdtvestAngleBracket, - IdCustomDrawScrollbars, - IdCustomDrawPushButtons, - IdCustomDrawComboBoxs, - IdCustomDrawTreeViews, - IdCOLOR_SCROLLBAR, - IdCOLOR_BACKGROUND, - IdCOLOR_ACTIVECAPTION, - IdCOLOR_INACTIVECAPTION, - IdCOLOR_MENU, - IdCOLOR_WINDOW, - IdCOLOR_WINDOWFRAME, - IdCOLOR_MENUTEXT, - IdCOLOR_WINDOWTEXT, - IdCOLOR_CAPTIONTEXT, - IdCOLOR_ACTIVEBORDER, - IdCOLOR_INACTIVEBORDER, - IdCOLOR_APPWORKSPACE, - IdCOLOR_HIGHLIGHT, - IdCOLOR_HIGHLIGHTTEXT, - IdCOLOR_BTNFACE, - IdCOLOR_BTNSHADOW, - IdCOLOR_GRAYTEXT, - IdCOLOR_BTNTEXT, - IdCOLOR_INACTIVECAPTIONTEXT, - IdCOLOR_BTNHIGHLIGHT, - IdCOLOR_3DDKSHADOW, - IdCOLOR_3DLIGHT, - IdCOLOR_INFOTEXT, - IdCOLOR_INFOBK, - IdCOLOR_25, - IdCOLOR_HOTLIGHT, - IdCOLOR_GRADIENTACTIVECAPTION, - IdCOLOR_GRADIENTINACTIVECAPTION, - IdCOLOR_MENUHILIGHT, - IdCOLOR_MENUBAR, - IdCOLOR_FORM); -const - TIdents2Name:array[TIdent] of string=( - '', - 'COLORS', - 'SCHEME', - 'DEFAULTDARK','DEFAULTWHITE', - 'RGBTOCOLOR','GETSYSCOLOR', - 'TREEVIEWDISABLEHIDESELECTION','TREEVIEWEXPANDSIGNOVERRIDE','TREEVIEWEXPANDSIGNVALUE', - 'TVESTTHEME','TVESTPLUSMINUS','TVESTARROW','TVESTARROWFILL','TVESTANGLEBRACKET', - 'CUSTOMDRAWSCROLLBARS', - 'CUSTOMDRAWPUSHBUTTONS', - 'CUSTOMDRAWCOMBOBOXS', - 'CUSTOMDRAWTREEVIEWS', - 'COLOR_SCROLLBAR', - 'COLOR_BACKGROUND', - 'COLOR_ACTIVECAPTION', - 'COLOR_INACTIVECAPTION', - 'COLOR_MENU', - 'COLOR_WINDOW', - 'COLOR_WINDOWFRAME', - 'COLOR_MENUTEXT', - 'COLOR_WINDOWTEXT', - 'COLOR_CAPTIONTEXT', - 'COLOR_ACTIVEBORDER', - 'COLOR_INACTIVEBORDER', - 'COLOR_APPWORKSPACE', - 'COLOR_HIGHLIGHT', - 'COLOR_HIGHLIGHTTEXT', - 'COLOR_BTNFACE', - 'COLOR_BTNSHADOW', - 'COLOR_GRAYTEXT', - 'COLOR_BTNTEXT', - 'COLOR_INACTIVECAPTIONTEXT', - 'COLOR_BTNHIGHLIGHT', - 'COLOR_3DDKSHADOW', - 'COLOR_3DLIGHT', - 'COLOR_INFOTEXT', - 'COLOR_INFOBK', - 'COLOR_25', - 'COLOR_HOTLIGHT', - 'COLOR_GRADIENTACTIVECAPTION', - 'COLOR_GRADIENTINACTIVECAPTION', - 'COLOR_MENUHILIGHT', - 'COLOR_MENUBAR', - 'COLOR_FORM' - ); - -type - TSimpleEngine = class(TPasTreeContainer) - private - uname:string; - FElements:TObjectList; - public - - constructor Create; - destructor Destroy;override; - Procedure Log(Sender : TObject; Const Msg : String); - - function CreateElement(AClass: TPTreeElement; const AName: String; - AParent: TPasElement; AVisibility: TPasMemberVisibility; - const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement; - override; - function FindElement(const AName: String): TPasElement; override; - end; - - TOnMemoryStream = class(TCustomMemoryStream) - private - FReadOnly: Boolean; - protected - procedure SetSize(NewSize: Longint); override; - public - constructor Create(Ptr: Pointer; ASize: Longint; ReadOnlyMode: Boolean = True); - function Write(const Buffer; Count: Longint): Longint; override; - property ReadOnly: Boolean read FReadOnly write FReadOnly; - end; - - constructor TOnMemoryStream.Create(Ptr: Pointer; ASize: Longint; ReadOnlyMode: Boolean = True); - begin - inherited Create; - SetPointer(Ptr, ASize); - FReadOnly := ReadOnlyMode; - end; - {------------------------------------------------------------------------------} - function TOnMemoryStream.Write(const Buffer; Count: Longint): Longint; - var - Pos: Longint; - begin - if (Position >= 0) and (Count >= 0) and (not ReadOnly) and (Position + Count <=Size) then - begin - Pos := Position + Count; - System.Move(Buffer, Pointer(NativeUInt(Memory) + NativeUInt(Position))^, Count); - Position := Pos; - Result := Count; - end - else - Result := 0; - end; - {------------------------------------------------------------------------------} - procedure TOnMemoryStream.SetSize(NewSize: Longint); - begin - //ничего не делаем - end; - -destructor TSimpleEngine.Destroy; -begin - if assigned(FPackage) then - FPackage.Destroy; - if FElements<>nil then - FElements.Destroy; - inherited; -end; - -function TSimpleEngine.CreateElement(AClass: TPTreeElement; const AName: String; - AParent: TPasElement; AVisibility: TPasMemberVisibility; - const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement; -begin - Result := AClass.Create(AName, AParent); - Result.Visibility := AVisibility; - Result.SourceFilename := ASourceFilename; - Result.SourceLinenumber := ASourceLinenumber; - if FElements=nil then - FElements:=TObjectList.Create; - FElements.Add(result); -end; -constructor TSimpleEngine.Create; -begin - inherited; - FPackage:=TPasPackage.Create('',nil); - FElements:=nil; -end; -procedure TSimpleEngine.Log(Sender : TObject; Const Msg : String); -begin - DebugLn(format('[MetaDarkStyle] %s',[Msg])); -end; -function TSimpleEngine.FindElement(const AName: String): TPasElement; -begin - { dummy implementation, see TFPDocEngine.FindElement for a real example } - Result := nil; -end; - -function Identifer2TIdent(id:string):TIdent; -begin - id:=UpperCase(id); - for Result:=Succ(Low(TIdent)) to High(TIdent) do - if TIdents2Name[Result]=id then - exit; - Result:=Low(TIdent); -end; - -function GetTreeViewExpandSignValue(pn:TPASEXPR):TTreeViewExpandSignType; -var - lid:TIdent; -begin - if pn is TPrimitiveExpr then begin - lid:=Identifer2TIdent(TPrimitiveExpr(pn).Value); - case lid of - IdtvestTheme:result:=tvestTheme; - IdtvestPlusMinus:result:=tvestPlusMinus; - IdtvestArrow:result:=tvestArrow; - IdtvestArrowFill:result:=tvestArrowFill; -IdtvestAngleBracket:result:={$If declared(tvestAngleBracket)} - tvestAngleBracket;//появилось в 02eed0c903e14a33c95b4abded0c66d193678d70 - {$Else} - tvestArrow; - {$EndIf} - else - Exception.Create(format('Error in line %d (only allowed "tvestTheme", "tvestPlusMinus", "tvestArrow", "tvestArrowFill", "tvestAngleBracket")',[pn.SourceLinenumber])); - end; - end else - Exception.Create(format('Error in line %d (only palette names allowed "DefaultDark", "DefaultWhite")',[pn.SourceLinenumber])); -end; - -function GetPaletteByName(pn:TPASEXPR):TDSColors; -var - lid:TIdent; -begin - if pn is TPrimitiveExpr then begin - lid:=Identifer2TIdent(TPrimitiveExpr(pn).Value); - case lid of - IdDefaultDark:result:=DefaultDark; -IdDefaultWhite:result:=DefaultWhite; - else - Exception.Create(format('Error in line %d (only palette names allowed "DefaultDark", "DefaultWhite")',[pn.SourceLinenumber])); - end; - end else - Exception.Create(format('Error in line %d (only palette names allowed "DefaultDark", "DefaultWhite")',[pn.SourceLinenumber])); -end; - -function GetArrayIndex(indxs:TPasExprArray):integer; -var - lid:TIdent; -begin - if Length(indxs)<>1 then - Exception.Create(format('Error in line %d (only one index allowed)',[indxs[0].SourceLinenumber])); - if indxs[0] is TPrimitiveExpr then begin - case TPrimitiveExpr(indxs[0]).Kind of - pekIdent:begin - lid:=Identifer2TIdent(TPrimitiveExpr(indxs[0]).Value); - case lid of - IdCOLOR_SCROLLBAR..IdCOLOR_FORM:Result:=ord(lid)-ord(IdCOLOR_SCROLLBAR); - else - Exception.Create(format('Error in line %d (unknown index [%s])',[indxs[0].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); - end; - end; - pekNumber:begin - if not TryStrToInt(TPrimitiveExpr(indxs[0]).Value,result) then - Exception.Create(format('Error in line %d (unknown index [%s])',[indxs[0].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); - end; - else - Exception.Create(format('Error in line %d (unknown index [%s])',[indxs[0].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); - end; - end else - Exception.Create(format('Error in line %d (unknown index [])',[indxs[0].SourceLinenumber])); -end; - -function GetRGBColor(indxs:TPasExprArray):TColor; -var - lid:TIdent; - r,g,b:integer; -begin - if Length(indxs)<>3 then - Exception.Create(format('Error in line %d (only 3 params allowed)',[indxs[0].SourceLinenumber])); - if indxs[0] is TPrimitiveExpr then begin - case TPrimitiveExpr(indxs[0]).Kind of - pekNumber:begin - if not TryStrToInt(TPrimitiveExpr(indxs[0]).Value,r) then - Exception.Create(format('Error in line %d (unknown unknown param 1 [%s])',[indxs[0].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); - end; - else - Exception.Create(format('Error in line %d (unknown unknown param 1 [%s])',[indxs[0].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); - end; - end else - Exception.Create(format('Error in line %d (unknown param 1 )',[indxs[0].SourceLinenumber])); - if indxs[1] is TPrimitiveExpr then begin - case TPrimitiveExpr(indxs[1]).Kind of - pekNumber:begin - if not TryStrToInt(TPrimitiveExpr(indxs[1]).Value,g) then - Exception.Create(format('Error in line %d (unknown unknown param 2 [%s])',[indxs[1].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); - end; - else - Exception.Create(format('Error in line %d (unknown unknown param 2 [%s])',[indxs[1].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); - end; - end else - Exception.Create(format('Error in line %d (unknown param 2 )',[indxs[1].SourceLinenumber])); - if indxs[2] is TPrimitiveExpr then begin - case TPrimitiveExpr(indxs[2]).Kind of - pekNumber:begin - if not TryStrToInt(TPrimitiveExpr(indxs[2]).Value,b) then - Exception.Create(format('Error in line %d (unknown unknown param 3 [%s])',[indxs[2].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); - end; - else - Exception.Create(format('Error in line %d (unknown unknown param 3 [%s])',[indxs[2].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); - end; - end else - Exception.Create(format('Error in line %d (unknown param 3 )',[indxs[2].SourceLinenumber])); - result:=RGBToColor(r,g,b); -end; - -function GetColor(fn:TPASEXPR):TColor; -var - lid:TIdent; - i:integer; -begin - if fn.Kind=pekFuncParams then begin - lid:=Identifer2TIdent(TPrimitiveExpr(TParamsExpr(fn).Value).Value); - case lid of - IdRGBToColor:begin - result:=GetRGBColor(TParamsExpr(fn).Params); - end; - IdGetSysColor:begin - i:=GetArrayIndex(TParamsExpr(fn).Params); - result:=GetSysColor(i); - end - else - Exception.Create(format('Error in line %d (only "RGBToColor()", "GetSysColor()" allowed, but "%s" found)',[fn.SourceLinenumber,TParamsExpr(fn).Value])); - end; - end else - Exception.Create(format('Error in line %d (only "RGBToColor()", "GetSysColor()" allowed)',[fn.SourceLinenumber])); -end; - -procedure SetBoolean(var ABoolean:Boolean;pn:TPASEXPR); -begin - if pn is TBoolConstExpr then - ABoolean:=TBoolConstExpr(pn).Value - else - Exception.Create(format('Error in line %d (only True or False allowed)',[pn.SourceLinenumber])); -end; - - -procedure PrepareAssign(Ass:TPasImplAssign;var DSC:TDSColors); -var - lid:TIdent; - i:integer; -begin - if Ass.Left.OpCode=eopNone then begin - if Ass.Left.Kind=pekIdent then begin - lid:=Identifer2TIdent(TPrimitiveExpr(Ass.Left).Value); - case lid of - IdScheme:DSC:=GetPaletteByName(Ass.Right); - IdTreeViewExpandSignOverride:SetBoolean(DSC.DrawControl.TreeViewExpandSignOverride,Ass.Right); - IdTreeViewExpandSignValue:DSC.DrawControl.TreeViewExpandSignValue:=GetTreeViewExpandSignValue(Ass.Right); - IdCustomDrawScrollbars:SetBoolean(DSC.DrawControl.CustomDrawScrollbars,Ass.Right); - IdCustomDrawPushButtons:SetBoolean(DSC.DrawControl.CustomDrawPushButtons,Ass.Right); - IdCustomDrawComboBoxs:SetBoolean(DSC.DrawControl.CustomDrawComboBoxs,Ass.Right); - IdCustomDrawTreeViews:SetBoolean(DSC.DrawControl.CustomDrawTreeViews,Ass.Right); -IdTreeViewDisableHideSelection:SetBoolean(DSC.DrawControl.TreeViewDisableHideSelection,Ass.Right); - else - Exception.Create(format('Error in line %d (wrong left side)',[Ass.SourceLinenumber])); - end; - end else if Ass.Left.Kind=pekArrayParams then begin - if (not(Ass.Left is TParamsExpr))and(not(TParamsExpr(Ass.Left).Value is TPrimitiveExpr)) then - Exception.Create(format('Error in line %d (wrong left side: wrong array index)',[Ass.SourceLinenumber])); - lid:=Identifer2TIdent(TPrimitiveExpr(TParamsExpr(Ass.Left).Value).Value); - if lid<>IdColors then - Exception.Create(format('Error in line %d (wrong left side: only "Colors[]" allowed)',[Ass.SourceLinenumber])); - i:=GetArrayIndex(TParamsExpr(Ass.Left).Params); - DSC.SysColor[i]:=GetColor(Ass.Right) - end else - Exception.Create(format('Error in line %d (wrong left side: not ident[] or ident)',[Ass.SourceLinenumber])); - end else - raise Exception.Create(format('Error in line %d (wrong left side)',[Ass.SourceLinenumber])); -end; - -procedure PrepareElement(pie:TPasImplElement;var DSC:TDSColors); -begin - if pie is TPasImplAssign then - PrepareAssign(pie as TPasImplAssign,DSC) - else - raise Exception.Create(format('Error in line %d (only := alowed)',[pie.SourceLinenumber])); -end; - -function PrepareModule(m:TPasProgram):TDSColors; -var - pie:TPasImplElement; -begin - if not(m is TPasProgram) then - raise Exception.Create('Program is expected'); - if not assigned((m as TPasProgram).InitializationSection) then - raise Exception.Create('Program is empty'); - if ((m as TPasProgram).InputFile<>'')or((m as TPasProgram).OutPutFile<>'') then - raise Exception.Create('No input/output file needed'); - - for pointer(pie) in (m as TPasProgram).InitializationSection.Elements do - PrepareElement(pie,Result); -end; - -function ScanModule(modulename:string;module:TStream;out DSC:TDSColors):Boolean; -var - E:TSimpleEngine; - Parser: TPasParser; - Resolver:TStreamResolver; - Scanner: TPascalScanner; - m:TPasModule; - -begin - E := TSimpleEngine.Create; - E.uname:=modulename; - - Resolver:=TStreamResolver.Create; - Scanner:=TPascalScanner.Create(Resolver); - Scanner.LogEvents:=[sleFile,sleLineNumber,sleConditionals,sleDirective]; - Scanner.OnLog:=E.Onlog; - Parser := TPasParser.Create(Scanner, Resolver, E); - Parser.LogEvents:=[pleInterface,pleImplementation]; - Parser.OnLog:=E.Onlog; - result:=False; - - try - try - Resolver.AddStream(modulename,module); - Scanner.OpenFile(modulename); - Parser.ParseMain(m); - try - result:=True; - dsc:=PrepareModule(TPasProgram(m)); - except - on excep:Exception do begin - DebugLn(format('{EM}[MetaDarkStyle]DSScheme prepare exception: "%s" in file "%s"',[excep.message,modulename])); - result:=false; - end - else; - end; - - except - on excep:EParserError do begin - DebugLn(format('{EM}[MetaDarkStyle]DSScheme parse error: "%s" line:%d column:%d file:%s',[excep.message,excep.row,excep.column,excep.filename])); - FreeAndNil(result); - end; - on excep:Exception do begin - DebugLn(format('{EM}[MetaDarkStyle]DSScheme parse exception: "%s" in file "%s"',[excep.message,modulename])); - FreeAndNil(result); - end - else begin - DebugLn(format('{EM}[MetaDarkStyle]Error in file "%s"',[modulename])); - FreeAndNil(result); - end; - end; - finally - Parser.Free; - {$IFDEF FPC_FULLVERSION}{$IF FPC_FULLVERSION > 30202} - //error in 3.2.2 cause memoryleak - E.Free; - {$ENDIF}{$ENDIF} - Resolver.Free; - Scanner.Free; - end; -end; - -function ParseColors(modulename:string;module:TStream;out DSC:TDSColors):Boolean;overload; -var - m:TPasProgram; -begin - result:=false; - try - try - result:=ScanModule(modulename,module,DSC); - except - on excep:Exception do begin - DebugLn(format('{EM}[MetaDarkStyle]DSScheme prepare exception: "%s" in file "%s"',[excep.message,modulename])); - result:=false; - end - else; - end; - finally - end; -end; - -function ParseColors(modulename,module:string;out DSC:TDSColors):Boolean;overload; -var - ms:TOnMemoryStream; -begin - ms:=TOnMemoryStream.Create(@module[1],Length(module)*sizeof(module[1])); - result:=ParseColors(modulename,ms,DSC); - ms.Destroy; -end; - -function ParseColorsFile(AFile:string;out DSC:TDSColors):Boolean;overload; -var - bfs:TBufferedFileStream; -begin - bfs:=TBufferedFileStream.Create(AFile,fmOpenRead or fmShareDenyWrite); - result:=ParseColors(AFile,bfs,DSC); - bfs.Destroy; -end; - -end. diff --git a/peazip-sources/dev/metadarkstyle/src/uimport.pas b/peazip-sources/dev/metadarkstyle/src/uimport.pas deleted file mode 100644 index b1e857d6..00000000 --- a/peazip-sources/dev/metadarkstyle/src/uimport.pas +++ /dev/null @@ -1,150 +0,0 @@ -unit uImport; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, Windows; - -function FindImportLibrary(hModule: THandle; pLibName: PAnsiChar): PPointer; -function FindImportFunction(pLibrary: PPointer; pFunction: Pointer): PPointer; -function ReplaceImportFunction(pOldFunction: PPointer; pNewFunction: Pointer): Pointer; - -function FindDelayImportLibrary(hModule: THandle; pLibName: PAnsiChar): Pointer; -function FindDelayImportFunction(hModule: THandle; pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; pFuncName: PAnsiChar): PPointer; -procedure ReplaceDelayImportFunction(hModule: THandle; pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; pFuncName: PAnsiChar; pNewFunction: Pointer); - -implementation - -type -{$IFDEF WIN64} - PIMAGE_NT_HEADERS = PIMAGE_NT_HEADERS64; -{$ELSE} - PIMAGE_NT_HEADERS = PIMAGE_NT_HEADERS32; -{$ENDIF} - -function FindImageDirectory(hModule: THandle; Index: Integer; out DataDir: PIMAGE_DATA_DIRECTORY): Pointer; -var - pNTHeaders: PIMAGE_NT_HEADERS; - pModule: PByte absolute hModule; - pDosHeader: PIMAGE_DOS_HEADER absolute hModule; -begin - if pDosHeader^.e_magic = IMAGE_DOS_SIGNATURE then - begin - pNTHeaders := @pModule[pDosHeader^.e_lfanew]; - if pNTHeaders^.Signature = IMAGE_NT_SIGNATURE then - begin - DataDir := @pNTHeaders^.OptionalHeader.DataDirectory[Index]; - Result := @pModule[DataDir^.VirtualAddress]; - Exit; - end; - end; - Result := nil; -end; - -function FindImportLibrary(hModule: THandle; pLibName: PAnsiChar): PPointer; -var - pEnd: PByte; - pImpDir: PIMAGE_DATA_DIRECTORY; - pImpDesc: PIMAGE_IMPORT_DESCRIPTOR; - pModule: PAnsiChar absolute hModule; -begin - pImpDesc := FindImageDirectory(hModule, IMAGE_DIRECTORY_ENTRY_IMPORT, pImpDir); - if pImpDesc = nil then Exit(nil); - - pEnd := PByte(pImpDesc) + pImpDir^.Size; - - while (PByte(pImpDesc) < pEnd) and (pImpDesc^.FirstThunk <> 0) do - begin - if StrIComp(@pModule[pImpDesc^.Name], pLibName) = 0 then - begin - Result := @pModule[pImpDesc^.FirstThunk]; - Exit; - end; - Inc(pImpDesc); - end; - Result := nil; -end; - -function FindImportFunction(pLibrary: PPointer; pFunction: Pointer): PPointer; -begin - while Assigned(pLibrary^) do - begin - if pLibrary^ = pFunction then Exit(pLibrary); - Inc(pLibrary); - end; - Result := nil; -end; - -function ReplaceImportFunction(pOldFunction: PPointer; pNewFunction: Pointer): Pointer; -var - dwOldProtect: DWORD = 0; -begin - if VirtualProtect(pOldFunction, SizeOf(Pointer), PAGE_READWRITE, dwOldProtect) then - begin - Result := pOldFunction^; - pOldFunction^ := pNewFunction; - VirtualProtect(pOldFunction, SizeOf(Pointer), dwOldProtect, dwOldProtect); - end; -end; - -function FindDelayImportLibrary(hModule: THandle; pLibName: PAnsiChar): Pointer; -var - pEnd: PByte; - pImpDir: PIMAGE_DATA_DIRECTORY; - pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; - pModule: PAnsiChar absolute hModule; -begin - pImpDesc := FindImageDirectory(hModule, IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT, pImpDir); - if pImpDesc = nil then Exit(nil); - - pEnd := PByte(pImpDesc) + pImpDir^.Size; - - while (PByte(pImpDesc) < pEnd) and (pImpDesc^.DllNameRVA > 0) do - begin - if StrIComp(@pModule[pImpDesc^.DllNameRVA], pLibName) = 0 then - Exit(pImpDesc); - - Inc(pImpDesc); - end; - Result := nil; -end; - -function FindDelayImportFunction(hModule: THandle; - pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; pFuncName: PAnsiChar): PPointer; -var - pImpName: PIMAGE_IMPORT_BY_NAME; - pImgThunkName: PIMAGE_THUNK_DATA; - pImgThunkAddr: PIMAGE_THUNK_DATA; - pModule: PAnsiChar absolute hModule; -begin - pImgThunkName:= @pModule[pImpDesc^.ImportNameTableRVA]; - pImgThunkAddr:= @pModule[pImpDesc^.ImportAddressTableRVA]; - - while (pImgThunkName^.u1.Ordinal <> 0) do - begin - if not (IMAGE_SNAP_BY_ORDINAL(pImgThunkName^.u1.Ordinal)) then - begin - pImpName:= @pModule[pImgThunkName^.u1.AddressOfData]; - if (StrIComp(pImpName^.Name, pFuncName) = 0) then - Exit(PPointer(@pImgThunkAddr^.u1._Function)); - end; - Inc(pImgThunkName); - Inc(pImgThunkAddr); - end; - Result:= nil; -end; - -procedure ReplaceDelayImportFunction(hModule: THandle; - pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; pFuncName: PAnsiChar; - pNewFunction: Pointer); -var - pOldFunction: PPointer; -begin - pOldFunction:= FindDelayImportFunction(hModule, pImpDesc, pFuncName); - if Assigned(pOldFunction) then ReplaceImportFunction(pOldFunction, pNewFunction); -end; - -end. - diff --git a/peazip-sources/dev/metadarkstyle/src/umetadarkstyle.pas b/peazip-sources/dev/metadarkstyle/src/umetadarkstyle.pas deleted file mode 100644 index ded2f389..00000000 --- a/peazip-sources/dev/metadarkstyle/src/umetadarkstyle.pas +++ /dev/null @@ -1,41 +0,0 @@ -{ -@author(Andrey Zubarev ) -} - -unit uMetaDarkStyle; - -interface - -{$IFDEF WINDOWS} -uses - {IF DEFINED(LCLQT5)} - uDarkStyle, - {ENDIF} - uDarkStyleParams, - {$IFDEF LCLWIN32} - uWin32WidgetSetDark, - {$ENDIF} - uDarkStyleSchemesLoader; -{$ENDIF} - -{$IFDEF WINDOWS} -procedure ApplyMetaDarkStyle(const CS:TDSColors); -{$ENDIF} -procedure MetaDarkFormChanged(Form: TObject); - -implementation - -{$IFDEF WINDOWS} -procedure ApplyMetaDarkStyle(const CS:TDSColors); -begin - InitDarkMode; - Initialize(CS); - ApplyDarkStyle; -end; -{$ENDIF} - -procedure MetaDarkFormChanged(Form: TObject); -begin - {$IFDEF LCLWIN32}DarkFormChanged(Form);{$ENDIF} -end; -end. diff --git a/peazip-sources/dev/metadarkstyle/src/uwin32widgetsetdark.pas b/peazip-sources/dev/metadarkstyle/src/uwin32widgetsetdark.pas deleted file mode 100644 index 9036f542..00000000 --- a/peazip-sources/dev/metadarkstyle/src/uwin32widgetsetdark.pas +++ /dev/null @@ -1,2419 +0,0 @@ -{ - Double Commander - ------------------------------------------------------------------------- - Windows dark style widgetset implementation - - Copyright (C) 2021-2023 Alexander Koblov (alexx2000@mail.ru) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this program. If not, see . -} - -unit uWin32WidgetSetDark; - -{$mode objfpc}{$H+} -{$modeswitch advancedrecords} - -interface - -uses - Controls, - LCLVersion, uDarkStyleParams, uDarkStyleSchemes; - -procedure ApplyDarkStyle; -procedure DarkFormChanged(Form: TObject); -procedure Initialize(const CS:TDSColors); -procedure SetColorsScheme(Scheme:TDSColors); -procedure TryEnforceDarkStyleForCtrl(AWinControl: TWinControl); - -implementation - -uses - Classes, SysUtils, Win32Int, WSLCLClasses, Forms, Windows, Win32Proc, Menus, - LCLType, Win32WSComCtrls, ComCtrls, LMessages, Win32WSStdCtrls, - WSStdCtrls, Win32WSControls, StdCtrls, WSControls, Graphics, Themes, LazUTF8, - UxTheme, Win32Themes, ExtCtrls, WSMenus, JwaWinGDI, FPImage, Math, uDarkStyle, - WSComCtrls, CommCtrl, uImport, WSForms, Win32WSButtons, Buttons, Win32Extra, - Win32WSForms, Win32WSSpin, Spin, Win32WSMenus, Dialogs, GraphUtil, - Generics.Collections, TmSchema, InterfaceBase; - -type - TWinControlDark = class(TWinControl); - TCustomGroupBoxDark = class(TCustomGroupBox); - -type - - { TWin32WSWinControlDark } - - TWin32WSWinControlDark = class(TWin32WSWinControl) - published - class function CreateHandle(const AWinControl: TWinControl; - const AParams: TCreateParams): HWND; override; - end; - - { TWin32WSStatusBarDark } - - TWin32WSStatusBarDark = class(TWin32WSStatusBar) - published - class function CreateHandle(const AWinControl: TWinControl; - const AParams: TCreateParams): HWND; override; - end; - - { TWin32WSCustomComboBoxDark } - - TWin32WSCustomComboBoxDark = class(TWin32WSCustomComboBox) - published - class function CreateHandle(const AWinControl: TWinControl; - const AParams: TCreateParams): HWND; override; - class function GetDefaultColor(const AControl: TControl; - const ADefaultColorType: TDefaultColorType): TColor; override; - end; - - { TWin32WSCustomMemoDark } - - TWin32WSCustomMemoDark = class(TWin32WSCustomMemo) - published - class function CreateHandle(const AWinControl: TWinControl; - const AParams: TCreateParams): HWND; override; - end; - - { TWin32WSCustomListBoxDark } - - TWin32WSCustomListBoxDark = class(TWin32WSCustomListBox) - published - class function CreateHandle(const AWinControl: TWinControl; - const AParams: TCreateParams): HWND; override; - end; - - { TWin32WSCustomListViewDark } - - TWin32WSCustomListViewDark = class(TWin32WSCustomListView) - published - class function CreateHandle(const AWinControl: TWinControl; - const AParams: TCreateParams): HWND; override; - end; - - { TWin32WSScrollBoxDark } - - TWin32WSScrollBoxDark = class(TWin32WSScrollBox) - published - class function CreateHandle(const AWinControl: TWinControl; - const AParams: TCreateParams): HWND; override; - end; - - { TWin32WSCustomFormDark } - - TWin32WSCustomFormDark = class(TWin32WSCustomForm) - published - class function CreateHandle(const AWinControl: TWinControl; - const AParams: TCreateParams): HWND; override; - end; - - { TWin32WSTrackBarDark } - - TWin32WSTrackBarDark = class(TWin32WSTrackBar) - published - class function CreateHandle(const AWinControl: TWinControl; - const AParams: TCreateParams): HWND; override; - class procedure DefaultWndHandler(const AWinControl: TWinControl; - var AMessage); override; - end; - - { TWin32WSPopupMenuDark } - - TWin32WSPopupMenuDark = class(TWin32WSPopupMenu) - published - class procedure Popup(const APopupMenu: TPopupMenu; const X, Y: integer); override; - end; - -const - ID_SUB_SCROLLBOX = 1; - ID_SUB_LISTBOX = 2; - ID_SUB_COMBOBOX = 3; - ID_SUB_STATUSBAR = 4; - ID_SUB_TRACKBAR = 5; - ID_SUB_LISTVIEW = 6; - -const - themelib = 'uxtheme.dll'; - -const - VSCLASS_DARK_EDIT = 'DarkMode_CFD::Edit'; - VSCLASS_DARK_TAB = 'BrowserTab::Tab'; - VSCLASS_DARK_BUTTON = 'DarkMode_Explorer::Button'; - VSCLASS_DARK_COMBOBOX = 'DarkMode_CFD::Combobox'; - VSCLASS_DARK_SCROLLBAR = 'DarkMode_Explorer::ScrollBar'; - VSCLASS_DARK_HEADER = 'Header'; - VSCLASS_PROGRESS_INDER = 'Indeterminate::Progress'; - -const - MDL_MENU_SUBMENU = #$EE#$A5#$B0; // $E970 - - MDL_RADIO_FILLED = #$EE#$A8#$BB; // $EA3B - MDL_RADIO_CHECKED = #$EE#$A4#$95; // $E915 - MDL_RADIO_OUTLINE = #$EE#$A8#$BA; // $EA3A - - MDL_CHECKBOX_FILLED = #$EE#$9C#$BB; // $E73B - MDL_CHECKBOX_CHECKED = #$EE#$9C#$BE; // $E73E - MDL_CHECKBOX_GRAYED = #$EE#$9C#$BC; // $E73C - MDL_CHECKBOX_OUTLINE = #$EE#$9C#$B9; // $E739 - - MDL_SCROLLBOX_BTNLEFT = #$EE#$B7#$99; // $E00E - MDL_SCROLLBOX_BTNRIGHT = #$EE#$B7#$9A; // $E00F - MDL_SCROLLBOX_BTNUP = #$EE#$B7#$9B; // $E010 - MDL_SCROLLBOX_BTNDOWN = #$EE#$B7#$9C; // $E011 - - MDL_COMBOBOX_BTNDOWN = #$EE#$A5#$B2; // $E972 - -type - TThemeClassMap = specialize TDictionary; - -var - Theme: TThemeData; - ThemeClass: TThemeClassMap = nil; - OldUpDownWndProc: Windows.WNDPROC; - CustomFormWndProc: Windows.WNDPROC; - SysColor: TSysColors; - SysColorBrush: array[0..COLOR_ENDCOLORS] of HBRUSH; - DrawControl: TDrawControl; - DefSubclassProc: function(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; - SetWindowSubclass: function(hWnd: HWND; pfnSubclass: SUBCLASSPROC; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): BOOL; stdcall; - -var - TrampolineOpenThemeData: function(hwnd: HWND; pszClassList: LPCWSTR): HTHEME; stdcall = nil; - TrampolineDrawThemeText: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; pszText: LPCWSTR; iCharCount: Integer; - dwTextFlags, dwTextFlags2: DWORD; const pRect: TRect): HRESULT; stdcall = nil; - TrampolineDrawThemeBackground: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: Pointer): HRESULT; stdcall = nil; - -procedure EnableDarkStyle(Window: HWND); -begin - AllowDarkModeForWindow(Window, True); - SetWindowTheme(Window, 'DarkMode_Explorer', nil); - SendMessageW(Window, WM_THEMECHANGED, 0, 0); -end; - -procedure TryEnforceDarkStyleForCtrl(AWinControl:TWinControl); -begin - if (AWinControl <> nil) then begin - if (AWinControl Is TCustomMemo) then - (AWinControl As TCustomMemo).BorderStyle := bsNone; - AWinControl.Color := clWindow; - EnableDarkStyle(AWinControl.Handle); - end; -end; - -procedure AllowDarkStyle(var Window: HWND); -begin - if (Window <> 0) then - begin - AllowDarkModeForWindow(Window, True); - Window:= 0; - end; -end; - -function HSVToColor(H, S, V: Double): TColor; -var - R, G, B: Integer; -begin - HSVtoRGB(H, S, V, R, G, B); - R := Min(MAXBYTE, R); - G := Min(MAXBYTE, G); - B := Min(MAXBYTE, B); - Result:= RGBToColor(R, G, B); -end; - -function Darker(Color: TColor; Factor: Integer): TColor; forward; - -function Lighter(Color: TColor; Factor: Integer): TColor; -var - H, S, V: Double; -begin - // Invalid factor - if (Factor <= 0) then - Exit(Color); - // Makes color darker - if (Factor < 100) then begin - Exit(darker(Color, 10000 div Factor)); - end; - - ColorToHSV(Color, H, S, V); - - V:= (Factor * V) / 100; - if (V > High(Word)) then - begin - // Overflow, adjust saturation - S -= V - High(Word); - if (S < 0) then - S := 0; - V:= High(Word); - end; - - Result:= HSVToColor(H, S, V); -end; - -function Darker(Color: TColor; Factor: Integer): TColor; -var - H, S, V: Double; -begin - // Invalid factor - if (Factor <= 0) then - Exit(Color); - // Makes color lighter - if (Factor < 100) then - Exit(lighter(Color, 10000 div Factor)); - - ColorToHSV(Color, H, S, V); - V := (V * 100) / Factor; - - Result:= HSVToColor(H, S, V); -end; - -{ - Fill rectangle gradient -} -function FillGradient(hDC: HDC; Start, Finish: TColor; ARect: TRect; dwMode: ULONG): Boolean; -var - cc: TFPColor; - gRect: GRADIENT_RECT; - vert: array[0..1] of TRIVERTEX; -begin - cc:= TColorToFPColor(Start); - - vert[0].x := ARect.Left; - vert[0].y := ARect.Top; - vert[0].Red := cc.red; - vert[0].Green := cc.green; - vert[0].Blue := cc.blue; - vert[0].Alpha := cc.alpha; - - cc:= TColorToFPColor(ColorToRGB(Finish)); - - vert[1].x := ARect.Right; - vert[1].y := ARect.Bottom; - vert[1].Red := cc.red; - vert[1].Green := cc.green; - vert[1].Blue := cc.blue; - vert[1].Alpha := cc.alpha; - - gRect.UpperLeft := 0; - gRect.LowerRight := 1; - Result:= JwaWinGDI.GradientFill(hDC, vert, 2, @gRect, 1, dwMode); -end; - -function GetNonClientMenuBorderRect(Window: HWND): TRect; -var - R, W: TRect; -begin - GetClientRect(Window, @R); - // Map to screen coordinate space - MapWindowPoints(Window, 0, @R, 2); - GetWindowRect(Window, @W); - OffsetRect(R, -W.Left, -W.Top); - Result:= Classes.Rect(R.Left, R.Top - 1, R.Right, R.Top); -end; - -{ - Set menu background color -} -procedure SetMenuBackground(Menu: HMENU); -var - MenuInfo: TMenuInfo; -begin - MenuInfo:= Default(TMenuInfo); - MenuInfo.cbSize:= SizeOf(MenuInfo); - MenuInfo.fMask:= MIM_BACKGROUND or MIM_APPLYTOSUBMENUS; - MenuInfo.hbrBack:= CreateSolidBrush(SysColor[COLOR_MENU]{RGBToColor(45, 45, 45)}); - SetMenuInfo(Menu, @MenuInfo); -end; - -{ - Set control colors -} -procedure SetControlColors(Control: TControl; Canvas: HDC); -var - Color: TColor; -begin - if not (csDesigning in Control.ComponentState) then begin - - // Set background color - Color:= Control.Color; - if Color = clDefault then - begin - Color:= Control.GetDefaultColor(dctBrush); - end; - SetBkColor(Canvas, ColorToRGB(Color)); - - // Set text color - Color:= Control.Font.Color; - if Color = clDefault then - begin - Color:= Control.GetDefaultColor(dctFont); - end; - SetTextColor(Canvas, ColorToRGB(Color)); - - end; -end; - -{ TWin32WSUpDownControlDark } - -procedure DrawUpDownArrow(Window: HWND; Canvas: TCanvas; ARect: TRect; AType: TUDAlignButton); -var - j: integer; - ax, ay, ah, aw: integer; - - procedure Calculate(var a, b: Integer); - var - tmp: Double; - begin - tmp:= Double(a + 1) / 2; - if (tmp > b) then - begin - a:= 2 * b - 1; - b:= (a + 1) div 2; - end - else begin - b:= Round(tmp); - a:= 2 * b - 1; - end; - b:= Max(b, 3); - a:= Max(a, 5); - end; - -begin - aw:= ARect.Width div 2; - ah:= ARect.Height div 2; - - if IsWindowEnabled(Window) then - Canvas.Pen.Color:= clBtnText - else begin - Canvas.Pen.Color:= clGrayText; - end; - if (AType in [udLeft, udRight]) then - Calculate(ah, aw) - else begin - Calculate(aw, ah); - end; - ax:= ARect.Left + (ARect.Width - aw) div 2; - ay:= ARect.Top + (ARect.Height - ah) div 2; - - case AType of - udLeft: - begin - for j:= 0 to ah div 2 do - begin - Canvas.MoveTo(ax + aw - j - 2, ay + j); - Canvas.LineTo(ax + aw - j - 2, ay + ah - j - 1); - end; - end; - udRight: - begin - for j:= 0 to ah div 2 do - begin - Canvas.MoveTo(ax + j, ay + j); - Canvas.LineTo(ax + j, ay + ah - j - 1); - end; - end; - udTop: - begin - for j:= 0 to aw div 2 do - begin - Canvas.MoveTo(ax + j, ay + ah - j - 1); - Canvas.LineTo(ax + aw - j, ay + ah - j - 1); - end; - end; - udBottom: - begin - for j:= 0 to aw div 2 do - begin - Canvas.MoveTo(ax + j, ay + j); - Canvas.LineTo(ax + aw - j, ay + j); - end; - end; - end; -end; - -function UpDownWndProc(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM): LRESULT; stdcall; -var - DC: HDC; - L, R: TRect; - rcDst: TRect; - ARect: TRect; - PS: PAINTSTRUCT; - LCanvas : TCanvas; - LButton, RButton: TUDAlignButton; -begin - case Msg of - WM_PAINT: - begin - DC := BeginPaint(Window, @ps); - LCanvas := TCanvas.Create; - try - LCanvas.Handle:= DC; - - GetClientRect(Window, @ARect); - - LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; - LCanvas.FillRect(ps.rcPaint); - - L:= ARect; - R:= ARect; - - if (GetWindowLongPtr(Window, GWL_STYLE) and UDS_HORZ <> 0) then - begin - LButton:= udLeft; - RButton:= udRight; - R.Left:= R.Width div 2; - L.Right:= L.Right - L.Width div 2; - end - else begin - LButton:= udTop; - RButton:= udBottom; - R.Top:= R.Height div 2; - L.Bottom:= L.Bottom - L.Height div 2; - end; - - if (IntersectRect(rcDst, L, PS.rcPaint)) then - begin - LCanvas.Pen.Color:= SysColor[COLOR_BTNSHADOW];//RGBToColor(38, 38, 38); - LCanvas.RoundRect(L, 4, 4); - InflateRect(L, -1, -1); - LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT];//RGBToColor(92, 92, 92); - LCanvas.RoundRect(L, 4, 4); - DrawUpDownArrow(Window, LCanvas, L, LButton); - end; - - if (IntersectRect(rcDst, R, PS.rcPaint)) then - begin - LCanvas.Pen.Color:= SysColor[COLOR_BTNSHADOW];//RGBToColor(38, 38, 38); - LCanvas.RoundRect(R, 4, 4); - InflateRect(R, -1, -1); - LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT];//RGBToColor(92, 92, 92); - LCanvas.RoundRect(R, 4, 4); - DrawUpDownArrow(Window, LCanvas, R, RButton); - end; - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; - EndPaint(Window, @ps); - Result:= 0; - end; - WM_ERASEBKGND: - begin - Exit(1); - end; - else begin - Result:= CallWindowProc(OldUpDownWndProc, Window, Msg, WParam, LParam); - end; - end; -end; - -{ TWin32WSTrackBarDark } - -function TrackBarWindowProc(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM; uISubClass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; -begin - if Msg = WM_ERASEBKGND then - Result := 1 - else - Result := DefSubclassProc(Window, Msg, WParam, LParam); -end; - -class function TWin32WSTrackBarDark.CreateHandle( - const AWinControl: TWinControl; const AParams: TCreateParams): HWND; -begin - AWinControl.Color:= SysColor[COLOR_BTNFACE]; - Result:= inherited CreateHandle(AWinControl, AParams); - SetWindowSubclass(Result, @TrackBarWindowProc, ID_SUB_TRACKBAR, 0); -end; - -class procedure TWin32WSTrackBarDark.DefaultWndHandler( - const AWinControl: TWinControl; var AMessage); -var - NMHdr: PNMHDR; - NMCustomDraw: PNMCustomDraw; -begin - with TLMessage(AMessage) do - case Msg of - CN_NOTIFY: - begin - NMHdr := PNMHDR(LParam); - if NMHdr^.code = NM_CUSTOMDRAW then - begin - NMCustomDraw:= PNMCustomDraw(LParam); - case NMCustomDraw^.dwDrawStage of - CDDS_PREPAINT: - begin - Result := CDRF_NOTIFYITEMDRAW; - end; - CDDS_ITEMPREPAINT: - begin - case NMCustomDraw^.dwItemSpec of - TBCD_CHANNEL: - begin - Result:= CDRF_SKIPDEFAULT; - SelectObject(NMCustomDraw^.hdc, GetStockObject(DC_PEN)); - SetDCPenColor(NMCustomDraw^.hdc, SysColor[COLOR_BTNSHADOW]); - SelectObject(NMCustomDraw^.hdc, GetStockObject(DC_BRUSH)); - SetDCBrushColor(NMCustomDraw^.hdc, SysColor[COLOR_BTNFACE]); - with NMCustomDraw^.rc do - RoundRect(NMCustomDraw^.hdc, Left, Top, Right, Bottom, 6, 6); - end; - else begin - Result:= CDRF_DODEFAULT; - end; - end; - end; - end; - end; - end - else - inherited DefaultWndHandler(AWinControl, AMessage); - end; -end; - -{ TWin32WSScrollBoxDark } - -function ScrollBoxWindowProc(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM; uISubClass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; -var - DC: HDC; - R, W: TRect; - Delta: Integer; -begin - Result:= DefSubclassProc(Window, Msg, WParam, LParam); - - if Msg = WM_NCPAINT then - begin - GetClientRect(Window, @R); - MapWindowPoints(Window, 0, @R, 2); - GetWindowRect(Window, @W); - Delta:= Abs(W.Top - R.Top); - - DC:= GetWindowDC(Window); - ExcludeClipRect(DC, Delta, Delta, W.Width - Delta, W.Height - Delta); - SelectObject(DC, GetStockObject(DC_PEN)); - SelectObject(DC, GetStockObject(DC_BRUSH)); - SetDCPenColor(DC, SysColor[COLOR_BTNSHADOW]); - SetDCBrushColor(DC, SysColor[COLOR_BTNHIGHLIGHT]); - Rectangle(DC, 0, 0, W.Width, W.Height); - ReleaseDC(Window, DC); - end; -end; - -class function TWin32WSScrollBoxDark.CreateHandle( - const AWinControl: TWinControl; const AParams: TCreateParams): HWND; -begin - Result:= inherited CreateHandle(AWinControl, AParams); - if not (csDesigning in AWinControl.ComponentState) then begin - if TScrollBox(AWinControl).BorderStyle = bsSingle then begin - SetWindowSubclass(Result, @ScrollBoxWindowProc, ID_SUB_SCROLLBOX, 0); - end; - EnableDarkStyle(Result); - end; -end; - -{ TWin32WSPopupMenuDark } - -class procedure TWin32WSPopupMenuDark.Popup(const APopupMenu: TPopupMenu; - const X, Y: integer); -begin - SetMenuBackground(APopupMenu.Handle); - - inherited Popup(APopupMenu, X, Y); -end; - -{ TWin32WSWinControlDark } - -class function TWin32WSWinControlDark.CreateHandle( - const AWinControl: TWinControl; const AParams: TCreateParams): HWND; -var - P: TCreateParams; -begin - P:= AParams; - if not (csDesigning in AWinControl.ComponentState) then begin - if (AWinControl is TCustomTreeView) then - begin - AWinControl.Color:= SysColor[COLOR_WINDOW]; - with TCustomTreeView(AWinControl) do begin - if DrawControl.TreeViewExpandSignOverride then - ExpandSignType:=DrawControl.TreeViewExpandSignValue; - TreeLineColor:= SysColor[COLOR_GRAYTEXT]; - ExpandSignColor:= SysColor[COLOR_GRAYTEXT]; - end; - end; - P.ExStyle:= p.ExStyle and not WS_EX_CLIENTEDGE; - TWinControlDark(AWinControl).BorderStyle:= bsNone; - end; - - Result:= inherited CreateHandle(AWinControl, P); - - if not (csDesigning in AWinControl.ComponentState) then begin - EnableDarkStyle(Result); - end; -end; - -{ TWin32WSCustomFormDark } - -function FormWndProc2(Window: HWnd; Msg: UInt; WParam: Windows.WParam; - LParam: Windows.LParam): LResult; stdcall; -var - DC: HDC; - R: TRect; -begin - case Msg of - WM_NCACTIVATE, - WM_NCPAINT: - begin - Result:= CallWindowProc(CustomFormWndProc, Window, Msg, wParam, lParam); - - DC:= GetWindowDC(Window); - R:= GetNonclientMenuBorderRect(Window); - FillRect(DC, R, GetSysColorBrush(COLOR_WINDOW)); - ReleaseDC(Window, DC); - end; - WM_SHOWWINDOW: - begin - AllowDarkModeForWindow(Window, True); - RefreshTitleBarThemeColor(Window); - end - else begin - Result:= CallWindowProc(CustomFormWndProc, Window, Msg, wParam, lParam); - end; - end; -end; - -class function TWin32WSCustomFormDark.CreateHandle( - const AWinControl: TWinControl; const AParams: TCreateParams): HWND; -var - Info: PWin32WindowInfo; -begin - if not (csDesigning in AWinControl.ComponentState) then begin - AWinControl.DoubleBuffered:= True; - AWinControl.Color:= SysColor[COLOR_BTNFACE]; - AWinControl.Brush.Color:= SysColor[COLOR_BTNFACE]; - end; - - Result:= inherited CreateHandle(AWinControl, AParams); - - Info:= GetWin32WindowInfo(Result); - - Info^.DefWndProc:= @WindowProc; - - CustomFormWndProc:= Windows.WNDPROC(SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@FormWndProc2))); - - if not (csDesigning in AWinControl.ComponentState) then begin - AWinControl.Color:= SysColor[COLOR_BTNFACE]; - AWinControl.Font.Color:= SysColor[COLOR_BTNTEXT]; - end; -end; - -{ TWin32WSCustomListBoxDark } - -function ListBoxWindowProc2(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM; uISubClass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; -var - PS: TPaintStruct; -begin - if Msg = WM_PAINT then - begin - if SendMessage(Window, LB_GETCOUNT, 0, 0) = 0 then - begin - BeginPaint(Window, @ps); - // ListBox:= TCustomListBox(GetWin32WindowInfo(Window)^.WinControl); - // Windows.FillRect(DC, ps.rcPaint, ListBox.Brush.Reference.Handle); - EndPaint(Window, @ps); - end; - end; - Result:= DefSubclassProc(Window, Msg, WParam, LParam); -end; - -class function TWin32WSCustomListBoxDark.CreateHandle( - const AWinControl: TWinControl; const AParams: TCreateParams): HWND; -var - P: TCreateParams; -begin - P:= AParams; - if not (csDesigning in AWinControl.ComponentState) then begin - P.ExStyle:= P.ExStyle and not WS_EX_CLIENTEDGE; - TCustomListBox(AWinControl).BorderStyle:= bsNone; - end; - - Result:= inherited CreateHandle(AWinControl, P); - - if not (csDesigning in AWinControl.ComponentState) then begin - EnableDarkStyle(Result); - SetWindowSubclass(Result, @ListBoxWindowProc2, ID_SUB_LISTBOX, 0); - TCustomListBox(AWinControl).Color:= SysColor[COLOR_WINDOW]; - AWinControl.Font.Color:= SysColor[COLOR_WINDOWTEXT]; - end; -end; - -{ TWin32WSCustomListViewDark } - -function ListViewWindowProc(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM; uISubClass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; -var NMHdr: PNMHDR; NMCustomDraw: PNMCustomDraw; -begin - If Msg = WM_NOTIFY then begin - NMHdr := PNMHDR(LParam); - if NMHdr^.code = NM_CUSTOMDRAW then begin - NMCustomDraw:= PNMCustomDraw(LParam); - case NMCustomDraw^.dwDrawStage of - CDDS_PREPAINT: - begin - Result := CDRF_NOTIFYITEMDRAW; - exit; - end; - CDDS_ITEMPREPAINT: - begin - SetTextColor(NMCustomDraw^.hdc , SysColor[COLOR_HIGHLIGHTTEXT]); - Result := CDRF_NEWFONT; - exit; - end; - end; - end; - end; - Result := DefSubclassProc(Window, Msg, WParam, LParam); -end; - -class function TWin32WSCustomListViewDark.CreateHandle( - const AWinControl: TWinControl; const AParams: TCreateParams): HWND; -var - P: TCreateParams; -begin - P:= AParams; - P.ExStyle:= P.ExStyle and not WS_EX_CLIENTEDGE; - TCustomListView(AWinControl).BorderStyle:= bsNone; - Result:= inherited CreateHandle(AWinControl, P); - SetWindowSubclass(Result, @ListViewWindowProc, ID_SUB_LISTVIEW, 0); - if not (csDesigning in AWinControl.ComponentState) then begin - EnableDarkStyle(Result); - end; -end; - -{ TWin32WSCustomMemoDark } - -class function TWin32WSCustomMemoDark.CreateHandle( - const AWinControl: TWinControl; const AParams: TCreateParams): HWND; -var - P: TCreateParams; -begin - P:= AParams; - - if not (csDesigning in AWinControl.ComponentState) then begin - TCustomEdit(AWinControl).BorderStyle:= bsNone; - P.ExStyle:= P.ExStyle and not WS_EX_CLIENTEDGE; - AWinControl.Color:= SysColor[COLOR_WINDOW]; - AWinControl.Font.Color:= SysColor[COLOR_WINDOWTEXT]; - end; - - Result:= inherited CreateHandle(AWinControl, P); - - if not (csDesigning in AWinControl.ComponentState) then begin - EnableDarkStyle(Result); - end; -end; - -{ TWin32WSCustomComboBoxDark } - -function ComboBoxWindowProc(Window:HWND; Msg:UINT; wParam:Windows.WPARAM;lparam:Windows.LPARAM;uISubClass : UINT_PTR;dwRefData:DWORD_PTR):LRESULT; stdcall; -var - DC: HDC; - ComboBox: TCustomComboBox; -begin - case Msg of - WM_CTLCOLORLISTBOX: - begin - ComboBox:= TCustomComboBox(GetWin32WindowInfo(Window)^.WinControl); - DC:= HDC(wParam); - SetControlColors(ComboBox, DC); - Exit(LResult(ComboBox.Brush.Reference.Handle)); - end; - end; - Result:= DefSubclassProc(Window, Msg, wParam, lParam); -end; - -class function TWin32WSCustomComboBoxDark.CreateHandle( - const AWinControl: TWinControl; const AParams: TCreateParams): HWND; -var - Info: TComboboxInfo; -begin - if not (csDesigning in AWinControl.ComponentState) then begin - AWinControl.Color:= SysColor[COLOR_BTNFACE]; - AWinControl.Font.Color:= SysColor[COLOR_BTNTEXT]; - end; - - Result:= inherited CreateHandle(AWinControl, AParams); - - if not (csDesigning in AWinControl.ComponentState) then begin - Info.cbSize:= SizeOf(Info); - Win32Extra.GetComboBoxInfo(Result, @Info); - - EnableDarkStyle(Info.hwndList); - - AllowDarkModeForWindow(Result, True); - - SetWindowSubclass(Result, @ComboBoxWindowProc, ID_SUB_COMBOBOX, 0); - end; -end; - -class function TWin32WSCustomComboBoxDark.GetDefaultColor( - const AControl: TControl; const ADefaultColorType: TDefaultColorType): TColor; -const - DefColors: array[TDefaultColorType] of TColor = ( - { dctBrush } clBtnFace, - { dctFont } clBtnText - ); -begin - Result:= DefColors[ADefaultColorType]; -end; - -{ TWin32WSStatusBarDark } - -function StatusBarWndProc(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM; uISubClass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; -var - DC: HDC; - X: Integer; - Index: Integer; - PS: TPaintStruct; - LCanvas: TCanvas; - APanel: TStatusPanel; - StatusBar: TStatusBar; - Info: PWin32WindowInfo; - Detail:TThemedElementDetails; - Rect:trect; - gripSize: TSize; -begin - Info:= GetWin32WindowInfo(Window); - if (Info = nil) or (Info^.WinControl = nil) then - begin - Result:= CallDefaultWindowProc(Window, Msg, WParam, LParam); - Exit; - end; - - if Msg = WM_ERASEBKGND then - begin - StatusBar:= TStatusBar(Info^.WinControl); - TWin32WSStatusBar.DoUpdate(StatusBar); - Result:= 0; - Exit; - end; - - if Msg = WM_PAINT then - begin - StatusBar:= TStatusBar(Info^.WinControl); - - TWin32WSStatusBar.DoUpdate(StatusBar); - - DC:= BeginPaint(Window, @ps); - - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= DC; - LCanvas.Brush.Color:= SysColor[COLOR_MENUBAR]; - LCanvas.FillRect(ps.rcPaint); - - X:= 1; - LCanvas.Font.Color:= SysColor[COLOR_BTNTEXT]; - LCanvas.Pen.Color:= SysColor[COLOR_GRAYTEXT]; - if StatusBar.SimplePanel then - LCanvas.TextOut(X+3, (StatusBar.Height - LCanvas.TextHeight('Ag')) div 2, StatusBar.SimpleText) - else - for Index:= 0 to StatusBar.Panels.Count - 1 do - begin - APanel:= StatusBar.Panels[Index]; - if APanel.Width>0 then begin - LCanvas.TextOut(X+1, (StatusBar.Height - LCanvas.TextHeight('Ag')) div 2, APanel.Text); - if Index<>(StatusBar.Panels.Count - 1)then begin - X+= APanel.Width; - LCanvas.Line(x-2, ps.rcPaint.Top+3, x-2, ps.rcPaint.Bottom-3); - end; - end; - end; - if StatusBar.SizeGrip then begin - Rect:=StatusBar.ClientRect; - Detail:=ThemeServices.GetElementDetails(tsGripper); - GetThemePartSize(TWin32ThemeServices(ThemeServices).Theme[teStatus], - LCanvas.Handle, SP_GRIPPER, 0, @Rect, TS_DRAW, gripSize); - Rect.Left:=Rect.Right-gripSize.cx; - Rect.Top:=Rect.Bottom-gripSize.cy; - ThemeServices.DrawElement(LCanvas.Handle,Detail,Rect); - end; - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; - EndPaint(Window, @ps); - Result:= 0; - end - else - Result:= DefSubclassProc(Window, Msg, WParam, LParam); -end; - -class function TWin32WSStatusBarDark.CreateHandle( - const AWinControl: TWinControl; const AParams: TCreateParams): HWND; -begin - Result:= inherited CreateHandle(AWinControl, AParams); - SetWindowSubclass(Result, @StatusBarWndProc, ID_SUB_STATUSBAR, 0); -end; - -{ - Forward declared functions -} -function InterceptOpenThemeData(hwnd: hwnd; pszClassList: LPCWSTR): hTheme; stdcall; forward; -procedure DrawButton(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: PRECT); forward; -procedure DrawEdit(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: PRECT); forward; -procedure DrawReBar(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: PRECT); forward; -procedure DrawTreeView(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: PRECT); forward; - - -{ - Draws text using the color and font defined by the visual style -} -function DrawThemeTextDark(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; pszText: LPCWSTR; iCharCount: Integer; - dwTextFlags, dwTextFlags2: DWORD; const pRect: TRect): HRESULT; stdcall; -function needMenuGrayText(iPartId, iStateId: Integer):Boolean; -begin - case iPartId of - MENU_POPUPITEM:Result:=(iStateId = MDS_PRESSED)or(iStateId = MDS_DISABLED); - else - Result:=(iStateId in [MBI_DISABLED,MBI_DISABLEDHOT,MBI_DISABLEDPUSHED])and(iPartId<>MENU_BARITEM); - end; -end; -var - OldColor: COLORREF; - Index, Element: TThemedElement; -begin - OldColor:= GetTextColor(hdc); - for Index:= Low(TThemedElement) to High(TThemedElement) do - begin - if Theme[Index] = hTheme then - begin - Element:= Index; - - if Element = teToolTip then - OldColor:= SysColor[COLOR_INFOTEXT] - else if Element = teMenu then begin - if needMenuGrayText(iPartId, iStateId) then - OldColor:= SysColor[COLOR_GRAYTEXT] - else - OldColor:= SysColor[COLOR_BTNTEXT] - end else - OldColor:= SysColor[COLOR_BTNTEXT]; - - Break; - end; - end; - - OldColor:= SetTextColor(hdc, OldColor); - SetBkMode(hdc, TRANSPARENT); - - DrawTextExW(hdc, pszText, iCharCount, @pRect, dwTextFlags, nil); - - SetTextColor(hdc, OldColor); - - Result:= S_OK; -end; - -{ - Draws the border and fill defined by the visual style for the specified control part -} -function DrawThemeBackgroundDark(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT): HRESULT; stdcall; -function needMenuHiglightBkg(iPartId, iStateId: Integer):Boolean; -begin - case iPartId of - MENU_POPUPITEM:Result:=iStateId = MDS_HOT; - else - Result:=(((iStateId = MDS_HOT)or(iStateId = MDS_PRESSED))and(iPartId<>MENU_BARBACKGROUND))or((iPartId=MENU_BARITEM)and(iStateId = MDS_CHECKED)); - end; -end; - -var - LRect: TRect; - AColor: TColor; - LCanvas: TCanvas; - AStyle: TTextStyle; - Index, Element: TThemedElement; -begin - for Index:= Low(TThemedElement) to High(TThemedElement) do - begin - if Theme[Index] = hTheme then - begin - Element:= Index; - if Element = teScrollBar then begin - Element:= Index; - end else if Element = teHeader then begin - if iPartId in [HP_HEADERITEM, HP_HEADERITEMRIGHT] then - begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= hdc; - AColor:= SysColor[COLOR_BTNFACE]; - - if iStateId in [HIS_HOT, HIS_SORTEDHOT, HIS_ICONHOT, HIS_ICONSORTEDHOT] then - FillGradient(hdc, Lighter(AColor, 174), Lighter(AColor, 166), pRect, GRADIENT_FILL_RECT_V) - else - FillGradient(hdc, Lighter(AColor, 124), Lighter(AColor, 116), pRect, GRADIENT_FILL_RECT_V); - - if (iPartId <> HP_HEADERITEMRIGHT) then - begin - LCanvas.Pen.Color:= Lighter(AColor, 104); - LCanvas.Line(pRect.Right-1, pRect.Top, pRect.Right-1, pRect.Bottom); - - LCanvas.Pen.Color:= Lighter(AColor, 158); - LCanvas.Line(pRect.Right - 2, pRect.Top, pRect.Right - 2, pRect.Bottom); - end; - // Top line - LCanvas.Pen.Color:= Lighter(AColor, 164); - LCanvas.Line(pRect.Left, pRect.Top, pRect.Right, pRect.Top); - // Bottom line - LCanvas.Pen.Color:= Darker(AColor, 140); - LCanvas.Line(pRect.Left, pRect.Bottom - 1, pRect.Right, pRect.Bottom - 1); - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; - end; - end else if Element = teListView then begin - if iPartId in [HP_HEADERITEM, HP_HEADERITEMRIGHT] then - begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= hdc; - AColor:= {RGBToColor(95, 95, 95);} SysColor[COLOR_BTNFACE]; - - if iStateId in [HIS_HOT, HIS_SORTEDHOT, HIS_ICONHOT, HIS_ICONSORTEDHOT] then - FillGradient(hdc, Lighter(AColor, 174), Lighter(AColor, 166), pRect, GRADIENT_FILL_RECT_V) - else - FillGradient(hdc, Lighter(AColor, 124), Lighter(AColor, 116), pRect, GRADIENT_FILL_RECT_V); - - if (iPartId <> HP_HEADERITEMRIGHT) then - begin - LCanvas.Pen.Color:= Lighter(AColor, 101); - LCanvas.Line(pRect.Right - 1, pRect.Top, pRect.Right - 1, pRect.Bottom); - - LCanvas.Pen.Color:= Lighter(AColor, 131); - LCanvas.Line(pRect.Right - 2, pRect.Top, pRect.Right - 2, pRect.Bottom); - end; - // Top line - LCanvas.Pen.Color:= Lighter(AColor, 131); - LCanvas.Line(pRect.Left, pRect.Top, pRect.Right, pRect.Top); - // Bottom line - LCanvas.Pen.Color:= Darker(AColor, 140); - LCanvas.Line(pRect.Left, pRect.Bottom - 1, pRect.Right, pRect.Bottom - 1); - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; - end else - if (iPartId = 0) then begin // The unpainted area of the header after the rightmost column - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= hdc; - AColor:=SysColor[COLOR_BTNFACE]; - //FillGradient(hdc, Lighter(AColor, 124), Lighter(AColor, 116), pRect, GRADIENT_FILL_RECT_V); - FillGradient(hdc, Lighter(AColor, 102), Lighter(AColor, 94), pRect, GRADIENT_FILL_RECT_V); - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; - end else - if (iPartId = HP_HEADERSORTARROW) then begin // This applies to the current sort column - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= hdc; - LCanvas.Pen.Color:=RGBToColor(202, 202, 202); - if iStateId = HSAS_SORTEDUP then begin; // iStateId transports the SortDirection - LCanvas.Line(pRect.Left+3, 4, pRect.Left+7, 0); - LCanvas.Line(pRect.Left+6, 1, pRect.Left+10, 5); - end - else if iStateId = HSAS_SORTEDDOWN then begin; - LCanvas.Line(pRect.Left+3, 1, pRect.Left+7, 5); - LCanvas.Line(pRect.Left+6, 4, pRect.Left+10, 0); - end; - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; - end; - end else if Element = teMenu then begin - if iPartId in [MENU_BARBACKGROUND, MENU_BARITEM, MENU_POPUPITEM, MENU_POPUPGUTTER, - MENU_POPUPSUBMENU, MENU_POPUPSEPARATOR, MENU_POPUPCHECK, - MENU_POPUPCHECKBACKGROUND] then begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= hdc; - - if not (iPartId in [MENU_POPUPSUBMENU, MENU_POPUPCHECK, MENU_POPUPCHECKBACKGROUND]) then - begin - if needMenuHiglightBkg(iPartId,iStateId) then - LCanvas.Brush.Color:= SysColor[COLOR_MENUHILIGHT] - else begin - LCanvas.Brush.Color:= SysColor[COLOR_MENUBAR];//RGBToColor(45, 45, 45); - end; - LCanvas.FillRect(pRect); - end; - - if iPartId = MENU_POPUPCHECK then - begin - AStyle:= LCanvas.TextStyle; - AStyle.Layout:= tlCenter; - AStyle.Alignment:= taCenter; - LCanvas.Brush.Style:= bsClear; - LCanvas.Font.Name:= 'Segoe MDL2 Assets'; - LCanvas.Font.Color:= SysColor[COLOR_MENUTEXT];//RGBToColor(212, 212, 212); - LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_CHECKBOX_CHECKED, AStyle); - end; - - if iPartId = MENU_POPUPSEPARATOR then - begin - LRect:= pRect; - LCanvas.Pen.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(112, 112, 112); - LRect.Top:= LRect.Top + (LRect.Height div 2); - LRect.Bottom:= LRect.Top; - - LCanvas.Line(LRect); - end; - - if (iPartId = MENU_POPUPCHECKBACKGROUND) then - begin - LRect:= pRect; - InflateRect(LRect, -1, -1); - LCanvas.Pen.Color:= SysColor[COLOR_MENU];//RGBToColor(45, 45, 45); - LCanvas.Brush.Color:= SysColor[COLOR_MENUHILIGHT];//RGBToColor(81, 81, 81); - LCanvas.RoundRect(LRect, 6, 6); - end; - - if iPartId = MENU_POPUPSUBMENU then - begin - LCanvas.Brush.Style:= bsClear; - LCanvas.Font.Name:= 'Segoe MDL2 Assets'; - LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(111, 111, 111); - LCanvas.TextOut(pRect.Left, pRect.Top, MDL_MENU_SUBMENU); - end; - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; - end; - end else if Element = teToolBar then begin - if iPartId in [TP_BUTTON, TP_SPLITBUTTON, TP_SPLITBUTTONDROPDOWN] then - begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= hdc; - AColor:= SysColor[COLOR_BTNFACE]; - - if iStateId = TS_HOT then - LCanvas.Brush.Color:= Lighter(AColor, 116) - else if iStateId = TS_PRESSED then - LCanvas.Brush.Color:= Darker(AColor, 116) - else begin - LCanvas.Brush.Color:= AColor; - end; - LCanvas.FillRect(pRect); - - if iStateId <> TS_NORMAL then begin - if iStateId = TS_CHECKED then begin - LRect:= pRect; - InflateRect(LRect, -2, -2); - LCanvas.Brush.Color:= Lighter(AColor, 146); - LCanvas.FillRect(LRect); - end; - - LCanvas.Pen.Color:= Darker(AColor, 140); - LCanvas.RoundRect(pRect, 6, 6); - - LRect:= pRect; - - LCanvas.Pen.Color:= Lighter(AColor, 140); - InflateRect(LRect, -1, -1); - LCanvas.RoundRect(LRect, 6, 6); - end; - - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; - end; - if iPartId = TP_SPLITBUTTONDROPDOWN then - begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= hdc; - DrawUpDownArrow(hDC, LCanvas, pRect, udBottom); - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; - end; - end else if Element = teButton then - DrawButton(hTheme, hdc, iPartId, iStateId, pRect, pClipRect) - else if Element = teEdit then - DrawEdit(hTheme,hdc,iPartId,iStateId,pRect,pClipRect) - else if Element = teRebar then - DrawRebar(hTheme,hdc,iPartId,iStateId,pRect,pClipRect) - - else if (Element = teTreeview) and DrawControl.CustomDrawTreeViews then - DrawTreeView(hTheme,hdc,iPartId,iStateId,pRect,pClipRect) - else - TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - exit(S_OK); - end; - end; - TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - Result:= S_OK; -end; - -var - __CreateWindowExW: function(dwExStyle: DWORD; lpClassName: LPCWSTR; lpWindowName: LPCWSTR; dwStyle: DWORD; X: longint; Y: longint; nWidth: longint; nHeight: longint; hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: LPVOID): HWND; stdcall; - -function _DrawEdge(hdc: HDC; var qrc: TRect; edge: UINT; grfFlags: UINT): BOOL; stdcall; -var - Original: HGDIOBJ; - ClientRect: TRect; - ColorDark, ColorLight: TColorRef; - - procedure DrawLine(X1, Y1, X2, Y2: Integer); - begin - MoveToEx(hdc, X1, Y1, nil); - LineTo(hdc, X2, Y2); - end; - - procedure InternalDrawEdge(Outer: Boolean; const R: TRect); - var - X1, Y1, X2, Y2: Integer; - ColorLeftTop, ColorRightBottom: TColor; - begin - X1:= R.Left; - Y1:= R.Top; - X2:= R.Right; - Y2:= R.Bottom; - - ColorLeftTop:= clNone; - ColorRightBottom:= clNone; - - if Outer then - begin - if Edge and BDR_RAISEDOUTER <> 0 then - begin - ColorLeftTop:= ColorLight; - ColorRightBottom:= ColorDark; - end - else if Edge and BDR_SUNKENOUTER <> 0 then - begin - ColorLeftTop:= ColorDark; - ColorRightBottom:= ColorLight; - end; - end - else - begin - if Edge and BDR_RAISEDINNER <> 0 then - begin - ColorLeftTop:= ColorLight; - ColorRightBottom:= ColorDark; - end - else if Edge and BDR_SUNKENINNER <> 0 then - begin - ColorLeftTop:= ColorDark; - ColorRightBottom:= ColorLight; - end; - end; - - SetDCPenColor(hdc, ColorLeftTop); - - if grfFlags and BF_LEFT <> 0 then - DrawLine(X1, Y1, X1, Y2); - if grfFlags and BF_TOP <> 0 then - DrawLine(X1, Y1, X2, Y1); - - SetDCPenColor(hdc, ColorRightBottom); - - if grfFlags and BF_RIGHT <> 0 then - DrawLine(X2, Y1, X2, Y2); - if grfFlags and BF_BOTTOM <> 0 then - DrawLine(X1, Y2, X2, Y2); - end; - -begin - Result:= False; - if IsRectEmpty(qrc) then - Exit; - - ClientRect:= qrc; - Dec(ClientRect.Right, 1); - Dec(ClientRect.Bottom, 1); - Original:= SelectObject(hdc, GetStockObject(DC_PEN)); - try - ColorDark:= SysColor[COLOR_BTNSHADOW]; - ColorLight:= SysColor[COLOR_BTNHIGHLIGHT]; - - if Edge and (BDR_SUNKENOUTER or BDR_RAISEDOUTER) <> 0 then - begin - InternalDrawEdge(True, ClientRect); - end; - - InflateRect(ClientRect, -1, -1); - - if Edge and (BDR_SUNKENINNER or BDR_RAISEDINNER) <> 0 then - begin - InternalDrawEdge(False, ClientRect); - InflateRect(ClientRect, -1, -1); - end; - - Inc(ClientRect.Right); - Inc(ClientRect.Bottom); - - if grfFlags and BF_ADJUST <> 0 then - begin - qrc:= ClientRect; - end; - - Result:= True; - finally - SelectObject(hdc, Original); - end; -end; - -{ - Retrieves the current color of the specified display element -} -function GetSysColorDark(nIndex: longint): DWORD; stdcall; -begin - if (nIndex >= 0) and (nIndex <= COLOR_ENDCOLORS) then - Result:= SysColor[nIndex] - else begin - Result:= 0; - end; -end; - -{ - Retrieves a handle identifying a logical brush that corresponds to the specified color index -} -function GetSysColorBrushDark(nIndex: longint): HBRUSH; stdcall; -begin - if (nIndex >= 0) and (nIndex <= COLOR_ENDCOLORS) then - begin - if (SysColorBrush[nIndex] = 0) then - begin - SysColorBrush[nIndex]:= CreateSolidBrush(SysColor[nIndex]); - end; - Result:= SysColorBrush[nIndex]; - end - else begin - Result:= CreateSolidBrush(GetSysColorDark(nIndex)); - end; -end; - -const - ClassNameW: PWideChar = 'TCustomForm'; - ClassNameTC: PWideChar = 'TTOTAL_CMD'; // for compatibility with plugins - -function _CreateWindowExW(dwExStyle: DWORD; lpClassName: LPCWSTR; lpWindowName: LPCWSTR; dwStyle: DWORD; X: longint; Y: longint; nWidth: longint; nHeight: longint; hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: LPVOID): HWND; stdcall; -var - AParams: PNCCreateParams absolute lpParam; -begin - if Assigned(AParams) and (AParams^.WinControl is TCustomForm) then - begin - if (hWndParent = 0) and AParams^.WinControl.ClassNameIs('TfrmMain') then - lpClassName:= ClassNameTC - else begin - lpClassName:= ClassNameW; - end; - end else begin - dwExStyle:= dwExStyle or WS_EX_CONTEXTHELP; - end; - Result:= __CreateWindowExW(dwExStyle, lpClassName, lpWindowName, dwStyle, X, Y, nWidth, nHeight, hWndParent, hMenu, hInstance, lpParam); -end; - -function TaskDialogIndirectDark(const pTaskConfig: PTASKDIALOGCONFIG; pnButton: PInteger; pnRadioButton: PInteger; pfVerificationFlagChecked: PBOOL): HRESULT; stdcall; -const - BTN_USER = $1000; -var - Idx: Integer; - Index: Integer; - Button: TDialogButton; - Buttons: TDialogButtons; - DlgType: Integer = idDialogInfo; -begin - with pTaskConfig^ do - begin - if (pszMainIcon = TD_INFORMATION_ICON) then - DlgType:= idDialogInfo - else if (pszMainIcon = TD_WARNING_ICON) then - DlgType:= idDialogWarning - else if (pszMainIcon = TD_ERROR_ICON) then - DlgType:= idDialogError - else if (pszMainIcon = TD_SHIELD_ICON) then - DlgType:= idDialogShield - else if (dwFlags and TDF_USE_HICON_MAIN <> 0) then - begin - if (hMainIcon = Windows.LoadIcon(0, IDI_QUESTION)) then - DlgType:= idDialogConfirm; - end; - - Buttons:= TDialogButtons.Create(TDialogButton); - try - for Index:= 0 to cButtons - 1 do - begin - Button:= Buttons.Add; - Idx:= pButtons[Index].nButtonID; - Button.ModalResult:= (Idx + BTN_USER); - Button.Default:= (Idx = nDefaultButton); - Button.Caption:= UTF8Encode(UnicodeString(pButtons[Index].pszButtonText)); - end; - - Result:= DefaultQuestionDialog(UTF8Encode(UnicodeString(pszWindowTitle)), - UTF8Encode(UnicodeString(pszContent)), DlgType, Buttons, 0); - - if Assigned(pnButton) then - begin - if (Result < BTN_USER) then - pnButton^:= Result - else begin - pnButton^:= Result - BTN_USER; - end; - end; - finally - Buttons.Free; - end; - end; - Result:= S_OK; -end; - -procedure SubClassUpDown; -var - Window: HWND; -begin - Window:= CreateWindowW(UPDOWN_CLASSW, nil, 0, 0, 0, 200, 20, 0, 0, HINSTANCE, nil); - OldUpDownWndProc:= Windows.WNDPROC(GetClassLongPtr(Window, GCLP_WNDPROC)); - - SetClassLongPtr(Window, GCLP_WNDPROC, LONG_PTR(@UpDownWndProc)); - DestroyWindow(Window); -end; - -procedure ScreenFormEvent(Self, Sender: TObject; Form: TCustomForm); -begin - if Assigned(Form.Menu) then - begin - Form.Menu.OwnerDraw:= True; - SetMenuBackground(GetMenu(Form.Handle)); - Form.Menu.OwnerDraw:= False; - end; -end; - -procedure DarkFormChanged(Form: TObject); -begin - if not IsDarkModeEnabled then - Exit; - if Form is TForm then - ScreenFormEvent(nil,nil,Form as TForm); -end; - -{ - Override several widgetset controls -} -procedure ApplyDarkStyle; -var - Handler: TMethod; - Index: TThemedElement; -begin - if not IsDarkModeEnabled then - Exit; - - SubClassUpDown; - - OpenThemeData:= @InterceptOpenThemeData; - - DefBtnColors[dctFont]:= SysColor[COLOR_BTNTEXT]; - DefBtnColors[dctBrush]:= SysColor[COLOR_BTNFACE]; - - Handler.Code:= @ScreenFormEvent; - Screen.AddHandlerFormVisibleChanged(TScreenFormEvent(Handler), True); - - with TWinControl.Create(nil) do Free; - RegisterWSComponent(TWinControl, TWin32WSWinControlDark); - - WSComCtrls.RegisterStatusBar; - RegisterWSComponent(TStatusBar, TWin32WSStatusBarDark); - - WSStdCtrls.RegisterCustomComboBox; - RegisterWSComponent(TCustomComboBox, TWin32WSCustomComboBoxDark); - - WSStdCtrls.RegisterCustomEdit; - - WSStdCtrls.RegisterCustomMemo; - RegisterWSComponent(TCustomMemo, TWin32WSCustomMemoDark); - - WSStdCtrls.RegisterCustomListBox; - RegisterWSComponent(TCustomListBox, TWin32WSCustomListBoxDark); - - WSComCtrls.RegisterCustomListView; - RegisterWSComponent(TCustomListView, TWin32WSCustomListViewDark); - - WSForms.RegisterScrollingWinControl; - - WSForms.RegisterCustomForm; - RegisterWSComponent(TCustomForm, TWin32WSCustomFormDark); - - WSMenus.RegisterMenu; - WSMenus.RegisterPopupMenu; - RegisterWSComponent(TPopupMenu, TWin32WSPopupMenuDark); - - WSForms.RegisterScrollBox; - RegisterWSComponent(TScrollBox, TWin32WSScrollBoxDark); - - RegisterCustomTrackBar; - RegisterWSComponent(TCustomTrackBar, TWin32WSTrackBarDark); - - DrawThemeText:= @DrawThemeTextDark; - DrawThemeBackground:= @DrawThemeBackgroundDark; - - for Index:= Low(TThemedElement) to High(TThemedElement) do - begin - Theme[Index]:= TWin32ThemeServices(ThemeServices).Theme[Index]; - end; - - DefaultWindowInfo.DefWndProc:= @WindowProc; - - TaskDialogIndirect:= @TaskDialogIndirectDark; -end; - -function FormWndProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam; - LParam: Windows.LParam): LResult; stdcall; -var - Info: PWin32WindowInfo; -begin - if Msg = WM_CREATE then - begin - AllowDarkModeForWindow(Window, True); - RefreshTitleBarThemeColor(Window); - end - else if (Msg = WM_SETFONT) then - begin - Info := GetWin32WindowInfo(Window); - if Assigned(Info) then - begin - Info^.DefWndProc:= @WindowProc; - end; - Result:= CallWindowProc(@WindowProc, Window, Msg, WParam, LParam); - Exit; - end; - Result:= DefWindowProc(Window, Msg, WParam, LParam); -end; - -procedure DrawCheckBox(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -var - LCanvas: TCanvas; - AStyle: TTextStyle; -begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= HDC; - - LCanvas.Brush.Color:= clBtnFace; - LCanvas.FillRect(pRect); - - AStyle:= LCanvas.TextStyle; - AStyle.Layout:= tlCenter; - AStyle.ShowPrefix:= True; - - // Fill checkbox rect - LCanvas.Font.Name:= 'Segoe MDL2 Assets'; - LCanvas.Font.Color:= SysColor[COLOR_WINDOW]; - LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_CHECKBOX_FILLED, AStyle); - - // Draw checkbox border - if iStateId in [CBS_UNCHECKEDHOT, CBS_MIXEDHOT, CBS_CHECKEDHOT] then - LCanvas.Font.Color:= SysColor[COLOR_HIGHLIGHT] - else begin - LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); - end; - LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_CHECKBOX_OUTLINE, AStyle); - - // Draw checkbox state - if iStateId in [CBS_MIXEDNORMAL, CBS_MIXEDHOT, - CBS_MIXEDPRESSED, CBS_MIXEDDISABLED] then - begin - LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(120, 120, 120); - LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_CHECKBOX_GRAYED, AStyle); - end - else if iStateId in [CBS_CHECKEDNORMAL, CBS_CHECKEDHOT, - CBS_CHECKEDPRESSED, CBS_CHECKEDDISABLED] then - begin - LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); - LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_CHECKBOX_CHECKED, AStyle); - end; - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; -end; - -procedure DrawEdit(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -var - LCanvas: TCanvas; -begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= HDC; - - // Draw border - LCanvas.Brush.Style:= bsClear; - - case iStateId of - ETS_NORMAL:LCanvas.Pen.Color:= SysColor[COLOR_GRAYTEXT]; - ETS_HOT,ETS_FOCUSED,ETS_SELECTED:LCanvas.Pen.Color:= SysColor[COLOR_BTNTEXT]; - ETS_DISABLED,ETS_READONLY:LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; - end; - LCanvas.RoundRect(pRect, 0, 0); - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; -end; - -procedure DrawReBar(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: PRECT); -var - LCanvas: TCanvas; -begin - // Draw only background, need fix it - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= HDC; - - LCanvas.Brush.Style:= bsClear; - LCanvas.Pen.Color:=SysColor[COLOR_BTNFACE]; - - {case iStateId of - end;} - LCanvas.RoundRect(pRect, 0, 0); - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; -end; - - -procedure DrawRadionButton(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -var - LCanvas: TCanvas; - AStyle: TTextStyle; -begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= hdc; - - LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; - LCanvas.FillRect(pRect); - - AStyle:= LCanvas.TextStyle; - AStyle.Layout:= tlCenter; - AStyle.ShowPrefix:= True; - - // Draw radio circle - LCanvas.Font.Name:= 'Segoe MDL2 Assets'; - LCanvas.Font.Color:= SysColor[COLOR_WINDOW]; - LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_RADIO_FILLED, AStyle); - - // Draw radio button state - if iStateId in [RBS_CHECKEDNORMAL, RBS_CHECKEDHOT, - RBS_CHECKEDPRESSED, RBS_CHECKEDDISABLED] then - begin - LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); - LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_RADIO_CHECKED, AStyle ); - end; - - // Set outline circle color - if iStateId in [RBS_UNCHECKEDPRESSED, RBS_CHECKEDPRESSED] then - LCanvas.Font.Color:= SysColor[COLOR_HIGHLIGHT]//RGBToColor(83, 160, 237) - else if iStateId in [RBS_UNCHECKEDHOT, RBS_CHECKEDHOT] then - LCanvas.Font.Color:= SysColor[COLOR_HIGHLIGHT] - else begin - LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); - end; - // Draw outline circle - LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_RADIO_OUTLINE, AStyle); - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; -end; - -procedure DrawGroupBox(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -var - LCanvas: TCanvas; -begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= HDC; - - // Draw border - LCanvas.Brush.Style:= bsClear; - LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; - LCanvas.RoundRect(pRect, 10, 10); - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; -end; - -procedure DrawScrollBar(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -var - LCanvas: TCanvas; - AStyle: TTextStyle; - BtnSym: string; -begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= HDC; - - case iPartId of - SBP_ARROWBTN:begin - LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; - LCanvas.FillRect(pRect); - - AStyle:= LCanvas.TextStyle; - AStyle.Alignment:= taCenter; - AStyle.Layout:= tlCenter; - AStyle.ShowPrefix:= True; - LCanvas.Font.Name:= 'Segoe MDL2 Assets'; - case iStateId of - ABS_UPNORMAL, - ABS_UPHOT, - ABS_UPPRESSED, - ABS_UPDISABLED: BtnSym:=MDL_SCROLLBOX_BTNUP; - ABS_DOWNNORMAL, - ABS_DOWNHOT, - ABS_DOWNPRESSED, - ABS_DOWNDISABLED: BtnSym:=MDL_SCROLLBOX_BTNDOWN; - ABS_LEFTNORMAL, - ABS_LEFTHOT, - ABS_LEFTPRESSED, - ABS_LEFTDISABLED: BtnSym:=MDL_SCROLLBOX_BTNLEFT; - ABS_RIGHTNORMAL, - ABS_RIGHTHOT, - ABS_RIGHTPRESSED, - ABS_RIGHTDISABLED: BtnSym:=MDL_SCROLLBOX_BTNRIGHT; - ABS_UPHOVER: BtnSym:=MDL_SCROLLBOX_BTNUP; - ABS_DOWNHOVER: BtnSym:=MDL_SCROLLBOX_BTNDOWN; - ABS_LEFTHOVER: BtnSym:=MDL_SCROLLBOX_BTNLEFT; - ABS_RIGHTHOVER: BtnSym:=MDL_SCROLLBOX_BTNRIGHT; - end; - - if iStateId in [ABS_UPDISABLED,ABS_DOWNDISABLED, - ABS_LEFTDISABLED,ABS_RIGHTDISABLED] then - LCanvas.Font.Color:= SysColor[COLOR_WINDOW] - else if iStateId in [ABS_UPHOT,ABS_DOWNHOT, - ABS_LEFTHOT,ABS_RIGHTHOT, - ABS_UPPRESSED,ABS_DOWNPRESSED, - ABS_LEFTPRESSED,ABS_RIGHTPRESSED] then - LCanvas.Font.Color:= SysColor[COLOR_HIGHLIGHT] - else begin - LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); - end; - LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, BtnSym, AStyle); - end; - SBP_GRIPPERHORZ,SBP_GRIPPERVERT:begin - if iStateId in [ABS_UPDISABLED,ABS_DOWNDISABLED, - ABS_LEFTDISABLED,ABS_RIGHTDISABLED] then - LCanvas.Brush.Color:= SysColor[COLOR_WINDOW] - else if iStateId in [ABS_UPHOT,ABS_DOWNHOT, - ABS_LEFTHOT,ABS_RIGHTHOT, - ABS_UPPRESSED,ABS_DOWNPRESSED, - ABS_LEFTPRESSED,ABS_RIGHTPRESSED] then - LCanvas.Brush.Color:= SysColor[COLOR_HIGHLIGHT] - else begin - LCanvas.Brush.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); - end; - LCanvas.Pen.Color:=LCanvas.Brush.Color; - LCanvas.FrameRect(pRect{, 10, 10}); - end; - else begin - LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; - LCanvas.Pen.Color:=LCanvas.Brush.Color; - LCanvas.FillRect(pRect); - end; - - end; - - - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; -end; - -procedure DrawPushButton(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -var - LCanvas: TCanvas; -begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= HDC; - - LCanvas.Brush.Style:= bsClear; - - if iStateId in [PBS_NORMAL,PBS_DEFAULTED,PBS_DEFAULTED_ANIMATING] then begin - LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; - LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; - end else if iStateId in [PBS_HOT] then begin - LCanvas.Brush.Color:= SysColor[COLOR_BTNHIGHLIGHT]; - LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; - end else if iStateId in [PBS_PRESSED] then begin - LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; - LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; - end else begin - LCanvas.Brush.Color:= SysColor[COLOR_3DDKSHADOW]; - LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; - end; - - LCanvas.RoundRect(pRect, 10, 10); - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; -end; - - -procedure DrawButton(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -begin - case iPartId of - BP_PUSHBUTTON: if DrawControl.CustomDrawPushButtons then - DrawPushButton(hTheme, hdc, iPartId, iStateId, pRect, pClipRect) - else - TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - BP_RADIOBUTTON: DrawRadionButton(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - BP_CHECKBOX: DrawCheckBox(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - BP_GROUPBOX: DrawGroupBox(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - end; -end; - -procedure DrawComboBox(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -var - LCanvas: TCanvas; - AStyle: TTextStyle; - BtnSym: string; - r:TRect; -begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= HDC; - - case iPartId of - CP_BORDER:begin - LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; - LCanvas.FillRect(pRect); - - if iStateId in [CBXS_DISABLED] then begin - LCanvas.Brush.Color:= SysColor[COLOR_WINDOW] - end - else if iStateId in [CBXS_HOT] then begin - LCanvas.Brush.Color:= Darker(SysColor[COLOR_HIGHLIGHT],150) - end - else begin - LCanvas.Brush.Color:= SysColor[COLOR_WINDOW] - end; - LCanvas.FrameRect(pRect); - end; - - CP_DROPDOWNBUTTON,CP_DROPDOWNBUTTONRIGHT,CP_DROPDOWNBUTTONLEFT:begin - - AStyle:= LCanvas.TextStyle; - AStyle.Alignment:= taCenter; - AStyle.Layout:= tlCenter; - AStyle.ShowPrefix:= True; - LCanvas.Font.Name:= 'Segoe MDL2 Assets'; - BtnSym:=MDL_COMBOBOX_BTNDOWN; - - - if iStateId in [CBXS_DISABLED] then begin - LCanvas.Font.Color:= SysColor[COLOR_WINDOW]; - LCanvas.Brush.Color:= SysColor[COLOR_WINDOW] - end - else if iStateId in [CBXS_HOT] then begin - LCanvas.Font.Color:= SysColor[COLOR_HIGHLIGHT]; - LCanvas.Brush.Color:= Darker(SysColor[COLOR_HIGHLIGHT],150) - end - else begin - LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT]; - LCanvas.Brush.Color:= SysColor[COLOR_WINDOW] - end; - r:=pRect; - InflateRect(r,-1,-1); - LCanvas.FillRect(r); - LCanvas.TextRect(r, pRect.TopLeft.X, pRect.TopLeft.Y, BtnSym, AStyle); - end; - {else begin - LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; - LCanvas.Pen.Color:=LCanvas.Brush.Color; - LCanvas.FillRect(pRect); - end;} - - end; - - - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; -end; - - - -procedure DrawTabControl(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -var - ARect: TRect; - AColor: TColor; - ALight: TColor; - LCanvas: TCanvas; -begin - LCanvas:= TCanvas.Create; - try - LCanvas.Handle:= hdc; - - AColor:= SysColor[COLOR_BTNFACE]; - ALight:= Lighter(AColor, 160); - - case iPartId of - TABP_TOPTABITEM, - TABP_TOPTABITEMLEFTEDGE, - TABP_TOPTABITEMBOTHEDGE, - TABP_TOPTABITEMRIGHTEDGE: - begin - ARect:= pRect; - // Fill tab inside - if (iStateId <> TIS_SELECTED) then - begin - if iStateId <> TIS_HOT then - LCanvas.Brush.Color:= Lighter(AColor, 117) - else begin - LCanvas.Brush.Color:= Lighter(AColor, 200); - end; - end - else begin - Dec(ARect.Bottom); - InflateRect(ARect, -1, -1); - LCanvas.Brush.Color:= Lighter(AColor, 176); - end; - LCanvas.FillRect(ARect); - LCanvas.Pen.Color:= ALight; - - if iPartId in [TABP_TOPTABITEMLEFTEDGE, TABP_TOPTABITEMBOTHEDGE] then - begin - // Draw left border - LCanvas.Line(pRect.Left, pRect.Top, pRect.Left, pRect.Bottom); - end; - - if (iStateId <> TIS_SELECTED) then - begin - // Draw right border - LCanvas.Line(pRect.Right - 1, pRect.Top, pRect.Right - 1, pRect.Bottom) - end - else begin - // Draw left border - if (iPartId = TABP_TOPTABITEM) then - begin - LCanvas.Line(pRect.Left, pRect.Top, pRect.Left, pRect.Bottom - 1); - end; - // Draw right border - LCanvas.Line(pRect.Right - 1, pRect.Top, pRect.Right - 1, pRect.Bottom - 1); - end; - // Draw top border - LCanvas.Line(pRect.Left, pRect.Top, pRect.Right, pRect.Top); - end; - TABP_PANE: - begin - // Draw tab pane border - LCanvas.Brush.Color:= AColor; - LCanvas.Pen.Color:= ALight; - LCanvas.Rectangle(pRect); - end; - end; - finally - LCanvas.Handle:= 0; - LCanvas.Free; - end; -end; - -procedure DrawProgressBar(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -begin - if not (iPartId in [PP_TRANSPARENTBAR, PP_TRANSPARENTBARVERT]) then - TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect) - else begin - SelectObject(hdc, GetStockObject(DC_PEN)); - SetDCPenColor(hdc, SysColor[COLOR_BTNSHADOW]); - SelectObject(hdc, GetStockObject(DC_BRUSH)); - SetDCBrushColor(hdc, SysColor[COLOR_BTNFACE]); - with pRect do Rectangle(hdc, Left, Top, Right, Bottom); - end; -end; - -procedure DrawTreeView(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -begin - if (iPartId = TVP_TREEITEM) and (iStateId in [TREIS_SELECTEDNOTFOCUS,TREIS_SELECTED]) then begin - SelectObject(hdc, GetStockObject(DC_PEN)); - SetDCPenColor(hdc, SysColor[COLOR_BTNSHADOW]); - SelectObject(hdc, GetStockObject(DC_BRUSH)); - if DrawControl.TreeViewDisableHideSelection then - if iStateId=TREIS_SELECTEDNOTFOCUS then - iStateId:=TREIS_SELECTED; - case iStateId of - TREIS_SELECTEDNOTFOCUS:SetDCBrushColor(hdc, SysColor[COLOR_BTNHIGHLIGHT]); - TREIS_SELECTED:SetDCBrushColor(hdc, Lighter(SysColor[COLOR_BTNHIGHLIGHT], 146)); - end; - with pRect do Rectangle(hdc, Left, Top, Right, Bottom); - end else - TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect) -end; - -procedure DrawListViewHeader(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: PRECT); -begin - DrawThemeBackgroundDark(Theme[teListView], hdc, iPartId, iStateId, pRect, pClipRect); -end; - -function InterceptOpenThemeData(hwnd: hwnd; pszClassList: LPCWSTR): hTheme; stdcall; -var - P: LONG_PTR; -begin - if (hwnd <> 0) then - begin - P:= GetWindowLongPtr(hwnd, GWL_EXSTYLE); - - if (P and WS_EX_CONTEXTHELP = 0) or (lstrcmpiW(pszClassList, VSCLASS_MONTHCAL) = 0) then - begin - Result:= TrampolineOpenThemeData(hwnd, pszClassList); - Exit; - end; - end; - - if lstrcmpiW(pszClassList, VSCLASS_TAB) = 0 then - begin - AllowDarkStyle(hwnd); - pszClassList:= PWideChar(VSCLASS_DARK_TAB); - end - else if lstrcmpiW(pszClassList, VSCLASS_BUTTON) = 0 then - begin - AllowDarkStyle(hwnd); - pszClassList:= PWideChar(VSCLASS_DARK_BUTTON); - end - else if lstrcmpiW(pszClassList, VSCLASS_EDIT) = 0 then - begin - AllowDarkStyle(hwnd); - pszClassList:= PWideChar(VSCLASS_DARK_EDIT); - end - else if lstrcmpiW(pszClassList, VSCLASS_COMBOBOX) = 0 then - begin - AllowDarkStyle(hwnd); - pszClassList:= PWideChar(VSCLASS_DARK_COMBOBOX); - end - - else if lstrcmpiW(pszClassList, 'ListView') = 0 then - begin - ListView_SetBkColor(hwnd, SysColor[COLOR_WINDOW]); - ListView_SetTextBkColor(hwnd, SysColor[COLOR_WINDOW]); - ListView_SetTextColor(hwnd, SysColor[COLOR_WINDOWTEXT]); - end - - else if lstrcmpiW(pszClassList, VSCLASS_SCROLLBAR) = 0 then - begin - AllowDarkStyle(hwnd); - pszClassList:= PWideChar(VSCLASS_DARK_SCROLLBAR); - end; - - Result:= TrampolineOpenThemeData(hwnd, pszClassList); - ThemeClass.AddOrSetValue(Result, pszClassList); -end; - -function InterceptDrawThemeText(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; pszText: LPCWSTR; iCharCount: Integer; - dwTextFlags, dwTextFlags2: DWORD; const pRect: TRect): HRESULT; stdcall; -var - OldColor: COLORREF; - ClassName: LPCWSTR; -begin - if Assigned(ThemeClass) then - if ThemeClass.TryGetValue(hTheme, ClassName) then - begin - if SameText(ClassName, VSCLASS_DARK_COMBOBOX) or SameText(ClassName, VSCLASS_DARK_EDIT) then - begin - Result:= TrampolineDrawThemeText(hTheme, hdc, iPartId, iStateId, pszText, iCharCount, dwTextFlags, dwTextFlags2, pRect); - Exit; - end; - - if SameText(ClassName, VSCLASS_TOOLTIP) then - OldColor:= SysColor[COLOR_INFOTEXT] - else begin - OldColor:= SysColor[COLOR_BTNTEXT]; - end; - - if SameText(ClassName, VSCLASS_DARK_BUTTON) then - begin - if (iPartId = BP_CHECKBOX) and (iStateId in [CBS_UNCHECKEDDISABLED, CBS_CHECKEDDISABLED, CBS_MIXEDDISABLED]) then - OldColor:= SysColor[COLOR_GRAYTEXT] - else if (iPartId = BP_RADIOBUTTON) and (iStateId in [RBS_UNCHECKEDDISABLED, RBS_CHECKEDDISABLED]) then - OldColor:= SysColor[COLOR_GRAYTEXT] - else if (iPartId = BP_GROUPBOX) and (iStateId = GBS_DISABLED) then - OldColor:= SysColor[COLOR_GRAYTEXT] - else if (iPartId = BP_PUSHBUTTON) then - begin - Result:= TrampolineDrawThemeText(hTheme, hdc, iPartId, iStateId, pszText, iCharCount, dwTextFlags, dwTextFlags2, pRect); - Exit; - end; - end; - - OldColor:= SetTextColor(hdc, OldColor); - SetBkMode(hdc, TRANSPARENT); - - DrawTextExW(hdc, pszText, iCharCount, @pRect, dwTextFlags, nil); - - SetTextColor(hdc, OldColor); - - Exit(S_OK); - end; - Result:= TrampolineDrawThemeText(hTheme, hdc, iPartId, iStateId, pszText, iCharCount, dwTextFlags, dwTextFlags2, pRect); -end; - -function InterceptDrawThemeBackground(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; const pRect: TRect; - pClipRect: Pointer): HRESULT; stdcall; -var - Index: Integer; - ClassName: LPCWSTR; -begin - if assigned(ThemeClass)then - if ThemeClass.TryGetValue(hTheme, ClassName) then - begin - Index:= SaveDC(hdc); - try - if (SameText(ClassName, VSCLASS_DARK_SCROLLBAR))and DrawControl.CustomDrawScrollbars then - begin - DrawScrollBar(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - end - else if (SameText(ClassName,VSCLASS_DARK_COMBOBOX))and DrawControl.CustomDrawComboBoxs then - begin - DrawComboBox(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - end - else if SameText(ClassName, VSCLASS_DARK_BUTTON) then - begin - DrawButton(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - end - else if SameText(ClassName, VSCLASS_DARK_TAB) then - begin - DrawTabControl(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - end - else if SameText(ClassName, VSCLASS_PROGRESS) or SameText(ClassName, VSCLASS_PROGRESS_INDER) then - begin - DrawProgressBar(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - end - else if SameText(ClassName, VSCLASS_DARK_HEADER) then - begin - DrawListViewHeader(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - end - else begin - Result:= TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); - end; - finally - RestoreDC(hdc, Index); - end; - Exit(S_OK); - end; - Result:= TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); -end; - -function DrawThemeEdgeDark(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pDestRect: TRect; uEdge, - uFlags: UINT; pContentRect: PRECT): HRESULT; stdcall; -var - ARect: TRect; -begin - ARect:= pDestRect; - _DrawEdge(hdc, ARect, uEdge, uFlags); - if (uFlags and DFCS_ADJUSTRECT <> 0) and (pContentRect <> nil) then - pContentRect^ := ARect; - Result:= S_OK; -end; - -function GetThemeSysColorDark(hTheme: HTHEME; iColorId: Integer): COLORREF; stdcall; -begin - Result:= GetSysColor(iColorId); -end; - -function GetThemeSysColorBrushDark(hTheme: HTHEME; iColorId: Integer): HBRUSH; stdcall; -begin - Result:= GetSysColorBrush(iColorId); -end; - -var - DeleteObjectOld: function(ho: HGDIOBJ): WINBOOL; stdcall; - -function __DeleteObject(ho: HGDIOBJ): WINBOOL; stdcall; -var - Index: Integer; -begin - for Index:= 0 to High(SysColorBrush) do - begin - if SysColorBrush[Index] = ho then Exit(True); - end; - Result:= DeleteObjectOld(ho); -end; - -procedure InitializeColors(const CS:TDSColors); -begin - SysColor:=CS.SysColor; - DrawControl:=CS.DrawControl; -end; - -procedure SetColorsScheme(Scheme:TDSColors); -var - Index: Integer; -begin - for Index:= 0 to High(SysColorBrush) do - SysColorBrush[Index] := 0; - SysColor:=Scheme.SysColor; -end; - -function WinRegister(ClassName: PWideChar): Boolean; -var - WindowClassW: WndClassW; -begin - ZeroMemory(@WindowClassW, SizeOf(WndClassW)); - with WindowClassW do - begin - Style := CS_DBLCLKS; - LPFnWndProc := @FormWndProc; - hInstance := System.HInstance; - hIcon := Windows.LoadIcon(MainInstance, 'MAINICON'); - if hIcon = 0 then - hIcon := Windows.LoadIcon(0, IDI_APPLICATION); - hCursor := Windows.LoadCursor(0, IDC_ARROW); - LPSzClassName := ClassName; - end; - Result := Windows.RegisterClassW(@WindowClassW) <> 0; -end; - -procedure Initialize(const CS:TDSColors); -var - hModule, hUxTheme: THandle; - pLibrary, pFunction: PPointer; - pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; -begin - if not IsDarkModeEnabled then - Exit; - - InitializeColors(CS); - - WinRegister(ClassNameW); - WinRegister(ClassNameTC); - - ThemeClass:= TThemeClassMap.Create; - - hModule:= GetModuleHandle(gdi32); - Pointer(DeleteObjectOld):= GetProcAddress(hModule, 'DeleteObject'); - - hModule:= GetModuleHandle(comctl32); - Pointer(DefSubclassProc):= GetProcAddress(hModule, 'DefSubclassProc'); - Pointer(SetWindowSubclass):= GetProcAddress(hModule, 'SetWindowSubclass'); - - // Override several system functions - pLibrary:= FindImportLibrary(MainInstance, user32); - if Assigned(pLibrary) then - begin - hModule:= GetModuleHandle(user32); - - pFunction:= FindImportFunction(pLibrary, GetProcAddress(hModule, 'CreateWindowExW')); - if Assigned(pFunction) then - begin - Pointer(__CreateWindowExW):= ReplaceImportFunction(pFunction, @_CreateWindowExW); - end; - pFunction:= FindImportFunction(pLibrary, GetProcAddress(hModule, 'DrawEdge')); - if Assigned(pFunction) then - begin - ReplaceImportFunction(pFunction, @_DrawEdge); - end; - pFunction:= FindImportFunction(pLibrary, GetProcAddress(hModule, 'GetSysColor')); - if Assigned(pFunction) then - begin - ReplaceImportFunction(pFunction, @GetSysColorDark); - end; - pFunction:= FindImportFunction(pLibrary, GetProcAddress(hModule, 'GetSysColorBrush')); - if Assigned(pFunction) then - begin - ReplaceImportFunction(pFunction, @GetSysColorBrushDark); - end; - end; - pLibrary:= FindImportLibrary(MainInstance, gdi32); - if Assigned(pLibrary) then - begin - hModule:= GetModuleHandle(gdi32); - pFunction:= FindImportFunction(pLibrary, Pointer(DeleteObjectOld)); - if Assigned(pFunction) then - begin - ReplaceImportFunction(pFunction, @__DeleteObject); - end; - end; - - hModule:= GetModuleHandle(comctl32); - pImpDesc:= FindDelayImportLibrary(hModule, themelib); - if Assigned(pImpDesc) then - begin - hUxTheme:= GetModuleHandle(themelib); - Pointer(TrampolineOpenThemeData):= GetProcAddress(hUxTheme, 'OpenThemeData'); - Pointer(TrampolineDrawThemeText):= GetProcAddress(hUxTheme, 'DrawThemeText'); - Pointer(TrampolineDrawThemeBackground):= GetProcAddress(hUxTheme, 'DrawThemeBackground'); - - ReplaceDelayImportFunction(hModule, pImpDesc, 'OpenThemeData', @InterceptOpenThemeData); - ReplaceDelayImportFunction(hModule, pImpDesc, 'DrawThemeText', @InterceptDrawThemeText); - ReplaceDelayImportFunction(hModule, pImpDesc, 'DrawThemeBackground', @InterceptDrawThemeBackground); - - ReplaceDelayImportFunction(hModule, pImpDesc, 'DrawThemeEdge', @DrawThemeEdgeDark); - end; - - pLibrary:= FindImportLibrary(hModule, gdi32); - if Assigned(pLibrary) then - begin - pFunction:= FindImportFunction(pLibrary, Pointer(DeleteObjectOld)); - if Assigned(pFunction) then - begin - ReplaceImportFunction(pFunction, @__DeleteObject); - end; - end; - - hModule:= GetModuleHandle(comctl32); - pLibrary:= FindImportLibrary(hModule, user32); - if Assigned(pLibrary) then - begin - hModule:= GetModuleHandle(user32); - - pFunction:= FindImportFunction(pLibrary, GetProcAddress(hModule, 'DrawEdge')); - if Assigned(pFunction) then - begin - ReplaceImportFunction(pFunction, @_DrawEdge); - end; - end; -end; - -initialization - -finalization - if Assigned(ThemeClass) then - FreeAndNil(ThemeClass); -end. - diff --git a/use/metadarkstyle b/use/metadarkstyle deleted file mode 160000 index 77959879..00000000 --- a/use/metadarkstyle +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 77959879fd87ed9f12f42c7c467aa3901c7831a0 From e04ba1933ea71dd6a965d1bb790c5efad0fcf0c8 Mon Sep 17 00:00:00 2001 From: "Artem V. Ageev" Date: Wed, 15 Jan 2025 21:18:31 +0200 Subject: [PATCH 2/5] fix github-actions --- .github/workflows/make.pas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/make.pas b/.github/workflows/make.pas index dbbdfce8..d2c8b7da 100644 --- a/.github/workflows/make.pas +++ b/.github/workflows/make.pas @@ -179,7 +179,7 @@ Output = record try for Each in List do begin - if not ContainsStr(Each, 'dragdropfilesdll') then + if not ContainsStr(Each, 'project_demo_lib') {$IFDEF LINUX}and not ContainsStr(Each, 'dragdropfilesdll'){$ENDIF} then if ContainsStr(ReadFileToString(ReplaceStr(Each, '.lpi', '.lpr')), 'consoletestrunner') then RunTest(Each) From d10b66ccc24591f4d680546405630c8b73bea5eb Mon Sep 17 00:00:00 2001 From: "Artem V. Ageev" Date: Wed, 15 Jan 2025 21:42:37 +0200 Subject: [PATCH 3/5] Rewrote CI to Pascal --- .github/workflows/make.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/make.yml b/.github/workflows/make.yml index cc34f435..64dfc42f 100644 --- a/.github/workflows/make.yml +++ b/.github/workflows/make.yml @@ -9,6 +9,7 @@ on: - "**" pull_request: branches: + - source - master - main From e83cc82712159b7e26d3a186c2c247d4f759916d Mon Sep 17 00:00:00 2001 From: "Artem V. Ageev" Date: Wed, 15 Jan 2025 21:43:20 +0200 Subject: [PATCH 4/5] Rewrote CI to Pascal --- .github/workflows/make.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/make.yml b/.github/workflows/make.yml index 64dfc42f..8e466132 100644 --- a/.github/workflows/make.yml +++ b/.github/workflows/make.yml @@ -9,7 +9,7 @@ on: - "**" pull_request: branches: - - source + - sources - master - main From 4bd6f30ab878b3b31135b30b8d5f0c1316ba662c Mon Sep 17 00:00:00 2001 From: "Artem V. Ageev" Date: Thu, 16 Jan 2025 21:38:34 +0200 Subject: [PATCH 5/5] return metadarkstyle --- .../dev/metadarkstyle/metadarkstyle.lpk | 52 + .../dev/metadarkstyle/metadarkstyle.pas | 22 + .../src/CustomDark.darkstylecolors | 7 + .../dev/metadarkstyle/src/CustomDark.lrs | 5 + .../src/metadarkstyledsgnoptions.pas | 169 ++ .../src/metadarkstyledsgnoptionsframe.lfm | 80 + .../src/metadarkstyledsgnoptionsframe.pas | 109 + .../src/registermetadarkstyledsgn.pas | 53 + .../dev/metadarkstyle/src/udarkstyle.pas | 297 ++ .../metadarkstyle/src/udarkstyleparams.pas | 44 + .../metadarkstyle/src/udarkstyleschemes.pas | 228 ++ .../src/udarkstyleschemesadditional.pas | 16 + .../src/udarkstyleschemesloader.pas | 511 ++++ .../dev/metadarkstyle/src/uimport.pas | 150 + .../dev/metadarkstyle/src/umetadarkstyle.pas | 41 + .../metadarkstyle/src/uwin32widgetsetdark.pas | 2419 +++++++++++++++++ 16 files changed, 4203 insertions(+) create mode 100644 peazip-sources/dev/metadarkstyle/metadarkstyle.lpk create mode 100644 peazip-sources/dev/metadarkstyle/metadarkstyle.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/CustomDark.darkstylecolors create mode 100644 peazip-sources/dev/metadarkstyle/src/CustomDark.lrs create mode 100644 peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptions.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.lfm create mode 100644 peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/registermetadarkstyledsgn.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/udarkstyle.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/udarkstyleparams.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/udarkstyleschemes.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/udarkstyleschemesadditional.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/udarkstyleschemesloader.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/uimport.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/umetadarkstyle.pas create mode 100644 peazip-sources/dev/metadarkstyle/src/uwin32widgetsetdark.pas diff --git a/peazip-sources/dev/metadarkstyle/metadarkstyle.lpk b/peazip-sources/dev/metadarkstyle/metadarkstyle.lpk new file mode 100644 index 00000000..ee4a1f10 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/metadarkstyle.lpk @@ -0,0 +1,52 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/peazip-sources/dev/metadarkstyle/metadarkstyle.pas b/peazip-sources/dev/metadarkstyle/metadarkstyle.pas new file mode 100644 index 00000000..48d37e0b --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/metadarkstyle.pas @@ -0,0 +1,22 @@ +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit MetaDarkStyle; + +{$warn 5023 off : no warning about unused units} +interface + +uses + uMetaDarkStyle, uDarkStyleParams, uDarkStyleSchemesAdditional, + LazarusPackageIntf; + +implementation + +procedure Register; +begin +end; + +initialization + RegisterPackage('MetaDarkStyle', @Register); +end. diff --git a/peazip-sources/dev/metadarkstyle/src/CustomDark.darkstylecolors b/peazip-sources/dev/metadarkstyle/src/CustomDark.darkstylecolors new file mode 100644 index 00000000..a0bf8483 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/CustomDark.darkstylecolors @@ -0,0 +1,7 @@ +begin + Scheme:=DefaultDark; + CustomDrawScrollbars:=true; + CustomDrawPushButtons:=true; + CustomDrawComboBoxs:=true; + CustomDrawTreeViews:=true; +end. \ No newline at end of file diff --git a/peazip-sources/dev/metadarkstyle/src/CustomDark.lrs b/peazip-sources/dev/metadarkstyle/src/CustomDark.lrs new file mode 100644 index 00000000..03008bc1 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/CustomDark.lrs @@ -0,0 +1,5 @@ +LazarusResources.Add('CustomDark','DARKSTYLECOLORS',[ + 'begin'#13#10' Scheme:=DefaultDark;'#13#10' CustomDrawScrollbars:=true;'#13 + +#10' CustomDrawPushButtons:=true;'#13#10' CustomDrawComboBoxs:=true;'#13#10 + +' CustomDrawTreeViews:=true;'#13#10'end.' +]); diff --git a/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptions.pas b/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptions.pas new file mode 100644 index 00000000..db5f11c7 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptions.pas @@ -0,0 +1,169 @@ +unit MetaDarkStyleDSGNOptions; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, + LazConfigStorage, LazFileUtils, LazFileCache, + LCLProc, ComCtrls, Graphics, + BaseIDEIntf; + +const + amOptAllowDarkName='Allow dark'; + amOptForceDarkName='Force dark'; + amOptForceLightName='Force light'; +resourcestring + RSamOptAllowDarkName=amOptAllowDarkName; + RSamOptForceDarkName=amOptForceDarkName; + RSamOptForceLightName=amOptForceLightName; + +type + TAppModeOpt=(amOptAllowDark,amOptForceDark,amOptForceLight); + +const + AppModeOptStr:array[TAppModeOpt] of String=(amOptAllowDarkName,amOptForceDarkName,amOptForceLightName); + AppModeOptLocalizedStr:array[TAppModeOpt] of String=(RSamOptAllowDarkName,RSamOptForceDarkName,RSamOptForceLightName); + +type + + TMetaDarkStyleDSGNOptions=class + private + const + DefaultAppMode:TAppModeOpt=amOptAllowDark; + DefaultColorScheme:String='Dark'; + var + FAppMode:TAppModeOpt; + FColorScheme:String; + FChangeStamp:Integer; + FLastSavedChangeStamp:Integer; + procedure SetAppMode(AValue:TAppModeOpt); + procedure SetColorScheme(AValue:String); + function GetModified:Boolean; + procedure SetModified(AValue: Boolean); + function Str2AppModeOpt(str:string):TAppModeOpt; + public + constructor Create; + procedure SaveSafe; + procedure LoadSafe; + procedure SaveToFile(AFilename:String); + procedure LoadFromFile(AFilename:String); + procedure IncreaseChangeStamp; + public + property ChangeStamp:Integer read FChangeStamp; + property Modified:Boolean read GetModified write SetModified; + + property AppMode:TAppModeOpt read FAppMode write SetAppMode; + property ColorScheme:String read FColorScheme write SetColorScheme; + end; + +const + MetaDarkStyleDSGNFileName='metadarkstyledsgnoptions.xml'; + +var + MetaDarkStyleDSGNOpt: TMetaDarkStyleDSGNOptions = nil; + +implementation + +{ TDockedOptions } + +function TMetaDarkStyleDSGNOptions.GetModified:Boolean; +begin + Result:=FLastSavedChangeStamp<>FChangeStamp; +end; + +procedure TMetaDarkStyleDSGNOptions.SetModified(AValue:Boolean); +begin + if AValue then + IncreaseChangeStamp + else + FLastSavedChangeStamp:=FChangeStamp; +end; + +procedure TMetaDarkStyleDSGNOptions.SetAppMode(AValue:TAppModeOpt); +begin + if FAppMode=AValue then Exit; + FAppMode:=AValue; + IncreaseChangeStamp; +end; + +procedure TMetaDarkStyleDSGNOptions.SetColorScheme(AValue:String); +begin + if FColorScheme=AValue then Exit; + FColorScheme:=AValue; + IncreaseChangeStamp; +end; + +constructor TMetaDarkStyleDSGNOptions.Create; +begin + FAppMode:=DefaultAppMode; + FChangeStamp:=LUInvalidChangeStamp+1; + FLastSavedChangeStamp:=FChangeStamp; +end; + +procedure TMetaDarkStyleDSGNOptions.SaveSafe; +begin + try + SaveToFile(MetaDarkStyleDSGNFileName); + Modified:=False; + except + on E: Exception do + DebugLn(['Error: (lazarus) [TMetaDarkStyleDSGNOptions.SaveSafe] ', E.Message]); + end; +end; + +procedure TMetaDarkStyleDSGNOptions.LoadSafe; +begin + try + LoadFromFile(MetaDarkStyleDSGNFileName); + except + on E: Exception do + DebugLn(['Error: (lazarus) [TMetaDarkStyleDSGNOptions.LoadSafe] ', E.Message]); + end; + Modified:=False; +end; + +procedure TMetaDarkStyleDSGNOptions.SaveToFile(AFilename: String); +var + Cfg: TConfigStorage; +begin + Cfg:=GetIDEConfigStorage(AFilename,False); + try + Cfg.SetDeleteValue('AppMode/Value',AppModeOptStr[AppMode],AppModeOptStr[DefaultAppMode]); + Cfg.SetDeleteValue('ColorScheme/Value',ColorScheme,DefaultColorScheme); + finally + Cfg.Free; + end; +end; + +function TMetaDarkStyleDSGNOptions.Str2AppModeOpt(str:string):TAppModeOpt; +var + i:TAppModeOpt; +begin + for i:=low(AppModeOptStr) to high(AppModeOptStr) do + if AppModeOptStr[i]=str then + exit(i); + result:=DefaultAppMode; +end; + +procedure TMetaDarkStyleDSGNOptions.LoadFromFile(AFilename: String); +var + Cfg: TConfigStorage; +begin + Cfg := GetIDEConfigStorage(AFilename,True); + try + AppMode:= Str2AppModeOpt(Cfg.GetValue('AppMode/Value',AppModeOptStr[DefaultAppMode])); + ColorScheme:= Cfg.GetValue('ColorScheme/Value',DefaultColorScheme); + finally + Cfg.Free; + end; +end; + +procedure TMetaDarkStyleDSGNOptions.IncreaseChangeStamp; +begin + LUIncreaseChangeStamp(FChangeStamp); +end; + +end. + diff --git a/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.lfm b/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.lfm new file mode 100644 index 00000000..7ce56863 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.lfm @@ -0,0 +1,80 @@ +object DarkStyleDSGNOptionsFrame: TDarkStyleDSGNOptionsFrame + Left = 0 + Height = 360 + Top = 0 + Width = 480 + ClientHeight = 360 + ClientWidth = 480 + DesignTimePPI = 144 + ParentBackground = False + ParentFont = False + TabOrder = 0 + DesignLeft = 556 + DesignTop = 10 + object Label1: TLabel + AnchorSideLeft.Control = Owner + AnchorSideTop.Control = PAMComboBox + AnchorSideTop.Side = asrCenter + Left = 6 + Height = 25 + Top = 10 + Width = 265 + BorderSpacing.Left = 6 + BorderSpacing.Right = 6 + Caption = 'PreferredAppMode (Need restart)' + end + object PAMComboBox: TComboBox + AnchorSideLeft.Control = Label1 + AnchorSideLeft.Side = asrBottom + AnchorSideTop.Control = Owner + AnchorSideRight.Control = Owner + AnchorSideRight.Side = asrBottom + Left = 277 + Height = 33 + Top = 6 + Width = 197 + Anchors = [akTop, akLeft, akRight] + BorderSpacing.Top = 6 + BorderSpacing.Right = 6 + ItemHeight = 25 + Items.Strings = ( + 'Default' + 'AllowDark' + 'ForceDark' + 'ForceLight' + ) + ParentFont = False + Style = csDropDownList + TabOrder = 0 + end + object CSComboBox: TComboBox + AnchorSideLeft.Control = Label2 + AnchorSideLeft.Side = asrBottom + AnchorSideTop.Control = PAMComboBox + AnchorSideTop.Side = asrBottom + AnchorSideRight.Control = Owner + AnchorSideRight.Side = asrBottom + Left = 120 + Height = 33 + Top = 45 + Width = 354 + Anchors = [akTop, akLeft, akRight] + BorderSpacing.Top = 6 + BorderSpacing.Right = 6 + ItemHeight = 25 + Style = csDropDownList + TabOrder = 1 + end + object Label2: TLabel + AnchorSideLeft.Control = Owner + AnchorSideTop.Control = CSComboBox + AnchorSideTop.Side = asrCenter + Left = 6 + Height = 25 + Top = 49 + Width = 108 + BorderSpacing.Left = 6 + BorderSpacing.Right = 6 + Caption = 'Color scheme' + end +end diff --git a/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.pas b/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.pas new file mode 100644 index 00000000..f067a2f6 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/metadarkstyledsgnoptionsframe.pas @@ -0,0 +1,109 @@ +unit MetaDarkStyleDSGNOptionsFrame; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, Forms, Controls, StdCtrls, + IDEOptionsIntf,IDEOptEditorIntf, + MetaDarkStyleDSGNOptions,uDarkStyleSchemes; + +resourceString + RSDarkStyleDSGNOptionsFrame='Dark style'; + + +type + + { TDarkStyleDSGNOptionsFrame } + + TDarkStyleDSGNOptionsFrame = class(TAbstractIDEOptionsEditor) + PAMComboBox: TComboBox; + CSComboBox: TComboBox; + Label1: TLabel; + Label2: TLabel; + private + + public + function GetTitle: String; override; + procedure Setup({%H-}ADialog: TAbstractOptionsEditorDialog); override; + procedure ReadSettings({%H-}AOptions: TAbstractIDEOptions); override; + procedure WriteSettings({%H-}AOptions: TAbstractIDEOptions); override; + procedure RestoreSettings({%H-}AOptions: TAbstractIDEOptions); override; + class function SupportedOptionsClass: TAbstractIDEOptionsClass; override; + end; + +implementation + +{$R *.lfm} + +function TDarkStyleDSGNOptionsFrame.GetTitle: String; +begin + result:=RSDarkStyleDSGNOptionsFrame; +end; + +procedure SchemeToComboSet(ASch:string;ACombo:TComboBox;curr:integer); +begin + if ASch=MetaDarkStyleDSGNOpt.ColorScheme then + ACombo.ItemIndex:=curr; +end; + +procedure TDarkStyleDSGNOptionsFrame.Setup({%H-}ADialog: TAbstractOptionsEditorDialog); +var + i:TAppModeOpt; + itr:TSchemes.TIterator; +begin + PAMComboBox.Items.Clear; + for i:=low(AppModeOptStr) to high(AppModeOptStr) do + PAMComboBox.Items.Add(AppModeOptLocalizedStr[i]); + CSComboBox.Items.Clear; + CSComboBox.Items.Add('Dark'); + CSComboBox.Items.Add('White'); + if Schemes<>nil then begin + itr:=Schemes.Min; + if itr<>nil then repeat + CSComboBox.Items.Add(itr.Data.Value.Name); + until not itr.Next; + itr.free; + end; +end; + +procedure TDarkStyleDSGNOptionsFrame.ReadSettings({%H-}AOptions: TAbstractIDEOptions); +begin + RestoreSettings(AOptions); +end; + +procedure TDarkStyleDSGNOptionsFrame.WriteSettings({%H-}AOptions: TAbstractIDEOptions); +begin + MetaDarkStyleDSGNOpt.AppMode:=TAppModeOpt(PAMComboBox.ItemIndex); + MetaDarkStyleDSGNOpt.ColorScheme:=CSComboBox.Items[CSComboBox.ItemIndex]; + if MetaDarkStyleDSGNOpt.Modified then + MetaDarkStyleDSGNOpt.SaveSafe; +end; + +procedure TDarkStyleDSGNOptionsFrame.RestoreSettings({%H-}AOptions: TAbstractIDEOptions); +var + itr:TSchemes.TIterator; + i:integer; +begin + PAMComboBox.ItemIndex:=ord(MetaDarkStyleDSGNOpt.AppMode); + SchemeToComboSet('Dark',CSComboBox,0); + SchemeToComboSet('White',CSComboBox,1); + if Schemes<>nil then begin + itr:=Schemes.Min; + i:=2; + if itr<>nil then repeat + SchemeToComboSet(itr.Data.Value.Name,CSComboBox,i); + inc(i); + until not itr.Next; + itr.free; + end; +end; + +class function TDarkStyleDSGNOptionsFrame.SupportedOptionsClass: TAbstractIDEOptionsClass; +begin + Result:=IDEEditorGroups.GetByIndex(GroupEnvironment)^.GroupClass; +end; + +end. + diff --git a/peazip-sources/dev/metadarkstyle/src/registermetadarkstyledsgn.pas b/peazip-sources/dev/metadarkstyle/src/registermetadarkstyledsgn.pas new file mode 100644 index 00000000..52705fd1 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/registermetadarkstyledsgn.pas @@ -0,0 +1,53 @@ +unit registerMetaDarkStyleDSGN; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, + IDEOptionsIntf, IDEOptEditorIntf, LazIDEIntf, lazconf, + uDarkStyleParams, uDarkStyleSchemes, uMetaDarkStyle, + MetaDarkStyleDSGNOptionsFrame, MetaDarkStyleDSGNOptions; + +var + MetaDarkStyleOptionsID: integer = 1000; + + +procedure Register; + +implementation + +function AppModeOpt2PreferredAppMode(am:TAppModeOpt):TPreferredAppMode; +begin + case am of + amOptAllowDark:result:=pamAllowDark; + amOptForceDark:result:=pamForceDark; + amOptForceLight:result:=pamForceLight; + end; +end; + +procedure SetDarkStyle; +begin + {$IF DEFINED(MSWINDOWS)} + LoadLResources; + LoadPath(GetPrimaryConfigPath+'/userschemes','*.'+DSColorsTypeName); + LoadPath(GetSecondaryConfigPath+'/userschemes','*.'+DSColorsTypeName); + MetaDarkStyleDSGNOpt:=TMetaDarkStyleDSGNOptions.Create; + MetaDarkStyleDSGNOpt.LoadSafe; + PreferredAppMode:=AppModeOpt2PreferredAppMode(MetaDarkStyleDSGNOpt.AppMode); + ApplyMetaDarkStyle(GetScheme(MetaDarkStyleDSGNOpt.ColorScheme)); + {$ENDIF} +end; + +procedure Register; +begin + MetaDarkStyleOptionsID:=RegisterIDEOptionsEditor(GroupEnvironment, + TDarkStyleDSGNOptionsFrame, + MetaDarkStyleOptionsID)^.Index; +end; + +initialization + AddBootHandler(libhEnvironmentOptionsLoaded,@SetDarkStyle); +end. + diff --git a/peazip-sources/dev/metadarkstyle/src/udarkstyle.pas b/peazip-sources/dev/metadarkstyle/src/udarkstyle.pas new file mode 100644 index 00000000..992b14d6 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/udarkstyle.pas @@ -0,0 +1,297 @@ +{ + Double Commander + ------------------------------------------------------------------------- + Dark mode support unit (Windows 10 + Qt5). + + Copyright (C) 2019-2021 Richard Yu + Copyright (C) 2019-2022 Alexander Koblov (alexx2000@mail.ru) + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all + copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + SOFTWARE. +} + +unit uDarkStyle; + +{$mode delphi} + +interface + +uses + Classes, SysUtils, Windows; + +var + g_buildNumber: DWORD = 0; + //g_darkModeEnabled: bool = false; + g_darkModeSupported: bool = false; + //gAppMode: integer = 1; + +{$IF DEFINED(LCLQT5) OR DEFINED(LCLQT6)} +procedure ApplyDarkStyle; +{$ENDIF} + +procedure RefreshTitleBarThemeColor(hWnd: HWND); +function AllowDarkModeForWindow(hWnd: HWND; allow: bool): bool; +procedure InitDarkMode; + +implementation + +uses + UxTheme, JwaWinUser, FileInfo, uDarkStyleParams + {$IF DEFINED(LCLQT5)} + ,Qt5 + {$ENDIF} + {$IF DEFINED(LCLQT6)} + ,Qt6 + {$ENDIF} + ; + +var + AppMode: TPreferredAppMode; + +var + RtlGetNtVersionNumbers: procedure(major, minor, build: LPDWORD); stdcall; + DwmSetWindowAttribute: function(hwnd: HWND; dwAttribute: DWORD; pvAttribute: Pointer; cbAttribute: DWORD): HRESULT; stdcall; + // 1809 17763 + _ShouldAppsUseDarkMode: function(): bool; stdcall; // ordinal 132 + _AllowDarkModeForWindow: function(hWnd: HWND; allow: bool): bool; stdcall; // ordinal 133 + _AllowDarkModeForApp: function(allow: bool): bool; stdcall; // ordinal 135, removed since 18334 + _RefreshImmersiveColorPolicyState: procedure(); stdcall; // ordinal 104 + _IsDarkModeAllowedForWindow: function(hWnd: HWND): bool; stdcall; // ordinal 137 + // Insider 18334 + _SetPreferredAppMode: function(appMode: TPreferredAppMode): TPreferredAppMode; stdcall; // ordinal 135, since 18334 + +function AllowDarkModeForWindow(hWnd: HWND; allow: bool): bool; +begin + if (g_darkModeSupported) then + Result:= _AllowDarkModeForWindow(hWnd, allow) + else + Result:= false; +end; + +function IsHighContrast(): bool; +var + highContrast: HIGHCONTRASTW; +begin + highContrast.cbSize:= SizeOf(HIGHCONTRASTW); + if (SystemParametersInfoW(SPI_GETHIGHCONTRAST, SizeOf(highContrast), @highContrast, 0)) then + Result:= (highContrast.dwFlags and HCF_HIGHCONTRASTON <> 0) + else + Result:= false; +end; + +function ShouldAppsUseDarkMode: Boolean; +var + bb:bool; +begin + bb:=_ShouldAppsUseDarkMode(); + Result:= (_ShouldAppsUseDarkMode() or (AppMode = pamForceDark)) and not IsHighContrast(); +end; + +procedure RefreshTitleBarThemeColor(hWnd: HWND); +const + DWMWA_USE_IMMERSIVE_DARK_MODE_OLD = 19; + DWMWA_USE_IMMERSIVE_DARK_MODE_NEW = 20; +var + dark: BOOL; + dwAttribute: DWORD; +begin + dark:= (_IsDarkModeAllowedForWindow(hWnd) and ShouldAppsUseDarkMode); + + if (Win32BuildNumber < 19041) then + dwAttribute:= DWMWA_USE_IMMERSIVE_DARK_MODE_OLD + else begin + dwAttribute:= DWMWA_USE_IMMERSIVE_DARK_MODE_NEW; + end; + + DwmSetWindowAttribute(hwnd, dwAttribute, @dark, SizeOf(dark)); +end; + +procedure AllowDarkModeForApp(allow: bool); +begin + if Assigned(_AllowDarkModeForApp) then + _AllowDarkModeForApp(allow) + else if Assigned(_SetPreferredAppMode) then + begin + if (allow) then + _SetPreferredAppMode(AppMode) + else + _SetPreferredAppMode(pamDefault); + end; +end; + +{$IF DEFINED(LCLQT5) OR DEFINED(LCLQT6)} +procedure ApplyDarkStyle; +const + StyleName: WideString = 'Fusion'; +var + AColor: TQColor; + APalette: QPaletteH; + + function QColor(R: Integer; G: Integer; B: Integer; A: Integer = 255): PQColor; + begin + Result:= @AColor; + QColor_fromRgb(Result, R, G, B, A); + end; + +begin + //g_darkModeEnabled:= True; + + QApplication_setStyle(QStyleFactory_create(@StyleName)); + + APalette:= QPalette_Create(); + + // Modify palette to dark + if (AppMode = pamForceDark) then + begin + // DarkMode Pallete + QPalette_setColor(APalette, QPaletteWindow, QColor(53, 53, 53)); + QPalette_setColor(APalette, QPaletteWindowText, QColor(255, 255, 255)); + QPalette_setColor(APalette, QPaletteDisabled, QPaletteWindowText, QColor(127, 127, 127)); + QPalette_setColor(APalette, QPaletteBase, QColor(42, 42, 42)); + QPalette_setColor(APalette, QPaletteAlternateBase, QColor(66, 66, 66)); + QPalette_setColor(APalette, QPaletteToolTipBase, QColor(255, 255, 255)); + QPalette_setColor(APalette, QPaletteToolTipText, QColor(53, 53, 53)); + QPalette_setColor(APalette, QPaletteText, QColor(255, 255, 255)); + QPalette_setColor(APalette, QPaletteDisabled, QPaletteText, QColor(127, 127, 127)); + QPalette_setColor(APalette, QPaletteDark, QColor(35, 35, 35)); + QPalette_setColor(APalette, QPaletteLight, QColor(66, 66, 66)); + QPalette_setColor(APalette, QPaletteShadow, QColor(20, 20, 20)); + QPalette_setColor(APalette, QPaletteButton, QColor(53, 53, 53)); + QPalette_setColor(APalette, QPaletteButtonText, QColor(255, 255, 255)); + QPalette_setColor(APalette, QPaletteDisabled, QPaletteButtonText, QColor(127, 127, 127)); + QPalette_setColor(APalette, QPaletteBrightText, QColor(255, 0, 0)); + QPalette_setColor(APalette, QPaletteLink, QColor(42, 130, 218)); + QPalette_setColor(APalette, QPaletteHighlight, QColor(42, 130, 218)); + QPalette_setColor(APalette, QPaletteDisabled, QPaletteHighlight, QColor(80, 80, 80)); + QPalette_setColor(APalette, QPaletteHighlightedText, QColor(255, 255, 255)); + QPalette_setColor(APalette, QPaletteDisabled, QPaletteHighlightedText, QColor(127, 127, 127)); + end + else + begin + // LightMode Pallete + QPalette_setColor(APalette, QPaletteWindow, QColor(240, 240, 240)); + QPalette_setColor(APalette, QPaletteWindowText, QColor(0, 0, 0)); + QPalette_setColor(APalette, QPaletteDisabled, QPaletteWindowText, QColor(127, 127, 127)); + QPalette_setColor(APalette, QPaletteBase, QColor(225, 225, 225)); + QPalette_setColor(APalette, QPaletteAlternateBase, QColor(255, 255, 255)); + QPalette_setColor(APalette, QPaletteToolTipBase, QColor(255, 255, 255)); + QPalette_setColor(APalette, QPaletteToolTipText, QColor(0, 0, 0)); + QPalette_setColor(APalette, QPaletteText, QColor(0, 0, 0)); + QPalette_setColor(APalette, QPaletteDisabled, QPaletteText, QColor(127, 127, 127)); + QPalette_setColor(APalette, QPaletteDark, QColor(200, 200, 200)); + QPalette_setColor(APalette, QPaletteLight, QColor(255, 255, 255)); + QPalette_setColor(APalette, QPaletteShadow, QColor(220, 220, 220)); + QPalette_setColor(APalette, QPaletteButton, QColor(240, 240, 240)); + QPalette_setColor(APalette, QPaletteButtonText, QColor(0, 0, 0)); + QPalette_setColor(APalette, QPaletteDisabled, QPaletteButtonText, QColor(127, 127, 127)); + QPalette_setColor(APalette, QPaletteBrightText, QColor(255, 0, 0)); + QPalette_setColor(APalette, QPaletteLink, QColor(42, 130, 218)); + QPalette_setColor(APalette, QPaletteHighlight, QColor(42, 130, 218)); + QPalette_setColor(APalette, QPaletteDisabled, QPaletteHighlight, QColor(200, 200, 200)); + QPalette_setColor(APalette, QPaletteHighlightedText, QColor(255, 255, 255)); + QPalette_setColor(APalette, QPaletteDisabled, QPaletteHighlightedText, QColor(127, 127, 127)); + end; + + QApplication_setPalette(APalette); +end; +{$ENDIF} + +const + LOAD_LIBRARY_SEARCH_SYSTEM32 = $800; + +function CheckBuildNumber(buildNumber: DWORD): Boolean; inline; +begin + Result := (buildNumber = 17763) or // Win 10: 1809 + (buildNumber = 18362) or // Win 10: 1903 & 1909 + (buildNumber = 19041) or // Win 10: 2004 & 20H2 & 21H1 & 21H2 + (buildNumber = 22000) or // Win 11: 21H2 + (buildNumber > 22000); // Win 11: Insider Preview +end; + +function GetBuildNumber(Instance: THandle): DWORD; +begin + try + with TVersionInfo.Create do + try + Load(Instance); + Result:= FixedInfo.FileVersion[2]; + finally + Free; + end; + except + Exit(0); + end; +end; + +procedure InitDarkMode(); +var + hUxtheme: HMODULE; + major, minor, build: DWORD; +begin + @RtlGetNtVersionNumbers := GetProcAddress(GetModuleHandleW('ntdll.dll'), 'RtlGetNtVersionNumbers'); + if Assigned(RtlGetNtVersionNumbers) then + begin + RtlGetNtVersionNumbers(@major, @minor, @build); + + if (major = 10) and (minor = 0) then + begin + hUxtheme := LoadLibraryExW('uxtheme.dll', 0, LOAD_LIBRARY_SEARCH_SYSTEM32); + if (hUxtheme <> 0) then + begin + g_buildNumber:= GetBuildNumber(hUxtheme); + + if CheckBuildNumber(g_buildNumber) then + begin + @_RefreshImmersiveColorPolicyState := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(104)); + @_ShouldAppsUseDarkMode := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(132)); + @_AllowDarkModeForWindow := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(133)); + + if (g_buildNumber < 18362) then + @_AllowDarkModeForApp := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(135)) + else + @_SetPreferredAppMode := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(135)); + + @_IsDarkModeAllowedForWindow := GetProcAddress(hUxtheme, MAKEINTRESOURCEA(137)); + + @DwmSetWindowAttribute := GetProcAddress(LoadLibrary('dwmapi.dll'), 'DwmSetWindowAttribute'); + + if Assigned(_RefreshImmersiveColorPolicyState) and + Assigned(_ShouldAppsUseDarkMode) and + Assigned(_AllowDarkModeForWindow) and + (Assigned(_AllowDarkModeForApp) or Assigned(_SetPreferredAppMode)) and + Assigned(_IsDarkModeAllowedForWindow) then + begin + g_darkModeSupported := true; + AppMode := PreferredAppMode; + if AppMode <> pamForceLight then + begin + AllowDarkModeForApp(true); + _RefreshImmersiveColorPolicyState(); + IsDarkModeEnabled := ShouldAppsUseDarkMode; + if IsDarkModeEnabled then AppMode := pamForceDark; + end; + end; + end; + end; + end; + end; +end; + +initialization +end. + diff --git a/peazip-sources/dev/metadarkstyle/src/udarkstyleparams.pas b/peazip-sources/dev/metadarkstyle/src/udarkstyleparams.pas new file mode 100644 index 00000000..8dcd68c0 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/udarkstyleparams.pas @@ -0,0 +1,44 @@ +{ +@author(Andrey Zubarev ) +} + +unit uDarkStyleParams; + +interface + +uses + LCLType,Graphics,ComCtrls; + +type + TSysColors=array[0..COLOR_ENDCOLORS] of TColor; + TDrawControl=record + TreeViewDisableHideSelection:Boolean; + TreeViewExpandSignOverride:Boolean; + TreeViewExpandSignValue: TTreeViewExpandSignType; + CustomDrawScrollbars:Boolean; + CustomDrawPushButtons:Boolean; + CustomDrawComboBoxs:Boolean; + CustomDrawTreeViews:Boolean; + end; + + TDSColors=record + SysColor:TSysColors; + DrawControl:TDrawControl; + end; + + // Insider 18334 + TPreferredAppMode = + ( + pamDefault, + pamAllowDark, + pamForceDark, + pamForceLight + ); + +var + PreferredAppMode:TPreferredAppMode=pamForceLight; + IsDarkModeEnabled: Boolean = False; + +implementation + +end. diff --git a/peazip-sources/dev/metadarkstyle/src/udarkstyleschemes.pas b/peazip-sources/dev/metadarkstyle/src/udarkstyleschemes.pas new file mode 100644 index 00000000..5d1cf9d9 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/udarkstyleschemes.pas @@ -0,0 +1,228 @@ +{ +@author(Andrey Zubarev ) +} + +unit uDarkStyleSchemes; + +interface + +uses + SysUtils, + LCLType,LCLIntf,Graphics,Masks, + LResources,ComCtrls, + uDarkStyleParams, + gmap,gutil; + +const + DSColorsTypeName='DARKSTYLECOLORS'; + +type + TSchemeName=String; + PTSchemeData=^TSchemeData; + TSchemeData=record + Name:TSchemeName; + Data:TDSColors; + end; + TSchemeKey=String; + TSchemes=class(specialize TMap>) + function GetMutableValue(key:TSchemeKey):PTSchemeData; + end; + + +var + DefaultDark,DefaultWhite:TDSColors; + Schemes:TSchemes=nil; + +function GetScheme(AName:TSchemeName):TDSColors; +function GetSchemeMutable(AName:TSchemeName):PTSchemeData; +procedure AddScheme(AName:TSchemeName;AData:TDSColors); +procedure LoadLResources; +procedure LoadPath(APath,AMask:string); + +implementation +uses + uDarkStyleSchemesLoader; + +function TSchemes.GetMutableValue(key:TSchemeKey):PTSchemeData; +var + Pair:TPair; + Node:TMSet.PNode; +begin + Pair.Key:=key; + Node:=FSet.NFind(Pair); + if Node=nil then + result:=nil + else + result:=@Node^.Data.Value; +end; + +function SchameName2SchameID(AName:TSchemeName):TSchemeKey;inline; +begin + result:=UpperCase(AName); +end; + +function GetSchemeMutable(AName:TSchemeName):PTSchemeData; +begin + if Schemes=nil then + exit(nil); + result:=Schemes.GetMutableValue(SchameName2SchameID(AName)); +end; + +function GetScheme(AName:TSchemeName):TDSColors; +var + ps:PTSchemeData; + UCName:string; +begin + UCName:=UpperCase(AName); + if UCName='DARK' then + result:=DefaultDark + else if UCName='WHITE' then + result:=DefaultWhite + else begin + ps:=GetSchemeMutable(AName); + if ps=nil then + result:=DefaultDark + else + result:=ps^.Data; + end; +end; + +function CreateTSchemeData(AName:TSchemeName;AData:TDSColors):TSchemeData; +begin + result.Data:=AData; + result.Name:=AName; +end; + +procedure AddScheme(AName:TSchemeName;AData:TDSColors); +var + id:TSchemeKey; +begin + id:=SchameName2SchameID(AName); + if Schemes=nil then begin + Schemes:=TSchemes.Create; + Schemes.Insert(id,CreateTSchemeData(AName,AData)); + end else begin + if Schemes.GetMutableValue(id)=nil then + Schemes.Insert(id,CreateTSchemeData(AName,AData)); + end; +end; + +procedure LoadLResources; +var + r:TLResource; + DSC:TDSColors; + i:integer; +begin + for i:=0 to LazarusResources.Count-1 do begin + r:=LazarusResources.Items[i]; + if UpperCase(r.ValueType)=DSColorsTypeName then + if GetSchemeMutable(r.Value)=nil then + if ParseColors(r.Name,r.Value,DSC) then + AddScheme(r.Name,DSC); + end; +end; + +procedure LoadPath(APath,AMask:string); +var + DSC:TDSColors; + sr: TSearchRec; +begin + if FindFirst(APath+'/*',faAnyFile,sr) = 0 then begin + repeat + if (sr.Name <> '.') and (sr.Name <> '..') then begin + if MatchesMask(sr.Name,AMask) then + if ParseColorsFile(APath+'/'+sr.Name,DSC) then + AddScheme(ChangeFileExt(sr.Name,''),DSC); + end; + until FindNext(sr) <> 0; + FindClose(sr); + end; +end; + +procedure InitializeDefaultColors; +begin + DefaultDark.SysColor[COLOR_SCROLLBAR]:= RGBToColor(53, 53, 53); + DefaultDark.SysColor[COLOR_BACKGROUND]:= RGBToColor(53, 53, 53); + DefaultDark.SysColor[COLOR_ACTIVECAPTION]:= RGBToColor(42, 130, 218); + DefaultDark.SysColor[COLOR_INACTIVECAPTION]:= RGBToColor(53, 53, 53); + DefaultDark.SysColor[COLOR_MENU]:= RGBToColor(42, 42, 42); + DefaultDark.SysColor[COLOR_WINDOW]:= RGBToColor(42, 42, 42); + DefaultDark.SysColor[COLOR_WINDOWFRAME]:= RGBToColor(20, 20, 20); + DefaultDark.SysColor[COLOR_MENUTEXT]:= RGBToColor(245, 245, 245); + DefaultDark.SysColor[COLOR_WINDOWTEXT]:= RGBToColor(245, 245, 245); + DefaultDark.SysColor[COLOR_CAPTIONTEXT]:= RGBToColor(245, 245, 245); + DefaultDark.SysColor[COLOR_ACTIVEBORDER] := RGBToColor(53, 53, 53); + DefaultDark.SysColor[COLOR_INACTIVEBORDER]:= RGBToColor(53, 53, 53); + DefaultDark.SysColor[COLOR_APPWORKSPACE]:= RGBToColor(53, 53, 53); + DefaultDark.SysColor[COLOR_HIGHLIGHT]:= RGBToColor(42, 130, 218); + DefaultDark.SysColor[COLOR_HIGHLIGHTTEXT]:= RGBToColor(245, 245, 245); + DefaultDark.SysColor[COLOR_BTNFACE]:= RGBToColor(53, 53, 53); + DefaultDark.SysColor[COLOR_BTNSHADOW]:= RGBToColor(35, 35, 35); + DefaultDark.SysColor[COLOR_GRAYTEXT]:= RGBToColor(160, 160, 160); + DefaultDark.SysColor[COLOR_BTNTEXT]:= RGBToColor(245, 245, 245); + DefaultDark.SysColor[COLOR_INACTIVECAPTIONTEXT]:= RGBToColor(245, 245, 245); + DefaultDark.SysColor[COLOR_BTNHIGHLIGHT]:= RGBToColor(66, 66, 66); + DefaultDark.SysColor[COLOR_3DDKSHADOW]:= RGBToColor(20, 20, 20); + DefaultDark.SysColor[COLOR_3DLIGHT]:= RGBToColor(40, 40, 40); + DefaultDark.SysColor[COLOR_INFOTEXT]:= RGBToColor(53, 53, 53); + DefaultDark.SysColor[COLOR_INFOBK]:= RGBToColor(245, 245, 245); + DefaultDark.SysColor[COLOR_HOTLIGHT]:= RGBToColor(66, 66, 66); + DefaultDark.SysColor[COLOR_GRADIENTACTIVECAPTION]:= GetSysColor(COLOR_GRADIENTACTIVECAPTION); + DefaultDark.SysColor[COLOR_GRADIENTINACTIVECAPTION]:= GetSysColor(COLOR_GRADIENTINACTIVECAPTION); + DefaultDark.SysColor[COLOR_MENUHILIGHT]:= RGBToColor(66, 66, 66); + DefaultDark.SysColor[COLOR_MENUBAR]:= RGBToColor(42, 42, 42); + DefaultDark.SysColor[COLOR_FORM]:= RGBToColor(53, 53, 53); + DefaultDark.DrawControl.CustomDrawScrollbars:= False; + DefaultDark.DrawControl.TreeViewDisableHideSelection:= False; + DefaultDark.DrawControl.TreeViewExpandSignOverride:= False; + DefaultDark.DrawControl.TreeViewExpandSignValue:= tvestTheme; + DefaultDark.DrawControl.CustomDrawPushButtons:= False; + DefaultDark.DrawControl.CustomDrawComboBoxs:= False; + DefaultDark.DrawControl.CustomDrawTreeViews:= False; + + DefaultWhite.SysColor[COLOR_SCROLLBAR]:= GetSysColor(COLOR_SCROLLBAR); + DefaultWhite.SysColor[COLOR_BACKGROUND]:= GetSysColor(COLOR_BACKGROUND); + DefaultWhite.SysColor[COLOR_ACTIVECAPTION]:= GetSysColor(COLOR_ACTIVECAPTION); + DefaultWhite.SysColor[COLOR_INACTIVECAPTION]:= GetSysColor(COLOR_INACTIVECAPTION); + DefaultWhite.SysColor[COLOR_MENU]:= GetSysColor(COLOR_MENU); + DefaultWhite.SysColor[COLOR_WINDOW]:= GetSysColor(COLOR_WINDOW); + DefaultWhite.SysColor[COLOR_WINDOWFRAME]:= GetSysColor(COLOR_WINDOWFRAME); + DefaultWhite.SysColor[COLOR_MENUTEXT]:= GetSysColor(COLOR_MENUTEXT); + DefaultWhite.SysColor[COLOR_WINDOWTEXT]:= GetSysColor(COLOR_WINDOWTEXT); + DefaultWhite.SysColor[COLOR_CAPTIONTEXT]:= GetSysColor(COLOR_CAPTIONTEXT); + DefaultWhite.SysColor[COLOR_ACTIVEBORDER] := GetSysColor(COLOR_ACTIVEBORDER); + DefaultWhite.SysColor[COLOR_INACTIVEBORDER]:= GetSysColor(COLOR_INACTIVEBORDER); + DefaultWhite.SysColor[COLOR_APPWORKSPACE]:= GetSysColor(COLOR_APPWORKSPACE); + DefaultWhite.SysColor[COLOR_HIGHLIGHT]:= GetSysColor(COLOR_HIGHLIGHT); + DefaultWhite.SysColor[COLOR_HIGHLIGHTTEXT]:= GetSysColor(COLOR_HIGHLIGHTTEXT); + DefaultWhite.SysColor[COLOR_BTNFACE]:= GetSysColor(COLOR_BTNFACE); + DefaultWhite.SysColor[COLOR_BTNSHADOW]:= GetSysColor(COLOR_BTNSHADOW); + DefaultWhite.SysColor[COLOR_GRAYTEXT]:= GetSysColor(COLOR_GRAYTEXT); + DefaultWhite.SysColor[COLOR_BTNTEXT]:= GetSysColor(COLOR_BTNTEXT); + DefaultWhite.SysColor[COLOR_INACTIVECAPTIONTEXT]:= GetSysColor(COLOR_INACTIVECAPTIONTEXT); + DefaultWhite.SysColor[COLOR_BTNHIGHLIGHT]:= GetSysColor(COLOR_BTNHIGHLIGHT); + DefaultWhite.SysColor[COLOR_3DDKSHADOW]:= GetSysColor(COLOR_3DDKSHADOW); + DefaultWhite.SysColor[COLOR_3DLIGHT]:= GetSysColor(COLOR_3DLIGHT); + DefaultWhite.SysColor[COLOR_INFOTEXT]:= GetSysColor(COLOR_INFOTEXT); + DefaultWhite.SysColor[COLOR_INFOBK]:= GetSysColor(COLOR_INFOBK); + DefaultWhite.SysColor[COLOR_HOTLIGHT]:= GetSysColor(COLOR_HOTLIGHT); + DefaultWhite.SysColor[COLOR_GRADIENTACTIVECAPTION]:= GetSysColor(COLOR_GRADIENTACTIVECAPTION); + DefaultWhite.SysColor[COLOR_GRADIENTINACTIVECAPTION]:= GetSysColor(COLOR_GRADIENTINACTIVECAPTION); + DefaultWhite.SysColor[COLOR_MENUHILIGHT]:= GetSysColor(COLOR_MENUHILIGHT); + DefaultWhite.SysColor[COLOR_MENUBAR]:= GetSysColor(COLOR_MENUBAR); + DefaultWhite.SysColor[COLOR_FORM]:= GetSysColor(COLOR_FORM); + DefaultWhite.DrawControl.CustomDrawScrollbars:= True; + DefaultWhite.DrawControl.TreeViewDisableHideSelection:=False; + DefaultWhite.DrawControl.TreeViewExpandSignOverride:= False; + DefaultWhite.DrawControl.TreeViewExpandSignValue:= tvestTheme; + DefaultWhite.DrawControl.CustomDrawPushButtons:= True; + DefaultWhite.DrawControl.CustomDrawComboBoxs:= True; + DefaultWhite.DrawControl.CustomDrawTreeViews:= True; +end; + +initialization + InitializeDefaultColors; +finalization + if Schemes<>nil then + Schemes.Destroy; +end. diff --git a/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesadditional.pas b/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesadditional.pas new file mode 100644 index 00000000..0167879e --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesadditional.pas @@ -0,0 +1,16 @@ +{ +@author(Andrey Zubarev ) +} + +unit uDarkStyleSchemesAdditional; + +interface + +uses + LResources; + +implementation + +initialization +{$I CustomDark.lrs} +end. diff --git a/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesloader.pas b/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesloader.pas new file mode 100644 index 00000000..515360ba --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/udarkstyleschemesloader.pas @@ -0,0 +1,511 @@ +{ +@author(Andrey Zubarev ) +} + +unit uDarkStyleSchemesLoader; + +interface + +uses + SysUtils,Classes,contnrs,bufstream, + LCLProc,LCLType,LCLIntf,Graphics,LCLVersion, + LResources,ComCtrls, + PScanner, PParser, PasTree, + uDarkStyleParams,uDarkStyleSchemes; + +function ParseColors(modulename,module:string;out DSC:TDSColors):Boolean;overload; +function ParseColors(modulename:string;module:TStream;out DSC:TDSColors):Boolean;overload; +function ParseColorsFile(AFile:string;out DSC:TDSColors):Boolean;overload; + +implementation + +type + TIdent=(IdUnknown, + IdColors, + IdScheme, + IdDefaultDark,IdDefaultWhite, + IdRGBToColor,IdGetSysColor, + IdTreeViewDisableHideSelection,IdTreeViewExpandSignOverride,IdTreeViewExpandSignValue, + IdtvestTheme,IdtvestPlusMinus,IdtvestArrow,IdtvestArrowFill,IdtvestAngleBracket, + IdCustomDrawScrollbars, + IdCustomDrawPushButtons, + IdCustomDrawComboBoxs, + IdCustomDrawTreeViews, + IdCOLOR_SCROLLBAR, + IdCOLOR_BACKGROUND, + IdCOLOR_ACTIVECAPTION, + IdCOLOR_INACTIVECAPTION, + IdCOLOR_MENU, + IdCOLOR_WINDOW, + IdCOLOR_WINDOWFRAME, + IdCOLOR_MENUTEXT, + IdCOLOR_WINDOWTEXT, + IdCOLOR_CAPTIONTEXT, + IdCOLOR_ACTIVEBORDER, + IdCOLOR_INACTIVEBORDER, + IdCOLOR_APPWORKSPACE, + IdCOLOR_HIGHLIGHT, + IdCOLOR_HIGHLIGHTTEXT, + IdCOLOR_BTNFACE, + IdCOLOR_BTNSHADOW, + IdCOLOR_GRAYTEXT, + IdCOLOR_BTNTEXT, + IdCOLOR_INACTIVECAPTIONTEXT, + IdCOLOR_BTNHIGHLIGHT, + IdCOLOR_3DDKSHADOW, + IdCOLOR_3DLIGHT, + IdCOLOR_INFOTEXT, + IdCOLOR_INFOBK, + IdCOLOR_25, + IdCOLOR_HOTLIGHT, + IdCOLOR_GRADIENTACTIVECAPTION, + IdCOLOR_GRADIENTINACTIVECAPTION, + IdCOLOR_MENUHILIGHT, + IdCOLOR_MENUBAR, + IdCOLOR_FORM); +const + TIdents2Name:array[TIdent] of string=( + '', + 'COLORS', + 'SCHEME', + 'DEFAULTDARK','DEFAULTWHITE', + 'RGBTOCOLOR','GETSYSCOLOR', + 'TREEVIEWDISABLEHIDESELECTION','TREEVIEWEXPANDSIGNOVERRIDE','TREEVIEWEXPANDSIGNVALUE', + 'TVESTTHEME','TVESTPLUSMINUS','TVESTARROW','TVESTARROWFILL','TVESTANGLEBRACKET', + 'CUSTOMDRAWSCROLLBARS', + 'CUSTOMDRAWPUSHBUTTONS', + 'CUSTOMDRAWCOMBOBOXS', + 'CUSTOMDRAWTREEVIEWS', + 'COLOR_SCROLLBAR', + 'COLOR_BACKGROUND', + 'COLOR_ACTIVECAPTION', + 'COLOR_INACTIVECAPTION', + 'COLOR_MENU', + 'COLOR_WINDOW', + 'COLOR_WINDOWFRAME', + 'COLOR_MENUTEXT', + 'COLOR_WINDOWTEXT', + 'COLOR_CAPTIONTEXT', + 'COLOR_ACTIVEBORDER', + 'COLOR_INACTIVEBORDER', + 'COLOR_APPWORKSPACE', + 'COLOR_HIGHLIGHT', + 'COLOR_HIGHLIGHTTEXT', + 'COLOR_BTNFACE', + 'COLOR_BTNSHADOW', + 'COLOR_GRAYTEXT', + 'COLOR_BTNTEXT', + 'COLOR_INACTIVECAPTIONTEXT', + 'COLOR_BTNHIGHLIGHT', + 'COLOR_3DDKSHADOW', + 'COLOR_3DLIGHT', + 'COLOR_INFOTEXT', + 'COLOR_INFOBK', + 'COLOR_25', + 'COLOR_HOTLIGHT', + 'COLOR_GRADIENTACTIVECAPTION', + 'COLOR_GRADIENTINACTIVECAPTION', + 'COLOR_MENUHILIGHT', + 'COLOR_MENUBAR', + 'COLOR_FORM' + ); + +type + TSimpleEngine = class(TPasTreeContainer) + private + uname:string; + FElements:TObjectList; + public + + constructor Create; + destructor Destroy;override; + Procedure Log(Sender : TObject; Const Msg : String); + + function CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement; + override; + function FindElement(const AName: String): TPasElement; override; + end; + + TOnMemoryStream = class(TCustomMemoryStream) + private + FReadOnly: Boolean; + protected + procedure SetSize(NewSize: Longint); override; + public + constructor Create(Ptr: Pointer; ASize: Longint; ReadOnlyMode: Boolean = True); + function Write(const Buffer; Count: Longint): Longint; override; + property ReadOnly: Boolean read FReadOnly write FReadOnly; + end; + + constructor TOnMemoryStream.Create(Ptr: Pointer; ASize: Longint; ReadOnlyMode: Boolean = True); + begin + inherited Create; + SetPointer(Ptr, ASize); + FReadOnly := ReadOnlyMode; + end; + {------------------------------------------------------------------------------} + function TOnMemoryStream.Write(const Buffer; Count: Longint): Longint; + var + Pos: Longint; + begin + if (Position >= 0) and (Count >= 0) and (not ReadOnly) and (Position + Count <=Size) then + begin + Pos := Position + Count; + System.Move(Buffer, Pointer(NativeUInt(Memory) + NativeUInt(Position))^, Count); + Position := Pos; + Result := Count; + end + else + Result := 0; + end; + {------------------------------------------------------------------------------} + procedure TOnMemoryStream.SetSize(NewSize: Longint); + begin + //ничего не делаем + end; + +destructor TSimpleEngine.Destroy; +begin + if assigned(FPackage) then + FPackage.Destroy; + if FElements<>nil then + FElements.Destroy; + inherited; +end; + +function TSimpleEngine.CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement; +begin + Result := AClass.Create(AName, AParent); + Result.Visibility := AVisibility; + Result.SourceFilename := ASourceFilename; + Result.SourceLinenumber := ASourceLinenumber; + if FElements=nil then + FElements:=TObjectList.Create; + FElements.Add(result); +end; +constructor TSimpleEngine.Create; +begin + inherited; + FPackage:=TPasPackage.Create('',nil); + FElements:=nil; +end; +procedure TSimpleEngine.Log(Sender : TObject; Const Msg : String); +begin + DebugLn(format('[MetaDarkStyle] %s',[Msg])); +end; +function TSimpleEngine.FindElement(const AName: String): TPasElement; +begin + { dummy implementation, see TFPDocEngine.FindElement for a real example } + Result := nil; +end; + +function Identifer2TIdent(id:string):TIdent; +begin + id:=UpperCase(id); + for Result:=Succ(Low(TIdent)) to High(TIdent) do + if TIdents2Name[Result]=id then + exit; + Result:=Low(TIdent); +end; + +function GetTreeViewExpandSignValue(pn:TPASEXPR):TTreeViewExpandSignType; +var + lid:TIdent; +begin + if pn is TPrimitiveExpr then begin + lid:=Identifer2TIdent(TPrimitiveExpr(pn).Value); + case lid of + IdtvestTheme:result:=tvestTheme; + IdtvestPlusMinus:result:=tvestPlusMinus; + IdtvestArrow:result:=tvestArrow; + IdtvestArrowFill:result:=tvestArrowFill; +IdtvestAngleBracket:result:={$If declared(tvestAngleBracket)} + tvestAngleBracket;//появилось в 02eed0c903e14a33c95b4abded0c66d193678d70 + {$Else} + tvestArrow; + {$EndIf} + else + Exception.Create(format('Error in line %d (only allowed "tvestTheme", "tvestPlusMinus", "tvestArrow", "tvestArrowFill", "tvestAngleBracket")',[pn.SourceLinenumber])); + end; + end else + Exception.Create(format('Error in line %d (only palette names allowed "DefaultDark", "DefaultWhite")',[pn.SourceLinenumber])); +end; + +function GetPaletteByName(pn:TPASEXPR):TDSColors; +var + lid:TIdent; +begin + if pn is TPrimitiveExpr then begin + lid:=Identifer2TIdent(TPrimitiveExpr(pn).Value); + case lid of + IdDefaultDark:result:=DefaultDark; +IdDefaultWhite:result:=DefaultWhite; + else + Exception.Create(format('Error in line %d (only palette names allowed "DefaultDark", "DefaultWhite")',[pn.SourceLinenumber])); + end; + end else + Exception.Create(format('Error in line %d (only palette names allowed "DefaultDark", "DefaultWhite")',[pn.SourceLinenumber])); +end; + +function GetArrayIndex(indxs:TPasExprArray):integer; +var + lid:TIdent; +begin + if Length(indxs)<>1 then + Exception.Create(format('Error in line %d (only one index allowed)',[indxs[0].SourceLinenumber])); + if indxs[0] is TPrimitiveExpr then begin + case TPrimitiveExpr(indxs[0]).Kind of + pekIdent:begin + lid:=Identifer2TIdent(TPrimitiveExpr(indxs[0]).Value); + case lid of + IdCOLOR_SCROLLBAR..IdCOLOR_FORM:Result:=ord(lid)-ord(IdCOLOR_SCROLLBAR); + else + Exception.Create(format('Error in line %d (unknown index [%s])',[indxs[0].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); + end; + end; + pekNumber:begin + if not TryStrToInt(TPrimitiveExpr(indxs[0]).Value,result) then + Exception.Create(format('Error in line %d (unknown index [%s])',[indxs[0].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); + end; + else + Exception.Create(format('Error in line %d (unknown index [%s])',[indxs[0].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); + end; + end else + Exception.Create(format('Error in line %d (unknown index [])',[indxs[0].SourceLinenumber])); +end; + +function GetRGBColor(indxs:TPasExprArray):TColor; +var + lid:TIdent; + r,g,b:integer; +begin + if Length(indxs)<>3 then + Exception.Create(format('Error in line %d (only 3 params allowed)',[indxs[0].SourceLinenumber])); + if indxs[0] is TPrimitiveExpr then begin + case TPrimitiveExpr(indxs[0]).Kind of + pekNumber:begin + if not TryStrToInt(TPrimitiveExpr(indxs[0]).Value,r) then + Exception.Create(format('Error in line %d (unknown unknown param 1 [%s])',[indxs[0].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); + end; + else + Exception.Create(format('Error in line %d (unknown unknown param 1 [%s])',[indxs[0].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); + end; + end else + Exception.Create(format('Error in line %d (unknown param 1 )',[indxs[0].SourceLinenumber])); + if indxs[1] is TPrimitiveExpr then begin + case TPrimitiveExpr(indxs[1]).Kind of + pekNumber:begin + if not TryStrToInt(TPrimitiveExpr(indxs[1]).Value,g) then + Exception.Create(format('Error in line %d (unknown unknown param 2 [%s])',[indxs[1].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); + end; + else + Exception.Create(format('Error in line %d (unknown unknown param 2 [%s])',[indxs[1].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); + end; + end else + Exception.Create(format('Error in line %d (unknown param 2 )',[indxs[1].SourceLinenumber])); + if indxs[2] is TPrimitiveExpr then begin + case TPrimitiveExpr(indxs[2]).Kind of + pekNumber:begin + if not TryStrToInt(TPrimitiveExpr(indxs[2]).Value,b) then + Exception.Create(format('Error in line %d (unknown unknown param 3 [%s])',[indxs[2].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); + end; + else + Exception.Create(format('Error in line %d (unknown unknown param 3 [%s])',[indxs[2].SourceLinenumber,TPrimitiveExpr(indxs[0]).Value])); + end; + end else + Exception.Create(format('Error in line %d (unknown param 3 )',[indxs[2].SourceLinenumber])); + result:=RGBToColor(r,g,b); +end; + +function GetColor(fn:TPASEXPR):TColor; +var + lid:TIdent; + i:integer; +begin + if fn.Kind=pekFuncParams then begin + lid:=Identifer2TIdent(TPrimitiveExpr(TParamsExpr(fn).Value).Value); + case lid of + IdRGBToColor:begin + result:=GetRGBColor(TParamsExpr(fn).Params); + end; + IdGetSysColor:begin + i:=GetArrayIndex(TParamsExpr(fn).Params); + result:=GetSysColor(i); + end + else + Exception.Create(format('Error in line %d (only "RGBToColor()", "GetSysColor()" allowed, but "%s" found)',[fn.SourceLinenumber,TParamsExpr(fn).Value])); + end; + end else + Exception.Create(format('Error in line %d (only "RGBToColor()", "GetSysColor()" allowed)',[fn.SourceLinenumber])); +end; + +procedure SetBoolean(var ABoolean:Boolean;pn:TPASEXPR); +begin + if pn is TBoolConstExpr then + ABoolean:=TBoolConstExpr(pn).Value + else + Exception.Create(format('Error in line %d (only True or False allowed)',[pn.SourceLinenumber])); +end; + + +procedure PrepareAssign(Ass:TPasImplAssign;var DSC:TDSColors); +var + lid:TIdent; + i:integer; +begin + if Ass.Left.OpCode=eopNone then begin + if Ass.Left.Kind=pekIdent then begin + lid:=Identifer2TIdent(TPrimitiveExpr(Ass.Left).Value); + case lid of + IdScheme:DSC:=GetPaletteByName(Ass.Right); + IdTreeViewExpandSignOverride:SetBoolean(DSC.DrawControl.TreeViewExpandSignOverride,Ass.Right); + IdTreeViewExpandSignValue:DSC.DrawControl.TreeViewExpandSignValue:=GetTreeViewExpandSignValue(Ass.Right); + IdCustomDrawScrollbars:SetBoolean(DSC.DrawControl.CustomDrawScrollbars,Ass.Right); + IdCustomDrawPushButtons:SetBoolean(DSC.DrawControl.CustomDrawPushButtons,Ass.Right); + IdCustomDrawComboBoxs:SetBoolean(DSC.DrawControl.CustomDrawComboBoxs,Ass.Right); + IdCustomDrawTreeViews:SetBoolean(DSC.DrawControl.CustomDrawTreeViews,Ass.Right); +IdTreeViewDisableHideSelection:SetBoolean(DSC.DrawControl.TreeViewDisableHideSelection,Ass.Right); + else + Exception.Create(format('Error in line %d (wrong left side)',[Ass.SourceLinenumber])); + end; + end else if Ass.Left.Kind=pekArrayParams then begin + if (not(Ass.Left is TParamsExpr))and(not(TParamsExpr(Ass.Left).Value is TPrimitiveExpr)) then + Exception.Create(format('Error in line %d (wrong left side: wrong array index)',[Ass.SourceLinenumber])); + lid:=Identifer2TIdent(TPrimitiveExpr(TParamsExpr(Ass.Left).Value).Value); + if lid<>IdColors then + Exception.Create(format('Error in line %d (wrong left side: only "Colors[]" allowed)',[Ass.SourceLinenumber])); + i:=GetArrayIndex(TParamsExpr(Ass.Left).Params); + DSC.SysColor[i]:=GetColor(Ass.Right) + end else + Exception.Create(format('Error in line %d (wrong left side: not ident[] or ident)',[Ass.SourceLinenumber])); + end else + raise Exception.Create(format('Error in line %d (wrong left side)',[Ass.SourceLinenumber])); +end; + +procedure PrepareElement(pie:TPasImplElement;var DSC:TDSColors); +begin + if pie is TPasImplAssign then + PrepareAssign(pie as TPasImplAssign,DSC) + else + raise Exception.Create(format('Error in line %d (only := alowed)',[pie.SourceLinenumber])); +end; + +function PrepareModule(m:TPasProgram):TDSColors; +var + pie:TPasImplElement; +begin + if not(m is TPasProgram) then + raise Exception.Create('Program is expected'); + if not assigned((m as TPasProgram).InitializationSection) then + raise Exception.Create('Program is empty'); + if ((m as TPasProgram).InputFile<>'')or((m as TPasProgram).OutPutFile<>'') then + raise Exception.Create('No input/output file needed'); + + for pointer(pie) in (m as TPasProgram).InitializationSection.Elements do + PrepareElement(pie,Result); +end; + +function ScanModule(modulename:string;module:TStream;out DSC:TDSColors):Boolean; +var + E:TSimpleEngine; + Parser: TPasParser; + Resolver:TStreamResolver; + Scanner: TPascalScanner; + m:TPasModule; + +begin + E := TSimpleEngine.Create; + E.uname:=modulename; + + Resolver:=TStreamResolver.Create; + Scanner:=TPascalScanner.Create(Resolver); + Scanner.LogEvents:=[sleFile,sleLineNumber,sleConditionals,sleDirective]; + Scanner.OnLog:=E.Onlog; + Parser := TPasParser.Create(Scanner, Resolver, E); + Parser.LogEvents:=[pleInterface,pleImplementation]; + Parser.OnLog:=E.Onlog; + result:=False; + + try + try + Resolver.AddStream(modulename,module); + Scanner.OpenFile(modulename); + Parser.ParseMain(m); + try + result:=True; + dsc:=PrepareModule(TPasProgram(m)); + except + on excep:Exception do begin + DebugLn(format('{EM}[MetaDarkStyle]DSScheme prepare exception: "%s" in file "%s"',[excep.message,modulename])); + result:=false; + end + else; + end; + + except + on excep:EParserError do begin + DebugLn(format('{EM}[MetaDarkStyle]DSScheme parse error: "%s" line:%d column:%d file:%s',[excep.message,excep.row,excep.column,excep.filename])); + FreeAndNil(result); + end; + on excep:Exception do begin + DebugLn(format('{EM}[MetaDarkStyle]DSScheme parse exception: "%s" in file "%s"',[excep.message,modulename])); + FreeAndNil(result); + end + else begin + DebugLn(format('{EM}[MetaDarkStyle]Error in file "%s"',[modulename])); + FreeAndNil(result); + end; + end; + finally + Parser.Free; + {$IFDEF FPC_FULLVERSION}{$IF FPC_FULLVERSION > 30202} + //error in 3.2.2 cause memoryleak + E.Free; + {$ENDIF}{$ENDIF} + Resolver.Free; + Scanner.Free; + end; +end; + +function ParseColors(modulename:string;module:TStream;out DSC:TDSColors):Boolean;overload; +var + m:TPasProgram; +begin + result:=false; + try + try + result:=ScanModule(modulename,module,DSC); + except + on excep:Exception do begin + DebugLn(format('{EM}[MetaDarkStyle]DSScheme prepare exception: "%s" in file "%s"',[excep.message,modulename])); + result:=false; + end + else; + end; + finally + end; +end; + +function ParseColors(modulename,module:string;out DSC:TDSColors):Boolean;overload; +var + ms:TOnMemoryStream; +begin + ms:=TOnMemoryStream.Create(@module[1],Length(module)*sizeof(module[1])); + result:=ParseColors(modulename,ms,DSC); + ms.Destroy; +end; + +function ParseColorsFile(AFile:string;out DSC:TDSColors):Boolean;overload; +var + bfs:TBufferedFileStream; +begin + bfs:=TBufferedFileStream.Create(AFile,fmOpenRead or fmShareDenyWrite); + result:=ParseColors(AFile,bfs,DSC); + bfs.Destroy; +end; + +end. diff --git a/peazip-sources/dev/metadarkstyle/src/uimport.pas b/peazip-sources/dev/metadarkstyle/src/uimport.pas new file mode 100644 index 00000000..b1e857d6 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/uimport.pas @@ -0,0 +1,150 @@ +unit uImport; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Windows; + +function FindImportLibrary(hModule: THandle; pLibName: PAnsiChar): PPointer; +function FindImportFunction(pLibrary: PPointer; pFunction: Pointer): PPointer; +function ReplaceImportFunction(pOldFunction: PPointer; pNewFunction: Pointer): Pointer; + +function FindDelayImportLibrary(hModule: THandle; pLibName: PAnsiChar): Pointer; +function FindDelayImportFunction(hModule: THandle; pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; pFuncName: PAnsiChar): PPointer; +procedure ReplaceDelayImportFunction(hModule: THandle; pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; pFuncName: PAnsiChar; pNewFunction: Pointer); + +implementation + +type +{$IFDEF WIN64} + PIMAGE_NT_HEADERS = PIMAGE_NT_HEADERS64; +{$ELSE} + PIMAGE_NT_HEADERS = PIMAGE_NT_HEADERS32; +{$ENDIF} + +function FindImageDirectory(hModule: THandle; Index: Integer; out DataDir: PIMAGE_DATA_DIRECTORY): Pointer; +var + pNTHeaders: PIMAGE_NT_HEADERS; + pModule: PByte absolute hModule; + pDosHeader: PIMAGE_DOS_HEADER absolute hModule; +begin + if pDosHeader^.e_magic = IMAGE_DOS_SIGNATURE then + begin + pNTHeaders := @pModule[pDosHeader^.e_lfanew]; + if pNTHeaders^.Signature = IMAGE_NT_SIGNATURE then + begin + DataDir := @pNTHeaders^.OptionalHeader.DataDirectory[Index]; + Result := @pModule[DataDir^.VirtualAddress]; + Exit; + end; + end; + Result := nil; +end; + +function FindImportLibrary(hModule: THandle; pLibName: PAnsiChar): PPointer; +var + pEnd: PByte; + pImpDir: PIMAGE_DATA_DIRECTORY; + pImpDesc: PIMAGE_IMPORT_DESCRIPTOR; + pModule: PAnsiChar absolute hModule; +begin + pImpDesc := FindImageDirectory(hModule, IMAGE_DIRECTORY_ENTRY_IMPORT, pImpDir); + if pImpDesc = nil then Exit(nil); + + pEnd := PByte(pImpDesc) + pImpDir^.Size; + + while (PByte(pImpDesc) < pEnd) and (pImpDesc^.FirstThunk <> 0) do + begin + if StrIComp(@pModule[pImpDesc^.Name], pLibName) = 0 then + begin + Result := @pModule[pImpDesc^.FirstThunk]; + Exit; + end; + Inc(pImpDesc); + end; + Result := nil; +end; + +function FindImportFunction(pLibrary: PPointer; pFunction: Pointer): PPointer; +begin + while Assigned(pLibrary^) do + begin + if pLibrary^ = pFunction then Exit(pLibrary); + Inc(pLibrary); + end; + Result := nil; +end; + +function ReplaceImportFunction(pOldFunction: PPointer; pNewFunction: Pointer): Pointer; +var + dwOldProtect: DWORD = 0; +begin + if VirtualProtect(pOldFunction, SizeOf(Pointer), PAGE_READWRITE, dwOldProtect) then + begin + Result := pOldFunction^; + pOldFunction^ := pNewFunction; + VirtualProtect(pOldFunction, SizeOf(Pointer), dwOldProtect, dwOldProtect); + end; +end; + +function FindDelayImportLibrary(hModule: THandle; pLibName: PAnsiChar): Pointer; +var + pEnd: PByte; + pImpDir: PIMAGE_DATA_DIRECTORY; + pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; + pModule: PAnsiChar absolute hModule; +begin + pImpDesc := FindImageDirectory(hModule, IMAGE_DIRECTORY_ENTRY_DELAY_IMPORT, pImpDir); + if pImpDesc = nil then Exit(nil); + + pEnd := PByte(pImpDesc) + pImpDir^.Size; + + while (PByte(pImpDesc) < pEnd) and (pImpDesc^.DllNameRVA > 0) do + begin + if StrIComp(@pModule[pImpDesc^.DllNameRVA], pLibName) = 0 then + Exit(pImpDesc); + + Inc(pImpDesc); + end; + Result := nil; +end; + +function FindDelayImportFunction(hModule: THandle; + pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; pFuncName: PAnsiChar): PPointer; +var + pImpName: PIMAGE_IMPORT_BY_NAME; + pImgThunkName: PIMAGE_THUNK_DATA; + pImgThunkAddr: PIMAGE_THUNK_DATA; + pModule: PAnsiChar absolute hModule; +begin + pImgThunkName:= @pModule[pImpDesc^.ImportNameTableRVA]; + pImgThunkAddr:= @pModule[pImpDesc^.ImportAddressTableRVA]; + + while (pImgThunkName^.u1.Ordinal <> 0) do + begin + if not (IMAGE_SNAP_BY_ORDINAL(pImgThunkName^.u1.Ordinal)) then + begin + pImpName:= @pModule[pImgThunkName^.u1.AddressOfData]; + if (StrIComp(pImpName^.Name, pFuncName) = 0) then + Exit(PPointer(@pImgThunkAddr^.u1._Function)); + end; + Inc(pImgThunkName); + Inc(pImgThunkAddr); + end; + Result:= nil; +end; + +procedure ReplaceDelayImportFunction(hModule: THandle; + pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; pFuncName: PAnsiChar; + pNewFunction: Pointer); +var + pOldFunction: PPointer; +begin + pOldFunction:= FindDelayImportFunction(hModule, pImpDesc, pFuncName); + if Assigned(pOldFunction) then ReplaceImportFunction(pOldFunction, pNewFunction); +end; + +end. + diff --git a/peazip-sources/dev/metadarkstyle/src/umetadarkstyle.pas b/peazip-sources/dev/metadarkstyle/src/umetadarkstyle.pas new file mode 100644 index 00000000..ded2f389 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/umetadarkstyle.pas @@ -0,0 +1,41 @@ +{ +@author(Andrey Zubarev ) +} + +unit uMetaDarkStyle; + +interface + +{$IFDEF WINDOWS} +uses + {IF DEFINED(LCLQT5)} + uDarkStyle, + {ENDIF} + uDarkStyleParams, + {$IFDEF LCLWIN32} + uWin32WidgetSetDark, + {$ENDIF} + uDarkStyleSchemesLoader; +{$ENDIF} + +{$IFDEF WINDOWS} +procedure ApplyMetaDarkStyle(const CS:TDSColors); +{$ENDIF} +procedure MetaDarkFormChanged(Form: TObject); + +implementation + +{$IFDEF WINDOWS} +procedure ApplyMetaDarkStyle(const CS:TDSColors); +begin + InitDarkMode; + Initialize(CS); + ApplyDarkStyle; +end; +{$ENDIF} + +procedure MetaDarkFormChanged(Form: TObject); +begin + {$IFDEF LCLWIN32}DarkFormChanged(Form);{$ENDIF} +end; +end. diff --git a/peazip-sources/dev/metadarkstyle/src/uwin32widgetsetdark.pas b/peazip-sources/dev/metadarkstyle/src/uwin32widgetsetdark.pas new file mode 100644 index 00000000..9036f542 --- /dev/null +++ b/peazip-sources/dev/metadarkstyle/src/uwin32widgetsetdark.pas @@ -0,0 +1,2419 @@ +{ + Double Commander + ------------------------------------------------------------------------- + Windows dark style widgetset implementation + + Copyright (C) 2021-2023 Alexander Koblov (alexx2000@mail.ru) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this program. If not, see . +} + +unit uWin32WidgetSetDark; + +{$mode objfpc}{$H+} +{$modeswitch advancedrecords} + +interface + +uses + Controls, + LCLVersion, uDarkStyleParams, uDarkStyleSchemes; + +procedure ApplyDarkStyle; +procedure DarkFormChanged(Form: TObject); +procedure Initialize(const CS:TDSColors); +procedure SetColorsScheme(Scheme:TDSColors); +procedure TryEnforceDarkStyleForCtrl(AWinControl: TWinControl); + +implementation + +uses + Classes, SysUtils, Win32Int, WSLCLClasses, Forms, Windows, Win32Proc, Menus, + LCLType, Win32WSComCtrls, ComCtrls, LMessages, Win32WSStdCtrls, + WSStdCtrls, Win32WSControls, StdCtrls, WSControls, Graphics, Themes, LazUTF8, + UxTheme, Win32Themes, ExtCtrls, WSMenus, JwaWinGDI, FPImage, Math, uDarkStyle, + WSComCtrls, CommCtrl, uImport, WSForms, Win32WSButtons, Buttons, Win32Extra, + Win32WSForms, Win32WSSpin, Spin, Win32WSMenus, Dialogs, GraphUtil, + Generics.Collections, TmSchema, InterfaceBase; + +type + TWinControlDark = class(TWinControl); + TCustomGroupBoxDark = class(TCustomGroupBox); + +type + + { TWin32WSWinControlDark } + + TWin32WSWinControlDark = class(TWin32WSWinControl) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; override; + end; + + { TWin32WSStatusBarDark } + + TWin32WSStatusBarDark = class(TWin32WSStatusBar) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; override; + end; + + { TWin32WSCustomComboBoxDark } + + TWin32WSCustomComboBoxDark = class(TWin32WSCustomComboBox) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; override; + class function GetDefaultColor(const AControl: TControl; + const ADefaultColorType: TDefaultColorType): TColor; override; + end; + + { TWin32WSCustomMemoDark } + + TWin32WSCustomMemoDark = class(TWin32WSCustomMemo) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; override; + end; + + { TWin32WSCustomListBoxDark } + + TWin32WSCustomListBoxDark = class(TWin32WSCustomListBox) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; override; + end; + + { TWin32WSCustomListViewDark } + + TWin32WSCustomListViewDark = class(TWin32WSCustomListView) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; override; + end; + + { TWin32WSScrollBoxDark } + + TWin32WSScrollBoxDark = class(TWin32WSScrollBox) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; override; + end; + + { TWin32WSCustomFormDark } + + TWin32WSCustomFormDark = class(TWin32WSCustomForm) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; override; + end; + + { TWin32WSTrackBarDark } + + TWin32WSTrackBarDark = class(TWin32WSTrackBar) + published + class function CreateHandle(const AWinControl: TWinControl; + const AParams: TCreateParams): HWND; override; + class procedure DefaultWndHandler(const AWinControl: TWinControl; + var AMessage); override; + end; + + { TWin32WSPopupMenuDark } + + TWin32WSPopupMenuDark = class(TWin32WSPopupMenu) + published + class procedure Popup(const APopupMenu: TPopupMenu; const X, Y: integer); override; + end; + +const + ID_SUB_SCROLLBOX = 1; + ID_SUB_LISTBOX = 2; + ID_SUB_COMBOBOX = 3; + ID_SUB_STATUSBAR = 4; + ID_SUB_TRACKBAR = 5; + ID_SUB_LISTVIEW = 6; + +const + themelib = 'uxtheme.dll'; + +const + VSCLASS_DARK_EDIT = 'DarkMode_CFD::Edit'; + VSCLASS_DARK_TAB = 'BrowserTab::Tab'; + VSCLASS_DARK_BUTTON = 'DarkMode_Explorer::Button'; + VSCLASS_DARK_COMBOBOX = 'DarkMode_CFD::Combobox'; + VSCLASS_DARK_SCROLLBAR = 'DarkMode_Explorer::ScrollBar'; + VSCLASS_DARK_HEADER = 'Header'; + VSCLASS_PROGRESS_INDER = 'Indeterminate::Progress'; + +const + MDL_MENU_SUBMENU = #$EE#$A5#$B0; // $E970 + + MDL_RADIO_FILLED = #$EE#$A8#$BB; // $EA3B + MDL_RADIO_CHECKED = #$EE#$A4#$95; // $E915 + MDL_RADIO_OUTLINE = #$EE#$A8#$BA; // $EA3A + + MDL_CHECKBOX_FILLED = #$EE#$9C#$BB; // $E73B + MDL_CHECKBOX_CHECKED = #$EE#$9C#$BE; // $E73E + MDL_CHECKBOX_GRAYED = #$EE#$9C#$BC; // $E73C + MDL_CHECKBOX_OUTLINE = #$EE#$9C#$B9; // $E739 + + MDL_SCROLLBOX_BTNLEFT = #$EE#$B7#$99; // $E00E + MDL_SCROLLBOX_BTNRIGHT = #$EE#$B7#$9A; // $E00F + MDL_SCROLLBOX_BTNUP = #$EE#$B7#$9B; // $E010 + MDL_SCROLLBOX_BTNDOWN = #$EE#$B7#$9C; // $E011 + + MDL_COMBOBOX_BTNDOWN = #$EE#$A5#$B2; // $E972 + +type + TThemeClassMap = specialize TDictionary; + +var + Theme: TThemeData; + ThemeClass: TThemeClassMap = nil; + OldUpDownWndProc: Windows.WNDPROC; + CustomFormWndProc: Windows.WNDPROC; + SysColor: TSysColors; + SysColorBrush: array[0..COLOR_ENDCOLORS] of HBRUSH; + DrawControl: TDrawControl; + DefSubclassProc: function(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; + SetWindowSubclass: function(hWnd: HWND; pfnSubclass: SUBCLASSPROC; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): BOOL; stdcall; + +var + TrampolineOpenThemeData: function(hwnd: HWND; pszClassList: LPCWSTR): HTHEME; stdcall = nil; + TrampolineDrawThemeText: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; pszText: LPCWSTR; iCharCount: Integer; + dwTextFlags, dwTextFlags2: DWORD; const pRect: TRect): HRESULT; stdcall = nil; + TrampolineDrawThemeBackground: function(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: Pointer): HRESULT; stdcall = nil; + +procedure EnableDarkStyle(Window: HWND); +begin + AllowDarkModeForWindow(Window, True); + SetWindowTheme(Window, 'DarkMode_Explorer', nil); + SendMessageW(Window, WM_THEMECHANGED, 0, 0); +end; + +procedure TryEnforceDarkStyleForCtrl(AWinControl:TWinControl); +begin + if (AWinControl <> nil) then begin + if (AWinControl Is TCustomMemo) then + (AWinControl As TCustomMemo).BorderStyle := bsNone; + AWinControl.Color := clWindow; + EnableDarkStyle(AWinControl.Handle); + end; +end; + +procedure AllowDarkStyle(var Window: HWND); +begin + if (Window <> 0) then + begin + AllowDarkModeForWindow(Window, True); + Window:= 0; + end; +end; + +function HSVToColor(H, S, V: Double): TColor; +var + R, G, B: Integer; +begin + HSVtoRGB(H, S, V, R, G, B); + R := Min(MAXBYTE, R); + G := Min(MAXBYTE, G); + B := Min(MAXBYTE, B); + Result:= RGBToColor(R, G, B); +end; + +function Darker(Color: TColor; Factor: Integer): TColor; forward; + +function Lighter(Color: TColor; Factor: Integer): TColor; +var + H, S, V: Double; +begin + // Invalid factor + if (Factor <= 0) then + Exit(Color); + // Makes color darker + if (Factor < 100) then begin + Exit(darker(Color, 10000 div Factor)); + end; + + ColorToHSV(Color, H, S, V); + + V:= (Factor * V) / 100; + if (V > High(Word)) then + begin + // Overflow, adjust saturation + S -= V - High(Word); + if (S < 0) then + S := 0; + V:= High(Word); + end; + + Result:= HSVToColor(H, S, V); +end; + +function Darker(Color: TColor; Factor: Integer): TColor; +var + H, S, V: Double; +begin + // Invalid factor + if (Factor <= 0) then + Exit(Color); + // Makes color lighter + if (Factor < 100) then + Exit(lighter(Color, 10000 div Factor)); + + ColorToHSV(Color, H, S, V); + V := (V * 100) / Factor; + + Result:= HSVToColor(H, S, V); +end; + +{ + Fill rectangle gradient +} +function FillGradient(hDC: HDC; Start, Finish: TColor; ARect: TRect; dwMode: ULONG): Boolean; +var + cc: TFPColor; + gRect: GRADIENT_RECT; + vert: array[0..1] of TRIVERTEX; +begin + cc:= TColorToFPColor(Start); + + vert[0].x := ARect.Left; + vert[0].y := ARect.Top; + vert[0].Red := cc.red; + vert[0].Green := cc.green; + vert[0].Blue := cc.blue; + vert[0].Alpha := cc.alpha; + + cc:= TColorToFPColor(ColorToRGB(Finish)); + + vert[1].x := ARect.Right; + vert[1].y := ARect.Bottom; + vert[1].Red := cc.red; + vert[1].Green := cc.green; + vert[1].Blue := cc.blue; + vert[1].Alpha := cc.alpha; + + gRect.UpperLeft := 0; + gRect.LowerRight := 1; + Result:= JwaWinGDI.GradientFill(hDC, vert, 2, @gRect, 1, dwMode); +end; + +function GetNonClientMenuBorderRect(Window: HWND): TRect; +var + R, W: TRect; +begin + GetClientRect(Window, @R); + // Map to screen coordinate space + MapWindowPoints(Window, 0, @R, 2); + GetWindowRect(Window, @W); + OffsetRect(R, -W.Left, -W.Top); + Result:= Classes.Rect(R.Left, R.Top - 1, R.Right, R.Top); +end; + +{ + Set menu background color +} +procedure SetMenuBackground(Menu: HMENU); +var + MenuInfo: TMenuInfo; +begin + MenuInfo:= Default(TMenuInfo); + MenuInfo.cbSize:= SizeOf(MenuInfo); + MenuInfo.fMask:= MIM_BACKGROUND or MIM_APPLYTOSUBMENUS; + MenuInfo.hbrBack:= CreateSolidBrush(SysColor[COLOR_MENU]{RGBToColor(45, 45, 45)}); + SetMenuInfo(Menu, @MenuInfo); +end; + +{ + Set control colors +} +procedure SetControlColors(Control: TControl; Canvas: HDC); +var + Color: TColor; +begin + if not (csDesigning in Control.ComponentState) then begin + + // Set background color + Color:= Control.Color; + if Color = clDefault then + begin + Color:= Control.GetDefaultColor(dctBrush); + end; + SetBkColor(Canvas, ColorToRGB(Color)); + + // Set text color + Color:= Control.Font.Color; + if Color = clDefault then + begin + Color:= Control.GetDefaultColor(dctFont); + end; + SetTextColor(Canvas, ColorToRGB(Color)); + + end; +end; + +{ TWin32WSUpDownControlDark } + +procedure DrawUpDownArrow(Window: HWND; Canvas: TCanvas; ARect: TRect; AType: TUDAlignButton); +var + j: integer; + ax, ay, ah, aw: integer; + + procedure Calculate(var a, b: Integer); + var + tmp: Double; + begin + tmp:= Double(a + 1) / 2; + if (tmp > b) then + begin + a:= 2 * b - 1; + b:= (a + 1) div 2; + end + else begin + b:= Round(tmp); + a:= 2 * b - 1; + end; + b:= Max(b, 3); + a:= Max(a, 5); + end; + +begin + aw:= ARect.Width div 2; + ah:= ARect.Height div 2; + + if IsWindowEnabled(Window) then + Canvas.Pen.Color:= clBtnText + else begin + Canvas.Pen.Color:= clGrayText; + end; + if (AType in [udLeft, udRight]) then + Calculate(ah, aw) + else begin + Calculate(aw, ah); + end; + ax:= ARect.Left + (ARect.Width - aw) div 2; + ay:= ARect.Top + (ARect.Height - ah) div 2; + + case AType of + udLeft: + begin + for j:= 0 to ah div 2 do + begin + Canvas.MoveTo(ax + aw - j - 2, ay + j); + Canvas.LineTo(ax + aw - j - 2, ay + ah - j - 1); + end; + end; + udRight: + begin + for j:= 0 to ah div 2 do + begin + Canvas.MoveTo(ax + j, ay + j); + Canvas.LineTo(ax + j, ay + ah - j - 1); + end; + end; + udTop: + begin + for j:= 0 to aw div 2 do + begin + Canvas.MoveTo(ax + j, ay + ah - j - 1); + Canvas.LineTo(ax + aw - j, ay + ah - j - 1); + end; + end; + udBottom: + begin + for j:= 0 to aw div 2 do + begin + Canvas.MoveTo(ax + j, ay + j); + Canvas.LineTo(ax + aw - j, ay + j); + end; + end; + end; +end; + +function UpDownWndProc(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM): LRESULT; stdcall; +var + DC: HDC; + L, R: TRect; + rcDst: TRect; + ARect: TRect; + PS: PAINTSTRUCT; + LCanvas : TCanvas; + LButton, RButton: TUDAlignButton; +begin + case Msg of + WM_PAINT: + begin + DC := BeginPaint(Window, @ps); + LCanvas := TCanvas.Create; + try + LCanvas.Handle:= DC; + + GetClientRect(Window, @ARect); + + LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; + LCanvas.FillRect(ps.rcPaint); + + L:= ARect; + R:= ARect; + + if (GetWindowLongPtr(Window, GWL_STYLE) and UDS_HORZ <> 0) then + begin + LButton:= udLeft; + RButton:= udRight; + R.Left:= R.Width div 2; + L.Right:= L.Right - L.Width div 2; + end + else begin + LButton:= udTop; + RButton:= udBottom; + R.Top:= R.Height div 2; + L.Bottom:= L.Bottom - L.Height div 2; + end; + + if (IntersectRect(rcDst, L, PS.rcPaint)) then + begin + LCanvas.Pen.Color:= SysColor[COLOR_BTNSHADOW];//RGBToColor(38, 38, 38); + LCanvas.RoundRect(L, 4, 4); + InflateRect(L, -1, -1); + LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT];//RGBToColor(92, 92, 92); + LCanvas.RoundRect(L, 4, 4); + DrawUpDownArrow(Window, LCanvas, L, LButton); + end; + + if (IntersectRect(rcDst, R, PS.rcPaint)) then + begin + LCanvas.Pen.Color:= SysColor[COLOR_BTNSHADOW];//RGBToColor(38, 38, 38); + LCanvas.RoundRect(R, 4, 4); + InflateRect(R, -1, -1); + LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT];//RGBToColor(92, 92, 92); + LCanvas.RoundRect(R, 4, 4); + DrawUpDownArrow(Window, LCanvas, R, RButton); + end; + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; + EndPaint(Window, @ps); + Result:= 0; + end; + WM_ERASEBKGND: + begin + Exit(1); + end; + else begin + Result:= CallWindowProc(OldUpDownWndProc, Window, Msg, WParam, LParam); + end; + end; +end; + +{ TWin32WSTrackBarDark } + +function TrackBarWindowProc(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM; uISubClass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; +begin + if Msg = WM_ERASEBKGND then + Result := 1 + else + Result := DefSubclassProc(Window, Msg, WParam, LParam); +end; + +class function TWin32WSTrackBarDark.CreateHandle( + const AWinControl: TWinControl; const AParams: TCreateParams): HWND; +begin + AWinControl.Color:= SysColor[COLOR_BTNFACE]; + Result:= inherited CreateHandle(AWinControl, AParams); + SetWindowSubclass(Result, @TrackBarWindowProc, ID_SUB_TRACKBAR, 0); +end; + +class procedure TWin32WSTrackBarDark.DefaultWndHandler( + const AWinControl: TWinControl; var AMessage); +var + NMHdr: PNMHDR; + NMCustomDraw: PNMCustomDraw; +begin + with TLMessage(AMessage) do + case Msg of + CN_NOTIFY: + begin + NMHdr := PNMHDR(LParam); + if NMHdr^.code = NM_CUSTOMDRAW then + begin + NMCustomDraw:= PNMCustomDraw(LParam); + case NMCustomDraw^.dwDrawStage of + CDDS_PREPAINT: + begin + Result := CDRF_NOTIFYITEMDRAW; + end; + CDDS_ITEMPREPAINT: + begin + case NMCustomDraw^.dwItemSpec of + TBCD_CHANNEL: + begin + Result:= CDRF_SKIPDEFAULT; + SelectObject(NMCustomDraw^.hdc, GetStockObject(DC_PEN)); + SetDCPenColor(NMCustomDraw^.hdc, SysColor[COLOR_BTNSHADOW]); + SelectObject(NMCustomDraw^.hdc, GetStockObject(DC_BRUSH)); + SetDCBrushColor(NMCustomDraw^.hdc, SysColor[COLOR_BTNFACE]); + with NMCustomDraw^.rc do + RoundRect(NMCustomDraw^.hdc, Left, Top, Right, Bottom, 6, 6); + end; + else begin + Result:= CDRF_DODEFAULT; + end; + end; + end; + end; + end; + end + else + inherited DefaultWndHandler(AWinControl, AMessage); + end; +end; + +{ TWin32WSScrollBoxDark } + +function ScrollBoxWindowProc(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM; uISubClass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; +var + DC: HDC; + R, W: TRect; + Delta: Integer; +begin + Result:= DefSubclassProc(Window, Msg, WParam, LParam); + + if Msg = WM_NCPAINT then + begin + GetClientRect(Window, @R); + MapWindowPoints(Window, 0, @R, 2); + GetWindowRect(Window, @W); + Delta:= Abs(W.Top - R.Top); + + DC:= GetWindowDC(Window); + ExcludeClipRect(DC, Delta, Delta, W.Width - Delta, W.Height - Delta); + SelectObject(DC, GetStockObject(DC_PEN)); + SelectObject(DC, GetStockObject(DC_BRUSH)); + SetDCPenColor(DC, SysColor[COLOR_BTNSHADOW]); + SetDCBrushColor(DC, SysColor[COLOR_BTNHIGHLIGHT]); + Rectangle(DC, 0, 0, W.Width, W.Height); + ReleaseDC(Window, DC); + end; +end; + +class function TWin32WSScrollBoxDark.CreateHandle( + const AWinControl: TWinControl; const AParams: TCreateParams): HWND; +begin + Result:= inherited CreateHandle(AWinControl, AParams); + if not (csDesigning in AWinControl.ComponentState) then begin + if TScrollBox(AWinControl).BorderStyle = bsSingle then begin + SetWindowSubclass(Result, @ScrollBoxWindowProc, ID_SUB_SCROLLBOX, 0); + end; + EnableDarkStyle(Result); + end; +end; + +{ TWin32WSPopupMenuDark } + +class procedure TWin32WSPopupMenuDark.Popup(const APopupMenu: TPopupMenu; + const X, Y: integer); +begin + SetMenuBackground(APopupMenu.Handle); + + inherited Popup(APopupMenu, X, Y); +end; + +{ TWin32WSWinControlDark } + +class function TWin32WSWinControlDark.CreateHandle( + const AWinControl: TWinControl; const AParams: TCreateParams): HWND; +var + P: TCreateParams; +begin + P:= AParams; + if not (csDesigning in AWinControl.ComponentState) then begin + if (AWinControl is TCustomTreeView) then + begin + AWinControl.Color:= SysColor[COLOR_WINDOW]; + with TCustomTreeView(AWinControl) do begin + if DrawControl.TreeViewExpandSignOverride then + ExpandSignType:=DrawControl.TreeViewExpandSignValue; + TreeLineColor:= SysColor[COLOR_GRAYTEXT]; + ExpandSignColor:= SysColor[COLOR_GRAYTEXT]; + end; + end; + P.ExStyle:= p.ExStyle and not WS_EX_CLIENTEDGE; + TWinControlDark(AWinControl).BorderStyle:= bsNone; + end; + + Result:= inherited CreateHandle(AWinControl, P); + + if not (csDesigning in AWinControl.ComponentState) then begin + EnableDarkStyle(Result); + end; +end; + +{ TWin32WSCustomFormDark } + +function FormWndProc2(Window: HWnd; Msg: UInt; WParam: Windows.WParam; + LParam: Windows.LParam): LResult; stdcall; +var + DC: HDC; + R: TRect; +begin + case Msg of + WM_NCACTIVATE, + WM_NCPAINT: + begin + Result:= CallWindowProc(CustomFormWndProc, Window, Msg, wParam, lParam); + + DC:= GetWindowDC(Window); + R:= GetNonclientMenuBorderRect(Window); + FillRect(DC, R, GetSysColorBrush(COLOR_WINDOW)); + ReleaseDC(Window, DC); + end; + WM_SHOWWINDOW: + begin + AllowDarkModeForWindow(Window, True); + RefreshTitleBarThemeColor(Window); + end + else begin + Result:= CallWindowProc(CustomFormWndProc, Window, Msg, wParam, lParam); + end; + end; +end; + +class function TWin32WSCustomFormDark.CreateHandle( + const AWinControl: TWinControl; const AParams: TCreateParams): HWND; +var + Info: PWin32WindowInfo; +begin + if not (csDesigning in AWinControl.ComponentState) then begin + AWinControl.DoubleBuffered:= True; + AWinControl.Color:= SysColor[COLOR_BTNFACE]; + AWinControl.Brush.Color:= SysColor[COLOR_BTNFACE]; + end; + + Result:= inherited CreateHandle(AWinControl, AParams); + + Info:= GetWin32WindowInfo(Result); + + Info^.DefWndProc:= @WindowProc; + + CustomFormWndProc:= Windows.WNDPROC(SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@FormWndProc2))); + + if not (csDesigning in AWinControl.ComponentState) then begin + AWinControl.Color:= SysColor[COLOR_BTNFACE]; + AWinControl.Font.Color:= SysColor[COLOR_BTNTEXT]; + end; +end; + +{ TWin32WSCustomListBoxDark } + +function ListBoxWindowProc2(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM; uISubClass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; +var + PS: TPaintStruct; +begin + if Msg = WM_PAINT then + begin + if SendMessage(Window, LB_GETCOUNT, 0, 0) = 0 then + begin + BeginPaint(Window, @ps); + // ListBox:= TCustomListBox(GetWin32WindowInfo(Window)^.WinControl); + // Windows.FillRect(DC, ps.rcPaint, ListBox.Brush.Reference.Handle); + EndPaint(Window, @ps); + end; + end; + Result:= DefSubclassProc(Window, Msg, WParam, LParam); +end; + +class function TWin32WSCustomListBoxDark.CreateHandle( + const AWinControl: TWinControl; const AParams: TCreateParams): HWND; +var + P: TCreateParams; +begin + P:= AParams; + if not (csDesigning in AWinControl.ComponentState) then begin + P.ExStyle:= P.ExStyle and not WS_EX_CLIENTEDGE; + TCustomListBox(AWinControl).BorderStyle:= bsNone; + end; + + Result:= inherited CreateHandle(AWinControl, P); + + if not (csDesigning in AWinControl.ComponentState) then begin + EnableDarkStyle(Result); + SetWindowSubclass(Result, @ListBoxWindowProc2, ID_SUB_LISTBOX, 0); + TCustomListBox(AWinControl).Color:= SysColor[COLOR_WINDOW]; + AWinControl.Font.Color:= SysColor[COLOR_WINDOWTEXT]; + end; +end; + +{ TWin32WSCustomListViewDark } + +function ListViewWindowProc(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM; uISubClass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; +var NMHdr: PNMHDR; NMCustomDraw: PNMCustomDraw; +begin + If Msg = WM_NOTIFY then begin + NMHdr := PNMHDR(LParam); + if NMHdr^.code = NM_CUSTOMDRAW then begin + NMCustomDraw:= PNMCustomDraw(LParam); + case NMCustomDraw^.dwDrawStage of + CDDS_PREPAINT: + begin + Result := CDRF_NOTIFYITEMDRAW; + exit; + end; + CDDS_ITEMPREPAINT: + begin + SetTextColor(NMCustomDraw^.hdc , SysColor[COLOR_HIGHLIGHTTEXT]); + Result := CDRF_NEWFONT; + exit; + end; + end; + end; + end; + Result := DefSubclassProc(Window, Msg, WParam, LParam); +end; + +class function TWin32WSCustomListViewDark.CreateHandle( + const AWinControl: TWinControl; const AParams: TCreateParams): HWND; +var + P: TCreateParams; +begin + P:= AParams; + P.ExStyle:= P.ExStyle and not WS_EX_CLIENTEDGE; + TCustomListView(AWinControl).BorderStyle:= bsNone; + Result:= inherited CreateHandle(AWinControl, P); + SetWindowSubclass(Result, @ListViewWindowProc, ID_SUB_LISTVIEW, 0); + if not (csDesigning in AWinControl.ComponentState) then begin + EnableDarkStyle(Result); + end; +end; + +{ TWin32WSCustomMemoDark } + +class function TWin32WSCustomMemoDark.CreateHandle( + const AWinControl: TWinControl; const AParams: TCreateParams): HWND; +var + P: TCreateParams; +begin + P:= AParams; + + if not (csDesigning in AWinControl.ComponentState) then begin + TCustomEdit(AWinControl).BorderStyle:= bsNone; + P.ExStyle:= P.ExStyle and not WS_EX_CLIENTEDGE; + AWinControl.Color:= SysColor[COLOR_WINDOW]; + AWinControl.Font.Color:= SysColor[COLOR_WINDOWTEXT]; + end; + + Result:= inherited CreateHandle(AWinControl, P); + + if not (csDesigning in AWinControl.ComponentState) then begin + EnableDarkStyle(Result); + end; +end; + +{ TWin32WSCustomComboBoxDark } + +function ComboBoxWindowProc(Window:HWND; Msg:UINT; wParam:Windows.WPARAM;lparam:Windows.LPARAM;uISubClass : UINT_PTR;dwRefData:DWORD_PTR):LRESULT; stdcall; +var + DC: HDC; + ComboBox: TCustomComboBox; +begin + case Msg of + WM_CTLCOLORLISTBOX: + begin + ComboBox:= TCustomComboBox(GetWin32WindowInfo(Window)^.WinControl); + DC:= HDC(wParam); + SetControlColors(ComboBox, DC); + Exit(LResult(ComboBox.Brush.Reference.Handle)); + end; + end; + Result:= DefSubclassProc(Window, Msg, wParam, lParam); +end; + +class function TWin32WSCustomComboBoxDark.CreateHandle( + const AWinControl: TWinControl; const AParams: TCreateParams): HWND; +var + Info: TComboboxInfo; +begin + if not (csDesigning in AWinControl.ComponentState) then begin + AWinControl.Color:= SysColor[COLOR_BTNFACE]; + AWinControl.Font.Color:= SysColor[COLOR_BTNTEXT]; + end; + + Result:= inherited CreateHandle(AWinControl, AParams); + + if not (csDesigning in AWinControl.ComponentState) then begin + Info.cbSize:= SizeOf(Info); + Win32Extra.GetComboBoxInfo(Result, @Info); + + EnableDarkStyle(Info.hwndList); + + AllowDarkModeForWindow(Result, True); + + SetWindowSubclass(Result, @ComboBoxWindowProc, ID_SUB_COMBOBOX, 0); + end; +end; + +class function TWin32WSCustomComboBoxDark.GetDefaultColor( + const AControl: TControl; const ADefaultColorType: TDefaultColorType): TColor; +const + DefColors: array[TDefaultColorType] of TColor = ( + { dctBrush } clBtnFace, + { dctFont } clBtnText + ); +begin + Result:= DefColors[ADefaultColorType]; +end; + +{ TWin32WSStatusBarDark } + +function StatusBarWndProc(Window: HWND; Msg: UINT; wParam: Windows.WPARAM; lParam: Windows.LPARAM; uISubClass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall; +var + DC: HDC; + X: Integer; + Index: Integer; + PS: TPaintStruct; + LCanvas: TCanvas; + APanel: TStatusPanel; + StatusBar: TStatusBar; + Info: PWin32WindowInfo; + Detail:TThemedElementDetails; + Rect:trect; + gripSize: TSize; +begin + Info:= GetWin32WindowInfo(Window); + if (Info = nil) or (Info^.WinControl = nil) then + begin + Result:= CallDefaultWindowProc(Window, Msg, WParam, LParam); + Exit; + end; + + if Msg = WM_ERASEBKGND then + begin + StatusBar:= TStatusBar(Info^.WinControl); + TWin32WSStatusBar.DoUpdate(StatusBar); + Result:= 0; + Exit; + end; + + if Msg = WM_PAINT then + begin + StatusBar:= TStatusBar(Info^.WinControl); + + TWin32WSStatusBar.DoUpdate(StatusBar); + + DC:= BeginPaint(Window, @ps); + + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= DC; + LCanvas.Brush.Color:= SysColor[COLOR_MENUBAR]; + LCanvas.FillRect(ps.rcPaint); + + X:= 1; + LCanvas.Font.Color:= SysColor[COLOR_BTNTEXT]; + LCanvas.Pen.Color:= SysColor[COLOR_GRAYTEXT]; + if StatusBar.SimplePanel then + LCanvas.TextOut(X+3, (StatusBar.Height - LCanvas.TextHeight('Ag')) div 2, StatusBar.SimpleText) + else + for Index:= 0 to StatusBar.Panels.Count - 1 do + begin + APanel:= StatusBar.Panels[Index]; + if APanel.Width>0 then begin + LCanvas.TextOut(X+1, (StatusBar.Height - LCanvas.TextHeight('Ag')) div 2, APanel.Text); + if Index<>(StatusBar.Panels.Count - 1)then begin + X+= APanel.Width; + LCanvas.Line(x-2, ps.rcPaint.Top+3, x-2, ps.rcPaint.Bottom-3); + end; + end; + end; + if StatusBar.SizeGrip then begin + Rect:=StatusBar.ClientRect; + Detail:=ThemeServices.GetElementDetails(tsGripper); + GetThemePartSize(TWin32ThemeServices(ThemeServices).Theme[teStatus], + LCanvas.Handle, SP_GRIPPER, 0, @Rect, TS_DRAW, gripSize); + Rect.Left:=Rect.Right-gripSize.cx; + Rect.Top:=Rect.Bottom-gripSize.cy; + ThemeServices.DrawElement(LCanvas.Handle,Detail,Rect); + end; + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; + EndPaint(Window, @ps); + Result:= 0; + end + else + Result:= DefSubclassProc(Window, Msg, WParam, LParam); +end; + +class function TWin32WSStatusBarDark.CreateHandle( + const AWinControl: TWinControl; const AParams: TCreateParams): HWND; +begin + Result:= inherited CreateHandle(AWinControl, AParams); + SetWindowSubclass(Result, @StatusBarWndProc, ID_SUB_STATUSBAR, 0); +end; + +{ + Forward declared functions +} +function InterceptOpenThemeData(hwnd: hwnd; pszClassList: LPCWSTR): hTheme; stdcall; forward; +procedure DrawButton(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: PRECT); forward; +procedure DrawEdit(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: PRECT); forward; +procedure DrawReBar(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: PRECT); forward; +procedure DrawTreeView(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: PRECT); forward; + + +{ + Draws text using the color and font defined by the visual style +} +function DrawThemeTextDark(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; pszText: LPCWSTR; iCharCount: Integer; + dwTextFlags, dwTextFlags2: DWORD; const pRect: TRect): HRESULT; stdcall; +function needMenuGrayText(iPartId, iStateId: Integer):Boolean; +begin + case iPartId of + MENU_POPUPITEM:Result:=(iStateId = MDS_PRESSED)or(iStateId = MDS_DISABLED); + else + Result:=(iStateId in [MBI_DISABLED,MBI_DISABLEDHOT,MBI_DISABLEDPUSHED])and(iPartId<>MENU_BARITEM); + end; +end; +var + OldColor: COLORREF; + Index, Element: TThemedElement; +begin + OldColor:= GetTextColor(hdc); + for Index:= Low(TThemedElement) to High(TThemedElement) do + begin + if Theme[Index] = hTheme then + begin + Element:= Index; + + if Element = teToolTip then + OldColor:= SysColor[COLOR_INFOTEXT] + else if Element = teMenu then begin + if needMenuGrayText(iPartId, iStateId) then + OldColor:= SysColor[COLOR_GRAYTEXT] + else + OldColor:= SysColor[COLOR_BTNTEXT] + end else + OldColor:= SysColor[COLOR_BTNTEXT]; + + Break; + end; + end; + + OldColor:= SetTextColor(hdc, OldColor); + SetBkMode(hdc, TRANSPARENT); + + DrawTextExW(hdc, pszText, iCharCount, @pRect, dwTextFlags, nil); + + SetTextColor(hdc, OldColor); + + Result:= S_OK; +end; + +{ + Draws the border and fill defined by the visual style for the specified control part +} +function DrawThemeBackgroundDark(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT): HRESULT; stdcall; +function needMenuHiglightBkg(iPartId, iStateId: Integer):Boolean; +begin + case iPartId of + MENU_POPUPITEM:Result:=iStateId = MDS_HOT; + else + Result:=(((iStateId = MDS_HOT)or(iStateId = MDS_PRESSED))and(iPartId<>MENU_BARBACKGROUND))or((iPartId=MENU_BARITEM)and(iStateId = MDS_CHECKED)); + end; +end; + +var + LRect: TRect; + AColor: TColor; + LCanvas: TCanvas; + AStyle: TTextStyle; + Index, Element: TThemedElement; +begin + for Index:= Low(TThemedElement) to High(TThemedElement) do + begin + if Theme[Index] = hTheme then + begin + Element:= Index; + if Element = teScrollBar then begin + Element:= Index; + end else if Element = teHeader then begin + if iPartId in [HP_HEADERITEM, HP_HEADERITEMRIGHT] then + begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= hdc; + AColor:= SysColor[COLOR_BTNFACE]; + + if iStateId in [HIS_HOT, HIS_SORTEDHOT, HIS_ICONHOT, HIS_ICONSORTEDHOT] then + FillGradient(hdc, Lighter(AColor, 174), Lighter(AColor, 166), pRect, GRADIENT_FILL_RECT_V) + else + FillGradient(hdc, Lighter(AColor, 124), Lighter(AColor, 116), pRect, GRADIENT_FILL_RECT_V); + + if (iPartId <> HP_HEADERITEMRIGHT) then + begin + LCanvas.Pen.Color:= Lighter(AColor, 104); + LCanvas.Line(pRect.Right-1, pRect.Top, pRect.Right-1, pRect.Bottom); + + LCanvas.Pen.Color:= Lighter(AColor, 158); + LCanvas.Line(pRect.Right - 2, pRect.Top, pRect.Right - 2, pRect.Bottom); + end; + // Top line + LCanvas.Pen.Color:= Lighter(AColor, 164); + LCanvas.Line(pRect.Left, pRect.Top, pRect.Right, pRect.Top); + // Bottom line + LCanvas.Pen.Color:= Darker(AColor, 140); + LCanvas.Line(pRect.Left, pRect.Bottom - 1, pRect.Right, pRect.Bottom - 1); + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; + end; + end else if Element = teListView then begin + if iPartId in [HP_HEADERITEM, HP_HEADERITEMRIGHT] then + begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= hdc; + AColor:= {RGBToColor(95, 95, 95);} SysColor[COLOR_BTNFACE]; + + if iStateId in [HIS_HOT, HIS_SORTEDHOT, HIS_ICONHOT, HIS_ICONSORTEDHOT] then + FillGradient(hdc, Lighter(AColor, 174), Lighter(AColor, 166), pRect, GRADIENT_FILL_RECT_V) + else + FillGradient(hdc, Lighter(AColor, 124), Lighter(AColor, 116), pRect, GRADIENT_FILL_RECT_V); + + if (iPartId <> HP_HEADERITEMRIGHT) then + begin + LCanvas.Pen.Color:= Lighter(AColor, 101); + LCanvas.Line(pRect.Right - 1, pRect.Top, pRect.Right - 1, pRect.Bottom); + + LCanvas.Pen.Color:= Lighter(AColor, 131); + LCanvas.Line(pRect.Right - 2, pRect.Top, pRect.Right - 2, pRect.Bottom); + end; + // Top line + LCanvas.Pen.Color:= Lighter(AColor, 131); + LCanvas.Line(pRect.Left, pRect.Top, pRect.Right, pRect.Top); + // Bottom line + LCanvas.Pen.Color:= Darker(AColor, 140); + LCanvas.Line(pRect.Left, pRect.Bottom - 1, pRect.Right, pRect.Bottom - 1); + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; + end else + if (iPartId = 0) then begin // The unpainted area of the header after the rightmost column + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= hdc; + AColor:=SysColor[COLOR_BTNFACE]; + //FillGradient(hdc, Lighter(AColor, 124), Lighter(AColor, 116), pRect, GRADIENT_FILL_RECT_V); + FillGradient(hdc, Lighter(AColor, 102), Lighter(AColor, 94), pRect, GRADIENT_FILL_RECT_V); + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; + end else + if (iPartId = HP_HEADERSORTARROW) then begin // This applies to the current sort column + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= hdc; + LCanvas.Pen.Color:=RGBToColor(202, 202, 202); + if iStateId = HSAS_SORTEDUP then begin; // iStateId transports the SortDirection + LCanvas.Line(pRect.Left+3, 4, pRect.Left+7, 0); + LCanvas.Line(pRect.Left+6, 1, pRect.Left+10, 5); + end + else if iStateId = HSAS_SORTEDDOWN then begin; + LCanvas.Line(pRect.Left+3, 1, pRect.Left+7, 5); + LCanvas.Line(pRect.Left+6, 4, pRect.Left+10, 0); + end; + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; + end; + end else if Element = teMenu then begin + if iPartId in [MENU_BARBACKGROUND, MENU_BARITEM, MENU_POPUPITEM, MENU_POPUPGUTTER, + MENU_POPUPSUBMENU, MENU_POPUPSEPARATOR, MENU_POPUPCHECK, + MENU_POPUPCHECKBACKGROUND] then begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= hdc; + + if not (iPartId in [MENU_POPUPSUBMENU, MENU_POPUPCHECK, MENU_POPUPCHECKBACKGROUND]) then + begin + if needMenuHiglightBkg(iPartId,iStateId) then + LCanvas.Brush.Color:= SysColor[COLOR_MENUHILIGHT] + else begin + LCanvas.Brush.Color:= SysColor[COLOR_MENUBAR];//RGBToColor(45, 45, 45); + end; + LCanvas.FillRect(pRect); + end; + + if iPartId = MENU_POPUPCHECK then + begin + AStyle:= LCanvas.TextStyle; + AStyle.Layout:= tlCenter; + AStyle.Alignment:= taCenter; + LCanvas.Brush.Style:= bsClear; + LCanvas.Font.Name:= 'Segoe MDL2 Assets'; + LCanvas.Font.Color:= SysColor[COLOR_MENUTEXT];//RGBToColor(212, 212, 212); + LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_CHECKBOX_CHECKED, AStyle); + end; + + if iPartId = MENU_POPUPSEPARATOR then + begin + LRect:= pRect; + LCanvas.Pen.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(112, 112, 112); + LRect.Top:= LRect.Top + (LRect.Height div 2); + LRect.Bottom:= LRect.Top; + + LCanvas.Line(LRect); + end; + + if (iPartId = MENU_POPUPCHECKBACKGROUND) then + begin + LRect:= pRect; + InflateRect(LRect, -1, -1); + LCanvas.Pen.Color:= SysColor[COLOR_MENU];//RGBToColor(45, 45, 45); + LCanvas.Brush.Color:= SysColor[COLOR_MENUHILIGHT];//RGBToColor(81, 81, 81); + LCanvas.RoundRect(LRect, 6, 6); + end; + + if iPartId = MENU_POPUPSUBMENU then + begin + LCanvas.Brush.Style:= bsClear; + LCanvas.Font.Name:= 'Segoe MDL2 Assets'; + LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(111, 111, 111); + LCanvas.TextOut(pRect.Left, pRect.Top, MDL_MENU_SUBMENU); + end; + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; + end; + end else if Element = teToolBar then begin + if iPartId in [TP_BUTTON, TP_SPLITBUTTON, TP_SPLITBUTTONDROPDOWN] then + begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= hdc; + AColor:= SysColor[COLOR_BTNFACE]; + + if iStateId = TS_HOT then + LCanvas.Brush.Color:= Lighter(AColor, 116) + else if iStateId = TS_PRESSED then + LCanvas.Brush.Color:= Darker(AColor, 116) + else begin + LCanvas.Brush.Color:= AColor; + end; + LCanvas.FillRect(pRect); + + if iStateId <> TS_NORMAL then begin + if iStateId = TS_CHECKED then begin + LRect:= pRect; + InflateRect(LRect, -2, -2); + LCanvas.Brush.Color:= Lighter(AColor, 146); + LCanvas.FillRect(LRect); + end; + + LCanvas.Pen.Color:= Darker(AColor, 140); + LCanvas.RoundRect(pRect, 6, 6); + + LRect:= pRect; + + LCanvas.Pen.Color:= Lighter(AColor, 140); + InflateRect(LRect, -1, -1); + LCanvas.RoundRect(LRect, 6, 6); + end; + + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; + end; + if iPartId = TP_SPLITBUTTONDROPDOWN then + begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= hdc; + DrawUpDownArrow(hDC, LCanvas, pRect, udBottom); + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; + end; + end else if Element = teButton then + DrawButton(hTheme, hdc, iPartId, iStateId, pRect, pClipRect) + else if Element = teEdit then + DrawEdit(hTheme,hdc,iPartId,iStateId,pRect,pClipRect) + else if Element = teRebar then + DrawRebar(hTheme,hdc,iPartId,iStateId,pRect,pClipRect) + + else if (Element = teTreeview) and DrawControl.CustomDrawTreeViews then + DrawTreeView(hTheme,hdc,iPartId,iStateId,pRect,pClipRect) + else + TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + exit(S_OK); + end; + end; + TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + Result:= S_OK; +end; + +var + __CreateWindowExW: function(dwExStyle: DWORD; lpClassName: LPCWSTR; lpWindowName: LPCWSTR; dwStyle: DWORD; X: longint; Y: longint; nWidth: longint; nHeight: longint; hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: LPVOID): HWND; stdcall; + +function _DrawEdge(hdc: HDC; var qrc: TRect; edge: UINT; grfFlags: UINT): BOOL; stdcall; +var + Original: HGDIOBJ; + ClientRect: TRect; + ColorDark, ColorLight: TColorRef; + + procedure DrawLine(X1, Y1, X2, Y2: Integer); + begin + MoveToEx(hdc, X1, Y1, nil); + LineTo(hdc, X2, Y2); + end; + + procedure InternalDrawEdge(Outer: Boolean; const R: TRect); + var + X1, Y1, X2, Y2: Integer; + ColorLeftTop, ColorRightBottom: TColor; + begin + X1:= R.Left; + Y1:= R.Top; + X2:= R.Right; + Y2:= R.Bottom; + + ColorLeftTop:= clNone; + ColorRightBottom:= clNone; + + if Outer then + begin + if Edge and BDR_RAISEDOUTER <> 0 then + begin + ColorLeftTop:= ColorLight; + ColorRightBottom:= ColorDark; + end + else if Edge and BDR_SUNKENOUTER <> 0 then + begin + ColorLeftTop:= ColorDark; + ColorRightBottom:= ColorLight; + end; + end + else + begin + if Edge and BDR_RAISEDINNER <> 0 then + begin + ColorLeftTop:= ColorLight; + ColorRightBottom:= ColorDark; + end + else if Edge and BDR_SUNKENINNER <> 0 then + begin + ColorLeftTop:= ColorDark; + ColorRightBottom:= ColorLight; + end; + end; + + SetDCPenColor(hdc, ColorLeftTop); + + if grfFlags and BF_LEFT <> 0 then + DrawLine(X1, Y1, X1, Y2); + if grfFlags and BF_TOP <> 0 then + DrawLine(X1, Y1, X2, Y1); + + SetDCPenColor(hdc, ColorRightBottom); + + if grfFlags and BF_RIGHT <> 0 then + DrawLine(X2, Y1, X2, Y2); + if grfFlags and BF_BOTTOM <> 0 then + DrawLine(X1, Y2, X2, Y2); + end; + +begin + Result:= False; + if IsRectEmpty(qrc) then + Exit; + + ClientRect:= qrc; + Dec(ClientRect.Right, 1); + Dec(ClientRect.Bottom, 1); + Original:= SelectObject(hdc, GetStockObject(DC_PEN)); + try + ColorDark:= SysColor[COLOR_BTNSHADOW]; + ColorLight:= SysColor[COLOR_BTNHIGHLIGHT]; + + if Edge and (BDR_SUNKENOUTER or BDR_RAISEDOUTER) <> 0 then + begin + InternalDrawEdge(True, ClientRect); + end; + + InflateRect(ClientRect, -1, -1); + + if Edge and (BDR_SUNKENINNER or BDR_RAISEDINNER) <> 0 then + begin + InternalDrawEdge(False, ClientRect); + InflateRect(ClientRect, -1, -1); + end; + + Inc(ClientRect.Right); + Inc(ClientRect.Bottom); + + if grfFlags and BF_ADJUST <> 0 then + begin + qrc:= ClientRect; + end; + + Result:= True; + finally + SelectObject(hdc, Original); + end; +end; + +{ + Retrieves the current color of the specified display element +} +function GetSysColorDark(nIndex: longint): DWORD; stdcall; +begin + if (nIndex >= 0) and (nIndex <= COLOR_ENDCOLORS) then + Result:= SysColor[nIndex] + else begin + Result:= 0; + end; +end; + +{ + Retrieves a handle identifying a logical brush that corresponds to the specified color index +} +function GetSysColorBrushDark(nIndex: longint): HBRUSH; stdcall; +begin + if (nIndex >= 0) and (nIndex <= COLOR_ENDCOLORS) then + begin + if (SysColorBrush[nIndex] = 0) then + begin + SysColorBrush[nIndex]:= CreateSolidBrush(SysColor[nIndex]); + end; + Result:= SysColorBrush[nIndex]; + end + else begin + Result:= CreateSolidBrush(GetSysColorDark(nIndex)); + end; +end; + +const + ClassNameW: PWideChar = 'TCustomForm'; + ClassNameTC: PWideChar = 'TTOTAL_CMD'; // for compatibility with plugins + +function _CreateWindowExW(dwExStyle: DWORD; lpClassName: LPCWSTR; lpWindowName: LPCWSTR; dwStyle: DWORD; X: longint; Y: longint; nWidth: longint; nHeight: longint; hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: LPVOID): HWND; stdcall; +var + AParams: PNCCreateParams absolute lpParam; +begin + if Assigned(AParams) and (AParams^.WinControl is TCustomForm) then + begin + if (hWndParent = 0) and AParams^.WinControl.ClassNameIs('TfrmMain') then + lpClassName:= ClassNameTC + else begin + lpClassName:= ClassNameW; + end; + end else begin + dwExStyle:= dwExStyle or WS_EX_CONTEXTHELP; + end; + Result:= __CreateWindowExW(dwExStyle, lpClassName, lpWindowName, dwStyle, X, Y, nWidth, nHeight, hWndParent, hMenu, hInstance, lpParam); +end; + +function TaskDialogIndirectDark(const pTaskConfig: PTASKDIALOGCONFIG; pnButton: PInteger; pnRadioButton: PInteger; pfVerificationFlagChecked: PBOOL): HRESULT; stdcall; +const + BTN_USER = $1000; +var + Idx: Integer; + Index: Integer; + Button: TDialogButton; + Buttons: TDialogButtons; + DlgType: Integer = idDialogInfo; +begin + with pTaskConfig^ do + begin + if (pszMainIcon = TD_INFORMATION_ICON) then + DlgType:= idDialogInfo + else if (pszMainIcon = TD_WARNING_ICON) then + DlgType:= idDialogWarning + else if (pszMainIcon = TD_ERROR_ICON) then + DlgType:= idDialogError + else if (pszMainIcon = TD_SHIELD_ICON) then + DlgType:= idDialogShield + else if (dwFlags and TDF_USE_HICON_MAIN <> 0) then + begin + if (hMainIcon = Windows.LoadIcon(0, IDI_QUESTION)) then + DlgType:= idDialogConfirm; + end; + + Buttons:= TDialogButtons.Create(TDialogButton); + try + for Index:= 0 to cButtons - 1 do + begin + Button:= Buttons.Add; + Idx:= pButtons[Index].nButtonID; + Button.ModalResult:= (Idx + BTN_USER); + Button.Default:= (Idx = nDefaultButton); + Button.Caption:= UTF8Encode(UnicodeString(pButtons[Index].pszButtonText)); + end; + + Result:= DefaultQuestionDialog(UTF8Encode(UnicodeString(pszWindowTitle)), + UTF8Encode(UnicodeString(pszContent)), DlgType, Buttons, 0); + + if Assigned(pnButton) then + begin + if (Result < BTN_USER) then + pnButton^:= Result + else begin + pnButton^:= Result - BTN_USER; + end; + end; + finally + Buttons.Free; + end; + end; + Result:= S_OK; +end; + +procedure SubClassUpDown; +var + Window: HWND; +begin + Window:= CreateWindowW(UPDOWN_CLASSW, nil, 0, 0, 0, 200, 20, 0, 0, HINSTANCE, nil); + OldUpDownWndProc:= Windows.WNDPROC(GetClassLongPtr(Window, GCLP_WNDPROC)); + + SetClassLongPtr(Window, GCLP_WNDPROC, LONG_PTR(@UpDownWndProc)); + DestroyWindow(Window); +end; + +procedure ScreenFormEvent(Self, Sender: TObject; Form: TCustomForm); +begin + if Assigned(Form.Menu) then + begin + Form.Menu.OwnerDraw:= True; + SetMenuBackground(GetMenu(Form.Handle)); + Form.Menu.OwnerDraw:= False; + end; +end; + +procedure DarkFormChanged(Form: TObject); +begin + if not IsDarkModeEnabled then + Exit; + if Form is TForm then + ScreenFormEvent(nil,nil,Form as TForm); +end; + +{ + Override several widgetset controls +} +procedure ApplyDarkStyle; +var + Handler: TMethod; + Index: TThemedElement; +begin + if not IsDarkModeEnabled then + Exit; + + SubClassUpDown; + + OpenThemeData:= @InterceptOpenThemeData; + + DefBtnColors[dctFont]:= SysColor[COLOR_BTNTEXT]; + DefBtnColors[dctBrush]:= SysColor[COLOR_BTNFACE]; + + Handler.Code:= @ScreenFormEvent; + Screen.AddHandlerFormVisibleChanged(TScreenFormEvent(Handler), True); + + with TWinControl.Create(nil) do Free; + RegisterWSComponent(TWinControl, TWin32WSWinControlDark); + + WSComCtrls.RegisterStatusBar; + RegisterWSComponent(TStatusBar, TWin32WSStatusBarDark); + + WSStdCtrls.RegisterCustomComboBox; + RegisterWSComponent(TCustomComboBox, TWin32WSCustomComboBoxDark); + + WSStdCtrls.RegisterCustomEdit; + + WSStdCtrls.RegisterCustomMemo; + RegisterWSComponent(TCustomMemo, TWin32WSCustomMemoDark); + + WSStdCtrls.RegisterCustomListBox; + RegisterWSComponent(TCustomListBox, TWin32WSCustomListBoxDark); + + WSComCtrls.RegisterCustomListView; + RegisterWSComponent(TCustomListView, TWin32WSCustomListViewDark); + + WSForms.RegisterScrollingWinControl; + + WSForms.RegisterCustomForm; + RegisterWSComponent(TCustomForm, TWin32WSCustomFormDark); + + WSMenus.RegisterMenu; + WSMenus.RegisterPopupMenu; + RegisterWSComponent(TPopupMenu, TWin32WSPopupMenuDark); + + WSForms.RegisterScrollBox; + RegisterWSComponent(TScrollBox, TWin32WSScrollBoxDark); + + RegisterCustomTrackBar; + RegisterWSComponent(TCustomTrackBar, TWin32WSTrackBarDark); + + DrawThemeText:= @DrawThemeTextDark; + DrawThemeBackground:= @DrawThemeBackgroundDark; + + for Index:= Low(TThemedElement) to High(TThemedElement) do + begin + Theme[Index]:= TWin32ThemeServices(ThemeServices).Theme[Index]; + end; + + DefaultWindowInfo.DefWndProc:= @WindowProc; + + TaskDialogIndirect:= @TaskDialogIndirectDark; +end; + +function FormWndProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam; + LParam: Windows.LParam): LResult; stdcall; +var + Info: PWin32WindowInfo; +begin + if Msg = WM_CREATE then + begin + AllowDarkModeForWindow(Window, True); + RefreshTitleBarThemeColor(Window); + end + else if (Msg = WM_SETFONT) then + begin + Info := GetWin32WindowInfo(Window); + if Assigned(Info) then + begin + Info^.DefWndProc:= @WindowProc; + end; + Result:= CallWindowProc(@WindowProc, Window, Msg, WParam, LParam); + Exit; + end; + Result:= DefWindowProc(Window, Msg, WParam, LParam); +end; + +procedure DrawCheckBox(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +var + LCanvas: TCanvas; + AStyle: TTextStyle; +begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= HDC; + + LCanvas.Brush.Color:= clBtnFace; + LCanvas.FillRect(pRect); + + AStyle:= LCanvas.TextStyle; + AStyle.Layout:= tlCenter; + AStyle.ShowPrefix:= True; + + // Fill checkbox rect + LCanvas.Font.Name:= 'Segoe MDL2 Assets'; + LCanvas.Font.Color:= SysColor[COLOR_WINDOW]; + LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_CHECKBOX_FILLED, AStyle); + + // Draw checkbox border + if iStateId in [CBS_UNCHECKEDHOT, CBS_MIXEDHOT, CBS_CHECKEDHOT] then + LCanvas.Font.Color:= SysColor[COLOR_HIGHLIGHT] + else begin + LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); + end; + LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_CHECKBOX_OUTLINE, AStyle); + + // Draw checkbox state + if iStateId in [CBS_MIXEDNORMAL, CBS_MIXEDHOT, + CBS_MIXEDPRESSED, CBS_MIXEDDISABLED] then + begin + LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(120, 120, 120); + LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_CHECKBOX_GRAYED, AStyle); + end + else if iStateId in [CBS_CHECKEDNORMAL, CBS_CHECKEDHOT, + CBS_CHECKEDPRESSED, CBS_CHECKEDDISABLED] then + begin + LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); + LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_CHECKBOX_CHECKED, AStyle); + end; + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; +end; + +procedure DrawEdit(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +var + LCanvas: TCanvas; +begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= HDC; + + // Draw border + LCanvas.Brush.Style:= bsClear; + + case iStateId of + ETS_NORMAL:LCanvas.Pen.Color:= SysColor[COLOR_GRAYTEXT]; + ETS_HOT,ETS_FOCUSED,ETS_SELECTED:LCanvas.Pen.Color:= SysColor[COLOR_BTNTEXT]; + ETS_DISABLED,ETS_READONLY:LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; + end; + LCanvas.RoundRect(pRect, 0, 0); + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; +end; + +procedure DrawReBar(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; pClipRect: PRECT); +var + LCanvas: TCanvas; +begin + // Draw only background, need fix it + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= HDC; + + LCanvas.Brush.Style:= bsClear; + LCanvas.Pen.Color:=SysColor[COLOR_BTNFACE]; + + {case iStateId of + end;} + LCanvas.RoundRect(pRect, 0, 0); + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; +end; + + +procedure DrawRadionButton(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +var + LCanvas: TCanvas; + AStyle: TTextStyle; +begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= hdc; + + LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; + LCanvas.FillRect(pRect); + + AStyle:= LCanvas.TextStyle; + AStyle.Layout:= tlCenter; + AStyle.ShowPrefix:= True; + + // Draw radio circle + LCanvas.Font.Name:= 'Segoe MDL2 Assets'; + LCanvas.Font.Color:= SysColor[COLOR_WINDOW]; + LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_RADIO_FILLED, AStyle); + + // Draw radio button state + if iStateId in [RBS_CHECKEDNORMAL, RBS_CHECKEDHOT, + RBS_CHECKEDPRESSED, RBS_CHECKEDDISABLED] then + begin + LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); + LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_RADIO_CHECKED, AStyle ); + end; + + // Set outline circle color + if iStateId in [RBS_UNCHECKEDPRESSED, RBS_CHECKEDPRESSED] then + LCanvas.Font.Color:= SysColor[COLOR_HIGHLIGHT]//RGBToColor(83, 160, 237) + else if iStateId in [RBS_UNCHECKEDHOT, RBS_CHECKEDHOT] then + LCanvas.Font.Color:= SysColor[COLOR_HIGHLIGHT] + else begin + LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); + end; + // Draw outline circle + LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, MDL_RADIO_OUTLINE, AStyle); + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; +end; + +procedure DrawGroupBox(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +var + LCanvas: TCanvas; +begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= HDC; + + // Draw border + LCanvas.Brush.Style:= bsClear; + LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; + LCanvas.RoundRect(pRect, 10, 10); + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; +end; + +procedure DrawScrollBar(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +var + LCanvas: TCanvas; + AStyle: TTextStyle; + BtnSym: string; +begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= HDC; + + case iPartId of + SBP_ARROWBTN:begin + LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; + LCanvas.FillRect(pRect); + + AStyle:= LCanvas.TextStyle; + AStyle.Alignment:= taCenter; + AStyle.Layout:= tlCenter; + AStyle.ShowPrefix:= True; + LCanvas.Font.Name:= 'Segoe MDL2 Assets'; + case iStateId of + ABS_UPNORMAL, + ABS_UPHOT, + ABS_UPPRESSED, + ABS_UPDISABLED: BtnSym:=MDL_SCROLLBOX_BTNUP; + ABS_DOWNNORMAL, + ABS_DOWNHOT, + ABS_DOWNPRESSED, + ABS_DOWNDISABLED: BtnSym:=MDL_SCROLLBOX_BTNDOWN; + ABS_LEFTNORMAL, + ABS_LEFTHOT, + ABS_LEFTPRESSED, + ABS_LEFTDISABLED: BtnSym:=MDL_SCROLLBOX_BTNLEFT; + ABS_RIGHTNORMAL, + ABS_RIGHTHOT, + ABS_RIGHTPRESSED, + ABS_RIGHTDISABLED: BtnSym:=MDL_SCROLLBOX_BTNRIGHT; + ABS_UPHOVER: BtnSym:=MDL_SCROLLBOX_BTNUP; + ABS_DOWNHOVER: BtnSym:=MDL_SCROLLBOX_BTNDOWN; + ABS_LEFTHOVER: BtnSym:=MDL_SCROLLBOX_BTNLEFT; + ABS_RIGHTHOVER: BtnSym:=MDL_SCROLLBOX_BTNRIGHT; + end; + + if iStateId in [ABS_UPDISABLED,ABS_DOWNDISABLED, + ABS_LEFTDISABLED,ABS_RIGHTDISABLED] then + LCanvas.Font.Color:= SysColor[COLOR_WINDOW] + else if iStateId in [ABS_UPHOT,ABS_DOWNHOT, + ABS_LEFTHOT,ABS_RIGHTHOT, + ABS_UPPRESSED,ABS_DOWNPRESSED, + ABS_LEFTPRESSED,ABS_RIGHTPRESSED] then + LCanvas.Font.Color:= SysColor[COLOR_HIGHLIGHT] + else begin + LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); + end; + LCanvas.TextRect(pRect, pRect.TopLeft.X, pRect.TopLeft.Y, BtnSym, AStyle); + end; + SBP_GRIPPERHORZ,SBP_GRIPPERVERT:begin + if iStateId in [ABS_UPDISABLED,ABS_DOWNDISABLED, + ABS_LEFTDISABLED,ABS_RIGHTDISABLED] then + LCanvas.Brush.Color:= SysColor[COLOR_WINDOW] + else if iStateId in [ABS_UPHOT,ABS_DOWNHOT, + ABS_LEFTHOT,ABS_RIGHTHOT, + ABS_UPPRESSED,ABS_DOWNPRESSED, + ABS_LEFTPRESSED,ABS_RIGHTPRESSED] then + LCanvas.Brush.Color:= SysColor[COLOR_HIGHLIGHT] + else begin + LCanvas.Brush.Color:= SysColor[COLOR_GRAYTEXT];//RGBToColor(192, 192, 192); + end; + LCanvas.Pen.Color:=LCanvas.Brush.Color; + LCanvas.FrameRect(pRect{, 10, 10}); + end; + else begin + LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; + LCanvas.Pen.Color:=LCanvas.Brush.Color; + LCanvas.FillRect(pRect); + end; + + end; + + + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; +end; + +procedure DrawPushButton(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +var + LCanvas: TCanvas; +begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= HDC; + + LCanvas.Brush.Style:= bsClear; + + if iStateId in [PBS_NORMAL,PBS_DEFAULTED,PBS_DEFAULTED_ANIMATING] then begin + LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; + LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; + end else if iStateId in [PBS_HOT] then begin + LCanvas.Brush.Color:= SysColor[COLOR_BTNHIGHLIGHT]; + LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; + end else if iStateId in [PBS_PRESSED] then begin + LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; + LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; + end else begin + LCanvas.Brush.Color:= SysColor[COLOR_3DDKSHADOW]; + LCanvas.Pen.Color:= SysColor[COLOR_BTNHIGHLIGHT]; + end; + + LCanvas.RoundRect(pRect, 10, 10); + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; +end; + + +procedure DrawButton(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +begin + case iPartId of + BP_PUSHBUTTON: if DrawControl.CustomDrawPushButtons then + DrawPushButton(hTheme, hdc, iPartId, iStateId, pRect, pClipRect) + else + TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + BP_RADIOBUTTON: DrawRadionButton(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + BP_CHECKBOX: DrawCheckBox(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + BP_GROUPBOX: DrawGroupBox(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + end; +end; + +procedure DrawComboBox(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +var + LCanvas: TCanvas; + AStyle: TTextStyle; + BtnSym: string; + r:TRect; +begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= HDC; + + case iPartId of + CP_BORDER:begin + LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; + LCanvas.FillRect(pRect); + + if iStateId in [CBXS_DISABLED] then begin + LCanvas.Brush.Color:= SysColor[COLOR_WINDOW] + end + else if iStateId in [CBXS_HOT] then begin + LCanvas.Brush.Color:= Darker(SysColor[COLOR_HIGHLIGHT],150) + end + else begin + LCanvas.Brush.Color:= SysColor[COLOR_WINDOW] + end; + LCanvas.FrameRect(pRect); + end; + + CP_DROPDOWNBUTTON,CP_DROPDOWNBUTTONRIGHT,CP_DROPDOWNBUTTONLEFT:begin + + AStyle:= LCanvas.TextStyle; + AStyle.Alignment:= taCenter; + AStyle.Layout:= tlCenter; + AStyle.ShowPrefix:= True; + LCanvas.Font.Name:= 'Segoe MDL2 Assets'; + BtnSym:=MDL_COMBOBOX_BTNDOWN; + + + if iStateId in [CBXS_DISABLED] then begin + LCanvas.Font.Color:= SysColor[COLOR_WINDOW]; + LCanvas.Brush.Color:= SysColor[COLOR_WINDOW] + end + else if iStateId in [CBXS_HOT] then begin + LCanvas.Font.Color:= SysColor[COLOR_HIGHLIGHT]; + LCanvas.Brush.Color:= Darker(SysColor[COLOR_HIGHLIGHT],150) + end + else begin + LCanvas.Font.Color:= SysColor[COLOR_GRAYTEXT]; + LCanvas.Brush.Color:= SysColor[COLOR_WINDOW] + end; + r:=pRect; + InflateRect(r,-1,-1); + LCanvas.FillRect(r); + LCanvas.TextRect(r, pRect.TopLeft.X, pRect.TopLeft.Y, BtnSym, AStyle); + end; + {else begin + LCanvas.Brush.Color:= SysColor[COLOR_BTNFACE]; + LCanvas.Pen.Color:=LCanvas.Brush.Color; + LCanvas.FillRect(pRect); + end;} + + end; + + + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; +end; + + + +procedure DrawTabControl(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +var + ARect: TRect; + AColor: TColor; + ALight: TColor; + LCanvas: TCanvas; +begin + LCanvas:= TCanvas.Create; + try + LCanvas.Handle:= hdc; + + AColor:= SysColor[COLOR_BTNFACE]; + ALight:= Lighter(AColor, 160); + + case iPartId of + TABP_TOPTABITEM, + TABP_TOPTABITEMLEFTEDGE, + TABP_TOPTABITEMBOTHEDGE, + TABP_TOPTABITEMRIGHTEDGE: + begin + ARect:= pRect; + // Fill tab inside + if (iStateId <> TIS_SELECTED) then + begin + if iStateId <> TIS_HOT then + LCanvas.Brush.Color:= Lighter(AColor, 117) + else begin + LCanvas.Brush.Color:= Lighter(AColor, 200); + end; + end + else begin + Dec(ARect.Bottom); + InflateRect(ARect, -1, -1); + LCanvas.Brush.Color:= Lighter(AColor, 176); + end; + LCanvas.FillRect(ARect); + LCanvas.Pen.Color:= ALight; + + if iPartId in [TABP_TOPTABITEMLEFTEDGE, TABP_TOPTABITEMBOTHEDGE] then + begin + // Draw left border + LCanvas.Line(pRect.Left, pRect.Top, pRect.Left, pRect.Bottom); + end; + + if (iStateId <> TIS_SELECTED) then + begin + // Draw right border + LCanvas.Line(pRect.Right - 1, pRect.Top, pRect.Right - 1, pRect.Bottom) + end + else begin + // Draw left border + if (iPartId = TABP_TOPTABITEM) then + begin + LCanvas.Line(pRect.Left, pRect.Top, pRect.Left, pRect.Bottom - 1); + end; + // Draw right border + LCanvas.Line(pRect.Right - 1, pRect.Top, pRect.Right - 1, pRect.Bottom - 1); + end; + // Draw top border + LCanvas.Line(pRect.Left, pRect.Top, pRect.Right, pRect.Top); + end; + TABP_PANE: + begin + // Draw tab pane border + LCanvas.Brush.Color:= AColor; + LCanvas.Pen.Color:= ALight; + LCanvas.Rectangle(pRect); + end; + end; + finally + LCanvas.Handle:= 0; + LCanvas.Free; + end; +end; + +procedure DrawProgressBar(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +begin + if not (iPartId in [PP_TRANSPARENTBAR, PP_TRANSPARENTBARVERT]) then + TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect) + else begin + SelectObject(hdc, GetStockObject(DC_PEN)); + SetDCPenColor(hdc, SysColor[COLOR_BTNSHADOW]); + SelectObject(hdc, GetStockObject(DC_BRUSH)); + SetDCBrushColor(hdc, SysColor[COLOR_BTNFACE]); + with pRect do Rectangle(hdc, Left, Top, Right, Bottom); + end; +end; + +procedure DrawTreeView(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +begin + if (iPartId = TVP_TREEITEM) and (iStateId in [TREIS_SELECTEDNOTFOCUS,TREIS_SELECTED]) then begin + SelectObject(hdc, GetStockObject(DC_PEN)); + SetDCPenColor(hdc, SysColor[COLOR_BTNSHADOW]); + SelectObject(hdc, GetStockObject(DC_BRUSH)); + if DrawControl.TreeViewDisableHideSelection then + if iStateId=TREIS_SELECTEDNOTFOCUS then + iStateId:=TREIS_SELECTED; + case iStateId of + TREIS_SELECTEDNOTFOCUS:SetDCBrushColor(hdc, SysColor[COLOR_BTNHIGHLIGHT]); + TREIS_SELECTED:SetDCBrushColor(hdc, Lighter(SysColor[COLOR_BTNHIGHLIGHT], 146)); + end; + with pRect do Rectangle(hdc, Left, Top, Right, Bottom); + end else + TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect) +end; + +procedure DrawListViewHeader(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: PRECT); +begin + DrawThemeBackgroundDark(Theme[teListView], hdc, iPartId, iStateId, pRect, pClipRect); +end; + +function InterceptOpenThemeData(hwnd: hwnd; pszClassList: LPCWSTR): hTheme; stdcall; +var + P: LONG_PTR; +begin + if (hwnd <> 0) then + begin + P:= GetWindowLongPtr(hwnd, GWL_EXSTYLE); + + if (P and WS_EX_CONTEXTHELP = 0) or (lstrcmpiW(pszClassList, VSCLASS_MONTHCAL) = 0) then + begin + Result:= TrampolineOpenThemeData(hwnd, pszClassList); + Exit; + end; + end; + + if lstrcmpiW(pszClassList, VSCLASS_TAB) = 0 then + begin + AllowDarkStyle(hwnd); + pszClassList:= PWideChar(VSCLASS_DARK_TAB); + end + else if lstrcmpiW(pszClassList, VSCLASS_BUTTON) = 0 then + begin + AllowDarkStyle(hwnd); + pszClassList:= PWideChar(VSCLASS_DARK_BUTTON); + end + else if lstrcmpiW(pszClassList, VSCLASS_EDIT) = 0 then + begin + AllowDarkStyle(hwnd); + pszClassList:= PWideChar(VSCLASS_DARK_EDIT); + end + else if lstrcmpiW(pszClassList, VSCLASS_COMBOBOX) = 0 then + begin + AllowDarkStyle(hwnd); + pszClassList:= PWideChar(VSCLASS_DARK_COMBOBOX); + end + + else if lstrcmpiW(pszClassList, 'ListView') = 0 then + begin + ListView_SetBkColor(hwnd, SysColor[COLOR_WINDOW]); + ListView_SetTextBkColor(hwnd, SysColor[COLOR_WINDOW]); + ListView_SetTextColor(hwnd, SysColor[COLOR_WINDOWTEXT]); + end + + else if lstrcmpiW(pszClassList, VSCLASS_SCROLLBAR) = 0 then + begin + AllowDarkStyle(hwnd); + pszClassList:= PWideChar(VSCLASS_DARK_SCROLLBAR); + end; + + Result:= TrampolineOpenThemeData(hwnd, pszClassList); + ThemeClass.AddOrSetValue(Result, pszClassList); +end; + +function InterceptDrawThemeText(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; pszText: LPCWSTR; iCharCount: Integer; + dwTextFlags, dwTextFlags2: DWORD; const pRect: TRect): HRESULT; stdcall; +var + OldColor: COLORREF; + ClassName: LPCWSTR; +begin + if Assigned(ThemeClass) then + if ThemeClass.TryGetValue(hTheme, ClassName) then + begin + if SameText(ClassName, VSCLASS_DARK_COMBOBOX) or SameText(ClassName, VSCLASS_DARK_EDIT) then + begin + Result:= TrampolineDrawThemeText(hTheme, hdc, iPartId, iStateId, pszText, iCharCount, dwTextFlags, dwTextFlags2, pRect); + Exit; + end; + + if SameText(ClassName, VSCLASS_TOOLTIP) then + OldColor:= SysColor[COLOR_INFOTEXT] + else begin + OldColor:= SysColor[COLOR_BTNTEXT]; + end; + + if SameText(ClassName, VSCLASS_DARK_BUTTON) then + begin + if (iPartId = BP_CHECKBOX) and (iStateId in [CBS_UNCHECKEDDISABLED, CBS_CHECKEDDISABLED, CBS_MIXEDDISABLED]) then + OldColor:= SysColor[COLOR_GRAYTEXT] + else if (iPartId = BP_RADIOBUTTON) and (iStateId in [RBS_UNCHECKEDDISABLED, RBS_CHECKEDDISABLED]) then + OldColor:= SysColor[COLOR_GRAYTEXT] + else if (iPartId = BP_GROUPBOX) and (iStateId = GBS_DISABLED) then + OldColor:= SysColor[COLOR_GRAYTEXT] + else if (iPartId = BP_PUSHBUTTON) then + begin + Result:= TrampolineDrawThemeText(hTheme, hdc, iPartId, iStateId, pszText, iCharCount, dwTextFlags, dwTextFlags2, pRect); + Exit; + end; + end; + + OldColor:= SetTextColor(hdc, OldColor); + SetBkMode(hdc, TRANSPARENT); + + DrawTextExW(hdc, pszText, iCharCount, @pRect, dwTextFlags, nil); + + SetTextColor(hdc, OldColor); + + Exit(S_OK); + end; + Result:= TrampolineDrawThemeText(hTheme, hdc, iPartId, iStateId, pszText, iCharCount, dwTextFlags, dwTextFlags2, pRect); +end; + +function InterceptDrawThemeBackground(hTheme: hTheme; hdc: hdc; iPartId, iStateId: Integer; const pRect: TRect; + pClipRect: Pointer): HRESULT; stdcall; +var + Index: Integer; + ClassName: LPCWSTR; +begin + if assigned(ThemeClass)then + if ThemeClass.TryGetValue(hTheme, ClassName) then + begin + Index:= SaveDC(hdc); + try + if (SameText(ClassName, VSCLASS_DARK_SCROLLBAR))and DrawControl.CustomDrawScrollbars then + begin + DrawScrollBar(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + end + else if (SameText(ClassName,VSCLASS_DARK_COMBOBOX))and DrawControl.CustomDrawComboBoxs then + begin + DrawComboBox(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + end + else if SameText(ClassName, VSCLASS_DARK_BUTTON) then + begin + DrawButton(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + end + else if SameText(ClassName, VSCLASS_DARK_TAB) then + begin + DrawTabControl(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + end + else if SameText(ClassName, VSCLASS_PROGRESS) or SameText(ClassName, VSCLASS_PROGRESS_INDER) then + begin + DrawProgressBar(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + end + else if SameText(ClassName, VSCLASS_DARK_HEADER) then + begin + DrawListViewHeader(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + end + else begin + Result:= TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); + end; + finally + RestoreDC(hdc, Index); + end; + Exit(S_OK); + end; + Result:= TrampolineDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, pClipRect); +end; + +function DrawThemeEdgeDark(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer; const pDestRect: TRect; uEdge, + uFlags: UINT; pContentRect: PRECT): HRESULT; stdcall; +var + ARect: TRect; +begin + ARect:= pDestRect; + _DrawEdge(hdc, ARect, uEdge, uFlags); + if (uFlags and DFCS_ADJUSTRECT <> 0) and (pContentRect <> nil) then + pContentRect^ := ARect; + Result:= S_OK; +end; + +function GetThemeSysColorDark(hTheme: HTHEME; iColorId: Integer): COLORREF; stdcall; +begin + Result:= GetSysColor(iColorId); +end; + +function GetThemeSysColorBrushDark(hTheme: HTHEME; iColorId: Integer): HBRUSH; stdcall; +begin + Result:= GetSysColorBrush(iColorId); +end; + +var + DeleteObjectOld: function(ho: HGDIOBJ): WINBOOL; stdcall; + +function __DeleteObject(ho: HGDIOBJ): WINBOOL; stdcall; +var + Index: Integer; +begin + for Index:= 0 to High(SysColorBrush) do + begin + if SysColorBrush[Index] = ho then Exit(True); + end; + Result:= DeleteObjectOld(ho); +end; + +procedure InitializeColors(const CS:TDSColors); +begin + SysColor:=CS.SysColor; + DrawControl:=CS.DrawControl; +end; + +procedure SetColorsScheme(Scheme:TDSColors); +var + Index: Integer; +begin + for Index:= 0 to High(SysColorBrush) do + SysColorBrush[Index] := 0; + SysColor:=Scheme.SysColor; +end; + +function WinRegister(ClassName: PWideChar): Boolean; +var + WindowClassW: WndClassW; +begin + ZeroMemory(@WindowClassW, SizeOf(WndClassW)); + with WindowClassW do + begin + Style := CS_DBLCLKS; + LPFnWndProc := @FormWndProc; + hInstance := System.HInstance; + hIcon := Windows.LoadIcon(MainInstance, 'MAINICON'); + if hIcon = 0 then + hIcon := Windows.LoadIcon(0, IDI_APPLICATION); + hCursor := Windows.LoadCursor(0, IDC_ARROW); + LPSzClassName := ClassName; + end; + Result := Windows.RegisterClassW(@WindowClassW) <> 0; +end; + +procedure Initialize(const CS:TDSColors); +var + hModule, hUxTheme: THandle; + pLibrary, pFunction: PPointer; + pImpDesc: PIMAGE_DELAYLOAD_DESCRIPTOR; +begin + if not IsDarkModeEnabled then + Exit; + + InitializeColors(CS); + + WinRegister(ClassNameW); + WinRegister(ClassNameTC); + + ThemeClass:= TThemeClassMap.Create; + + hModule:= GetModuleHandle(gdi32); + Pointer(DeleteObjectOld):= GetProcAddress(hModule, 'DeleteObject'); + + hModule:= GetModuleHandle(comctl32); + Pointer(DefSubclassProc):= GetProcAddress(hModule, 'DefSubclassProc'); + Pointer(SetWindowSubclass):= GetProcAddress(hModule, 'SetWindowSubclass'); + + // Override several system functions + pLibrary:= FindImportLibrary(MainInstance, user32); + if Assigned(pLibrary) then + begin + hModule:= GetModuleHandle(user32); + + pFunction:= FindImportFunction(pLibrary, GetProcAddress(hModule, 'CreateWindowExW')); + if Assigned(pFunction) then + begin + Pointer(__CreateWindowExW):= ReplaceImportFunction(pFunction, @_CreateWindowExW); + end; + pFunction:= FindImportFunction(pLibrary, GetProcAddress(hModule, 'DrawEdge')); + if Assigned(pFunction) then + begin + ReplaceImportFunction(pFunction, @_DrawEdge); + end; + pFunction:= FindImportFunction(pLibrary, GetProcAddress(hModule, 'GetSysColor')); + if Assigned(pFunction) then + begin + ReplaceImportFunction(pFunction, @GetSysColorDark); + end; + pFunction:= FindImportFunction(pLibrary, GetProcAddress(hModule, 'GetSysColorBrush')); + if Assigned(pFunction) then + begin + ReplaceImportFunction(pFunction, @GetSysColorBrushDark); + end; + end; + pLibrary:= FindImportLibrary(MainInstance, gdi32); + if Assigned(pLibrary) then + begin + hModule:= GetModuleHandle(gdi32); + pFunction:= FindImportFunction(pLibrary, Pointer(DeleteObjectOld)); + if Assigned(pFunction) then + begin + ReplaceImportFunction(pFunction, @__DeleteObject); + end; + end; + + hModule:= GetModuleHandle(comctl32); + pImpDesc:= FindDelayImportLibrary(hModule, themelib); + if Assigned(pImpDesc) then + begin + hUxTheme:= GetModuleHandle(themelib); + Pointer(TrampolineOpenThemeData):= GetProcAddress(hUxTheme, 'OpenThemeData'); + Pointer(TrampolineDrawThemeText):= GetProcAddress(hUxTheme, 'DrawThemeText'); + Pointer(TrampolineDrawThemeBackground):= GetProcAddress(hUxTheme, 'DrawThemeBackground'); + + ReplaceDelayImportFunction(hModule, pImpDesc, 'OpenThemeData', @InterceptOpenThemeData); + ReplaceDelayImportFunction(hModule, pImpDesc, 'DrawThemeText', @InterceptDrawThemeText); + ReplaceDelayImportFunction(hModule, pImpDesc, 'DrawThemeBackground', @InterceptDrawThemeBackground); + + ReplaceDelayImportFunction(hModule, pImpDesc, 'DrawThemeEdge', @DrawThemeEdgeDark); + end; + + pLibrary:= FindImportLibrary(hModule, gdi32); + if Assigned(pLibrary) then + begin + pFunction:= FindImportFunction(pLibrary, Pointer(DeleteObjectOld)); + if Assigned(pFunction) then + begin + ReplaceImportFunction(pFunction, @__DeleteObject); + end; + end; + + hModule:= GetModuleHandle(comctl32); + pLibrary:= FindImportLibrary(hModule, user32); + if Assigned(pLibrary) then + begin + hModule:= GetModuleHandle(user32); + + pFunction:= FindImportFunction(pLibrary, GetProcAddress(hModule, 'DrawEdge')); + if Assigned(pFunction) then + begin + ReplaceImportFunction(pFunction, @_DrawEdge); + end; + end; +end; + +initialization + +finalization + if Assigned(ThemeClass) then + FreeAndNil(ThemeClass); +end. +