Jump to content

Renate Schaaf

Members
 View Profile  See their activity

  • Content Count

    136

  • Joined

  • Last visited

  • Days Won

    5

Posts posted by Renate Schaaf

  1. Posted

    Meanwhile I've followed your suggestions and rewrote the algorithm so it writes one line at a time. Sadly, I couldn't give SuperDuper a chance to shine, as I would need to transpose memory in chunks of 16 Bytes instead of 4. Still, it got a little faster, and since both unthreaded routines are faster than Graphics32, I don't think I'm doing so badly.

    For the threaded version I used

    On 4/12/2021 at 5:23 PM, Fr0sT.Brutal said:

    A

    B

    C

    D

    with a minimum of 2 and a maximum of 8 threads. Is rather fast if it works.

    Sadly the fails for the tasks version became, if anything, more frequent, and a Tparallel.for version hung indefinitely a few times. I failed to completely recover from the timeouts, after a fail the next call would likely fail again.

     

    So, finally I just set up 8 oldfashioned threads which wake up as needed, do a chunk of the work as needed and  signal that they're done.  I didn't even bother to put in checks for timeouts. It's the fastest yet and has never failed so far. Guess that is a strong indication that the culprit was TTask. If you are curious, here is a 720x540 video that got written at 40 FPS, a new record for me 🙂. Once I do similar optimizations for the transitions, the writing speed might be acceptable.

     

    Thanks again to all!

  2. Posted

    53 minutes ago, Anders Melander said:

    I can't see why the intermediate buffer would need to be a bitmap; It's just a chunk of memory.

    W and Height are the size in byte of the memory chunk? Do you transpose byte by byte, I guess not, wouldn't make any sense for bgra-records. Well, I need to play around with it. Pity I don't read ASM. Is this for 32bit only?

     

    Thanks 🙂

     

     

  3. Posted

    5 hours ago, Dalija Prasnikar said:

    In that case AnonymousThread approach can be good enough

    It isn't, the creation of the threads takes too long, in the end the procedure takes about twice the time of the unthreaded one. I would really hate to have to use the approach with waking up existing threads to do the resampling ...

     

    5 hours ago, Dalija Prasnikar said:

    and that using no timeout would just hang indefinitely (it might be worth trying, though)

    I introduced the timeout, because the first time this happened, I had to kill the application.

     

    I am right to assume then, that there isn't anything obviously wrong in my approach which would cause the timeout?

    5 hours ago, Anders Melander said:

    While this isn't related to your threading problem, it seems you are processing the bitmap by column instead of by row.

    This is true for the target, and to a degree of the source, too. But the intermediate Columnx is in fact a "row" the way it's allocated. But you are right; and maybe one can get away without the transposing. Also, if the intermediate storage is a TBitmap, the algorithms wouldn't be "symmetric" anymore, the transpose of the target wouldn't be the same as the target of the transpose, but that's probably just nitpick.

    Anyway, if you'd care to share the code for the transposing, I'd be glad.

     

    5 hours ago, Anders Melander said:

    Another thing to be aware of when multiple threads read or write to the same memory is that if two threads read and write to two different locations, but those two locations are within the same cache line, then you will generally get a decrease in performance as the cores fight over the cache line. 

     

    2 hours ago, M.Joos said:

    Indeed, this is then called "false sharing"

    I didn't know that. Thanks. Another point in favor of doing complete rows first, or to have the threads compute chunks of full rows.

     

    Thank you all, I have a lot to do.

  4. Posted

    37 minutes ago, Dalija Prasnikar said:

    But, if you are resampling video frames, that suggests that you are resizing same sized frames to same output size. In that case, calculating contributor weights for each frame again is huge waste. Calculate that once, and then just reuse it.

    Good idea, but I'm doing zoom-pans, the fixed resizing I leave to the video-encoder to do.

    I want to be reasonably sure that this runs on any system, not just mine .. Time to do some more stress tests 🙂

  6. Posted · Edited by Renate Schaaf

    I agree that it isn't very nice to just dump the source code here. So here is the explanation:

     

    In the routines, nevermind SourceRect, imagine it to be the full rect of the source bitmap.
    The Radius isn't important either.

    Contributors:

    For pixel(x,y) in the target, ContribsX[x] is a record, that defines the range of x-Values of pixels in the source, which contribute to the value of p(x,y).
    The record also contains the weights which have to be applied before summing up.
    The further away from the center of the range, the lower the weight (simplified).
    The range and the weights are independent of y, so the array ContribsX is computed in advance.

    ContribsY[y] does the same for the source pixels in y-direction.

    The way the contributors are computed isn't important here, it's done outside of the tasks.

     

    Pseudo-Code for computing p(x,y): (ps is a source pixel)
    (Imagine the weights to be floats, and results being rounded) 

    p(x,y) := 0;
