Open/Save dialog issue with Windows 10 and light/dark theme

[rickard67]

To fix these issues we need to modify the file "Vcl.Styles.UxTheme".

Fix 1.) First to fix the explorer navigation pane issue add "SameText(LThemeClass, 'ExplorerNavPane')" to the if statement below.

function Detour_UxTheme_GetThemeColor(hTheme: HTHEME; iPartId, iStateId, iPropId: Integer; var pColor: COLORREF): HRESULT;  Stdcall;
...
      {$IFDEF HOOK_TreeView}
      if SameText(LThemeClass, VSCLASS_TREEVIEW) or SameText(LThemeClass, VSCLASS_PROPERTREE) or
         SameText(LThemeClass, 'ExplorerNavPane') then
      begin
        pColor := clNone;
        case iPartId of
          0, 2:
            case iStateId  of
              0 :  pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow));
            end;
        end;

       if TColor(pColor) = clNone then
       begin
         Result := Trampoline_UxTheme_GetThemeColor(hTheme, iPartId, iStateId, iPropId, pColor);
         //OutputDebugString(PChar(Format('Detour_GetThemeColor Class %s hTheme %d iPartId %d iStateId %d  iPropId %d Color %8.x', [LThemeClass, hTheme, iPartId, iStateId, iPropId, pColor])));
       end
       else
         Result := S_OK;
      end
      else
     {$ENDIF}
...
end;

To fix the "CommonItemsDialog" area (save name and filter...) and the search box you can either use fix 2 only, or maybe both fix 2 and fix 3.

Fix 2.) Simply modify the last else statement in the function below.

function Detour_UxTheme_DrawThemeMain(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer;  const pRect: TRect; Foo: Pointer; Trampoline : TDrawThemeBackground): HRESULT; Stdcall;
...
begin
...
   else
   begin
//     OutputDebugString(PChar(Format('Detour_UxTheme_DrawThemeMain class %s hTheme %d iPartId %d iStateId %d', [LThemeClass, hTheme, iPartId, iStateId])));
//     Exit(Trampoline(hTheme, hdc, iPartId, iStateId, pRect, Foo));
     DrawStyleFillRect(hdc, pRect, clBtnFace);
     Exit(S_OK);
   end;
  finally
    VCLStylesLock.Leave;
  end;
end;

Fix 3.) Add a new function (listed below) in the implementation section.

function UxTheme_CommonItemsDialog(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer;  const pRect: TRect; Foo: Pointer; Trampoline : TDrawThemeBackground; LThemeClass : string; hwnd : HWND): HRESULT; Stdcall;
var
 LColor : TColor;
begin
  case iPartId of
    1:
      begin
        case iStateId of
         //background
         0 :
             begin
               DrawStyleElement(hdc, StyleServices.GetElementDetails(twWindowRoot), pRect);
               Exit(S_OK);
             end;
        end;
      end;
  end;

   //OutputDebugString(PChar(Format('UxTheme_CommonItemsDialog class %s hTheme %d iPartId %d iStateId %d', [LThemeClass, hTheme, iPartId, iStateId])));
   Exit(Trampoline(hTheme, hdc, iPartId, iStateId, pRect, Foo));
end;

Find the

{$IFDEF HOOK_Navigation}
const
  VSCLASS_NAVIGATION                  = 'Navigation';
  VSCLASS_COMMONITEMSDIALOG           = 'CommonItemsDialog';
{$ENDIF}

and modify it as seen above.

Then add the function "UxTheme_CommonItemsDialog" to the draw functions in the initialization section.

initialization
...
  if StyleServices.Available then
  begin
  ...
    {$IFDEF HOOK_Navigation}
    if TOSVersion.Check(6, 2) then //Windows 8,10...
    begin
      FuncsDrawThemeBackground.Add(VSCLASS_NAVIGATION, @UxTheme_Navigation);
      FuncsDrawThemeBackground.Add(VSCLASS_COMMONITEMSDIALOG, @UxTheme_CommonItemsDialog);
    end;
    {$ENDIF}
  end;

It should look like this when done:

I hope that helps someone... /Rickard

[StefanGrube]

Outcommenting the line "// Exit(..." in Fix 2 leads to a W1035, return value could be undefined. Are you sure that either you quoted the correct lines or want to really outcomment the Exit() function?

[rickard67]

You could add Exit(S_OK) right after the DrawStyleFillRect():

DrawStyleFillRect(hdc, pRect, clBtnFace);
Exit(S_OK);

I modified the code above. Below is what my own code looks like.

function Detour_UxTheme_DrawThemeMain(hTheme: HTHEME; hdc: HDC; iPartId, iStateId: Integer;  const pRect: TRect; Foo: Pointer; Trampoline : TDrawThemeBackground): HRESULT; Stdcall;
var
  LThemeClass : string;
  LHWND       : HWND;
  LFuncDrawThemeBackground : TFuncDrawThemeBackground;
