Mark Williams

On 6/20/2025 at 4:11 AM, dwrbudr said:

I think TVirtualImageList is automatically scaled when DPI changes only when TVirtualImageList is placed on a TForm/TFrame (look for SendChangeScaleMessage in the VCL code).

So you'll have to override the panel ChangeScale method and set the image list size.

Taken some time for me to resolve the issue. Managed to override the ChangeScale event, but still couldn't get it to work quite right. However, resolved the issue in the end by changing the component container from TPanel to TFrame. I have other components that use image resources for which the fix won't be that simple. But have dug around and discovered the TCustomForm's onBeforeMonitorDPIChanged and onAfterMonitorDPIChanged events and TWinControl's  ScaleForPPI procedure. Suspect these in combination will allow me to do what's needed. I'll post back with the results when I get to it.

I have a custom component derived from TPanel. There are several other components included including a TToolBar. There was also a TImageList which loaded bitmaps from a resource file to provide the icons for the toolbar.

I'm finally getting around to trying to update this to work with TVirtualImageList and transparent PNG files (24 x 24) rather than bitmaps. It works, but is not scaling properly. On higher resolution monitors the toolbuttons are far too small.

I suspect my problem is with the scaling of the toolbar rather than the imagelist. But I'm not entirely sure that's correct or what to do about it. The relevant code is below.

  FImageList := TVirtualImageList.create(self);
  FImageList.SetSize(TargetSize, TargetSize);
  FImageList.ImageCollection := FImageCollection;
  FImageList.DisabledGrayscale := true;

   FImageList.Height := 24;
   FImageList.Width := 24;

   FToolBar := TToolbar.create(self);

  FToolBar.parent := self;

  with FToolBar do
  begin
    Height := 36;
    ButtonWidth := 35;
    ButtonHeight := 35;   
    align := alTop;
    ShowHint := true;
    AutoSize := true;
    Wrapable := true;
  end;

As it turns out, I idiotically downloaded an older version from Sourceforge rather than the latest version from Github! 

After two long days of updating a huge project to incorporate the latest version of the Windows Ribbon Framework (for some reason it is no longer possible to link ribbon commands with TActions), I am left with one issue I cannot resolve. Previous versions of the framework had a UseDarkMode property which put the ribbon into/out of dark mode. THis has been removed from the latest version of the ribbon. Now it just remains dull grey even if you have dark mode enabled on your PC.

I have added the relevant procedure back in to UIRibbon.Pas:

procedure TUIRibbon.SetDarkMode(const Value: Boolean);
var
  PropertyStore: IPropertyStore;
  PropValue: TPropVariant;

begin
  if Assigned(FRibbon) and Supports(FRibbon, IPropertyStore, PropertyStore) then
  begin
    UIInitPropertyFromBoolean(UI_PKEY_DarkModeRibbon, Value, PropValue);
    PropertyStore.SetValue(TPropertyKey(UI_PKEY_DarkModeRibbon), PropValue);
    PropertyStore.Commit;
    FDarkMode := True;
  end;
end;

But calling this makes no difference.  All the other colouring functions have been retained and work, but not this one. Anyone have any idea how to get the ribbon into dark mode please?

I've just updated my version to the latest and have found the the TRibbonApplicationModes set has been removed from UIRibbon.Pas. As far as I can see there is now no way of querying what ApplicationModes are currently deployed.

Seems like an odd feature removal. I query these quite a lot. Presumably, you are now expected to keep track of the Application modes yourself. Am I missing something here?

Thanks Peter. That worked a treat.

I'm working on a component derived from a TTabControl. I want to manipulate the individual tabs in various ways. To do so I need to override the DrawTab event. This works well until you activate a theme and then the DrawTab event doesn't fire unless you disable seClient for styleElements., which I don't wish to do as I don't want to have to try and draw the body.

 If I add a TTabControl to a form and then access its OnDrawTab event, I can override the themed drawing of the tab with a theme active even though seClient styleElements is true.  

That seems a bit odd to me.

I have tried catching various paint messages and tab drawing messages, but nothing seems to fire in my custom control with seClient set to true.

Is there a way of doing this? 