for i:=0 to ContribsX[x].high do
  for j:= 0 to ContribsY[y].high do
     p(x,y) := p(x,y) + ContribsX[x].Weights[i] * ContribsY[y].Weights[j] * ps(ContribsX[x].min + i, ContribsY[y].min + j);

    Since this isn't very efficient and can't well be divided into tasks, the averaging in x- and y-direction is done separately.

    Here's where the routine ProcessColumn comes in, it's the most important procedure, and it writes one column of the target bitmap's memory in 2 steps:

    Resample.thumb.png.81c18cb67996130463688c997bf59e92.png

    PseudoCode for ProcessColumn:  (x is given, Compute Column at x)

    Step 1: resample to intermediate array ColumnX: 

    for ys:= 0 to OldHeight-1 do
begin
  ColumnX[ys] := 0;
  for i:=0 to ContribsX[x].high do
   ColumnX[ys] := ColumnX[ys] + ContribsX[x].Weights[i]*ps(ContribsX[x].min +i, ys);
end;

    Step 2: resample ColumnX to the target column: 

    for y := 0 to NewHeight-1 do
begin
  p(x,y):=0;
  for j := 0 to ContribsY[y].high do
    p(x,y) := p(x,y) + ContribsY[y].Weights[j]*ColumnX[ContribsY[y].min + j];
