Jump to content

KodeZwerg

Members
  • Content Count

    289
  • Joined

  • Last visited

  • Days Won

    3

Posts posted by KodeZwerg


  1. unit Unit12;
    
    interface
    
    uses
      Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
      Vcl.Controls, Vcl.Forms, Vcl.Dialogs;
    
    type
      TForm12 = class(TForm)
        procedure FormCreate(Sender: TObject);
        procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
          Shift: TShiftState; X, Y: Integer);
        procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
        procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
          Shift: TShiftState; X, Y: Integer);
      private
        procedure DrawLine(Color : TColor);
      public
        FStartX, FStartY,
        FEndX, FEndY : integer;
        FLineDrawn : boolean;
      end;
    
    var
      Form12: TForm12;
    
    implementation
    
    {$R *.dfm}
    
    { TForm12 }
    
    procedure TForm12.FormCreate(Sender: TObject);
    begin
      FLineDrawn := False;
    end;
    
    procedure TForm12.FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    begin
      FLineDrawn := True;
      FStartX := X;
      FStartY := Y;
    end;
    
    procedure TForm12.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    begin
      FEndX := X;
      FEndY := Y;
      if FLineDrawn then
        DrawLine(clRed);
    end;
    
    procedure TForm12.FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    begin
      FLineDrawn := False;
      DrawLine(clGreen);
    end;
    
    procedure TForm12.DrawLine(Color : TColor);
    begin
      Self.Refresh;
      Canvas.Pen.Color := Color;
      Canvas.MoveTo(FStartX, FStartY);
      Canvas.LineTo(FEndX, FEndY);
    end;
    
    end.

    A very basic example that might lead you into the direction you want.
    Steps to reproduce:
    1. Create a new Vcl Application.
    2. Add handlers as shown in above example.
    3. run app and press mouse button, keep it pressed while moving, release button for a final drawing.


  2. I have a problem with Delphi Alexandria and it's JSON methods, maybe I just do it wrong and would like to get help.

    Here is my demo project that show the problem.

    program Project12;
    
    {$APPTYPE CONSOLE}
    
    {$R *.res}
    
    uses
      Winapi.Windows,
      System.Classes,
      System.SysUtils,
      System.IOUtils,
      System.JSON;
    
    type
      TMyJsonRec = packed record
        MyInteger: Integer;
        MyInt64: Int64;
        MyUInt64: UInt64;
        MyDWORD: DWORD;
        MyDouble: Double;
        MyBoolean: Boolean;
        MyString: string;
      end;
    
    procedure SaveJsonToFile(const AJsonObject: TJSONObject; const AFileName: string);
    var
      JsonText: string;
      StreamWriter: TStreamWriter;
    begin
      JsonText := AJsonObject.ToString; // is this the problematic part?
      StreamWriter := TStreamWriter.Create(AFileName, False, TEncoding.UTF8);
      try
        StreamWriter.Write(JsonText);
      finally
        StreamWriter.Free;
      end;
    end;
    
    procedure SaveRecordToJson(const ARecord: TMyJsonRec; const AFileName: string);
    var
      JsonObject: TJSONObject;
    begin
      JsonObject := TJSONObject.Create;
      try
        JsonObject.AddPair('MyInteger', TJSONNumber.Create(ARecord.MyInteger));
        JsonObject.AddPair('MyInt64', TJSONNumber.Create(ARecord.MyInt64));
        JsonObject.AddPair('MyUInt64', TJSONNumber.Create(ARecord.MyUInt64)); // this does not work as I would have thought it does, when it exceed Int64 range it break
        JsonObject.AddPair('MyDWORD', TJSONNumber.Create(ARecord.MyDWORD));
        JsonObject.AddPair('MyDouble', TJSONNumber.Create(ARecord.MyDouble));
        JsonObject.AddPair('MyBoolean', TJSONBool.Create(ARecord.MyBoolean));
        JsonObject.AddPair('MyString', ARecord.MyString);
        SaveJsonToFile(JSonObject, AFileName);
      finally
        JsonObject.Free;
      end;
    end;
    
    function LoadRecordFromJson(const AFileName: string): TMyJsonRec;
    var
      JsonObject: TJSONObject;
    begin
      JsonObject := TJSONObject.ParseJSONValue(TFile.ReadAllText(AFileName)) as TJSONObject;
      try
        Result.MyInteger := JsonObject.GetValue('MyInteger').AsType<Integer>;
        Result.MyInt64 := JsonObject.GetValue('MyInt64').AsType<Int64>;
        Result.MyUInt64 := JsonObject.GetValue('MyUInt64').AsType<UInt64>; // this does not work as I would have thought it does, when it exceed Int64 range it break
        Result.MyDWORD := JsonObject.GetValue('MyDWORD').AsType<DWORD>;
        Result.MyDouble := JsonObject.GetValue('MyDouble').AsType<Double>;
        Result.MyBoolean := JsonObject.GetValue('MyBoolean').AsType<Boolean>;
        Result.MyString := JsonObject.GetValue('MyString').Value;
      finally    JsonObject.Free;
      end;
    end;
    
    var
      MyRecord1, MyRecord2: TMyJsonRec;
    begin
      // Initialize the record
      MyRecord1.MyInteger := High(Integer);
      MyRecord1.MyInt64 := High(Int64);
      MyRecord1.MyUInt64 := High(UInt64);
      MyRecord1.MyDWORD := High(DWORD);
      MyRecord1.MyDouble := 123.456;
      MyRecord1.MyBoolean := True;
      MyRecord1.MyString := 'Hello, World!';
    
      Writeln('Original record:');
      Writeln('MyInteger: ', MyRecord1.MyInteger);
      Writeln('MyInt64: ', MyRecord1.MyInt64);
      Writeln('MyUInt64: ', MyRecord1.MyUInt64);
      Writeln('MyDWORD: ', MyRecord1.MyDWORD);
      Writeln('MyDouble: ', MyRecord1.MyDouble);
      Writeln('MyBoolean: ', MyRecord1.MyBoolean);
      Writeln('MyString: ', MyRecord1.MyString);
    
      SaveRecordToJson(MyRecord1, '.\test.json');
      MyRecord2 := LoadRecordFromJson('.\test.json');
    
      // Output the loaded record
      Writeln('Loaded record:');
      Writeln('MyInteger: ', MyRecord2.MyInteger);
      Writeln('MyInt64: ', MyRecord2.MyInt64);
      Writeln('MyUInt64: ', MyRecord2.MyUInt64);
      Writeln('MyDWORD: ', MyRecord2.MyDWORD);
      Writeln('MyDouble: ', MyRecord2.MyDouble);
      Writeln('MyBoolean: ', MyRecord2.MyBoolean);
      Writeln('MyString: ', MyRecord2.MyString);
    
      ReadLn;
    end.

    I am unsure if it is the saving part or the reading part.


  3. On 7/31/2023 at 1:51 PM, milurt said:

    and kodezwerg: my question was pointer^:=rgb;

     

    To correct you, your topic is "bitmap not displayed", very informative but anyway I've read, later we found out that you try to code in a non-Vcl style by doing many things wrong.
    So Remy and I spend our time to write you an example.
    While you say that you can not compile for whatever reason Remy's code you said nothing to mine.
    Anders was correcting mine so it will do what your initial problem was, it display a bitmap. (even without fixing it does work...)

    Why you insist to still use your wrong way of doing?
    Why you never use the </> button to put your code better readable in?
    Why am I replying to this topic anymore?

    Best of luck!

    • Like 2

  4. I can not answer if it is implemented in your Delphi 7 installation, maybe upgrade to a more common Delphi Community Edition can help.

    uses
      ...TypInfo, Rtti...
    
    
    function SetProperty(const AControl: TControl; const AProperty: string; const AValue: TValue): Boolean;
    var
      LControl: TControl;
      LRttiContext: TRttiContext;
      LRttiProperty: TRttiProperty;
    begin
      Result := False;
      try
        LControl := AControl;
        LRttiProperty := LRttiContext.GetType(LControl.ClassType).GetProperty(AProperty);
        if ((LRttiProperty <> nil) and (LRttiProperty.Visibility in [mvPrivate, mvProtected, mvPublic, mvPublished])) then
        begin
          LRttiProperty.SetValue(LControl, AValue);
          Result := True;
        end;
      except
      end;
    end;

    Call that method by giving a control as argument 1, write the property as it is named for argument 2 and finally as argument 3 put your wanted value in.
    Best of luck.


  5. On 7/8/2023 at 3:29 AM, Remy Lebeau said:

    So, for example, using Toolhelp32:

    
    function GetParentProcessID(const AProcessID: DWORD): DWORD;
    var
      hSnapshot: THandle;
      pe: PROCESSENTRY32;
    begin
      Result := 0;
      hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
      if hSnapshot <> INVALID_HANDLE_VALUE then
      try
        pe.dwSize := SizeOf(dwSize);
        if Process32First(hSnapshot, pe) then
        repeat
          if pe.th32ProcessID = AProcessID then
          begin
            Result := pe.th32ParentProcessID;
            Exit;
          end;
        until not Process32Next(hSnapshot, pe);
      finally
        CloseHandle(hSnapshot);
      end;
    end;

     

    A mini small correction;

        pe.dwSize := SizeOf(pe);

     

    • Like 1

  6. 37 minutes ago, Remy Lebeau said:

    Override the Form's CreateParams() method to enable the WS_EX_NOACTIVATE extended style:

    
    procedure CreateParams(var Params: TCreateParams); override;
    ...
    procedure TMyForm.CreateParams(var Params: TCreateParams);
    begin
      inherited;
      Params.WindowClass.ExStyle := Params.WindowClass.ExStyle or WS_EX_NOACTIVATE;
    end;

     

    Is this not just for the purpose that at generation it will not get focus?
    I mean, the generated form can still be clicked and it get focus, or?


  7. 24 minutes ago, CoMPi74 said:

    @KodeZwerg I did not test it but I am afraid such a form can be activated (gets focus) when clicked. I want to avoid such behaviour.

    You can do this to prevent that the second form get a focus:

    ...
      protected
        procedure ActiveFormChanged(Sender: TObject);
    ...
    
    procedure TForm1.ActiveFormChanged(Sender: TObject);
    begin
      if not (csDestroying in ComponentState) then
        if ActiveControl <> nil then
          ActiveControl.SetFocus
    end;
    
    procedure TForm1.FormCreate(Sender: TObject);
    begin
      Screen.OnActiveFormChange := ActiveFormChanged;
    end;

     


  8. How about

    - Design a form

    - make it borderless

    - put a Panel on (alClient)

    - put a Timer on

    - create OnShow event to activate timer

    - in Timer event simple call "Close"

     

    from your calling Form

    - create an event that does

      - "Form.Panel.Caption := 'My Text';"

      - "Form.Timer.Interval := 1234;"

     - "Form.Show;"

     

    In theory it does what you wanted, adjust what I forgot to mention.


  9. function GetParentProcessID(const AProcessID: DWORD): DWORD;
    var
      aProcesses: array[0..1023] of DWORD;
      cbNeeded, cProcesses, i: DWORD;
      hProcess: THandle;
      parentProcessID: DWORD;
    begin
      Result := 0;
      // Get the list of process identifiers
      if not EnumProcesses(@aProcesses[0], SizeOf(aProcesses), cbNeeded) then
        Exit;
    
      // Calculate how many process identifiers were returned
      cProcesses := cbNeeded div SizeOf(DWORD);
    
      // Find the process with the given process ID and get its parent process ID
      for i := 0 to cProcesses - 1 do
      begin
        if aProcesses[i] = AProcessID then
        begin
          hProcess := OpenProcess(PROCESS_QUERY_INFORMATION  or PROCESS_VM_READ, False, AProcessID);
          if hProcess <> 0 then
          begin
            try
              if GetProcessId(hProcess) <> 0 then
                parentProcessID := GetProcessId(hProcess);
            finally
              CloseHandle(hProcess);
            end;
          end;
          Break;
        end;
      end;
    
      Result := parentProcessID;
    end;

    Heres a faster way to get Parent ProcessID.

    • Sad 1

  10. Why not simple use a mutex and check at startup for its presence?
    No need to do all that what @programmerdelphi2k wrote at all.
    @programmerdelphi2k I suggest to switch to EnumProcesses(), it is way faster compared to CreateToolhelp32Snapshot().

     

    Here's a small snippet example that you could run at startup
     

    function AppStartedByItself: Boolean;
    var
      dummy: THandle;
      FSA: SECURITY_ATTRIBUTES;
      FSD: SECURITY_DESCRIPTOR;
    begin
      InitializeSecurityDescriptor(@FSD, SECURITY_DESCRIPTOR_REVISION);
      SetSecurityDescriptorDacl(@FSD, True, nil, False);
      FSA.lpSecurityDescriptor := @FSD;
      FSA.nLength := SizeOf(SECURITY_ATTRIBUTES);
      FSA.bInheritHandle := True;
      dummy := CreateMutexW(@FSA, True, PWideChar('Global\' + 'SomethingUnique'));
      Result := (GetLastError = ERROR_ALREADY_EXISTS);
    end;

    call this method and react on True (app was started by itself) or False (app was started not by itself)

     

    //updated the result setting


  11. 10 minutes ago, Uwe Raabe said:

    How do you want to handle the case when both dates are equal as well as a Sunday? 

    How, if they are not equal and both are a Sunday?

    I am sorry, here is a fixed version that also react for leap years...

    function CountSundays(const AStartDate, AEndDate: TDateTime): Integer;
      function MonthOf(const AValue: TDateTime): Word;
      var
        Year, Month, Day: Word;
      begin
        DecodeDate(AValue, Year, Month, Day);
        Result := Month;
      end;
      function YearOf(const AValue: TDateTime): Word;
      var
        Year, Month, Day: Word;
      begin
        DecodeDate(AValue, Year, Month, Day);
        Result := Year;
      end;
      function DayOf(const AValue: TDateTime): Word;
      var
        Year, Month, Day: Word;
      begin
        DecodeDate(AValue, Year, Month, Day);
        Result := Day;
      end;
    var
      LCurrentDate: TDateTime;
      LDirection: Integer;
      LDaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
    begin
      Result := 0;
      if AStartDate > AEndDate then
        LDirection := -1 // Search for Sundays in reverse order
      else
        LDirection := 1; // Search for Sundays in forward order
      LCurrentDate := AStartDate;
      while DayOfWeek(LCurrentDate) <> 1 do // Find the first Sunday
        LCurrentDate := LCurrentDate + LDirection;
      if (LDirection = 1) and (LCurrentDate = AEndDate) then
        Inc(Result) // Add 1 if the end date is a Sunday
      else if (LDirection = -1) and (LCurrentDate = AEndDate) and (DayOfWeek(AStartDate) = 1) then
        Inc(Result) // Add 1 if the start and end dates are the same and represent a Sunday
      else
      begin
        while (AStartDate < AEndDate) and (LCurrentDate <= AEndDate) or (AStartDate > AEndDate) and (LCurrentDate >= AEndDate) do
        begin
          Inc(Result);
          LCurrentDate := LCurrentDate + (7 * LDirection); // Increment to next Sunday
          if MonthOf(LCurrentDate) = 2 then // Adjust for leap year
          begin
            if IsLeapYear(YearOf(LCurrentDate)) then
              LDaysInMonth[2] := 29
            else
              LDaysInMonth[2] := 28;
          end;
          if DayOf(LCurrentDate) > LDaysInMonth[MonthOf(LCurrentDate)] then // Adjust for end of month
            LCurrentDate := EncodeDate(YearOf(LCurrentDate), MonthOf(LCurrentDate) + 1, 1) - 1;
        end;
      end;
    end;

     


  12. How about:

    function CountSundays(const AStartDate, AEndDate: TDateTime): Integer;
    var
      LCurrentDate: TDateTime;
      LDirection: Integer;
    begin
      Result := 0;
      if AStartDate > AEndDate then
        LDirection := -1 // Search for Sundays in reverse order
      else
        LDirection := 1; // Search for Sundays in forward order
      LCurrentDate := AStartDate;
      while DayOfWeek(LCurrentDate) <> 1 do // Find the first Sunday
        LCurrentDate := LCurrentDate + LDirection;
      while (AStartDate < AEndDate) and (LCurrentDate <= AEndDate) or (AStartDate > AEndDate) and (LCurrentDate >= AEndDate) do
      begin
        Inc(Result);
        LCurrentDate := LCurrentDate + (7 * LDirection); // Jump to next/prior Sunday
      end;
    end;

    That approach works in both directions (ie: it does not matter what the start- and end- date is)


  13. Or instead of dealing with the Vcl/Theme style you can easily put a label/panel next to a control and color it however you like and maybe add handler to simulate same behavior for mouse clicks. (Anchoring works great on that matter)

×