On 5/10/2025 at 10:09 AM, Olli73 said:

How looks the code for the creation of the query?

I posted this a day or so ago. Its disappeared! Thanks for the perseverance. I've given up hope of finding out what's causing this. The FindConnection kludge seems to do the job!

20 hours ago, Olli73 said:

What is the setting for Connection.ResourceOptions.KeepConnection ?

 

It's the default ie true

15 hours ago, Olli73 said:

What is the setting for Connection.ResourceOptions.KeepConnection ?

 

The TFDManager's resourceOptions.KeepConnection is the default, which I have tested and is true.

1 hour ago, Zoran Bonuš said:

Setting SQL forces the FDQuery to close. My guess is that in combination with pooled connection, it might release the connection too. 

That makes sense. Then presumably calling execute reopens the connection, but this is not happening in this case due to the breach of the specific constraint?

1 hour ago, Zoran Bonuš said:

Have you tried setting the SQL before starting the transaction 

 

 

I haven't tried setting the SQL before starting the transaction. As there are a series of transactions with rollback on fail, it needs to come after StartTransaction.

1 hour ago, Zoran Bonuš said:

or even setting the FDQuery.Connection ?

Is that not what the additional code I added (FindConnection) does?

1 hour ago, Zoran Bonuš said:

You might try to debug and trace into the line where you set the SQL to see what after-effects it has in your context.

I've tried debugging, tracing, around the setting of the SQL it provides no information whatsoever. 

Thinking about it, it seems that the most sensible thing to do is to check in the finally block whether or not the connection has been dropped and restore it with FindConnection if needs be before calling commit or rollback,

Thanks for the insight.

I am using FireDAC component within an ISAPI DLL to access a PostgreSQL database

I create the FDMAnager component on startup:

FDManager := TFDManager.Create(Nil);
        with FDManager do
        begin
          ResourceOptions.SilentMode := true;
          ResourceOptions.AutoReconnect := true;
          UpdateOptions.CheckRequired := true;
          UpdateOptions.CheckReadOnly := false;
          UpdateOptions.CheckUpdatable := false;
          AddConnectionDef(FD_POOLED_CONN, 'PG', oParams);
          FDManager.Active := true;
        end;

Each function then creates a TFDQuery component as required and connects to the pooled connection. I then commence a series of transactions within a try...finally block with a rollback if one of the transaction fails. This works fine except I am encountering odd behaviour within one of the transactions. The connection is lost after setting the query's sql.text property even though there is no error when actually setting the query. I get an error when executing the query and this is due to my client app providing the wrong data. This I can fix. I am more concerned as to why the setting of the query property should cause the connection to be lost without without an error being triggered. The relevant code is:

try
	With FDQuery do
	begin
  		Connection.StartTransaction;

            if length(insertArr) > 0 then
            begin
              AddToLog('1 Before call queryConnection assigned=' +
                ord(assigned(Connection)).ToString, leDevelopment); ///connection assigned here
             
              try
                SQL.Text :=
                  'INSERT INTO doc_cat_profiles_detail (doc_cats_id,  priority, '
                  + 'auto_disclose, profile_id) VALUES(:DOCCAT, :PRIORITY, :AUTOD, :PROFID)';
                AddToLog('SET SQL OK', leDevelopment); //quuery sets fine here
              except
                on E: Exception do
                  AddToLog('Exception while setting SQL: ' + E.Message,
                    leCriticalError);
              end;
                        
              AddToLog('2 Before call query Connection assigned=' +
                ord(assigned(Connection)).ToString, leDevelopment); //Connection is lost here

              Params.BindMode := pbByNumber;
              Params[0].DataType := ftInteger;
              Params[1].DataType := ftInteger;
              Params[2].DataType := ftSmallInt;
              Params[3].DataType := ftInteger;
            
              Params.ArraySize := length(insertArr);

			  for i := 0 to high(insertArr) do
              begin
                Params[0].AsIntegers[i] := Profile[insertArr[i]].doc_cat;
                Params[1].AsIntegers[i] := Profile[insertArr[i]].Priority;
                Params[2].AsSmallInts[i] := Profile[insertArr[i]].auto_disclose;
                Params[3].AsIntegers[i] := Profile[insertArr[i]].profile_id;                
              end;

              try
                execute(Params.ArraySize);
              except
                on E: Exception do
                begin
                  AddToLog('SaveCategoriesAndProfile - Failed on insert new profile detail'
                    + '. ' + E.Message, leCriticalError);
                  Success := false;
                  exit;
                end;
              end;
            end;

		 Success := true;
       finally
            if Success then
            begin
              Connection.Commit;
              SetResponse(Response, 200, 'Success');
            end
            else
            begin
              if Connection.InTransaction then
                Connection.Rollback;
               SetResponse(Response, 500, 'Internal Server Error',
                  'SaveCategoriesAndProfile failed', leCriticalError);
            end;
		end;

