SetWindowSubclass changes ANSI windows to UNICODE - delphi

Is SetWindowSubClass() supposed to change an ANSI window into a UNICODE widow? I didn't find anything in the documentation, or on the web, about this behavior.
I created a test application (full source) just to illustrate how SetWindowSubclass (I believe) changes the type of the affected window from ANSI to UNICODE, as it shouldn't! IsWindowUnicode() confirms the change.
program TwoWaySubclassing;
{$apptype gui}
{$R Generic.res}
{
{ I created this test application just to illustrate how SetWindowSubclass()
{ changes -- I believe -- the type of the affected window from ANSI to UNICODE,
{ as it shouldn't! IsWindowUnicode() confirms that.
{
{ The Delphi 7 (all ANSI) application has 2 edit controls:
{ 1. The smaller, which is subclassed in 2 switchable ways (called Modes).
{ 2. The bigger, like a memo, not subclassed. Just for dumping info.
{ 3. A button for switching between modes, on-the-fly.
{
{ The default subclassing Mode uses SetWindowLong (the classic way).
{ When pressing the button, the edit control is subclassed via SetWindowSubclass.
{ Pressing it again brings the edit control back to the default SetWindowLong mode.
{
{ The main window (and all child controls) are created using the ANSI version
{ of the API procedure, so the message handler should receive, in "lParam",
{ a pointer to an ANSI text (along with the wm_SetText message), always!
{
{ The problem is that's not happening when the edit control is subclassed using
{ the SetWindowSubclass mode! SetWindowSubclass() simply changes the window
{ from ANSI to UNICODE and starts sending a PWideChar(lParam) rather than the
{ expected PAnsiChar(lParam).
{
{ Once back to the default SetWindowLong mode, the window becomes ANSI again!
{ Just run the application and try switching between modes. Look carefully at the
{ detailed info shown in the bigger edit control.
{
{ Screenshots:
{ 1. http://imgh.us/mode1.png
{ 2. http://imgh.us/mode2.png
{
{ Environment:
{ Windows 7 32-bit
{ Delphi 7 (all-ANSI)
{
{ Regards,
{ Paulo França Lacerda
}
uses
Windows,
Messages,
SysUtils;
type
UINT_PTR = Cardinal;
DWORD_PTR = Cardinal;
TSubClassProc = function (hWnd:HWND; uMsg:UINT; wParam:WPARAM; lParam:LPARAM; uIdSubclass:UINT_PTR; dwRefData:DWORD_PTR) :LRESULT; stdcall;
TSubMode = (
subSetWindowLong,
subSetWindowSubclass);
const
LtBool :Array[Boolean] of String = ('False', 'True');
LtSubMode :Array[TSubMode] of String = ('SetWindowLong', 'SetWindowSubclass');
strTextUsingPAnsiChar = 'ANSI Text in PAnsiChar(lParam)';
strTextUsingPWideChar = 'UNICODE Text in PWideChar(lParam)';
const
cctrl = Windows.comctl32;
function SetWindowSubclass (hWnd:Windows.HWND; pfnSubclass:TSubClassProc; uIdSubclass:UINT_PTR; dwRefData:DWORD_PTR) :BOOL; stdcall; external cctrl name 'SetWindowSubclass';
function RemoveWindowSubclass (hWnd:Windows.HWND; pfnSubclass:TSubClassProc; uIdSubclass:UINT_PTR) :BOOL; stdcall; external cctrl name 'RemoveWindowSubclass';
function DefSubclassProc (hWnd:HWND; uMsg:UINT; wParam:WPARAM; lParam:LPARAM) :LRESULT; stdcall; external cctrl name 'DefSubclassProc';
var
wc :TWndClass;
Msg :TMsg;
hButton :HWnd;
hEdit :HWnd;
hEdit2 :HWnd;
hFont :HWnd;
hFont2 :HWnd;
hMainHandle :HWnd;
swl_OldProc :Pointer; // Default Procedure for Subclassing #1 (via SetWindowLong)
SubMode :TSubMode;
procedure Release_Resources;
begin
DestroyWindow (hButton); hButton := 0;
DestroyWindow (hEdit); hEdit := 0;
DestroyWindow (hEdit2); hEdit2 := 0;
DeleteObject (hFont); hFont := 0;
DeleteObject (hFont2); hFont2 := 0;
end;
procedure MsgBox (S:String);
begin
MessageBox (hMainHandle, PChar(S), 'Information', mb_Ok or mb_IconInformation);
end;
procedure Reveal_Text (lParam:LPARAM);
const
lf = #13#10;
lf2 = lf+lf;
var
S :String;
AnsiTxt :String;
UnicTxt :String;
Remarks :Array[1..3] of String;
begin
if IsWindowUnicode(hEdit)
then Remarks[1] := ' (Man! SetWindowSubclass changed it to Unicode!!)'
else Remarks[1] := ' (great! as designed)';
AnsiTxt := PAnsiChar(lParam);
if (Length(AnsiTxt) = 1)
then Remarks[2] := ' (text is obviously truncated)'
else Remarks[2] := ' (text is healthy and is ANSI, as it should)';
UnicTxt := PWideChar(lParam);
if (Pos('?',UnicTxt) > 0)
then Remarks[3] := ' (text is obviously garbaged)'
else Remarks[3] := ' (text is healthy, but I want it to be ANSI)';
S :=
'Subclassed using: '
+lf +' '+LtSubMode[SubMode]+'()'
+lf2+ 'IsUnicodeWindow(hEdit)? '
+lf +' '+LtBool[IsWindowUnicode(hEdit)]
+lf + Remarks[1]
+lf2+'PAnsiChar(lParam):'
+lf +' "'+PAnsiChar(lParam)+'"'
+lf + Remarks[2]
+lf2+ 'PWideChar(lParam):'
+lf +' "'+PWideChar(lParam)+'"'
+lf + Remarks[3];
SetWindowText (hEdit2, PChar(S));
end;
function swl_EditWndProc (hWnd:HWnd; uMsg:UInt; wParam:WParam; lParam:LParam) :LResult; stdcall;
begin
Result := CallWindowProc (swl_OldProc, hWnd, uMsg, wParam, lParam);
if (uMsg = wm_SetText) then Reveal_Text(lParam);
end;
function sws_EditWndProc (hWnd:HWND; uMsg:UINT; wParam:WPARAM; lParam:LPARAM; uIdSubclass:UINT_PTR; dwRefData:DWORD_PTR) :LRESULT; stdcall;
begin
Result := DefSubclassProc (hWnd, uMsg, wParam, lParam);
if (uMsg = wm_SetText) then Reveal_Text(lParam);
end;
procedure do_SetWindowSubclass;
begin
if not SetWindowSubclass (hEdit, #sws_EditWndProc, 1, dword_ptr($1234{whatever}))
then RaiseLastOSError;
SubMode := subSetWindowSubclass;
end;
procedure undo_SetWindowSubclass;
begin
if not RemoveWindowSubclass (hEdit, #sws_EditWndProc, 1)
then RaiseLastOSError;
SubMode := subSetWindowLong; // restored
end;
function AppWindowProc (hWnd:HWnd; uMsg:UInt; wParam:WParam; lParam:LParam) :LResult; stdcall;
begin
case uMsg of
wm_Command:
begin
if (lParam = hButton) then
case SubMode of
subSetWindowLong:
begin
do_SetWindowSubclass; // now using SetWindowSubclass()
SetWindowText (hEdit, PChar(strTextUsingPWideChar));
SetWindowText (hButton, PChar('Switch back to SetWindowLong mode'));
end;
subSetWindowSubclass:
begin
undo_SetWindowSubclass; // back to SetWindowLong()
SetWindowText (hEdit, PChar(strTextUsingPAnsiChar));
SetWindowText (hButton, PChar('Switch to SetWindowSubclass mode'));
end;
end;
end;
wm_Destroy:
begin
Release_Resources;
PostQuitMessage (0);
Exit;
end;
end;
Result := DefWindowProc (hWnd, uMsg, wParam, lParam);
end;
var
W,H :Integer;
begin
wc.hInstance := hInstance;
wc.lpszClassName := 'ANSI_Wnd';
wc.Style := cs_ParentDC;
wc.hIcon := LoadIcon(hInstance,'MAINICON');
wc.lpfnWndProc := #AppWindowProc;
wc.hbrBackground := GetStockObject(white_brush);
wc.hCursor := LoadCursor(0,IDC_ARROW);
RegisterClass(wc); // ANSI (using Delphi 7, so all Windows API is mapped to ANSI).
W := 500;
H := 480;
hMainHandle := CreateWindow ( // ANSI (using Delphi 7, so all Windows API is mapped to ANSI).
wc.lpszClassName,'2-Way Subclassing App',
ws_OverlappedWindow or ws_Caption or ws_MinimizeBox or ws_SysMenu or ws_Visible,
((GetSystemMetrics(SM_CXSCREEN)-W) div 2), // vertically centered in screen
((GetSystemMetrics(SM_CYSCREEN)-H) div 2), // horizontally centered in screen
W,H,0,0,hInstance,nil);
// create the fonts
hFont := CreateFont (-14,0,0,0,0,0,0,0, default_charset, out_default_precis, clip_default_precis, default_quality, variable_pitch or ff_swiss, 'Tahoma');
hFont2:= CreateFont (-14,0,0,0,0,0,0,0, default_charset, out_default_precis, clip_default_precis, default_quality, variable_pitch or ff_swiss, 'Courier New');
// create the edits
hEdit :=CreateWindowEx (WS_EX_CLIENTEDGE,'EDIT','some text', WS_VISIBLE or WS_CHILD or ES_LEFT or ES_AUTOHSCROLL, 10,35,W-40, 23,hMainHandle,0,hInstance,nil);
hEdit2:=CreateWindowEx (WS_EX_CLIENTEDGE,'EDIT','details', WS_VISIBLE or WS_CHILD or ES_LEFT or ES_AUTOHSCROLL or ES_MULTILINE,10,72,W-40,300,hMainHandle,0,hInstance,nil);
SendMessage(hEdit, WM_SETFONT,hFont, 0);
SendMessage(hEdit2,WM_SETFONT,hFont2,0);
// create the button
hButton:=CreateWindow ('Button','Switch to SetWindowSubclass mode', WS_VISIBLE or WS_CHILD or BS_PUSHBUTTON or BS_TEXT, 90,H-95,290,32,hMainHandle,0,hInstance,nil);
SendMessage(hButton,WM_SETFONT,hFont,0);
// subclass the Edit using the default method.
swl_OldProc := Pointer(GetWindowLong(hEdit,GWL_WNDPROC));
SetWindowLong (hEdit,GWL_WNDPROC,Longint(#swl_EditWndProc));
SubMode := subSetWindowLong;
SetWindowText (hEdit, PChar(strTextUsingPAnsiChar));
// message loop
while GetMessage(Msg,0,0,0) do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end.
The application has 2 edit controls:
The smaller one, which is subclassed in 2 switchable ways (here called Modes).
The bigger one, like a memo, not subclassed. Just for dumping info.
There is also a button for switching between the modes.
The default subclassing mode uses SetWindowLong() (the classic way):
In Delphi 2007 and earlier, the main window (and all child controls) are created using the ANSI version of the Win32 API procedures, so the message handler (of the subclassed control) should receive ANSI text (along with the WM_SETTEXT message), always!
The problem is that's not happening when the edit control is subclassed using SetWindowSubclass()! SetWindowSubClass() changes the window from ANSI to UNICODE and it starts receiving Unicode text rather than the expected ANSI text.
Pressing the button subclasses the edit control via SetWindowSubclass():
Pressing the button again subclasses the edit control via SetWindowLong().
Once back to the SetWindowLong() mode, the edit control automatically receives ANSI text again:
Just run the application and try switching between modes. Look carefully at the detailed info shown in the bigger edit control.
Just to be clear: I think this is a Microsoft bug. However, in case it's a "feature", could someone lead me to the respective documentation? I could not find it anywhere.

According to MSDN:
Subclassing Controls Using ComCtl32.dll version 6
Note ComCtl32.dll version 6 is Unicode only. The common controls
supported by ComCtl32.dll version 6 should not be subclassed (or
superclassed) with ANSI window procedures.
...
Note All strings passed to the procedure are Unicode strings even if Unicode is not specified as a preprocessor definition.
So it seems this is as designed.
comctl32.dll in my c:\windows\syswow64 folder is version 6.1.

Related

VCL richedit, slow to change word colors

I have the following code in a delphi program (VCL based desktop application) to iterate through lines of text (sentences of between about 8-15 words) in a richedit, find instances of a user selected word, and then color that word 'red' should it appear on a line.
The problem: The color changing proceeds painfully slowly (several minutes elapse) if the procedure must work through more than a few thousand lines. I'm left sitting here while the cursor dances around. Here's the procedure that is the source of the delay:
procedure Color_Words(RE: TRichEdit; Word: String; Color: TColor);
var
i, startPos, CharPos2, nosChars: Integer;
begin
startPos := 0;
nosChars := 0;
charpos2:=0;
RE.lines.beginupdate;
for i := 0 to Pred(RE.Lines.Count) do
begin
nosChars := nosChars + Length(RE.Lines[i]);
CharPos2 := RE.FindText(word, startPos,nosChars,stmatchcase]);
startPos := CharPos2+1;
RE.SelStart := CharPos2;
RE.SelLength :=(Length(word));
RE.SelAttributes.Color := Color;
end;
RE.Lines.EndUpdate;
end;
Can someone come up with a procedure that is much, much quicker, or advise me how to solve matters? Also, if you could explain the slow processing in layman's terms that would be wonderful. (I am but a hobbyist).
First thing to do is change your code to use the version 4.1 of RichEdit control (introduced with Windows XP SP1), that alone might speed things up.
"RichEdit20W": Riched20.dll (Windows 98)
"RICHEDIT50W": Msftedit.dll (Windows XP SP1)
Windows continues to support the older versions of the RichEdit control, but Delphi stubbornly continues to use the old version, as you can see in Vcl.ComCtrls.pas:
procedure TCustomRichEdit.CreateParams(var Params: TCreateParams);
const
RichEditClassName = 'RICHEDIT20W';
begin
inherited CreateParams(Params);
CreateSubClass(Params, RichEditClassName); //<-- 'RICHEDIT20W'
//...
end;
Tell Delphi to use the Windows XP era RichEdit 4.1
There are a couple ways to fix this; the least intrusive is to create a new unit:
MicrosoftEdit.pas
unit MicrosoftEdit;
interface
uses
Vcl.ComCtrls, Winapi.RichEdit, Vcl.Controls, Winapi.Windows, System.Classes;
type
TRichEdit = class(Vcl.ComCtrls.TRichEdit)
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
implementation
{ TMicrosoftEdit }
procedure TRichEdit.CreateParams(var Params: TCreateParams);
const
MSFTEDIT_CLASS = 'RICHEDIT50W'; //Richedit 4.1, Msftedit.dll
begin
LoadLibrary('msftedit.dll');
inherited CreateParams({var}Params);
CreateSubClass({var}Params, MSFTEDIT_CLASS); //"RICHEDIT50W"
end;
end.
And then include MicrosoftEdit.pas as the last unit in the interface section of your form's uses clause. And you can even be doubly sure that it works by re-declaring TRichEdit to be your new TRichEdit:
unit MyForm;
uses
Forms, RichEdit, MicrosoftEdit;
type
TRichEdit = MicrosoftEdit.TRichEdit; //use our own TRichEdit
TMyForm = class(TForm)
RichEdit1: TRichEdit;
private
protected
public
end;
//...
OnChange?
If you are making formatting changes to the text in a RichEdit:
procedure TMyForm.Button1Click(Sender: TObject);
begin
Color_Words(RichEdit1, 'Trump', clRed);
end;
and you have an OnChange handler attached to the RichEdit, it will fire the OnChange every time the formatting changes. You need to stop that:
procedure TMyForm.Button1Click(Sender: TObject);
var
oldOnChange: TNotifyEvent;
begin
oldOnChange := RichEdit1.OnChange;
RichEdit1.OnChange := nil;
try
Color_Words(RichEdit1, 'Trump', clRed);
finally
RichEdit1.OnChange := oldOnChange;
end;
end;
Undos
In addition, every coloring change you make will be recorded in the Undo list! As well as the RichEdit redrawing every time. Stop those:
procedure TMyForm.Button1Click(Sender: TObject);
var
oldOnChange: TNotifyEvent;
begin
oldOnChange := RichEdit1.OnChange;
RichEdit1.OnChange := nil;
try
RichEditSuspendAll(RichEdit1, True);
try
Color_Words(RichEdit1, 'Trump', clRed);
finally
RichEditSuspendAll(RichEdit1, False);
end;
finally
RichEdit1.OnChange := oldOnChange;
end;
end;
With a helper function:
procedure RichEditSuspendAll(ARichEdit: TRichEdit; bSuspend: Boolean);
var
doc: ITextDocument;
re: IUnknown;
begin
{
http://bcbjournal.org/articles/vol3/9910/Faster_rich_edit_syntax_highlighting.htm
int eventMask = ::SendMessage(RichEdit1->Handle, EM_SETEVENTMASK, 0, 0);
SendMessage(RichEdit1->Handle, WM_SETREDRAW, false, 0);
ParseAllText(RichEdit1);
SendMessage(RichEdit1->Handle, WM_SETREDRAW, true, 0);
InvalidateRect(RichEdit1->Handle, 0, true);
SendMessage(RichEdit1->Handle, EM_SETEVENTMASK, 0, eventMask);
}
{
http://support.microsoft.com/KB/199852
How To Suspend and Resume the Undo Functionality in Richedit 3.0
If it is necessary to Undo an action that is performed before a suspend, after resuming the Undo, then,
tomFalse must be replaced with "tomSuspend" and tomTrue must be replaced with "tomResume".
This method retains the contents of the Undo buffer even when Undo is suspended.
Applications can retrieve an ITextDocument pointer from a rich edit control.
To do this, send an EM_GETOLEINTERFACE message to retrieve an IRichEditOle
object from a rich edit control. Then, call the object's
IUnknown::QueryInterface method to retrieve an ITextDocument pointer.
}
if ARichEdit = nil then
raise Exception.Create('ARichEdit is nil');
if SendMessage(ARichEdit.Handle, EM_GETOLEINTERFACE, 0, LPARAM(#re)) = 0 then
raise Exception.Create('Could not get OleInterface from RichEdit');
doc := re as ITextDocument;
doc := RichEditGetTextDocument(ARichEdit);
if bSuspend then
begin
RichEdit.Perform(WM_SETREDRAW, 0, 0); //disable all painting of the control
doc.Undo(Integer(tomSuspend)); // Suspends Undo.
end
else
begin
doc.Undo(Integer(tomResume)); // Resumes Undo.
RichEdit.Perform(WM_SETREDRAW, 0, 0); //disable all painting of the control
end;
end;

Delphi Canvas Textout with RightToLeft BidiMode

I want to print Right-to-left Unicode strings on a Canvas. I can't find a BidiMode property or something like that to get it done.
currently the symbols which are located at the end of strings, appear before the first character of the text which is printed on the Canvas.
FMX
FireMonkey does not have any BiDi capabilities at this time.
VCL
The Vcl.TControl class has public DrawTextBiDiModeFlags() and DrawTextBiDiModeFlagsReadingOnly() methods, which help the control decide the appropriate BiDi flags to specify when calling the Win32 API DrawText() function.
In Vcl.Graphics.TCanvas, its TextOut() and TextRect() methods do not use the Win32 API DrawText() function, they use the Win32 API ExtTextOut() function instead, where the value of the TCanvas.TextFlags property is passed to the fuOptions parameter of ExtTextOut(). The TextFlags property also influences the value of the TCanvas.CanvasOrientation property, which TextOut() and TextRect() use internally to adjust the X coordinate of the drawing.
For right-to-left drawing with TCanvas, include the ETO_RTLREADING flag in the TextFlags property.
Had no success to display RTL text with "TextOut" when form bidimode is set to "bdLeftToRight", so I usually used
XXX.Canvas.TextRect(Rect,Text,[tfRtlReading,tfRight]);
Worked very well for me..
I needed to detect Hebrew, so I did it like this:
function CheckHebrew(s: string): boolean;
var
i: Integer;
begin
Result := false;
for i := 1 to Length(s) do
if (ord(s[i])>=1424) and (ord(s[i])<1535) then
begin
Result := true;
exit;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
tf : TTextFormat;
r : TRect;
s : string;
begin
r.Left := 0;
r.Top := 0;
r.Width := Image1.Width;
r.Height := Image1.Height;
s := Edit1.Text;
if CheckHebrew(s) then
tf := [tfRtlReading,tfRight,tfWordBreak]
else
tf := [tfWordBreak];
Image1.Canvas.FillRect(r);
Image1.Canvas.TextRect(r,s,tf)
end;

Numeric edit control with flat button inside and no calculator

I'm writing a C++ project with RAD Studio, but this also applies to Delphi.
I need an edit control where user can only enter floats (2 decimal places) and can restore the original value (taken from a variable, not important here) clilcking on a button (actullay an icon) inside the edit control itself.
This is what I've done, using a TJvCalcEdit from JEDI library.
Control definition:
object Sconto1: TJvCalcEdit
[non-important attributes...]
ButtonFlat = True
Glyph.Data = {
D6020000424DD6020000000000003600000028000000100000000E0000000100
180000000000A0020000130B0000130B00000000000000000000FFFFFFFFFFFF
FFFFFFFFFFFFFFFFFF999EC29396C3FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9198C48694CBA7BAFE8493CA72
75B9FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8B96C5
8695CBA7BAFEA7BAFEA7BAFEA7BAFE747EB66D71B5FFFFFFFFFFFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFF8493CAA7BAFEA7BAFEA7BAFEA7BAFEA7BAFEA7BAFE84
93CA7E83CE6D71B4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF8F94C3A7BAFE
A7BAFEA7BAFEA7BAFEA7BAFEA7BAFE8492CA8288D27B7FCA6D71B4FFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFF8492CAA7BAFEA7BAFEA7BAFE828ECA7B82C993
96FA6D6FB67B7FCA7B7FCA6D6FB4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9299C2
A5B7FE7E88CA787DC99396FA9396FA9396FA9396FA6D6FB67B7FCA7B7FCA6D6F
B4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7678C89396FA9396FA9396FA9396FA93
96FA9396FA9396FA6D6FB67B7FCA7B7FCA6C6FB3FFFFFFFFFFFFFFFFFFFFFFFF
FFFFFF7678C89396FA9396FA9396FA9396FA9396FA9396FA9396FA6D6FB67B7F
CA7B7FCA7576B0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7678C89396FA9396FA93
96FA9396FA9396FA9396FA9396FA6D6FB67B7FCA6266A2D6D0E2FFFFFFFFFFFF
FFFFFFFFFFFFFFFFFF7678C89396FA9396FA9396FA9396FA9396FA9396FA9396
FA6D6FB67B7FCA7C7EB0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7678C893
96FA9396FA9396FA9396FA9396FA9396FA9396FA7679C66B6DACFFFFFFFFFFFF
FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7678C89396FA9396FA9093F58B8EEC7678
C87C7FC6ACABE5FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
FFFF7678C88283C5A4A4E7C4C1EBFFFFFFFFFFFFFFFFFFFFFFFF}
ImageKind = ikCustom
DecimalPlacesAlwaysShown = False
OnButtonClick = EScontoButtonClick
end
Method called on button click:
void __fastcall TFRigOrd::EScontoButtonClick(TObject *Sender)
{
TJvCalcEdit* edit = dynamic_cast<TJvCalcEdit*>(Sender);
edit->Value = oldSconto1;
}
The problem: at the end of this method a calculator popup appears below the control, requiring an action by the user. I don't want this to happen because I'm changing the value programmatically. I guess it's a default value due to the fact that such button is made for triggering the calculator. Moreover the value you see (255) appears without decimal point, with will be shown only once the calculator is closed.
So, can I disable this behaviour? Or can someone suggest me a solution with another control (standard, open source or free anyway)?
I'd use a TButtonedEdit to get the button, and to enforce floating-point input with a maximum of two decimals after the point, I'd do
TButtonedEdit = class(ExtCtrls.TButtonedEdit)
protected
procedure KeyPress(var Key: Char); override;
procedure WMPaste(var Message: TWMPaste); message WM_PASTE;
end;
...
procedure TButtonedEdit.KeyPress(var Key: Char);
function InvalidInput: boolean;
var
dc: integer;
begin
result := false;
if Character.IsControl(Key) then Exit;
dc := Pos(DecimalSeparator, Text);
if not (Key in ['0'..'9', DecimalSeparator]) then Exit(true);
if Pos(DecimalSeparator, Text) > 0 then
begin
if Key = DecimalSeparator then Exit(true);
if (Length(Text) - dc > 1)
and (Pos(DecimalSeparator, Text) < SelStart + 1) and
(SelLength = 0) then Exit(true);
end;
end;
begin
inherited;
if InvalidInput then
begin
Key := #0;
beep;
end;
end;
procedure TButtonedEdit.WMPaste(var Message: TWMPaste);
var
s: string;
i: integer;
hasdc: boolean;
NewText: string;
NewSelStart: integer;
begin
if Clipboard.HasFormat(CF_TEXT) then
begin
s := Clipboard.AsText;
NewText := Text;
Delete(NewText, SelStart + 1, SelLength);
Insert(s, NewText, SelStart + 1);
// Validate
hasdc := false;
for i := 1 to Length(NewText) do
begin
if NewText[i] = DecimalSeparator then
if hasdc then
begin
beep;
Exit;
end
else
hasdc := true
else if not (NewText[i] in ['0'..'9']) then
begin
beep;
Exit;
end;
end;
// Trim
if hasdc then
NewText := Copy(NewText, 1, Pos(DecimalSeparator, NewText) + 2);
NewSelStart := SelStart + Length(s);
Text := NewText;
SelStart := NewSelStart;
SelLength := 0;
end
else
inherited;
end;
Sample demo EXE
Use stock VCL buttoned editor
http://docwiki.embarcadero.com/Libraries/en/Vcl.ExtCtrls.TButtonedEdit
Use OnChange to filter out wrong input (or use JvValidators)
Another approach, JediVCL-based one, would be to use base button-enabled editor
http://wiki.delphi-jedi.org/wiki/JVCL_Help:TJvComboEdit
This has EditMask property, just like TMaskEdit has, so you can tweak it to accept only digits.
And at very least OnChange event would allow u to filter non-numeric text input as well.

Delphi - Win7 Window Focus Issue

I execute exe file by CreateProcess() and set foreground process by SetForegroundWindow().
but it doesn't work in Win7 so I have to click icon in taskbar.
How can I implement the behaviour I want (which is to Launch and BringToForeground)?
You shouldn't even try to do this. The change in SetForegroundWindow was intentional - it prevents applications from stealing the focus from what the user wants to have focus. See the Remarks section of the link above.
Win7 probably won't let non-administrative users change the needed registry setting, much less do it without a restart of the system.
You should just use FlashWindow instead to get the user's attention, as Microsoft recommends. Any application that insists on stealing focus away from what I choose to do will be uninstalled immediately.
I was going to post a link (in a comment) to a piece of code that I once had to apply to solve a problem of my own. The link has turned out to be broken now, so I'm posting the code here for what it's worth (it has been tested in Windows XP Pro SP2 and Windows Server 2003, but not in Windows 7):
function ForceForegroundWindow(hwnd: THandle): boolean;
{
found here:
http://delphi.newswhat.com/geoxml/forumhistorythread?groupname=borland.public.delphi.rtl.win32&messageid=501_3f8aac4b#newsgroups.borland.com
}
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID: DWORD;
timeout: DWORD;
begin
if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);
if GetForegroundWindow = hwnd then Result := true
else begin
// Windows 98/2000 doesn't want to foreground a window when some other
// window has keyboard focus
if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and ((Win32MajorVersion > 4) or
((Win32MajorVersion = 4) and (Win32MinorVersion > 0)))) then begin
// Code from Karl E. Peterson, www.mvps.org/vb/sample.htm
// Converted to Delphi by Ray Lischner
// Published in The Delphi Magazine 55, page 16
Result := false;
ForegroundThreadID := GetWindowThreadProcessID(GetForegroundWindow,nil);
ThisThreadID := GetWindowThreadPRocessId(hwnd,nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
AttachThreadInput(ThisThreadID, ForegroundThreadID, false); // bingo
Result := (GetForegroundWindow = hwnd);
end;
if not Result then begin
// Code by Daniel P. Stasinski
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, #timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), SPIF_SENDCHANGE);
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hWnd);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
end;
end
else begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
end;
Result := (GetForegroundWindow = hwnd);
end;
end; { ForceForegroundWindow }
end.
I didn't add anything to the function apart from a small comment 'bingo', which marks the line which actually brought about the desired effect.
Just so you guys didn't think I was abusing users' experience with this function, here's some explanation.
This function was used in an application that was called remotely with the help of Citrix software set up on users' Tablet PCs, and the application ran in full screen. A typical working session almost entirely consisted of that application (other parts were just system components which user never interacted with).
Now some parts of our application had to be implemented as separate small applications, and they were designed to stay on top of all other windows until closed, just like modal windows. Once in a while they used to lose their Z order and hide under the main application's main window, and that was a total disaster for users. Using the 'top-most' property wasn't an option there, so we had to find a way to sustain their Z-order positions. And so we used this function.
ForceForegroundWindow worked for me in Win10. However, it does not activate the external program. It only makes it visible and on top. The program also only does the same when calling itself. I am assuming that if it activated it would also setfocus appropriately for the user.
Rick
I found a resolution for activating and setting focus... In the "SetAppRestore" procedure I initiated it with "MainFrm.visible:= false". Then it goes to SwitchApp, and it calls ForceForegroundWindow. After it returns to "SetAppRestore", I inserted "MainFrm.visible:= true". This triggered the app to become active and have focus on defined component: DataPge.SetFocus.
I apologize for not placing the code in a code block. I couldn't understand the instructions. So I put it all between 2 ===== bars.
//==========================
function TMainFrm.FindWindowExtd(partialTitle: string): HWND; // get with wildcard
var // by Dorin Duminica, September 10, 2009
hWndTemp: hWnd;
iLenText: Integer;
cTitletemp: array [0..254] of Char;
sTitleTemp: string;
begin
hWndTemp := FindWindow(nil, nil);
while hWndTemp <> 0 do
begin
iLenText := GetWindowText(hWndTemp, cTitletemp, 255);
sTitleTemp := cTitletemp;
sTitleTemp := UpperCase(copy( sTitleTemp, 1, iLenText));
partialTitle := UpperCase(partialTitle);
if pos(partialTitle, sTitleTemp) <> 0 then Break;
hWndTemp := GetWindow(hWndTemp, GW_HWNDNEXT);
end;
result := hWndTemp;
end;
function ForceForegroundWindow(hwnd: THandle): boolean;
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID: DWORD;
timeout: DWORD;
begin
if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);
if GetForegroundWindow = hwnd
then Result:= true
else begin
// Windows 98/2000 doesn't want to foreground a window when some other
// window has keyboard focus
if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and ((Win32MajorVersion > 4) or
((Win32MajorVersion = 4) and (Win32MinorVersion > 0)))) then
begin
// Code from Karl E. Peterson, www.mvps.org/vb/sample.htm
// Converted to Delphi by Ray Lischner
// Published in The Delphi Magazine 55, page 16
Result:= false;
ForegroundThreadID:= GetWindowThreadProcessID(GetForegroundWindow,nil);
ThisThreadID:= GetWindowThreadPRocessId(hwnd,nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
AttachThreadInput(ThisThreadID, ForegroundThreadID, false); // bingo
Result:= (GetForegroundWindow = hwnd);
//showmessage('case 1');
end;
if not Result then
begin
// Code by Daniel P. Stasinski
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, #timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), SPIF_SENDCHANGE);
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hWnd);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
//showmessage('case 2');
end;
end
else begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
//showmessage('case 3');
end;
Result:= (GetForegroundWindow = hwnd);
end;
end; { ForceForegroundWindow }
procedure TMainFrm.SwitchApp(AppCaption:string); // application.restore;
begin
//TmpAppHandle:= FindWindow(nil, PChar(AppCaption)); // uses Windows unit - must be entire caption
TmpAppHandle:= FindWindowExtd(AppCaption); // finds 'notepad' as partial of 'Document - Notepad'
if (TmpAppHandle<>0)
then begin
//SetForegroundWindow(TmpAppHandle); // worked by itself for WinXP and Win7
ForceForegroundWindow(TmpAppHandle);
end
else ShowAlert(AppCaption+' *not found*');
end;
// application.restore can't restore from MainForm.windowstate:=wsMinimized
// SetAppMinimize and SetAppRestore fix that issue and manual minimizations
procedure TMainFrm.SetAppMinimize; // application.minimize
begin
if not(MainFrm.WindowState=wsMinimized) then
begin
MainFrm.WindowState:= wsMinimized;
end;
SwitchApp(ServerName); // autocad or bricscad
end;
procedure TMainFrm.SetAppRestore; // application.restore
begin
MainFrm.visible:= false; // ** to reinsate and focus in win10 **
if (MainFrm.WindowState=wsMinimized) then
begin
MainFrm.WindowState:= wsNormal;
end;
SwitchApp('CmdData'); // partial string for app title
MainFrm.visible:= true; // ** to reinsate and focus in win10 **
FormatGrid; // added for activex crash
DataPge.SetFocus;
Update;
end;
//==========================

How can I tell what monitor the Delphi IDE Object Inspector is on?

This is a follow up to How can I get the Delphi IDE's Main Form? which I now have working.
I'd like to go one step further and place my designer on the same form as the Object Inspector, for those who use the classic undocked desktop layout and may have the Object Inspector on a different screen than the main Delphi IDE form.
Any ideas on how I find which monitor the Object Inspector is on from inside my design time package?
This should work whether the property inspector is docked or not, since it falls back to the main form for the docked case:
function EnumWindowsProc(hwnd: HWND; lParam: LPARAM): Integer; stdcall;
var
ClassName: string;
PID: Cardinal;
begin
Result := 1;
GetWindowThreadProcessId(hwnd, PID);
if PID = GetCurrentProcessId then
begin
SetLength(ClassName, 64);
SetLength(ClassName, GetClassName(hwnd, PChar(ClassName), Length(ClassName)));
if ClassName = 'TPropertyInspector' then
begin
PHandle(lParam)^ := hwnd;
Result := 0;
end;
end;
end;
function GetPropertyInspectorMonitor: TMonitor;
var
hPropInsp: HWND;
begin
hPropInsp := 0;
EnumWindows(#EnumWindowsProc, LPARAM(#hPropInsp));
if hPropInsp = 0 then
hPropInsp := Application.MainFormHandle;
Result := Screen.MonitorFromWindow(hPropInsp);
end;

Resources