Jump to content

davornik

Members
 View Profile  See their activity

  • Content Count

    35

  • Joined

  • Last visited

Posts posted by davornik

  3. Posted

    1 hour ago, Uwe Raabe said:

    The buttons of a TButtonedEdit are no controls, so there simply is no handle. Instead they provide an instance FGlyph of a private type TGlyph derived from TCustomControl, which handles the mouse events. This control has the edit control as parent.

     

    Perhaps you can achieve your goal by deriving from TButtonControl and override GetEditButtonClass. This gives you access to the protected FGlyph and allows to replace it with a derived class implementing the requested behavior.

    If I correctly understood goal is to then find private TGlyph class name and then its handle? TGlyph is private inside the Vcl.ButtonedEdit unit.

    I can search for Glyph handle, and do GetWindowLongPtr/SetWindowLongPtr to detect WM_LBUTTONDOWN and WM_LBUTTONUP messages.

      

    var
  OldGlyphWndProc: Pointer = nil;

function CustomGlyphWndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
  if Msg = WM_LBUTTONUP then
    Form1.ButtonedEdit1.PasswordChar:='*'  // <- this does not fire
  else
  if Msg = WM_LBUTTONDOWN then
    Form1.ButtonedEdit1.PasswordChar:=#0;  // <- this now fires
  Result := CallWindowProc(OldGlyphWndProc, hWnd, Msg, wParam, lParam);
end;

procedure SubclassRightButtonGlyph(Edit: TButtonedEdit);
var
  GlyphHandle: HWND;
  ClassName: array[0..255] of Char;
begin
  GlyphHandle := GetWindow(Edit.Handle, GW_CHILD);
  while GlyphHandle <> 0 do begin
    if GetClassName(GlyphHandle, ClassName, Length(ClassName)) > 0 then
      if ClassName = 'TEditButton.TGlyph' then
        begin
          OldGlyphWndProc := Pointer(GetWindowLongPtr(GlyphHandle, GWL_WNDPROC));
          SetWindowLongPtr(GlyphHandle, GWL_WNDPROC, LONG_PTR(@CustomGlyphWndProc));
          Break;
        end;
    GlyphHandle := GetWindow(Edit.Handle, GW_HWNDNEXT);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  SubclassRightButtonGlyph(ButtonedEdit1);
end;

    How I can see password OnMouseDown, but it does not goes to hidden OnMouseUp?

  4. Posted

    Is it possible to detect OnMouseDown and on MouseUp events on the TButtonedEdit RightButton (TEditButton)?

    I am trying to set it to Show/Hide password when I press/unpress the right button, but there is only an OnClick event for the right button.

    Tried also subclassing, but there is no handle for the right button in TButtonedEdit?

      

    procedure TForm1.FormCreate(Sender: TObject);
begin
  //SetWindowSubclass(ButtonedEdit1.RightButton.Handle, @ButtonedEditSubclassProc, 1, DWORD_PTR(ButtonedEdit1.RightButton)); <- no Handle for RightButton
  SetWindowSubclass(ButtonedEdit1.Handle, @ButtonedEditSubclassProc, 1, DWORD_PTR(ButtonedEdit1));
end;

function ButtonedEditSubclassProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall;
begin
  case uMsg of
    WM_LBUTTONDOWN: Form1.ButtonedEdit1.PasswordChar:=#0; 
    WM_LBUTTONUP: Form1.ButtonedEdit1.PasswordChar:='*';
    WM_NCDESTROY: RemoveWindowSubclass(hWnd, @ButtonedEditSubclassProc, uIdSubclass);
  end;
  Result := DefSubclassProc(hWnd, uMsg, wParam, lParam);
end;

    Password is hidden

     

    1.png.ead8ebaa61fd8a0b8f58e1d6a1efa40b.png

     

    When I press right button is it possible for password to be shown and on unpress to be hidden again?

     

    2.png.d438d94e48537f2d927382793ecdef35.png

     

  5. Posted

    Finally, made it work 🙂 

    ...
    procedure DrawColoredTxt(aBtn: TButton; aCaption: string);
  private
    FOriginalButtonProc: LONG_PTR;
    FButtonWndProcInstance: Pointer;
    procedure ButtonWndProc(var Message: TMessage);