The query executes with this error: :insert or update on table "doc_cat_profiles_detail" violates foreign key constraint "ct_delete_prof_details".

II am providing invalid profile-ids in the client app. This I can sort. But I can't figure out why setting the SQL.Text property is causing the connection to drop. A FireDAC trace shows nothing. The PostgreSQL log logs the error re the foreign key constraint, but mention no loss of connection.

I've added code following the setting of the sql.text:

              if not assigned(Connection) then
              begin
                Connection := FDManager.FindConnection('pooled_connection');
                // Restore the connection
                AddToLog('Connection re-assigned after SQL.Text!',
                  leDevelopment);
              end;

This appears to solve this particular issue, but I am concerned that I may encounter this issue elsewhere in my DLL (which is chunky) and, as it effectively causes the DLL to hang in terms of database communication that could be a major issue.

7 hours ago, PeterBelow said:

Looks like the GetAdminSection function does not return an automation-compatible interface. Can you check what VarType the returned OleVariant has?

The code I am using was an example I got off the web. Can't even remember where now! Can't fund the MS documentation for it although I can find the documentation for the Application Host Administration Interface.

If I change the call as follows:

Site := ServerManager.GetAdminSection('sites', 'system.applicationHost/');

I then get an error advising that the first parameter is not a valid section path in the config file. So I think the return value of an OLEVariant is okay. I think the problem lies with the parameters passed to the function. I think the first param is correct 'system.applicationHost/sites'. I think it is the second param that is causing the problem:'MACHINE/WEBROOT/APPHOST'.

The second param is already declared in  the call to:

 ServerManager.CommitPath := 'MACHINE/WEBROOT/APPHOST';

That is that is the path to the config file.

The MS documentation for the Application Host Administration Interface states it relates to IIS7 and IIS8 and I am using IIS10, but can't find later documentation and I have tested it a little with IIS10 and seems to work. The documentation declares the GetAdminSection function as

HRESULT GetAdminSection(  
   [in,  
   string] BSTR bstrSectionName,  
   [in,  
   string] BSTR bstrPath,  
   [out,  
   retval] IAppHostElement** ppAdminSection  
);  

Calling the function as:

GetAdminSection('system.applicationHost/', 'MACHINE/WEBROOT/APPHOST', SitesSection);

Results in a run time error that there are too many parameters. This works using thee imported type library, but not as an OLE call. That would suggest that the second parameter in the OLE call is also correct. 

As you can probably see I am floundering! I guess I will have to work with the rather yuk interface! Thanks for your help.

14 hours ago, Vincent Parrett said:

There is a type library you can import - would save a lot of casting C:\Windows\System32\inetsrv\nativerd.dll

 

It's a pretty awful api to work with, it's been a while since I looked at it - Microsoft created a pretty extensive dotnet wrapper for it - https://www.nuget.org/packages/Microsoft.Web.Administration you could download the nuget package and use Ilspy to have a look at it - might help

I had started to go down this route. I'm using the 64 bit type library, which is even more of a pain to use. It does seem to work however. Thanks for the reference to the dotnet wrapper.

On 1/6/2025 at 12:06 PM, PeterBelow said:

Try

Result := not (VarIsClear(OleObject) or VarIsEmpty(OleObject) or VarIsNull(OleObject)) and (VarType(OleObject) = VT_DISPATCH);

 

Same result. It reports true for Server Manager, but then fails with the variant does not reference... error on the call to ServerManager.GetAdminSection.