end;

    The tasks just write 4 different chunks of colums, but they all read from the same source-bitmap-memory and from the same contributor-arrays.

    tasks.png.e5772c5811206d0dd3f68ca7d0c4d4d0.png

    The original source code is obfuscated by (at least:) 2 things:

       Values that should be float have been scaled to integers
       Pointers are used to walk along the arrays

     

    I'm afraid that's still too long.  ..Make it shorter ...Again, half the size

     

    Gruß, Renate

  7. Posted

    13 minutes ago, Anders Melander said:

    Instead of just posting your source and let us figure out what you're doing, it would be nice if you instead described exactly what your doing. I.e. what does the overall job do (e.g. it resamples a bitmap), how does it do that (describe the algorithm), how are you dividing the job, what does your individual tasks do, etc. Describe it as if we didn't have the source. This is basically also what your source comments should do.

    I'll try but it ain't easy. More than 10 years ago I spent days reading your code, before I understood what made it tick 🙂

  8. Posted

    I've tried to divide the work for resizing bitmaps into 4 parallel tasks. The result is, on average, a speed improvement by 60%, the bicubic resampler gets close to StretchBlt/Halftone. I'm using the routine for writing videos, where it is called at least once for every video frame. So, in my tests I must have called it at least 100 000 times. Problem is, that 3 times there was a timeout in TTask.WaitForAll.

    I'm not using any synchronization, because

     

    The tasks are completely independent of each other, i.e. none alters anything that the other uses.

    They write to memory chunks, which do not overlap.

    They don't use any VCL-code, not even VCL.Graphics.

    The memory they read does overlap, but I thought that was OK, but after reading up a bit, I get the impression that I am wrong here.

     

    From what I gather, I have a "race condition" caused by "not atomic reads" (this is all very new to me, sorry, if I'm talking rubbish).

    The threads are (among other things) all reading from two contributor-arrays, which contain records of varying size, so could that be it?

    What can I do to prevent the error?

    Maybe I should make copies of the arrays for each task?

     

    Here is the unit, it only uses a bicubic filter to make things a little simpler: 

    unit uResample;

interface

uses WinApi.Windows, System.Types, VCL.Graphics, System.SysUtils,
  System.Classes, System.Math;

type
  TZoomProcedure = procedure(const Source, Target: TBitmap; SourceRect: TRectF;
    Radius: single);

  // "bicubic" resampler based on ideas by Anders Melander, Mike Lischke
  // and Eric Grange. It supports float values for filter radii and float-valued
  // zoom rectangles. Source, Target should be pf32bit. Target must be set to the
  // correct size.
procedure ZoomResample(const Source, Target: TBitmap; SourceRect: TRectF;
  Radius: single);

// Same as above divided into 4 parallel tasks
procedure ZoomResampleParallel(const Source, Target: TBitmap;
  SourceRect: TRectF; Radius: single);

implementation

uses WinApi.MMSystem, VCL.Dialogs, System.SyncObjs, System.Threading;

type

  TContributor = record
    min, High: integer;
    // Min: start source pixel
    // High+1: number of source pixels to contribute to the result
    Weights: array of integer; // doubles scaled by $800
  end;

  TContribArray = array of TContributor;

  TBGRAInt = record
    b, g, r, a: integer;
  end;

  PBGRAInt = ^TBGRAInt;

  TBGRAIntArray = array of TBGRAInt;

const
  beta = 0.525; // f(beta)=0
  beta2 = beta * beta;
  alpha = 105 / (16 - 112 * beta2);
  aa = 1 / 7 * alpha;
  bb = -1 / 5 * alpha * (2 + beta2);
  cc = 1 / 3 * alpha * (1 + 2 * beta2);
  dd = -alpha * beta2;
  // constants computed with maple for polynomial fit

function AntiFilter(X: double): double; inline;
// Antiderivative of a filter function similar to bicubic, but I like it better
begin
  if X < -1 then
    Result := -0.5
  else if X < 1 then
    Result := aa * X * X * X * X * X * X * X + bb * X * X * X * X * X + cc * X *
      X * X + dd * X
  else
    Result := 0.5;
end;

procedure MakeContributors(r: single; SourceSize, TargetSize: integer;
  SourceStart, SourceFloatwidth: double; var Contribs: TContribArray);
// r: Filterradius
var
  xCenter, scale, rr: double;
  X, j: integer;
  x1, x2, delta: double;
  TrueMin, TrueMax, Mx: integer;
begin
  Assert(TargetSize > 0);
  if SourceFloatwidth = 0 then
    SourceFloatwidth := SourceSize;
  scale := SourceFloatwidth / TargetSize;
  SetLength(Contribs, TargetSize);

  if scale > 1 then
    // downsampling
    rr := r * scale
  else
    rr := r;
  delta := 1 / rr;

  for X := 0 to TargetSize - 1 do
  begin
    xCenter := (X + 0.5) * scale;
    TrueMin := Ceil(xCenter - rr + SourceStart - 1);
    TrueMax := Floor(xCenter + rr + SourceStart);
    Contribs[X].min := min(max(TrueMin, 0), SourceSize - 1);
    // make sure not to read in negative pixel locations
    Mx := max(min(TrueMax, SourceSize - 1), 0);
    // make sure not to read past w-1 in the source
    Contribs[X].High := Mx - Contribs[X].min;
    Assert(Contribs[X].High >= 0);
    // High=Number of contributing pixels minus 1
    SetLength(Contribs[X].Weights, Contribs[X].High + 1);
    with Contribs[X] do
    begin
      x1 := delta * (min - SourceStart - xCenter);
      for j := 0 to High do
      begin
        x2 := x1 + delta;
        Weights[j] := round($800 * (AntiFilter(x2) - AntiFilter(x1)));
        x1 := x2;
      end;
      for j := TrueMin - min to -1 do
      begin
        // assume the first pixel to be repeated
        x1 := delta * (min + j - SourceStart - xCenter);
        x2 := x1 + delta;
        Weights[0] := Weights[0] +
          round($800 * (AntiFilter(x2) - AntiFilter(x1)));
      end;
      for j := High + 1 to TrueMax - min do
      begin
        // assume the last pixel to be repeated
        x1 := delta * (min + j - SourceStart - xCenter);
        x2 := x1 + delta;
        Weights[High] := Weights[High] +
          round($800 * (AntiFilter(x2) - AntiFilter(x1)));
      end;
    end; { with Contribs[x] }
  end; { for x }
end;

// This writes one column in the target
procedure ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight: integer;
  rStart, rTStart: PByte; runstart: PBGRAInt;
  const ContribsX, ContribsY: TContribArray); inline;