...

procedure TForm1.DrawColoredTxt(aBtn: TButton; aCaption: string);
...
end;

procedure TForm1.ButtonWndProc(var Message: TMessage);
var
  PS: TPaintStruct;
begin
  case Message.Msg of
    WM_PAINT: begin
                BeginPaint(Button2.Handle, PS);
                try
                  // 1. Let Windows paint default button
                  CallWindowProc(Pointer(FOriginalButtonProc), Button2.Handle, Message.Msg, Message.WParam, Message.LParam);
                  // 2. Add our custom text
                  DrawColoredTxt(Button2, 'Admin');
                finally
                  EndPaint(Button2.Handle, PS);
                end;
              end;
    // Forward all other messages to original handler
    else Message.Result := CallWindowProc(Pointer(FOriginalButtonProc), Button2.Handle, Message.Msg, Message.wParam, Message.lParam);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  //do OnCreate
  // 1. Create a method pointer instance
  FButtonWndProcInstance := MakeObjectInstance(ButtonWndProc);
  // 2. Store original proc
  FOriginalButtonProc := GetWindowLongPtr(Button2.Handle, GWLP_WNDPROC);
  // 3. Set new proc using the instance
  SetWindowLongPtr(Button2.Handle, GWLP_WNDPROC, LONG_PTR(FButtonWndProcInstance));
  Button2.Repaint;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  //do OnDestroy
  if (Button2.HandleAllocated) and (FOriginalButtonProc <> 0) then SetWindowLongPtr(Button2.Handle, GWLP_WNDPROC, FOriginalButtonProc);
  // Clean up the method pointer
  if Assigned(FButtonWndProcInstance) then FreeObjectInstance(FButtonWndProcInstance);
  Button2.Caption := 'Admin';
  Button2.Repaint;
end;

    Literally, I can now set color and clear it 🙂

  6. Posted

    47 minutes ago, Remy Lebeau said:

    That is because you are drawing outside of a painting event.

    I have tried to catch OnPaint message, something like this, but no success 😞 

    ...
  procedure DrawColoredTxt(aBtn: TButton; aCaption: string);
private
  procedure WM_PAINT(var Msg: TWMPaint); message WM_PAINT;
...

procedure TForm1.DrawColoredTxt(aBtn: TButton; aCaption: string);
var
  Canvas: TCanvas;
  R: TRect;
