Bugs found in pl_Orca

List index out of bounds in GradientAnimation 10 years 11 months ago #3734

gorkamorka Offline New Member Posts: 18 Thank you received: 2	Hi RockyLuck, You not only reporting bugs , you give the patches too.i just want to thank you..
	Please Log in or Create an account to join the conversation.

SIGSEGV but only when running debugger 10 years 11 months ago #3755

RockyLuck
Topic Author
Visitor

A problem is nagging me for days now:

Unzip the attached files to C:\codetyphon\lazarustemp\
Now try to run OrcaDBBug in the IDE environment (Win 32 bit).
The program runs until you close it (with the Windows Close button).
Then you get a SIGSEGV violation.
Now run it outside the IDE: nothing happens when you close it: no exception, it just terminates

Has anyone ever seen such behavior?

The problem is not with using the obsolete TDbf component, a similar test with sqlite-3 gave the same result.

It has to do with the TD2DBGrid component, but debugging did not deliver any info (mainly because conditional breakpoints simply do not work :angry:

)

Regards ;-}
Dick

OrcaDBBug.zip

Please Log in or Create an account to join the conversation.

Last edit: by RockyLuck. Reason: typo

SIGSEGV but only when running debugger 10 years 11 months ago #3777

RockyLuck Topic Author Visitor	RockyLuck wrote: A problem is nagging me for days now: Can anyone please confirm this problem?
	Please Log in or Create an account to join the conversation.

SIGSEGV but only when running debugger 10 years 11 months ago #3778

Sternas Stefanos Offline Moderator Ex Pilot, M.Sc, Ph.D Posts: 4508 Thank you received: 1100	Please give time Sir We fight with FPC (Rev 24418) and Lazarus (Rev 41045) mess now... PilotLogic Architect and Core Programmer
	Please Log in or Create an account to join the conversation. Last edit: by Sternas Stefanos.

Buffer flushed, even if nothing to flush 10 years 11 months ago #3779

RockyLuck
Topic Author
Visitor

In orca_scene2D_scene.inc the procedure WMEraseBkgnd is incorrect. Patch as follows:

procedure TD2CustomScene.WMEraseBkgnd(var Msg: TLMEraseBkgnd);
var
  rgnStatus: integer;
  rgn: HRgn;
begin
  if (Msg.DC <> 0) and (Canvas <> nil) then
  begin
    rgn := CreateRectRgn(0, 0, 1, 1);
   {$IFDEF WINDOWS}
    rgnStatus := GetUpdateRgn(Handle, rgn, false);
// {$ENDIF}               // *** DB ***
   {$ELSE}                // *** DB ***
    rgnStatus :=1;
   {$ENDIF}               // *** DB *** 
    if (rgnStatus = 1) then
    begin
      Canvas.FlushBuffer(0, 0, Msg.DC);
    end;
    DeleteObject(rgn);
  end;
  Msg.Result := 1;
end;

Please Log in or Create an account to join the conversation.

Buffer flushed, even if nothing to flush 10 years 11 months ago #3780

Sternas Stefanos Offline Moderator Ex Pilot, M.Sc, Ph.D Posts: 4508 Thank you received: 1100	We will test now PilotLogic Architect and Core Programmer
	Please Log in or Create an account to join the conversation.

SIGSEGV but only when running debugger 10 years 11 months ago #3781

RockyLuck Topic Author Visitor	Well, it doesn't necessarily have to be you guys. Any reader of this forum could do this little test.
	Please Log in or Create an account to join the conversation.

WideString and UTF8 fixes 10 years 11 months ago #3782

RockyLuck Topic Author Visitor	These fixes didn't make it in release 4.20: - Item #3553 and Item #3556 - The question in Item #3572 was not yet answered. - The serious bug shown in Item #3611 was not confirmed. Sternas, when do you think you'll have the time to implement or look at them? Regards ;-} Dick
	Please Log in or Create an account to join the conversation.

TD2ComboColorBox doesn't pass value to BindingObj 10 years 11 months ago #3783

RockyLuck Topic Author Visitor	In orca_scene2d_obj_comboboxies.inc the ColorComboBox does not pass its changed value to the binding objects. This is the fix: procedure TD2ComboColorBox.DoColorChange(Sender: TObject); begin FColorText.Text := Color; Repaint; if Assigned(FBindingObjects) then // * DB * ToBindingObjects; // * DB * if Assigned(FOnChange) then FOnChange(Self); end;
	Please Log in or Create an account to join the conversation. Last edit: by RockyLuck.