begin
  Result := S_FALSE;
  VCLStylesLock.Enter;
  try
    if StyleServices.IsSystemStyle or not TSysStyleManager.Enabled then
    begin
      Result := Trampoline(hTheme, hdc, iPartId, iStateId, pRect, Foo);
      Exit;
    end;

    if not THThemesClasses.ContainsKey(hTheme)  then
    begin
      LThemeClass := GetThemeClass(hTheme, iPartId, iStateId);
      if LThemeClass<>'' then
      begin
        THThemesClasses.Add(hTheme, LThemeClass);
        THThemesHWND.Add(hTheme, 0);
      end
      else
      begin
        Result := Trampoline(hTheme, hdc, iPartId, iStateId, pRect, Foo);
        Exit;
      end;
    end
    else
      LThemeClass := THThemesClasses.Items[hTheme];

    LHWND := THThemesHWND.Items[hTheme];

    if FuncsDrawThemeBackground.ContainsKey(LThemeClass) then
    begin
      LFuncDrawThemeBackground := FuncsDrawThemeBackground.Items[LThemeClass];
      Result := LFuncDrawThemeBackground(hTheme, hdc, iPartId, iStateId, pRect, Foo, Trampoline, LThemeClass, LHWND);
    end
    else
    begin
      DrawStyleFillRect(hdc, pRect, clBtnFace);
      Result := S_OK;
    end;
  finally
    VCLStylesLock.Leave;
  end;
end;

[StefanGrube]

Thanks, understood. You may want to create pull requests, so that they can easily be merged?

[lchris789]

Hello I have downloaded latest zip files, but I still experience this exact same issue with w10 1809 17763.316 and delphi RIO 10.3.1 my Detour_UxTheme_DrawThemeMain looks similar to rickard67 post above

Is this a problem with 10.3.1 a windows update or my setup ?

I had to add this part of code suggested by rickard67 in his first post to fix it

  if SameText(LThemeClass, VSCLASS_TREEVIEW) or SameText(LThemeClass, VSCLASS_PROPERTREE) or
     SameText(LThemeClass, 'ExplorerNavPane') then
  begin
    pColor := clNone;
    case iPartId of
      0, 2:
        case iStateId  of
          0 :  pColor := ColorToRGB(StyleServices.GetSystemColor(clWindow));
        end;
    end;

   if TColor(pColor) = clNone then
   begin
     Result := Trampoline_UxTheme_GetThemeColor(hTheme, iPartId, iStateId, iPropId, pColor);
     //OutputDebugString(PChar(Format('Detour_GetThemeColor Class %s hTheme %d iPartId %d iStateId %d  iPropId %d Color %8.x', [LThemeClass, hTheme, iPartId, iStateId, iPropId, pColor])));
   end
   else
     Result := S_OK;
  end

I still have a little issue with a black bar when a hint is displayed, not sure how to fix this.

[StefanGrube]

The proposed changes have not been incorporated into the original repository by RRUZ as no pull request was created. But there's a fork by salvadordf, that should have them, see the entry above yours.

[lchris789]

But there's a fork by salvadordf, that should have them, see the entry above yours.

many thanks. I have found the fork here https://github.com/salvadordf/vcl-styles-utils and this fix is indeed included.

(There is still a problem with black font in ExplorerNavPane hints [extension that appears when the text is too long for the panel])

Do you know if there is a better place than here to speak or ask about Styles ?

[rickard67]

Try making the following modification:

unit Vcl.Styles.UxTheme;

function  Detour_UxTheme_DrawThemeTextEx(hTheme: HTHEME; hdc: HDC; iPartId: Integer; iStateId: Integer; pszText: LPCWSTR; cchText: Integer; dwTextFlags: DWORD; pRect: PRect; var pOptions: TDTTOpts): HResult; stdcall;
...
begin
...
 if LThemeClass<>'' then
 begin
   if SameText(LThemeClass, VSCLASS_TREEVIEW) then
   begin
        case iPartId of
          1 :
          begin
            if iStateId = 2 then
            begin
              LCanvas:=TCanvas.Create;
              SaveIndex := SaveDC(hdc);
              try
                LCanvas.Handle:=hdc;
                if pOptions.dwFlags AND DTT_FONTPROP <> 0  then
                begin
                  ZeroMemory(@plf, SizeOf(plf));
                  plf.lfHeight := 13;
                  plf.lfCharSet := DEFAULT_CHARSET;
                  StrCopy(plf.lfFaceName, 'Tahoma');
                  LCanvas.Font.Handle := CreateFontIndirect(plf);
                end;
                LDetails := StyleServices.GetElementDetails(tlListItemNormal);
                ThemeTextColor := StyleServices.GetStyleFontColor(sfListItemTextNormal);
                StyleServices.DrawText(LCanvas.Handle, LDetails, string(pszText), pRect^, TTextFormatFlags(dwTextFlags), ThemeTextColor);
              finally
                if pOptions.dwFlags AND DTT_FONTPROP <> 0  then
                  DeleteObject(LCanvas.Font.Handle);
                LCanvas.Handle := 0;
                LCanvas.Free;
                RestoreDC(hdc, SaveIndex);
              end;

              Result := S_OK;
            end
            else
            begin
              //OutputDebugString(PChar(Format('Detour_UxTheme_DrawThemeTextEx hTheme %d iPartId %d iStateId %d  text %s', [hTheme, iPartId, iStateId, pszText])));
              Exit(Trampoline_UxTheme_DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, pszText, cchText, dwTextFlags, pRect, pOptions));
            end;
          end;
        else
          begin
             //OutputDebugString(PChar(Format('Detour_UxTheme_DrawThemeTextEx hTheme %d iPartId %d iStateId %d  text %s', [hTheme, iPartId, iStateId, pszText])));
             Exit(Trampoline_UxTheme_DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, pszText, cchText, dwTextFlags, pRect, pOptions));
          end;
        end;
   end
   {$IFDEF HOOK_ListView}
   else if SameText(LThemeClass, VSCLASS_LISTVIEW) or SameText(LThemeClass, VSCLASS_ITEMSVIEW_LISTVIEW) then
   begin
