davornik

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?

I have seen this example. Is there any way to just change font color without drawing a complete button?

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

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)?

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; 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.

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 ).

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.

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?

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;

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;

This is great. How can you set (background or font) color of particular date in TMonthCalendar?

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?

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

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.

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.

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;

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?

Is it posible in Android to intercept keyboard presses from hardware keyboard attached to device? I can detect is HID Device present, but how to get key input from HID before form does? function TForm1.AttachedHIDDevice: Boolean; var i: Jiterator; JavaObject: JObject; DeviceList: JHashMap; USBDevice: JUSBDevice; UsbManager: JUSBManager; begin //Device discovery Result := False; //Get pointer to UsbManager JavaObject := TAndroidHelper.Context.getSystemService(TJContext.JavaClass.USB_SERVICE); UsbManager := TJUsbManager.Wrap((JavaObject as ILocalObject).GetObjectID); if not Assigned(UsbManager) then Exit; //Get a list of connected devices DeviceList := UsbManager.getDeviceList; i := DeviceList.values.iterator; while i.hasNext do begin USBDevice := TJUsbDevice.Wrap((i.next as ILocalObject).GetObjectID); if (USBDevice.getInterfaceCount > 0) then begin Result := USBDevice.getInterface(0).getInterfaceClass = TJUsbConstantsUSB_CLASS_HID; if Result then Break; end; end; end;

Yes, I want to determine from where key is sent.

I would like to intercept Key from external keyboard before it reaches TEdit or Form. Is this possible?

That is not good solution, has some issues. However, OnFormKeyUp is better choice (key is possible to receive only once according to Android docs), but if TEdit is focused TForm doesn't get key. Then, again, if I type Key in external keyboard and I am in TEdit control, key is shown in TEdit (I would like to Intercept it before it reaches any Control on Form or Form itself). Is it possible to differentiate Key origin? Is it received from Virtual Keyboard or HID device?

Perhaps you can use this thread: https://en.delphipraxis.net/topic/5883-delphi-1042-ce-support-android-api-30/

Thank you for yours post, this also helped me to upload app to Google store. Just to make things clearer to download android-30 you must: - run cmd.exe - type cd [path] to go to location where sdkmanager.bat is (usually it is: C:\Users\Public\Documents\Embarcadero\Studio\21.0\PlatformSDKs\android-sdk-windows\tools\bin or C:\Users\Public\Documents\Embarcadero\Studio\21.0\CatalogRepository\AndroidSDK-2525-21.0.40680.4203\tools\bin) - type sdkmanager "platforms;android-30" - answer y on question, and wait until it says "done" Everything else is straightforward...

Code can be made compatible with 64-bit, i have posted probable solution here: https://stackoverflow.com/a/61874765/3225668 NOTE: in FastcodeCPUID.pas there is an error with position of registers when returning value. Registers in code goes like Move...EBX...EDX...ECX... Proper way should be EBX...ECX...EDX...!

// VMware detection as described by Elias Bachaalany function IsInsideVMware: Boolean; //------------------------------ procedure ChkVMware; asm push edx; push ecx; push ebx; mov eax, 'VMXh'; mov ebx, 0; mov ecx, 10; mov edx, 'VX'; in eax, dx; cmp ebx, 'VMXh'; setz [Result]; pop ebx; pop ecx; pop edx; end; //------------------------------ begin Result := True; try ChkVMware; except Result := False; end; end; function IsRunningUnderHyperV: BOOL; stdcall; var VMBranding: array[0..12] of AnsiChar; //------------------------------ procedure GetVMBrand; asm mov eax, $40000000; cpuid; mov dword ptr [VMBranding+0], ebx; // Get the VM branding string mov dword ptr [VMBranding+4], ecx; mov dword ptr [VMBranding+8], edx; end; //------------------------------ begin GetVMBrand; VMBranding[12] := #0; Result := CompareText(String(VMBranding), 'Microsoft Hv') = 0; end; How can thiese function be done in 64-bit? On compile I get [dcc64 Error] Unit1.pas(33): E2116 Invalid combination of opcode and operands Registers need to be changed. Which to use?