TD2AngleButton doesn't pass value to BindingObj's 10 years 11 months ago #3784

RockyLuck
Topic Author
Visitor

Same problem. This is the fix:

procedure TD2AngleButton.SetValue(const Value: single);
begin
  if (FFrequency = 0) then
  begin
    if (FValue <> Value) then
    begin
      FValue := Value;
      if Tick <> nil then
        Tick.RotateAngle := -FValue
      else
        Repaint;
      Text;
      if Assigned(FBindingObjects) then           // *** DB ***
        ToBindingObjects;                         // *** DB ***
      if Assigned(FOnChange) and (not FPressing or FTracking) then
        FOnChange(Self);
    end;
  end
  else
  begin
    if FValue <> Round(Value / FFrequency) * FFrequency then
    begin
      FValue := Round(Value / FFrequency) * FFrequency;
      if Tick <> nil then
        Tick.RotateAngle := -FValue
      else
        Repaint;
      Text;
      if Assigned(FBindingObjects) then           // *** DB ***
        ToBindingObjects;                         // *** DB ***
      if Assigned(FOnChange) and (not FPressing or FTracking) then
        FOnChange(Self);
    end;
  end;
end;

Please Log in or Create an account to join the conversation.

TD2ColorButton doesn't pass value to BindingObj's 10 years 11 months ago #3785

RockyLuck
Topic Author
Visitor

Same problem. Now two fixes are needed:

procedure TD2ColorButton.SetColor(const Value: string);
begin
  FColor := Value;
  if FFill <> nil then
    FFill.Fill.Color := FColor;
  if Assigned(FBindingObjects) then           // *** DB ***
    ToBindingObjects;                         // *** DB ***
  if not (csLoading in ComponentState) then
    if Assigned(FOnChange) then
      FOnChange(Self);
end;

function TD2ColorButton.GetData : Variant;  // *** DB ***
begin                                       // *** DB ***
   Result := Color;                         // *** DB ***
end;                                        // *** DB ***

The GetData function must be defined in orca_scene2d.pas:

TD2ColorButton = class(TD2CustomButton)
  private
    FFill: TD2Shape;
    FColor: string;
    FOnChange: TNotifyEvent;
    FUseStandardDialog: boolean;
    procedure SetColor(const Value: string);
  protected
    procedure ApplyStyle; override;
    procedure FreeStyle; override;
    procedure Click; override;
    function GetData: Variant; override;  // *** DB ***
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property AutoTranslate default false;
    property CanFocused default true;
    property DisableFocusEffect;
    property TabOrder;
    property Color: string read FColor write SetColor;
    property UseStandardDialog: boolean read FUseStandardDialog write FUseStandardDialog default true;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

Please Log in or Create an account to join the conversation.

Last edit: by RockyLuck. Reason: typo

TD2Spinbox bugs when value is float 10 years 11 months ago #3786

RockyLuck
Topic Author
Visitor

The TD2Spinbox in orca_scene2d_obj_boxies.inc has two bugs. These are the fixes:

procedure TD2SpinBox.Change;
begin
  try
    FValue := StrToFloat(Text);
    if FValue > FMax then FValue := FMax;
    if FValue < FMin then FValue := FMin;
//  if (frac(FValue) = 0) or (FValueType = d2ValueInteger) then // *** DB ***
    if FValueType = d2ValueInteger then    // *** DB ***
      FText := IntToStr(Trunc(FValue))
    else
//    FText := FloattoStr(FValue);         // *** DB *** this makes decimaldigits property inactive
      FText := Format('%.' + IntToStr(FDecimalDigits) + 'f', [FValue]);  // *** DB ***
  except
    if (frac(FValue) = 0) or (FValueType = d2ValueInteger) then
      FText := IntToStr(Trunc(FValue))
    else
      FText := FloattoStr(FValue);
  end;
  Repaint;
  inherited;
end;


procedure TD2SpinBox.SetValue(const AValue: single);
begin
  if FValue <> AValue then
  begin
    FValue := AValue;
    if FValue > FMax then FValue := FMax;
    if FValue < FMin then FValue := FMin;
//  if (frac(FValue) = 0) or (FValueType = d2ValueInteger) then  // *** DB ***
    if FValueType = d2ValueInteger then
      FText := IntToStr(Trunc(FValue))
    else