var
  ps, pT: PRGBQuad;
  rs, rT: PByte;
  y, xs, ys: integer;
  highx, highy, minx, miny: integer;
  WeightxStart, Weightx, Weighty: PInteger;
  Total: TBGRAInt;
  run: PBGRAInt;
begin
  rs := rStart;
  highx := ContribsX[X].High;
  minx := ContribsX[X].min;
  inc(rs, 4 * minx);
  WeightxStart := @ContribsX[X].Weights[0];
  run := runstart;
  // runstart points to Columnx[0]
  // Colmnx stores the result of the resampling in x-direction
  for y := ymin to ymax do
  begin
    // For each source line at y
    // Sum up weighted color values at source pixels ContribsX[x].Min+xs
    // 0<=xs<=ContribsX[x].High
    // and store the results in Columnx[y-ymin] etc.
    ps := PRGBQuad(rs);
    Weightx := WeightxStart;
    FillChar(run^, SizeOf(run^), 0);
    for xs := 0 to highx do
    begin
      inc(run.b, Weightx^ * ps.rgbBlue);
      inc(run.g, Weightx^ * ps.rgbGreen);
      inc(run.r, Weightx^ * ps.rgbRed);
      inc(run.a, Weightx^ * ps.rgbReserved);
      inc(Weightx);
      inc(ps);
    end;
    inc(run);
    dec(rs, Sbps);
  end;
  // Average in y-direction:
  // For each target line y sum up weighted colors in
  // Columnx[ys+ContribsY[y].Min-ymin], 0<=ys<=ContribsY[y].High
  // Store result in Total
  // round and assign to TargetPixel pt at [x,y]
  rT := rTStart;
  for y := 0 to NewHeight - 1 do
  begin
    pT := PRGBQuad(rT);
    inc(pT, X);
    highy := ContribsY[y].High;
    miny := ContribsY[y].min - ymin;
    Weighty := @ContribsY[y].Weights[0];
    run := runstart;
    inc(run, miny);
    FillChar(Total, SizeOf(Total), 0);
    for ys := 0 to highy do
    begin
      inc(Total.b, Weighty^ * run.b);
      inc(Total.g, Weighty^ * run.g);
      inc(Total.r, Weighty^ * run.r);
      inc(Total.a, Weighty^ * run.a);
      inc(Weighty);
      inc(run);
    end;
    Total.r := max(Total.r, 0);
    Total.g := max(Total.g, 0);
    Total.b := max(Total.b, 0);
    Total.a := max(Total.a, 0);
    // results could be negative, filter has negative values
    Total.r := (Total.r + $1FFFFF) shr 22; // "round" the result
    Total.g := (Total.g + $1FFFFF) shr 22;
    Total.b := (Total.b + $1FFFFF) shr 22;
    Total.a := (Total.a + $1FFFFF) shr 22;
    pT.rgbBlue := min(Total.b, 255);
    pT.rgbGreen := min(Total.g, 255);
    pT.rgbRed := min(Total.r, 255);
    pT.rgbReserved := min(Total.a, 255);
    dec(rT, Tbps);
  end; // for y