...

[salvadordf]

I just added your code. Thanks rickard67 !

[lchris789]

Try making the following modification:

Woaw, Just downloaded Salvador's fork with your fix and it works beautifully ! Thank you Rickard67 ! I dont know how to request a pull, I saw the option somewhere but can't remember where.

Glad to see a new skilled genious contributor, I usually keep away from opensource projects with only one genius contributor because the source are useless to me (not skilled enought) if the author stops providing fix and updates. You raised my confidence in this marvellous project !

[luebbe]

@salvadordf thanks for your fork. Now the font color of the highlighted entry is better than it was before. However the font of the entry under the mouse cursor is wrong.

See:

[rickard67]

This should solve it. Thank you!

Vcl.Styles.UxTheme

function  Detour_UxTheme_DrawThemeTextEx(hTheme: HTHEME; hdc: HDC; iPartId: Integer; iStateId: Integer; pszText: LPCWSTR; cchText: Integer; dwTextFlags: DWORD; pRect: PRect; var pOptions: TDTTOpts): HResult; stdcall;
var
  LDetails: TThemedElementDetails;
  ThemeTextColor : TColor;
  SaveIndex : Integer;
  LCanvas : TCanvas;
  LThemeClass : string;
  plf: LOGFONTW;
begin
  ...
 if LThemeClass<>'' then
 begin
   if SameText(LThemeClass, VSCLASS_TREEVIEW) then
   begin
        case iPartId of
          1 :
          begin
            if iStateId = 2 then
            begin
              SaveIndex := SaveDC(hdc);
              try
                LDetails := StyleServices.GetElementDetails(tlListItemNormal);
                ThemeTextColor := StyleServices.GetStyleFontColor(sfListItemTextNormal);
                if pOptions.dwFlags AND DTT_FONTPROP <> 0  then
                begin
                  LCanvas := TCanvas.Create;
                  try
                    LCanvas.Handle := hdc;
                    ZeroMemory(@plf, SizeOf(plf));
                    plf.lfHeight := 13;
                    plf.lfCharSet := DEFAULT_CHARSET;
                    StrCopy(plf.lfFaceName, 'Tahoma');
                    LCanvas.Font.Handle := CreateFontIndirect(plf);
                    StyleServices.DrawText(LCanvas.Handle, LDetails, string(pszText), pRect^, TTextFormatFlags(dwTextFlags), ThemeTextColor);
                  finally
                    if pOptions.dwFlags AND DTT_FONTPROP <> 0  then
                      DeleteObject(LCanvas.Font.Handle);
                    LCanvas.Handle := 0;
                    LCanvas.Free;
                  end;
                end
                else
                  StyleServices.DrawText(hdc, LDetails, string(pszText), pRect^, TTextFormatFlags(dwTextFlags), ThemeTextColor);
              finally
                RestoreDC(hdc, SaveIndex);
              end;
              Result := S_OK;
            end
            else
            begin
              //OutputDebugString(PChar(Format('Detour_UxTheme_DrawThemeTextEx hTheme %d iPartId %d iStateId %d  text %s', [hTheme, iPartId, iStateId, pszText])));
              Exit(Trampoline_UxTheme_DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, pszText, cchText, dwTextFlags, pRect, pOptions));
            end;
          end;
        else
          begin
             //OutputDebugString(PChar(Format('Detour_UxTheme_DrawThemeTextEx hTheme %d iPartId %d iStateId %d  text %s', [hTheme, iPartId, iStateId, pszText])));
             Exit(Trampoline_UxTheme_DrawThemeTextEx(hTheme, hdc, iPartId, iStateId, pszText, cchText, dwTextFlags, pRect, pOptions));
          end;
        end;
   end
   {$IFDEF HOOK_ListView}
  ...

Best regards, Rickard