//    *** DB *** Using decimalseparator is wrong (exception will occur): Format always uses dot (.)
//    FText := Format('%' + DecimalSeparator + IntToStr(FDecimalDigits) + 'f', [FValue]); // *** DB ***
      FText := Format('%.' + IntToStr(FDecimalDigits) + 'f', [FValue]);                   // *** DB ***
    SelLength := 0;
    Repaint;
  end;
end;

Please Log in or Create an account to join the conversation.

Last edit: by RockyLuck.

The name "Canvas"cannot be used in protoypes 10 years 11 months ago #3794

RockyLuck Topic Author Visitor	Because of a bug in fpc, the name "Canvas" in prototypes conflicts with a global Canvas, resulting in syntax errors. Therefore make this change in orca_scene2d_pas: //TD2PaintEvent = procedure (Sender: TObject; const Canvas: TD2Canvas) of object; // * DB * TD2PaintEvent = procedure (Sender: TObject; const ACanvas: TD2Canvas) of object; // * DB *
	Please Log in or Create an account to join the conversation.

TD2NumberBox and TD2SpinBox partly rewritten 10 years 11 months ago #3800

RockyLuck
Topic Author
Visitor

There are so many problems with TD2NumberBox and TD2SpinBox if the ValueType property is d2ValueFloat that I have largely rewritten these components.

First a small patch is needed in orca_scene2d.pas. Both in TD2NumberBox and in TD2SpinBox a private procedure Reformat is added, the SetText procedure with the WideString parameter is overwritten (eliminate the SetText with the String parameter) and in both components the procedure Change is eliminated:

    procedure SetDecimalDigits(const Value: integer);
    procedure Reformat;                                      // *** DB ***
  protected
//  procedure Change; override;                              // *** DB ***
//  procedure SetText(const Value: String); override;        // *** DB ***
    procedure SetText(const Value: WideString); override;    // *** DB ***

Apply this change in both component definitions.

The changes in the source code of TD2SpinBox and TD2NumberBox are so many, I've included their replacement texts:

File Attachment:

File Name: NumberAndS...nges.zip
File Size:2 KB

both components are streamlined in that a change in a property that affects the display of the text will be honored immediately. So if DecimalDigits changes, this is shown in the display immediately.

Thanks ;-}
Dick

NumberAndS...nges.zip

Please Log in or Create an account to join the conversation.

Last edit: by RockyLuck.

When binding values should be properly converted 10 years 11 months ago #3809

RockyLuck
Topic Author
Visitor

There are a number of places in the BindingSource logic, where the following code tries to set the controls value according to another controls value:

procedure TD2<<somecontrol>>.SetData(const Value: Variant);
begin
  if VarIsEvent(Value) then
    OnChange := VariantToEvent(Value)
  else
    if VarIsNumeric(Value) then
      Self.Value := Value
    else
      Self.Value := <<some value>>
end;

This code is wrong, because it does not allow for, say a textbox, to govern the value of, say a trackbar (the text of the textbox may contain all digits, it still does not fulfill the VarIsNumeric test).

The problem can best be illustrated in the C:\codetyphon\CodeOcean\ORCA\samples2d\binding\binding.lpr sample project.
If you run this project you can see the problem in the top leftmost panel. When you move the trackbar, the textbox will reflect its value. However, when you change the value in the textbox, the trackbar resets to 0!

These are the places that need an update:

procedure TD2AngleButton.SetData(const Value: Variant);
procedure TD2ProgressBar.SetData(const Value: Variant);
procedure TD2ScrollBar.SetData(const Value: Variant);
procedure TD2CustomTrack.SetData(const Value: Variant);

The update is this:

procedure TD2<<somecontrol>>.SetData(const Value: Variant);
begin
  if VarIsEvent(Value) then
    OnChange := VariantToEvent(Value)
  else
     Try
        Self.Value := Value;  // Let variant assignement decide if conversion is possible
     Except
        Self.Value := <<some value>>
     end{try};
end;

With these changes in place in the four indicated components, you will find the sample project to run as expected.

Thanks ;-}
Dick

Please Log in or Create an account to join the conversation.

Last edit: by RockyLuck.

When binding values should be properly converted 10 years 11 months ago #3810