end;

procedure ZoomResampleParallel(const Source, Target: TBitmap;
  SourceRect: TRectF; Radius: single);
var
  ContribsX, ContribsY: TContribArray;

  OldWidth, OldHeight: integer;
  NewWidth, NewHeight: integer;

  Sbps, Tbps: integer;
  rStart, rTStart: PByte; // Row start in Source, Target
  ymin, ymax, i: integer;
  tasks: array [0 .. 3] of ITask;
  Chunk: integer;
begin
  Source.PixelFormat := pf32bit;
  Target.PixelFormat := pf32bit; // for safety
  // Target needs to have been set to correct size
  NewWidth := Target.Width;
  NewHeight := Target.Height;
  OldWidth := Source.Width;
  OldHeight := Source.Height;

  Tbps := ((NewWidth * 32 + 31) and not 31) div 8;
  // BytesPerScanline Target
  Sbps := ((OldWidth * 32 + 31) and not 31) div 8;
  // BytesPerScanline Source

  MakeContributors(Radius, OldWidth, NewWidth, SourceRect.Left,
    SourceRect.Right - SourceRect.Left, ContribsX);
  MakeContributors(Radius, OldHeight, NewHeight, SourceRect.Top,
    SourceRect.Bottom - SourceRect.Top, ContribsY);
  ymin := ContribsY[0].min;
  ymax := ContribsY[NewHeight - 1].High + ContribsY[NewHeight - 1].min;

  rStart := Source.ScanLine[ymin];
  rTStart := Target.ScanLine[0];

  Chunk := NewWidth div 4;

  // stupid repetion!
  tasks[0] := TTask.create(
    procedure
    begin
      var
        Columnx: TBGRAIntArray; // Stores averaged x-Contributors
      var
        X, xmin, xmax: integer;
      var
        runstart: PBGRAInt;
      SetLength(Columnx, ymax - ymin + 1);
      runstart := @Columnx[0];
      xmin := 0;
      xmax := Chunk - 1;
      for X := xmin to xmax do
        ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight, rStart, rTStart,
          runstart, ContribsX, ContribsY);
    end);

  tasks[1] := TTask.create(
    procedure
    begin
      var
        Columnx: TBGRAIntArray;
      var
        X, xmin, xmax: integer;
      var
        runstart: PBGRAInt;
      SetLength(Columnx, ymax - ymin + 1);
      runstart := @Columnx[0];
      xmin := Chunk;
      xmax := 2 * Chunk - 1;
      for X := xmin to xmax do
        ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight, rStart, rTStart,
          runstart, ContribsX, ContribsY);
    end);

  tasks[2] := TTask.create(
    procedure
    begin
      var
        Columnx: TBGRAIntArray;
      var
        X, xmin, xmax: integer;
      var
        runstart: PBGRAInt;
      SetLength(Columnx, ymax - ymin + 1);
      runstart := @Columnx[0];
      xmin := 2 * Chunk;
      xmax := 3 * Chunk - 1;
      for X := xmin to xmax do
        ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight, rStart, rTStart,
          runstart, ContribsX, ContribsY);
    end);

  tasks[3] := TTask.create(
    procedure
    begin
      var
        Columnx: TBGRAIntArray;
      var
        X, xmin, xmax: integer;
      var
        runstart: PBGRAInt;
      SetLength(Columnx, ymax - ymin + 1);
      runstart := @Columnx[0];
      xmin := 3 * Chunk;
      xmax := NewWidth - 1;
      for X := xmin to xmax do
        ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight, rStart, rTStart,
          runstart, ContribsX, ContribsY);
    end);

  for i := 0 to 3 do
    tasks[i].start;
  if not TTask.WaitForAll(tasks, 10000) then
    Raise exception.create('Time out for parallel resampling threads');
end;