I cannot understand why the following code does not work:

function IsOleObjectActive(OleObject: OleVariant): Boolean;
begin
  Result := not VarIsClear(OleObject) and not VarIsEmpty(OleObject) and not VarIsNull(OleObject);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ServerManager: OleVariant;
  Site: OleVariant;
  AppPool: OleVariant;
  Security: OleVariant;
begin
  // Initialize COM library
  CoInitialize(nil);
  try
    // Create an instance of the ServerManager object
    ServerManager := CreateOleObject
      ('Microsoft.ApplicationHost.WritableAdminManager');

    ServerManager.CommitPath := 'MACHINE/WEBROOT/APPHOST';

    // Add a new site
    Site := ServerManager.GetAdminSection('system.applicationHost/sites',
      'MACHINE/WEBROOT/APPHOST');

-    if IsOleObjectActive(Site) then
      Showmessage('Active')
	 else
		exit;

    Site := Site.Collection.AddElement('site'); //FAILS HERE
    
	Site.Properties.Item('name').Value := trim(eSiteName.text);
    
    // Site.Properties.Item('id').Value := 2;
    Site.Properties.Item('physicalPath').Value := 'C:\inetpub\wwwroot\' + trim(ePhysicalPath.text);
    
    // Configure bindings
    Site.Bindings.Collection.AddElement('binding');
    Site.Bindings.Collection.Item(0).Properties.Item('protocol').Value
      := 'http';
    Site.Bindings.Collection.Item(0).Properties.Item('bindingInformation').Value
      := '*:80';

   
    Site.Bindings.Collection.AddElement('binding');
    Site.Bindings.Collection.Item(1).Properties.Item('protocol').Value
      := 'https';
    Site.Bindings.Collection.Item(1).Properties.Item('bindingInformation').Value
      := '*:443';
    
    // Add an application pool
    AppPool := ServerManager.GetAdminSection
      ('system.applicationHost/applicationPools', 'MACHINE/WEBROOT/APPHOST');
    AppPool := AppPool.Collection.AddElement('add');
  	AppPool.Properties.Item('name').Value := trim(eSiteName.text);
    AppPool.Properties.Item('managedRuntimeVersion').Value :=
      trim(eNetFramework.text);

    // Assign the application pool to the site
    Site.Applications.Collection.Item(0).Properties.Item('applicationPool')
      .Value := trim(eSiteName.text);
    
    // Commit the changes
    ServerManager.CommitChanges;
  finally
    // Uninitialize COM library
    CoUninitialize;
  end;

When I try to add the new site I get "Variant does not reference an automation object." 

I've tried adding the application pool first, but same problem.

As far as I can see the section names are correct as per the applicationHost.config file and all functions, properties are correct as per the nativerd.dll.

I've also tried running the app in elevated mode. Makes no difference.

1. But that will give me the textextent of the caption as it appears on a tpanel, not as it appears on the title bar. I assume these can be different depending on the theme.

2. Can't see how TMessageForm helps. Don't see that it addresses the theming issue.

I create a themed form on the fly. The form caption varies each time. I am trying to set the form width to a sufficient size so that the caption is displayed in full.

I can't see any easy way of doing this. I'm guessing I have to analyse all the elements on the title bar and go from there.

Starting with the text extent of the desired caption:

var
  Canvas: TCanvas;
  s: string;
  r: TRect;
  t: TTextFormat;
begin
  s := caption;

  Canvas := TCanvas.Create;
  try
    Canvas.Handle := GetDC(0);

    TStyleManager.ActiveStyle.GetTextExtent(Canvas.Handle, teTextLabel,
      s, t, r);

  finally
    ReleaseDC(0, Canvas.Handle);
  end;

First, I cannot work out which themed element represents the title bar caption. It has to be within the range [teCategoryButtons..teTextLabel]] ie:

teCategoryButtons,
teCategoryPanelGroup,
teCheckListBox,
teControlBar,
teDataNavButtons,
teGrid,
teHint,
tePanel,
teTabSet,
teTextLabel,

I've opted for teTextLabel, but have no idea if this is right.

Secondly, the code does not compile. "No overloaded version of GetTextExtent...". I don't understand why. GetTextExtent is declared as:

function GetTextExtent(DC: HDC; Details: TThemedElementDetails; const Text: string;
      Flags: TTextFormat; out ExtentRect: TRect): Boolean; overload;

Assuming I can get this to work and correctly calculate the required text width for the title bar, I guess I then have to work out the width required for all other elements on the title bar and set form width accordingly. 

It will probably take me the rest of my limited remaining years to work out how to query all the other elements on the title bar. 

Can anyone suggest a simpler way of achieving this?

I've moved to a new laptop running Windows 11.

I installed from the downloaded ISO.

I'm missing the help files.

When I go into Manage Platform (to try and switch off dark mode), I am told that setup cannot continue due to a corrupted installation file.

How can I get the help files please and is there a way of fixing the corrupted file?

That was ir. Must have inadvertently deleted it. Thanks

Just revisited a project after a few days away. Now, for one of the units in the project, when I toggle F12 to show its form, nothing happens. The menu item "Toggle Form/Unit is also disabled. It is only this one form and not any others that has this issue. I am  not aware of any changes I may have made last time that could be causing this issue.

When I view the project source, I can see that the unit is listed but it doesn't have its form listed after it like all the other project units that have associated forms. I assume that somehow the form's connection to the unit has been lost.

Restore in 'Restore.pas' {frmRestore},
Reconciler in 'Reconciler.pas' {frmReconciler},
Settings in 'Settings.pas';

I have tried removing the unit and re-adding it to the project, but that does nothing.

Anyone have any idea what might be causing this and how I can fix it?

Thanks

I have a licence for Delphi 10 through to 11.0. I haven't renewed my subscription since then.

I'm trying to move my Delphi to a new laptop. When try and download any version within the above range from Embarcadero I am simply advised that I haven't renewed my subscription and the download is declined.

I'm guessing there must be some way of doing this. Can anyone help please?

Ran some tests on an in memory dataset of 25K records.

Without filter 31ms to iterate the whole dataset (whilst also querying each record to see if it matched the required "document_category_id)." .

Filtering first took twice as long to filter and iterate  even though the resulting dataset was only 30 records. That sort of answers my question. But would this still hold true with say a million plus records?

I need to work with a potentially large dataset in memory. It has an integer field called "document_category_id". On first loading the table it is sometimes necessary to update records in the table from one document_category_id to another. This might need to be done for several, but not all of the various document_category_ids.

Trying to work out what is the most efficient way of iterating.

Would it be more efficient to filter on the requored document_category_ids first and then iterate or to iterate on an unfiltered table?

Managed to work out a solution in the end. Sure there will be some issues I haven't considered, but seems to work ok. If anyone is interested here's the code:

procedure TForm3.TabControl2DrawTab(Control: TCustomTabControl;
  TabIndex: Integer; const Rect: TRect; Active: Boolean);
  var
    TabName:String;
    Pt : TPoint;
    R: TRect;
    TabUnderMouse:Integer;


begin
  Pt := TabControl2.ScreenToClient(Mouse.CursorPos);
  TabUnderMouse := TabControl1.IndexOfTabAt(Pt.X, Pt.Y);

  with (Control as TTabControl).canvas do
    begin
      R := Rect;

      if TabIndex=1 then
        Font.Style := [fsStrikeout];

      if (TabUnderMouse = TabIndex)and Active  then
        Font.Color := TStyleManager.ActiveStyle.GetStyleFontColor(sfTabTextActiveHot)
      else if Active then
        Font.Color := TStyleManager.ActiveStyle.GetStyleFontColor(sfTabTextActiveNormal)
      else if (TabUnderMouse = TabIndex) then
        Font.Color := TStyleManager.ActiveStyle.GetStyleFontColor(sfTabTextInActiveHot)
      else
        Font.Color := TStyleManager.ActiveStyle.GetStyleFontColor(sfTabTextInActiveNormal);

      tabName := TTabControl(Control).Tabs[TabIndex];

      Brush.Style := bsClear;

      DrawText(Handle, PChar(TabName), Length(TabName), R,  DT_SINGLELINE or DT_VCENTER or DT_CENTER)
  end;
end;