begin
  aBtn.Caption := ''; // Clear default caption to avoid overlap
  Canvas := TCanvas.Create;
  try
    Canvas.Handle := GetDC(aBtn.Handle);
    try
      //Draw default button appearance
      SendMessage(aBtn.Handle, WM_ERASEBKGND, Canvas.Handle, 0);
      SendMessage(aBtn.Handle, WM_PRINTCLIENT, Canvas.Handle, PRF_CLIENT);
      // Draw custom text
      R := aBtn.ClientRect;
      Inc(R.Left, -15);  //move to left for width of drop-down-split-btn
      Canvas.Brush.Style := bsClear;
      Canvas.Font.Color := clRed;  // Change font color
      DrawText(Canvas.Handle, PChar(aCaption), -1, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
    finally
      ReleaseDC(aBtn.Handle, Canvas.Handle);
    end;
  finally
    Canvas.Free;
  end;
end;

//OnPaint Msg
procedure TForm1.WM_PAINT(var Msg: TWMPaint);
begin
  inherited;
  if Assigned(Button2) then DrawColoredTxt(Button2, 'Admin'); //<- this does not work
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DrawColoredTxt(Button2, 'Admin');  //<- this works
end;

    What am I missing?

  8. Posted · Edited by davornik

    What I like about Delphi and Windows is that there is always some way for a workaround 🙂

    I have tried to do drawtext over text on TButton and it works partially. 

    var
  aCaption: string;

procedure DrawColoredTxt(aBtn: TButton);
var
  Canvas: TCanvas;
  R: TRect;
begin
  // Bckp Caption
  if aCaption = '' then
    begin
      aCaption:=aBtn.Caption;
      aBtn.Caption := ''; // Hide default caption to avoid overlap
    end;
  //DoDraw
  Canvas := TCanvas.Create;
  try
    Canvas.Handle := GetDC(aBtn.Handle);
    try
      R := aBtn.ClientRect;
      Inc(R.Left, -15);  //move to left for width of dropsplitbtn
      Canvas.Brush.Style := bsClear;
      Canvas.Font.Color := clRed;  // Change font color
      DrawText(Canvas.Handle, PChar(aCaption), -1, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
    finally
      ReleaseDC(aBtn.Handle, Canvas.Handle);
    end;
  finally
    Canvas.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DrawColoredTxt(Button2);
end;

    I get changed font color like this:

     

    172492572_2025-04-1813_54_20-Form1.png.324337a26c34d9a4f6b7d5ddbebe53e4.png

     

    But when I move the mouse into Button2 everything falls apart 😞

    Is there any way to fix this to have properly painted text in Button2?

  10. Posted

    On 2/21/2025 at 11:19 AM, dummzeuch said:

    You could use TBitBtn instead, if that's an option.

    Unfortunatelly, TButton is exactly what I need because TCustomButton.TButtonStyle.bsSplitButton State.

  11. Posted

    I am trying to use TButton, but with changed caption Font.Color. Remy suggested to use BS_OWNERDRAW and intercept WM_DRAWITEM.

    and here also to subclass:

     

    https://stackoverflow.com/a/23125580

     

    I tried it to use like this but no success, font color does not change. 

    ...
type
  TMyButton = class(TButton)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  end;

function ButtonSubclassProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall;

var
  btnFntClr: TMyButton;
...

function ButtonSubclassProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall;
begin
  case uMsg of
    WM_DRAWITEM: TMyButton(dwRefData).Font.Color := clRed;
    WM_NCDESTROY: RemoveWindowSubclass(hWnd, @ButtonSubclassProc, uIdSubclass);
  end;
  Result := DefSubclassProc(hWnd, uMsg, wParam, lParam);
end;

procedure TMyButton.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do Style := Style or BS_OWNERDRAW;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  btnFntClr.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  btnFntClr:=TMyButton.Create(Form1);
  btnFntClr.Parent:=Form1;
  btnFntClr.Style:=TCustomButton.TButtonStyle.bsSplitButton;
  btnFntClr.Caption:='Options';
  with btnFntClr do begin
    Left:=10;
    Top:=10;
    Width:=120;
  end;
  SetWindowSubclass(btnFntClr.Handle, @ButtonSubclassProc, 1, DWORD_PTR(btnFntClr));
end;

    How to properly change font color in TButton?

  12. Posted

    On 11/7/2024 at 5:51 PM, rvk said:

    BTW. You could also do it like TJvDBGridFooter does. (just a inherited TStatusbar where you can define columns which get summed up).

    But there the TJvDBGridFooter and TDBGrid are really separated from each other (component wise) and it's up to the programmer to place the TJvDBGridFooter. 

    Yes, that is ok, but a solution with an "attached" TPanel (TStatusbar) is more practical.

    I have found in some article on SO from Remy Lebeau (thanks Remy for help) that in Designmode you must override WM_NCHitTest message to move TPanel with DBGrid!

      

    ...
protected
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHitTest;
...

procedure TEnhDBGrid.WMNCHitTest(var Message: TWMNCHitTest);
begin
  inherited;
  if (csDesigning in ComponentState) then SetRecPanelPos;
end;

     

    On 11/7/2024 at 5:51 PM, rvk said:

    You might want to do 

    
RecPanel.Parent:=Self.Parent; // this would be the same parent as the TDBGrid

    That's what I tried first, but it does not work.

    Since DBGrid is usually placed on TForm, RecPanel.Parent:=TWinControl(AOwner); will be better alternative, thanks.

  13. Posted

    5 minutes ago, rvk said:

    Do you want that panel over the TDBGrid? That would mean interference when using scrollbar and last record etc.

    No, Panel is below DBGrid because of that. Only thing left is to move it when DBGrid moves in Designmode.

    Everything else works fine, did not notice any other issue (yet :classic_biggrin:).

  14. Posted

    This would be component in simplest way possible. On Resize, TPanel moves/resizes with DBGrid.

    Only thing I don't know is how to make TPanel move with DBGrid in DesignMode?

     

      

    unit EnhDBGrid;

interface

uses
  SysUtils, Classes, DBGrids, ExtCtrls, Messages;

type
  TEnhDBGrid = class(TDBGrid)
  private
    RecPanel: TPanel;
    procedure SetRecPanelPos;
  protected
    procedure UpdateScrollBar; override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

procedure Register;

implementation

constructor TEnhDBGrid.Create(AOwner: TComponent);
begin
  inherited;
  RecPanel:=TPanel.Create(Self);
  RecPanel.Parent:=TDBGrid(AOwner);
  RecPanel.Alignment:=taLeftJustify;
  RecPanel.Caption := '0/0';
  RecPanel.Height := 16;
end;

procedure TEnhDBGrid.Resize;
begin
  inherited;
  if Assigned(RecPanel) then SetRecPanelPos;
end;

procedure TEnhDBGrid.UpdateScrollBar;
begin
  inherited; // to keep the expected behavior
  if Assigned(DataSource) and Assigned(DataSource.DataSet) and DataSource.DataSet.Active then
    RecPanel.Caption := DataSource.DataSet.RecNo.ToString+'/'+DataSource.DataSet.RecordCount.ToString;
end;

procedure TEnhDBGrid.SetRecPanelPos;
begin
  RecPanel.Left := Left;
  RecPanel.Width := Width;
  RecPanel.Top := Top + Height;
end;

procedure Register;
begin
   RegisterComponents('Data Controls', [TEnhDBGrid]);
end;

end.

     

  15. Posted

    Ok, then probably the next step is to make it like this without destructor, perhaps like this?

      

    type
  TDBGrid = class(Vcl.DBGrids.TDBGrid)
  private
    RecPanel: TPanel;
    procedure SetRecPanelPos;
  protected
    procedure UpdateScrollBar; override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

...

procedure TDBGrid.SetRecPanelPos;
begin
  RecPanel.Left := Self.Left;
  RecPanel.Width := Self.Width;
  RecPanel.Top := Self.Top + Self.Height
end;

procedure TDBGrid.Resize;
begin
  inherited;
  SetRecPanelPos;
end;

procedure TDBGrid.UpdateScrollBar;
begin
  //this must be updated here
  if Assigned(Self.DataSource.DataSet) then
    RecPanel.Caption := Self.DataSource.DataSet.RecNo.ToString+'/'+Self.DataSource.DataSet.RecordCount.ToString;
  inherited; // to keep the expected behavior
end;

constructor TDBGrid.Create(AOwner: TComponent);
begin
  inherited;
  RecPanel:=TPanel.Create(Self);
  RecPanel.Parent:=TDBGrid(AOwner);
  RecPanel.Alignment:=taLeftJustify;
  RecPanel.Caption := '0/0';
  RecPanel.Height := 16;
end;

    As far of DataChange event, then I get a message like this: Method 'DataChange' not found in base class...

    When doing it like this in designtime I don't have Panel shown below the DBGrid. I always have to reduce height of DBGrid for height of Panel.

    I suppose the next step is to create it like a component and install it in Delphi? Then Panel would be shown in designtime?

  16. Posted

    I am trying to add TPanel below DBGrid to show information about RecNo/RecCount position in DBGrid.

    Something like in attached image.

     

    I have tried to do this:

      

    type
  TDBGrid = class(Vcl.DBGrids.TDBGrid)
  private
    RecPanel: TPanel;
  protected
    procedure UpdateScrollBar; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

...

procedure TDBGrid.UpdateScrollBar;
begin
  //where is proper place to update this?
  RecPanel.Left := Self.Left;
  RecPanel.Width := Self.Width;
  RecPanel.Top := Self.Top + Self.Height;

  //is this best place to be updated?
  if Assigned(Self.DataSource.DataSet) then
    RecPanel.Caption := Self.DataSource.DataSet.RecNo.ToString+'/'+Self.DataSource.DataSet.RecordCount.ToString;

  inherited; // to keep the expected behavior
end;

constructor TDBGrid.Create(AOwner: TComponent);
begin
  inherited;
  RecPanel:=TPanel.Create(TDBGrid(AOwner));
  RecPanel.Parent:=TDBGrid(AOwner);
  RecPanel.Alignment:=taLeftJustify;
  RecPanel.Caption := '0/0';
  RecPanel.Height := 16;
end;

destructor TDBGrid.Destroy;
begin
  RecPanel.Free;
  inherited;
end;

    Is there better place to update Panel position and record position data then UpdateScrollBar function?

    Does creating Panel like TPanel.Create(TDBGrid(AOwner)) has some benefits than perhaps TPanel.Create(nil)?

     

     

    DBGrid+RecNo-RecCount_Panel.png

  17. Posted

    Hence I use CreateMessageDialog perhaps you can change Icon it self like this:

      

    var
  Dlg: TForm;
  ...
begin
  Dlg:=CreateMessageDialog('My Message', mtConfirmation, [mbOk, mbCancel]);
  //change icon
  TImage(Dlg.FindComponent('Image')).Picture.Icon.Handle := LoadIcon( 0, IDI_QUESTION);
  try
    Result:=Dlg.ShowModal;
  finally
    Dlg.Free;
  end;
end;

     

  18. Posted · Edited by davornik

    Maybe you can check if file is signed with this:

      

    uses Winapi.ImageHlp;

function IsFileDigitallySigned(const FileName: string): Boolean;
var
  FileHandle: THandle;
  CertHeader: TWinCertificate;
begin
  Result := False;
  FileHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
  if FileHandle <> INVALID_HANDLE_VALUE then
    try
      FillChar(CertHeader, SizeOf(CertHeader), 0);
      Result := ImageGetCertificateHeader(FileHandle, 0, CertHeader);
    finally
      CloseHandle(FileHandle);
    end;
end;

     

  20. Posted

    2 minutes ago, Remy Lebeau said:

    And yet, that is the way Microsoft wants you to use it.

    If you really want to detect a mouse click, you will likely have to subclass the TDateTimePicker's window to handle WM_MOUSE(DOWN|UP) messages directly.

    How to subclass TDateTimePicker's window on WM_MOUSE(DOWN|UP) messages?

  21. Posted

    4 hours ago, Lajos Juhász said:

    You are setting the date to today thus after the user clicks to reset the value will remain. Change the code to:

      

    
procedure TForm1.btnResetClick(Sender: TObject);
begin
  DateTimePicker1.Format:=' ';
  DateTimePicker1.Date:=0;
end;

    Now it will change when the user clicks on the today.

    Yes, but it will then show something like 1899 year. DateTimePicker1.Date must be :=Date; is because it needs to be on today's date for user convinience, when calendar drops down - it is user frendly to have view of current month.

  22. Posted

    4 hours ago, PeterBelow said:

    The control (a Windows common control under the VCL surtace) has no real concept of an "empty" state. The usual way to use it is to set the shown date to Today (it does that by default if memory serves) and accept that if the user does not change it. If your requirements really need a way to detect that the user has entered a date you can use an additional TCheckbox that disables the picker unless it is checked.

    I dont want to use checkbox, because it is not user frendly. Main problem is that OnChange event does not fire on every click on calendar but only if Date <> Today.

  23. Posted

    I am using DateTimePicker1.Format as ' ' to set the value to an empty string in TDateTimePicker (using it as dtkDate). 

    procedure TForm1.FormCreate(Sender: TObject);
begin
  DateTimePicker1.Format:=' ';
end;

procedure TForm1.DateTimePicker1Change(Sender: TObject);
begin
  DateTimePicker1.Format:='';
end;

procedure TForm1.btnResetClick(Sender: TObject);
begin
  DateTimePicker1.Format:=' '; //set as Empty
  DateTimePicker1.Date:=Date;
end;

    Change event does not fire if I select today's date. How can I detect a click on the calendar if today's date is selected or clicked somewhere in the calendar itself?

  24. Posted

    After searching myself for way to populate ComboBoxEx with items from TListView in order to be able to filter data I have made recursive function which iterates through all ListView data. It may be usefull.

      

    procedure TForm1.btnPopulateClick(Sender: TObject);
var
  lvl: Integer;
  mNode: TTreeNode;
//--
procedure PlaceTreeItem(nTree: TTreeNode; nLvl: Integer);
var
  nIndent, nImg: Integer;
  NextNode, LastNode: TTreeNode;
begin
  nIndent:=nLvl * 2;
  if nTree.HasChildren then nImg:=0 else nImg:=1;
  ComboBoxEx1.ItemsEx.AddItem(nTree.Text, nImg, nImg, nImg, nIndent, nTree.Data);
  if nTree.HasChildren then
    begin
      Inc(lvl);
      NextNode := nTree.getFirstChild;
      LastNode := nTree.GetLastChild;
      while NextNode <> nil do begin
        PlaceTreeItem(NextNode, lvl);
        if NextNode = LastNode then Dec(lvl);
        NextNode := NextNode.getNextSibling;
      end;
    end;
end;
//--
begin
  ComboBoxEx1.Clear;
  lvl:=0;
  mNode := TreeView1.Items.GetFirstNode;
  while Assigned(mNode) do begin
    PlaceTreeItem(mNode, 0);
    mNode := mNode.getNextSibling;
  end;
end;

     

  25. Posted · Edited by davornik

    I am trying to connect with web-browser to Indy HTTP server runing on https://127.0.0.1:4567.

     

    I have read many tutorials and some of them are interesting, like:
    1. https://mikejustin.wordpress.com/2019/06/14/how-to-lets-encrypt-certificates-with-indy-http-server/
    2. https://synaptica.info/en/2016/09/21/build-your-own-https-server-with-delphi/

    I have created self signed certificates with help of this example tutorial:
    https://github.com/glenkleidon/DelphiCertAuth
    As a passphrase for testing I used "123456".
    After that I have installed newly generated file root_cert.crt in Trusted Root CA in Windows (using "WinKey+R" and certmgr.msc)

     

    In my code I have set: 

    ...  
  // create IOHandler for OpenSSL
  IdServerIOHandlerSSLOpenSSL1.SSLOptions.CertFile := 'mycomputerCertificate.pem';
  IdServerIOHandlerSSLOpenSSL1.SSLOptions.KeyFile := 'mycomputerPrivateKey.pem';
  IdServerIOHandlerSSLOpenSSL1.SSLOptions.RootCertFile := 'certificateAuthorityCertificate.pem';
  IdServerIOHandlerSSLOpenSSL1.SSLOptions.Mode := sslmServer;
  IdServerIOHandlerSSLOpenSSL1.SSLOptions.SSLVersions := [sslvTLSv1, sslvTLSv1_1, sslvTLSv1_2];
...
procedure TForm1.IdServerIOHandlerSSLOpenSSL1GetPassword(var Password: string);
begin
  Password := '123456';
end;
...
procedure TForm1.IdHTTPServer1QuerySSLPort(APort: Word; var VUseSSL: Boolean);
// This will not be called when the request is a HTTPS request
// It facilitates the use of the server for testing via HTTP://localhost:8080 (i.e. without SSL)
begin
  VUseSSL := (APort <> 8080);
end;
...
function TForm1.IdServerIOHandlerSSLOpenSSL1VerifyPeer(Certificate: TIdX509;
  AOk: Boolean; ADepth, AError: Integer): Boolean;
begin
  if ADepth = 0 then
    Result := AOk
  else
    Result := True;
end;
...

    Unfortunately, when I try to connect to https://127.0.0.1:4567 I get an warning (check image).

     

    In application I can see messages and exception raised:
    IdServerIOHandlerSSLOpenSSL1StatusInfo(const AMsg: string);
    AMsg := SSL status: "before/accept initialization";
    AMsg := SSL status: "before/accept initialization";
    AMsg := SSL status: "SSLv3 read client hello A";
    AMsg := SSL status: "SSLv3 write server hello A";
    AMsg := SSL status: "SSLv3 write certificate A";
    AMsg := SSL status: "SSLv3 write server done A";
    AMsg := SSL status: "SSLv3 flush data";
    AMsg := SSL status: "SSLv3 read client certificate A";
    AMsg := SSL status: "SSLv3 read client key exchange A";
    AMsg := SSL status: "error";
    127.0.0.1:55810 Stat Disconnected.

     

    IdHTTPServer1Exception(AContext: TIdContext; AException: Exception);
    EIdOSSLUnderlyingCryptoError: Error accepting connection with SSL.
    error:14094416:SSL routines:ssl3_read_bytes:sslv3 alert certificate unknown


    Am I doing something wrong or I am missing something?

    Why I can't connect to IP address without warning?

     

    2022-11-29-Privacy error.png

×