Sternas Stefanos Offline Moderator Ex Pilot, M.Sc, Ph.D Posts: 4508 Thank you received: 1100	Thanks Sir PilotLogic Architect and Core Programmer
	Please Log in or Create an account to join the conversation.

When binding values should be properly converted 10 years 11 months ago #3814

RockyLuck
Topic Author
Visitor

sternas wrote: Thanks Sir

Hi Sternas,

The item #3800 is probably correct, but it causes the brush designer to fail. The OnChange event is fired when the text changes of the number box because of a number of factors. However this gives a loop in the brush designer. Apparently it uses the OnChange event of the number box causing it to loop.

I still think the changes are right, so I'll try to fix the problem in the brush designer, because that should not be dependent on the bug that was originally present in the number box (one of the two implementations that I redid).

So, for this moment do not apply #3800 fix yet :side:

Thanks ;-}
Dick

Please Log in or Create an account to join the conversation.

TD2NumberBox and TD2SpinBox partly rewritten 10 years 11 months ago #3815

RockyLuck
Topic Author
Visitor

RockyLuck wrote: both components are streamlined in that a change in a property that affects the display of the text will be honored immediately. So if DecimalDigits changes, this is shown in the display immediately.

Unfortunately the gradient and solid color editors contain an event loop, that came out because of these changes. Just a few small changes were needed there.

First of all, we need a loop blocking variable "InternalChange" to be defined in orca_scene2d.pas:

TD2BrushDesign = class(TForm)
.
.
.
  private
    FBrush: TD2Brush;
    FScene: Id2Scene;
    FComp: TPersistent;
    InternalChange: Boolean;           // *** DB ***
    procedure SetBrush(const Value: TD2Brush);
    procedure SetComp(const Value: TPersistent);
    procedure rebuilResList;
.
.
.

I have rewritten the OnChange logic in TD2NumberBox and TD2SpinBox a bit, so that OnChange only occurs if their Value property changes. I've included the changed code:

File Attachment:

File Name: NumberAndSpinbox.zip
File Size:2 KB

The prototype for the internal procedure Reformat has to be changed in the two places in orca_scene2d.pas as follows:

    procedure Reformat(const ValueChanged: Boolean);         // *** DB ***

The changes needed in the orca_scene2d_designers.inc file are minor:

procedure TD2BrushDesign.solidQuadChange(Sender: TObject);
begin
  if FBrush = nil then Exit;
  InternalChange := True;                                        // *** DB ***
  solidQuad.Alpha := ((FBrush.SolidColor and $FF000000) shr 24) / $FF;
  FBrush.SolidColor := (FBrush.SolidColor and not $FFFFFF) or ($00FFFFFF and d2HSLtoRGB(solidQuad.Hue, solidQuad.Sat, solidQuad.Lum));
  textSolidR.Value := TD2ColorRec(FBrush.SolidColor).R;
  textSolidG.Value := TD2ColorRec(FBrush.SolidColor).G;
  textSolidB.Value := TD2ColorRec(FBrush.SolidColor).B;
  textSolidA.Value := TD2ColorRec(FBrush.SolidColor).A;
  textSolidHex.TextW := d2ColorToStr(FBrush.SolidColor);
  InternalChange := False;                                        // ** DB ***
end;

procedure TD2BrushDesign.textSolidHexChange(Sender: TObject);
begin
  { change solid hex }
  if FBrush = nil then Exit;
  if InternalChange then Exit;                                    // *** DB ***
  FBrush.SolidColor := d2StrToColor(textSolidHex.TextW);
  solidPicker.Color := FBrush.SolidColor;
end;

procedure TD2BrushDesign.textSolidRChange(Sender: TObject);
var
  Color: TD2Color;
begin
  { solid textbox change }
  if FBrush = nil then Exit;
  Color := FBrush.SolidColor;
  TD2ColorRec(Color).R := trunc(textSolidR.Value);
  TD2ColorRec(Color).G := trunc(textSolidG.Value);
  TD2ColorRec(Color).B := trunc(textSolidB.Value);
  TD2ColorRec(Color).A := trunc(textSolidA.Value);
  if InternalChange then Exit;                                    // *** DB ***
  FBrush.SolidColor := Color;
  solidPicker.Color := FBrush.SolidColor;