procedure ZoomResample(const Source, Target: TBitmap; SourceRect: TRectF;
Radius: single);
var
  ContribsX, ContribsY: TContribArray;

  OldWidth, OldHeight: integer;
  NewWidth, NewHeight: integer;
  // Target needs to be set to correct size

  Sbps, Tbps: integer;
  rStart, rTStart: PByte; // Row start in Source, Target
  Columnx: TBGRAIntArray; // cache array, records for better memory layout
  X, ymin, ymax: integer;
  runstart: PBGRAInt;
begin
  Source.PixelFormat := pf32bit;
  Target.PixelFormat := pf32bit; // for safety
  NewWidth := Target.Width;
  NewHeight := Target.Height;
  OldWidth := Source.Width;
  OldHeight := Source.Height;

  Tbps := ((NewWidth * 32 + 31) and not 31) div 8;
  // BytesPerScanline Target
  Sbps := ((OldWidth * 32 + 31) and not 31) div 8;
  // BytesPerScanline Source

  MakeContributors(Radius, OldWidth, NewWidth, SourceRect.Left,
    SourceRect.Right - SourceRect.Left, ContribsX);
  MakeContributors(Radius, OldHeight, NewHeight, SourceRect.Top,
    SourceRect.Bottom - SourceRect.Top, ContribsY);
  ymin := ContribsY[0].min;
  ymax := ContribsY[NewHeight - 1].High + ContribsY[NewHeight - 1].min;

  rStart := Source.ScanLine[ymin];
  rTStart := Target.ScanLine[0];

  SetLength(Columnx, ymax - ymin + 1);

  runstart := @Columnx[0];

  // Compute colors for each target column at x
  for X := 0 to NewWidth - 1 do
  begin
    ProcessColumn(X, ymin, ymax, Sbps, Tbps, NewHeight, rStart, rTStart,
      runstart, ContribsX, ContribsY);
  end; // for x
end;

end.

     

  9. Posted

    16 minutes ago, Anders Melander said:

    I guess I'll take a look at it when my VTune trial expires.

    That would be great. Here are some relevant lines of the log file, I doubt they are of any use, though:

      

    2021.04.08	14:23:10.909	#DEBUG	#PeFile::Open	#PeFile.cpp(111)	#Executable (PE) C:\Windows\SysWOW64\ntdll.dll opened