end;
.
.
.
procedure TD2BrushDesign.gradQuadChange(Sender: TObject);
begin
  { chage color in current point }
  if FBrush = nil then Exit;
  InternalChange := True;                                         // *** DB ***
  gradEditor.Gradient.Points[gradEditor.CurrentPoint].IntColor :=
    (gradEditor.Gradient.Points[gradEditor.CurrentPoint].IntColor and $FF000000) or ($00FFFFFF and d2HSLtoRGB(gradQuad.Hue, gradQuad.Sat, gradQuad.Lum));
  FBrush.Gradient.Assign(gradEditor.Gradient);
  textGradR.Value := TD2ColorRec(gradColorRect.Color).R;
  textGradG.Value := TD2ColorRec(gradColorRect.Color).G;
  textGradB.Value := TD2ColorRec(gradColorRect.Color).B;
  textGradA.Value := TD2ColorRec(gradColorRect.Color).A;
  textGradHex.TextW := d2ColorToStr(gradColorRect.Color);
  gradEditor.Repaint;
  InternalChange := False;                                        // *** DB ***
end;
.
.
.
procedure TD2BrushDesign.textGradRChange(Sender: TObject);
var
  Color: TD2Color;
begin
  { change grad brush alpha }
  if FBrush = nil then Exit;
  Color := gradEditor.Gradient.Points[gradEditor.CurrentPoint].IntColor;
  TD2ColorRec(Color).R := trunc(textGradR.Value);
  TD2ColorRec(Color).G := trunc(textGradG.Value);
  TD2ColorRec(Color).B := trunc(textGradB.Value);
  TD2ColorRec(Color).A := trunc(textGradA.Value);
  gradEditor.Gradient.Points[gradEditor.CurrentPoint].IntColor := Color;
  if InternalChange then Exit;                                    // *** DB ***
  gradEditor.UpdateGradient;
end;
.
.
.
procedure TD2BrushDesign.textGradHexChange(Sender: TObject);
begin
  { change gradient hex }
  if FBrush = nil then Exit;
  gradEditor.Gradient.Points[gradEditor.CurrentPoint].IntColor := d2StrToColor(textGradHex.TextW);
  if InternalChange then Exit;                                    // *** DB ***
  gradEditor.UpdateGradient;
end;

This cures the problem that these two editors had a bug in the form of an event loop.

Thanks ;-}
Dick

NumberAndSpinbox.zip

Please Log in or Create an account to join the conversation.

Last edit: by RockyLuck.

TD2Inspector may use property info that's nil 10 years 11 months ago #3817

RockyLuck
Topic Author
Visitor

I could reproduce this by going into the resource designer, changing some gradient then change its type (through selecting the tab Solid) to solid, then change the color. Upon clicking OK I would get a SIGSEGV violation.

The culprit seems to be in the orca_scene2d_obj_inspector.inc file where a property info may have become nil. This fix solved the problem:

This is procedure TD2Inspector.DoEditorChange where this has to be changed:

if (Sender = FEditBox) and FEditBox.Visible then
    begin
      PropInfo := GetPropInfo(Selected.TagObject, Selected.TagString);
      if PropInfo <> nil then begin                      // *** DB ***
         if PropInfo^.PropType^.Kind = tkMethod then
         begin
           if GvarD2Designer <> nil then
           begin
             M := GvarD2Designer.AddMethod(TD2TextBox(Sender).TextW);
             SetMethodProp(Selected.TagObject, PropInfo, M);
             if (M.Code <> nil) and (TD2Object(Sender).TagObject <> nil) then
               TD2Label(TD2Object(Sender).TagObject).TextW := TD2TextBox(Sender).TextW;
           end;
         end
         else
         begin
           SetPropValue(Selected.TagObject, Selected.TagString, TD2TextBox(Sender).TextW);
           if TD2Object(Sender).TagObject <> nil then
             TD2Label(TD2Object(Sender).TagObject).TextW := TD2TextBox(Sender).TextW;
         end;
      end;                                               // *** DB ***
    end;

Thanks ;-}
Dick

Please Log in or Create an account to join the conversation.

Last edit: by RockyLuck.

TD2Calendar not finished? 10 years 11 months ago #3826

RockyLuck
Topic Author
Visitor

Here's a picture of the old Calendar and the new Calendar after the changes I made:

As you can see, in the old situation the next month, current date and previous month buttons are ridiculously small. Also the month name and the year are almost invisible. If the theme is dark, the buttons are almost invisible. It's not good.

Here are some changes I made (as always, the changes are marked with *** DB ***):

In orca_scene2d.pas a little change is needed in the TD2Calendar definition:

    .
    .
    procedure SetData(const Value: Variant); override;
    procedure MouseWheel(Shift: TShiftState; WheelDelta: integer; var Handled: boolean); override;
    procedure WeekDay0ApplyResource(Sender : TObject);                           // *** DB ***
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    .
    .

The other changes are in orca_scene2d_obj_calendars.inc.

First of all, in order to get buttons that are a little bigger, the stroke with which the graphics on these buttons is drawn should be made visible (it's transparent now). Further, in order to find these shapes later on, I gave them the resourcename 'calendarcontrol'.

This is done in the Create constructor of the TD2Calendar. At that point, you cannot set the appropriate color, because that is determined by the resource manager after the controls are created. It took me over two days to find a usable event that was not too early and also not too late :blink:

I determined that the OnApplyResource event is generated after the resource manager has done its stuff. The color I want for the buttons and the month and year should be the same as that used for showing the week days. So I made an OnApplyResource event for the first label used in the weekdays. This is part of the constructor TD2Calendar.Create in orca_scene2d_obj_calendars.inc:

    FPrev := TD2Button.Create(Self);
    with FPrev do
    begin
      Parent := L;
      Width := 19;
      Locked := true;
      Stored := false;
      Align := vaLeft;
      Padding.Right := 2;
      Resource := 'transparentcirclebuttonstyle';
      OnClick := DoPrevClick;
      RepeatClick := true;
      with TD2ScrollArrowLeft.Create(Self) do
      begin
        Parent := FPrev;
        Width := 5;
        Height := 5;
//      Stroke.Style := d2BrushNone;    // Very, very small arrows    *** DB ***
        Stroke.Style := d2BrushSolid;                              // *** DB ***
        ResourceName := 'calendarcontrol';    // So we can find it    *** DB ***
        Align := vaCenter;
        HitTest := false;
        Stored := false;
        Locked := true;
      end;
    end;
    FToday := TD2Button.Create(Self);
    with FToday do
    begin
      Parent := L;
      Width := 19;
      Locked := true;
      Stored := false;
      Align := vaLeft;
      Position.X := 30;
      Padding.Right := 2;
      Resource := 'transparentcirclebuttonstyle';
      OnClick := DoTodayClick;
//    RepeatClick := true;              // Select today many times?   *** DB ***
      RepeatClick := false;                                        // *** DB ***
      with TD2Ellipse.Create(Self) do
      begin
        Parent := FToday;
        Width := 5;
        Height := 5;                                               
//      Stroke.Style := d2BrushNone;                               // *** DB ***
        Stroke.Style := d2BrushSolid;                              // *** DB ***
        ResourceName := 'calendarcontrol';                         // *** DB ***
        Align := vaCenter;
        HitTest := false;
        Stored := false;
        Locked := true;
      end;
    end;
    FNext := TD2Button.Create(Self);
    with FNext do
    begin
      Parent := L;
      Width := 19;
      Locked := true;
      Stored := false;
      Position.X := 50;
      Align := vaLeft;
      Padding.Right := 2;
      Resource := 'transparentcirclebuttonstyle';
      RepeatClick := true;
      OnClick := DoNextClick;
      with TD2ScrollArrowRight.Create(Self) do
      begin
        Parent := FNext;
        Width := 5;
        Height := 5;
//      Stroke.Style := d2BrushNone;                               // *** DB ***
        Stroke.Style := d2BrushSolid;                              // *** DB ***
        ResourceName := 'calendarcontrol';                         // *** DB ***
        Align := vaCenter;
        HitTest := false;
        Stored := false;
        Locked := true;
      end;
    end;
    FMonths := TD2PopupBox.Create(Self);
    with FMonths do
    begin
      Parent := L;
      Align := vaClient;
      Locked := true;
      Stored := false;
      DisableFocusEffect := true;
      Padding.Left := 5;
      Padding.Right := 5;
      Resource := 'labelstyle';
      for i := 1 to 12 do
        Items.Add(LongMonthNames[i]);
      Font.Style := d2FontBold;
      TextAlign := d2TextAlignFar;
      ItemIndex := AMonth - 1;
      OnChange := DoMonthChange;
    end;
    FYears := TD2PopupBox.Create(Self);
    with FYears do
    begin
      Parent := L;
      Width := 40;
      Align := vaRight;
      Locked := true;
      Stored := false;
      DisableFocusEffect := true;
      Resource := 'labelstyle';
      for i := 1 to 10 do
        Items.Add(IntToStr(AYear - i));
      Items.Add(IntToStr(AYear));
      for i := 1 to 10 do
        Items.Add(IntToStr(AYear + i));
      Font.Style := d2FontBold;
      TextAlign := d2TextAlignNear;
      ItemIndex := 10;
      OnChange := DoYearChange;
    end;
  end;
  FWeek := TD2GridLayout.Create(Self);
  with FWeek do
  begin
    Parent := Self;
    Locked := true;
    Stored := false;
    Height := 19;
    Position.Y := 20;
    ItemHeight := 19;
    Align := vaTop;
    Padding.Bottom := 2;
    for i := 0 to 6 do
      with TD2Label.Create(Self) do
      begin
        Parent := FWeek;
        Locked := true;
        Stored := false;
        TextAlign := d2TextAlignCenter;
        WordWrap := false;
      end;
    TD2Label(Children[0]).OnApplyResource := WeekDay0ApplyResource;// *** DB ***
    ItemWidth := Width / 7;
  end;

So all that's left to do is implemenet the OnApplyResource for week day 0:

procedure TD2Calendar.WeekDay0ApplyResource(Sender : TObject);     // *** DB ***
var
   T: TD2Object;
   B: TD2Brush;

   procedure FillButton(btn: TD2Button);
   var
      T: TD2Object;
   begin
      T := btn.FindResource('calendarcontrol');
      if (T <> nil) and (T is TD2Shape) then begin
         TD2Shape(T).Stroke.Assign(B);
         TD2Shape(T).Fill.Assign(B);
      end{if};
   end;

   procedure FillTxtFont(lbl: TD2TextControl);
   var
      T: TD2Object;
   begin
      T := lbl.FindResource('text');
      if (T <> nil) and (T is TD2Text) then begin
         TD2Text(T).Fill.Assign(B);
      end{if};
   end;

begin
   B := TD2Brush.Create(d2BrushSolid, $FFFFFFFF);
   Try
      T := Sender as TD2Label;
      T := TD2Label(T).FindResource('text');
      if (T <> nil) and (T is TD2Text) then B.Assign(TD2Text(T).Fill)
                                       else Exit;
      FillButton(FPrev);
      FillButton(FToday);
      FillButton(FNext);

      FillTxtFont(FMonths);
      FillTxtFont(FYears);
   finally
      B.Free;
   end{try};
end;                                                               // *** DB ***

That code was not easily made.

For your interest: look at the way you get to the color of the text in the label. That's interesting for others too, if you want to change that color in code.

Cheers ;-}
Dick