2021.04.08	14:23:10.137	#DEBUG	#PeFile::InitializeSymbolEngine	#PeFile.cpp(699)	#Executable (PE) C:\Windows\SysWOW64\ntdll.dll started Symbol Engine initialization
2021.04.08	14:23:10.752	#DEBUG	#PeFile::InitializeSymbolEngine	#PeFile.cpp(751)	#Executable (PE) C:\Windows\SysWOW64\ntdll.dll initialized Symbol Engine: PDB
2021.04.08	14:23:10.662	#DEBUG	#PeFile::Open	#PeFile.cpp(111)	#Executable (PE) D:\DelphiSource\DelphiRio\mystuffR\uProfTest\Win32\Debug\uProfTest.exe opened
2021.04.08	14:23:10.945	#DEBUG	#PeFile::InitializeSymbolEngine	#PeFile.cpp(699)	#Executable (PE) D:\DelphiSource\DelphiRio\mystuffR\uProfTest\Win32\Debug\uProfTest.exe started Symbol Engine initialization
2021.04.08	14:23:10.113	#DEBUG	#PeFile::InitializeSymbolEngine	#PeFile.cpp(758)	#Executable (PE) D:\DelphiSource\DelphiRio\mystuffR\uProfTest\Win32\Debug\uProfTest.exe failed to initialize Symbol Engine: PDB
2021.04.08	14:23:10.740	#DEBUG	#PeFile::InitializeSymbolEngine	#PeFile.cpp(778)	#Executable (PE) D:\DelphiSource\DelphiRio\mystuffR\uProfTest\Win32\Debug\uProfTest.exe initialized Symbol Engine: COFF

     

    • Thanks 1

  11. Posted

    Just a note: Flickering when using styles can almost completely be eliminated by removing seBorder from the form's style elements. But if you prefer to see the buggy styled caption bar, you're out of luck:)

  12. Posted · Edited by Renate Schaaf
    Bug in previous attachment

    Ok, here is the installable component. The dimming is not tied to visible anymore, but to a property Active, which can only be set at runtime. The control to be dimmed isn't tied to the parent at design time, instead there is a published property DimmedControl, which the parent will be set to at runtime (unless it's nil, then no dimming is possible). At design time the component can be dropped anywhere to design the child controls. DimmedControl can be changed at runtime.

    The attachment contains packages for runtime and design and a crude demo. I haven't changed aehimself's unit- and class names, which I should have done, but I'm too tired now.

    I'm using Delphi 10.3.3, it should work for 10.4.*, too.

     

    Instructions:

    Load BuildandDemo.groupproj

    Build DimPanel.bpl (runtime) for both Win32 and Win64

    Build DimPanelD.bpl (design)

    Install DimPanelD.bpl

    Open and run DemoDim

     

    The component is on the "Additional" tab. If TDimPanel is grayed under Win64, try to close and reopen the IDE.

    Hope it roughly works 🙂

    Edit: Bug in previous attachment

    The size was not set right initially, has been fixed by an override to Loaded

    DimPanel.zip

     

     

    • Like 2

  13. Posted

    31 minutes ago, aehimself said:

    The constructor can be the standard, just throw an AV if the specified owner is not a TWinControl.

    If you drop a component, the owner is always the form. That's one of the things. You could of course always drop it on the control you want to dim, then you've got the parent right. But some things need to be disabled at design time, the VisibleChanging for once. I'm working on something that doesn't blow up in your face, lets you design the child controls, and also allows you to specify a dimmed control other than what you can drop it on at design time ... say, a listbox or a pagecontrol. Much of this works really nicely with your runtime-only version.

    I want to get this done without having to write a designer. Maybe it's not worth the trouble and placing the controls at runtime is easy enough 🙂

    • Like 1

  16. Posted · Edited by Renate Schaaf

    8 hours ago, aehimself said:

    I might also want to disable controls on the parent in VisibleChanging to ensure nothing can be focused by pressing tab as @Attila Kovacs suggested earlier.

    Good idea, also it's possible to parent the panel to the pagecontrol (I hadn't thought that it would work, but...). Then you also have the pagecontrol tabs disabled.

    https://imgur.com/48gzWCX  (how do you get images in here?)

    But for this some small changes must be made: 

    Constructor TDimPanel.Create(inOwner: TWinControl);
Begin
 ..........
 //******Width/Height instead of ClientWidth/ClientHeight
 Self.Width := Self.Parent.Width;
 Self.Height := Self.Parent.Height;
 Self.Anchors := [akLeft, akTop, akRight, akBottom];
 Self.BevelOuter := bvNone;
End;
    Procedure TDimPanel.VisibleChanging;
Begin
 inherited;

 If Not Self.Visible Then
 Begin
   Self.Resize;
   Self.UpdateBitmap; // UpdateBitmap is not called if Self.Visible is false...
   //********
   Self.BringToFront;  //BringToFront isn't called either, necessary for parent is TPageControl
 End
 Else
   _bitmap.SetSize(0, 0); // clear bitmap to free up memory
End;

    Now it would be really nice if one could use it as a component so one can design the controls on it...

  17. Posted

    29 minutes ago, Remy Lebeau said:

    Basically, the shadow TForm uses its AlphaBlend/Value properties to provide the dimming effect, and its TransparentColor/Value properties to mask out holes in the shadow where individual controls want to peek through.

    Dang! That's like the sample I posted and then deleted. There's nothing one can think of without you guys having thought of it before... :classic_smile:

  18. Posted

    1 hour ago, aehimself said:

    ..unless you have VCL Styles active. Then it flickers like madness 🙂

    For very simple forms I use a Fake-Style, which improves drawing immensely.

    One could call RemoveStyle(self) in OnCreate and FakeStyle(self) in OnCreate or whenever the style changes:

      

    uses ... VCL.Controls, VCL.ComCtrls, VCL.Forms, VCL.Themes;
//and what I forgot

type

  TCrackControl = class(Vcl.Controls.TControl);

procedure RemoveStyle(aControl: TControl);
var
  i: integer;
begin
  if (csDesigning in aControl.ComponentState) then
    exit;
  // I like to keep the style of the buttons and TabControls
  if not((aControl is TButton) or (aControl is TCustomTabControl)) then
    aControl.StyleElements := [];
  //keep the scrollbars of scrollboxes but get rid of the form's styled caption bar
  if (aControl is TScrollingWinControl) and (not(aControl is TForm)) then
  aControl.StyleElements:=[seBorder];

  if aControl is TWinControl then
    with TWinControl(aControl) do
      for i := 0 to ControlCount - 1 do
        RemoveStyle(Controls[i]);
end;

procedure FakeStyle(aControl: TControl);
var
  BGColor, FontColor {
    , SelectedColor,
    SelectedFontColor
  } : TColor;
  i: integer;
begin
  if (csDesigning in aControl.ComponentState) then
    exit;
  BGColor := StyleServices.GetStyleColor(scWindow);
  FontColor := StyleServices.GetStyleFontColor(sfWindowTextNormal);
  TCrackControl(aControl).Font.Color := FontColor;
  TCrackControl(aControl).Color := BGColor;
  if aControl is TWinControl then
    with TWinControl(aControl) do
      for i := 0 to ControlCount - 1 do
        FakeStyle(Controls[i]);
end;

     

  19. Posted · Edited by Renate Schaaf

    4 hours ago, aehimself said:

    Self.Canvas.Draw(0, 0, _bitmap, 128); draws only the top half of the panel.

    Maybe the bottom half gets alphablended away?  I noticed that black vanishes, which I don't understand. Everything is fine, when drawing a colored background first.

     

    Quote

    One more thing, this is not really going to work when resizing, as the parent of my dimmed control is the tabsheet (which I need the image of). When I take an image of the tabsheet while the dimmed panel is visible, it's image will be seen on the picture, slowly fading out everything in the process.

    On resize:

    You can send the panel to back, redraw its parent, capture the parent's bitmap, send the panel back to front. Surprisingly, there's hardly any flicker when doing this.

    ------------------------------- unless you use styles :classic_wacko:

  20. Posted · Edited by Renate Schaaf
    forgot the styles

    3 hours ago, aehimself said:

    While the bitmap screenshot idea will work, it feels really hacky.

     

    Here's a different kind of hack:

    Design another form with a completely transparent background (transparentColor = true) and borderless.

    Place the controls you would have on the semitransparent panel on this form instead.

    When you want to dim your tabsheet, place a blank semitransparent panel as before.

    Then place the second form on top of the tabsheet and show it.

    If so desired, you can have the transparent form size and move (WM_Move) with the main form.

       (In the handler for WM_Move check that the transparent form is assigned, as it is called very early for the main form)

    Event handlers for the controls on the 2nd form can be assigned in the code of the main form to avoid circular reference.

    It works so far for me, you can certainly figure out how to deal with the rest of the nooks and crannies.

     

    This is fun! :classic_biggrin:

     

    Edit: I forgot the styles: you need to remove seClient and seBorder from the style elements of the transparent form

     

  21. Posted · Edited by Renate Schaaf

    2 hours ago, aehimself said:

    ...one small question, though. Is it possible to make the panel transparent, but not the components on it?

    As you see, the code I referred to isn't mine, I just found it useful. But let me try 🙂

     

    Edit:

    The short answer seems to be that it isn't supported. When one tries to remove the layered style from the child controls of the panel they either get invisible or one gets a Win-Error. For the long answer I guess you have to go back to your bitmap-idea.

    This: https://www.codeguru.com/csharp/csharp/cs_controls/tutorials/article.php/c12323/Creating-NonTransparent-Controls-on-a-SemiTransparent-Window.htm is old, but looks good.

×