...nd_New_Cal.jpg

Please Log in or Create an account to join the conversation.

TOPIC:

List index out of bounds in GradientAnimation 10 years 11 months ago #3734

SIGSEGV but only when running debugger 10 years 11 months ago #3755

Attachments:

SIGSEGV but only when running debugger 10 years 11 months ago #3777

SIGSEGV but only when running debugger 10 years 11 months ago #3778

Buffer flushed, even if nothing to flush 10 years 11 months ago #3779

Buffer flushed, even if nothing to flush 10 years 11 months ago #3780

SIGSEGV but only when running debugger 10 years 11 months ago #3781

WideString and UTF8 fixes 10 years 11 months ago #3782

TD2ComboColorBox doesn't pass value to BindingObj 10 years 11 months ago #3783

TD2AngleButton doesn't pass value to BindingObj's 10 years 11 months ago #3784

TD2ColorButton doesn't pass value to BindingObj's 10 years 11 months ago #3785

TD2Spinbox bugs when value is float 10 years 11 months ago #3786

The name "Canvas"cannot be used in protoypes 10 years 11 months ago #3794

TD2NumberBox and TD2SpinBox partly rewritten 10 years 11 months ago #3800

File Attachment:

Attachments:

When binding values should be properly converted 10 years 11 months ago #3809

When binding values should be properly converted 10 years 11 months ago #3810

When binding values should be properly converted 10 years 11 months ago #3814

TD2NumberBox and TD2SpinBox partly rewritten 10 years 11 months ago #3815

File Attachment:

Attachments:

TD2Inspector may use property info that's nil 10 years 11 months ago #3817

TD2Calendar not finished? 10 years 11 months ago #3826

Attachments: