Assign Font From TComboBox D7 - delphi

Delphi v7
Let me preface my remedial question by saying that I am not a real programer. I am a Deputy Sheriff and I write an occasional project to help us do what we do.
My current project contains several TDBRichEdit controls. I have assigned various formatting processes to toolbar buttons. I would like to be able to change the RichEdit font using a ComboBox. The combobox is populated with the font list, but it does not affect the font of the TDBRichEdit control. I have been trying to figure this out for over a week and I cannot see the problem.
This is what I have done:
Form OnCreate procedure
procedure TForm1.FormCreate(Sender: TObject);
begin
PageControl1.ActivePage:= TabSheet1;
GetFontNames;
SelectionChange(Self);
CurrText.Name := DefFontData.Name;
CurrText.Size := -MulDiv(DefFontData.Height, 72, Screen.PixelsPerInch);
end;
Form Selection Change
procedure TForm1.SelectionChange(Sender: TObject);
begin
if ActiveControl is TDBRichEdit then
with ActiveControl as
TdbRichEdit do begin
try
Ctrlupdating := True;
Size.Text := IntToStr(SelAttributes.Size);
cmbFont.Text := SelAttributes.Name;
finally
Ctrlupdating := False;
end;
end;
end;
Functions (Except for the "ActiveControl part these are not my functions and I don't have enough knowledge to completely understand them.)
Function TForm1.CurrText: TTextAttributes;
begin
if ActiveControl is TDBRichEdit then
with ActiveControl as
TdbRichEdit do begin
if SelLength > 0 then Result := SelAttributes
else Result := DefAttributes;
end;
end;
function EnumFontsProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
FontType: Integer; Data: Pointer): Integer; stdcall;
begin
TStrings(Data).Add(LogFont.lfFaceName);
Result := 1;
end;
OnDraw event of the combobox
procedure TForm1.cmbFontDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
with (Control as TComboBox).Canvas do
begin
Font.Name := Screen.Fonts.Strings[Index];
FillRect(Rect) ;
TextOut(Rect.Left, Rect.Top, PChar(Screen.Fonts.Strings[Index]));
end;
end;
OnChange event for the combobox
procedure TForm1.cmbFontChange(Sender: TObject);
begin
if Ctrlupdating then Exit;
CurrText.Name := cmbFont.Items[cmbFont.ItemIndex];
end;
Any Ideas?

In your code you try to modify the text attributes in this code:
procedure TForm1.cmbFontChange(Sender: TObject);
begin
if Ctrlupdating then Exit;
CurrText.Name := cmbFont.Items[cmbFont.ItemIndex];
end;
When this code executes, ActiveControl will be cmbFont. Now look at CurrText.
if ActiveControl is TDBRichEdit then
with ActiveControl as TdbRichEdit do
begin
if SelLength > 0 then
Result := SelAttributes
else
Result := DefAttributes;
end;
So, the first if block will not be entered.
In fact your function appears not to assign anything to Result in this case. You must always assign to Result. The compiler will tell you this when you enable warnings and hints.
Instead of using ActiveControl you should specify the rich edit instance directly. I don't know how your form is arranged, but you'll need to use some other means to work out which rich edit control the change is to be applied to. Perhaps based on the active page of the page control.

I managed to get the combobox working. My code is probably very awkward, but it works. Thank you for your help. I would not have been able to solve this problem without it.
I wrote a separate function for each of the richedit contols. With FormCreate I had to add lines for each of the functions
procedure TForm1.FormCreate(Sender: TObject);
begin
PageControl1.ActivePage:= TabSheet1;
GetFontNames;
SelectionChange(Self);
**CurrText.Name := DefFontData.Name;
CurrText.Size := -MulDiv(DefFontData.Height, 72, Screen.PixelsPerInch);**
end;
In SelectionChange I had to make a call to the PARAGRAPH attributes of the rich edit control. I was not able to do that collectively. I addressed the rich edit control “reProc” only. The others seem to work fine with that one line. I would like to understand that one.
Form Selection Change
procedure TForm1.SelectionChange(Sender: TObject);
begin
if ActiveControl is TDBRichEdit then
with reProc.Paragraph do begin
try do begin
You gave me the idea. I was not able to address all the richedit controls collectively, so I wrote a function for each of the richedit controls separately.
function TForm1.CurrText: TTextAttributes;
begin
if reProc.SelLength > 0 then Result := reProc.SelAttributes
else Result := **reProc.DefAttributes;**
For the OnChange event for the combobox I had to add lines for each of the functions
procedure TForm1.cmbFontChange(Sender: TObject);
begin
if Ctrlupdating then Exit;
**CurrText.Name := cmbFont.Items[cmbFont.ItemIndex];**
end;

Related

Error on IF STATEMENT with multiple AND conditions

I have these controls TDateTimePicker, TComboBox, Tedit and TButton. TButton is disabled by default. What I would like to achieve is to enable TButton when all the other controls are filled or not null.
With the following codes, all the 3 controls starting with TDateTimePicker when filled I don't have any issues it works as expected.
The error comes when I fill TComboxBox followed by TEdit, it enables the TButton even TDateTimePicker is not filled yet. Or vise versa, I will fill TEdit followed by TComboBox, it enables the TButton.
From the codes below, I expect the TButton will not enable unless all the 3 controls are filled.
I've been trying to figure out (all day) how this error come to happen.
I will appreciate anyone there help me figure this out.
procedure TfrmHolidays.EnableSaveButton;
begin
if (edtHolidayName.Text <> NullAsStringValue) and (cmbHolidayType.ItemIndex <> -1)and (dtpHolidayDate.Date <> 0) then
begin
btnHolidaySave.Enabled := True;
end
else
begin
btnHolidaySave.Enabled := False;
end;
end;
procedure TfrmHolidays.dtpHolidayDateChange(Sender: TObject);
begin
EnableSaveButton;
end;
procedure TfrmHolidays.cmbHolidayTypeChange(Sender: TObject);
begin
EnableSaveButton;
end;
procedure TfrmHolidays.edtHolidayNameChange(Sender: TObject);
begin
EnableSaveButton; // triggers enable btnHolidaySave button
end;
By the way, I have more code related to making TDateTimePicker a blank and I supposed there's no issues with that. I also tried nesting within If Statement each condition and I am still getting the error. Further, I tested each condition at a time and It works fine.
Updates:
Here's how I initialized the dtpHolidayDate.Date:
procedure TfrmHolidays.FormCreate(Sender: TObject);
begin
DateTime_SetFormat(dtpHolidayDate.Handle, ' ');
FDTMDateEmpty := True;
end;
procedure TfrmHolidays.dtpHolidayDateCloseUp(Sender: TObject);
begin
DateTime_SetFormat(dtpHolidayDate.Handle, PChar('MMM dd yyyy (ddd)'));
end;
procedure TfrmHolidays.dtpHolidayDateChange(Sender: TObject);
begin
FDTMDateEmpty := False;
EnableSaveButton; // same and updated procedure above
end;
As pointed out in the comments above, you do not have an initialised value for the TDateTimePicker.
What you want is to have it default to a sensible date, rather than set to 0 - that is not at all helpful to users.
I would introduce a Boolean flag that you set yourself once the TDateTimePicker has been set.
You could set this flag in the OnChange event handler.
So something like:
interface
protected
blMyDTFlag: Boolean;
...
implementation
function TfrmHolidays.dtpHolidayDateChange(Sender: TObject);
begin
Self.blMyDTFlag:=True;
end
procedure TfrmHolidays.EnableSaveButton;
begin
if (edtHolidayName.Text <> '') and
(cmbHolidayType.ItemIndex <> -1) and
(Self.dtMyDTFlag) then
btnHolidaySave.Enabled := True
else
btnHolidaySave.Enabled := False;
end;
Although not shown in the question, I can guess that you initialize the date by
dtpHolidayDate.Date := 0;
After this, testing the date against 0 will (most likely) fail because the time portion still contains the time that the control is created.
You can initialize by
dtpHolidayDate.DateTime := 0;
then you can test the date as you do.
Alternatively you can use SameDate to do the comparison.
uses
dateutils;
if (edtHolidayName.Text <> NullAsStringValue) and (cmbHolidayType.ItemIndex <> -1)
and (not SameDate(dtpHolidayDate.Date, 0)) then

How to set a specific text to every TEdit?

I am super newbie and tried to write following code which sets every TEdit.Text to one mentioned in code
procedure TForm2.Button1Click(Sender: TObject);
var
i : integer;
Edit : TEdit;
begin
for i := 0 to Edit.ComponentCount - 1 do
begin
with Edit.Components[i] do
begin
Text := 'Done';
end;
end;
end;
What am I doing wrong ?
Here are the mistakes that I can see:
You never assign a value to Edit.
Typically the form owns all the components, and so a TEdit will have zero owned components.
Edit.Components[i] is of type TComponent which does not have a Text property. If your code compiles, then Text is actually that of the form. The lesson you should learn from this point is never to use with ever again.
You should solve this using code like this:
procedure TForm2.Button1Click(Sender: TObject);
var
i: Integer;
Edit: TEdit;
begin
for i := 0 to ComponentCount-1 do begin
if Components[i] is TEdit then begin
Edit := TEdit(Components[i]);
Edit.Text := 'Done';
end;
end;
end;
Note that here we are using ComponentCount and Components[] from the form itself. We have removed the evil with statement. And we have had to cast the component to a reference of type TEdit, after first using the is operator to check the type of the component.
This approach will work so long as the form owns all the edits found within it. However, if you create controls dynamically, or if you use frames or parented forms, then this approach, based on ownership via Components[] will not yield all the controls. In such more complex cases you would need to iterate using the parent/child relationship using ControlCount and Controls[].
What am I doing wrong? Just about everything. What I think you are trying to achieve is to put the same text in all TEdits on the form. So you need to go through all the components in TForm (not Edit!) and and check that each is really a Tedit, and if so assign the text. Like this:
procedure TForm2.Button1Click(Sender: TObject);
var
i:integer;
begin
for i := 0 to ComponentCount - 1 do
begin
if Components[ I ] is TEdit then
begin
(Components[ I ] as TEdit).Text := 'Done';
end;
end;
end;
As an aside - avoid using 'with'. It just cases ambiguity and confusion.
You could iterate over all child controls of the form, and if the current control is a TEdit, then you set its text. If the current control is a windowed control, it might have child controls of its own, and you need to redo same thing for this control. Hence, let's use recursion:
procedure SetAllEdits(AParent: TWinControl; const AText: string);
var
i: Integer;
begin
for i := 0 to AParent.ControlCount - 1 do
if AParent.Controls[i] is TCustomEdit then
TCustomEdit(AParent.Controls[i]).Text := AText
else if AParent.Controls[i] is TWinControl then
SetAllEdits(TWinControl(AParent.Controls[i]), AText);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetAllEdits(Self, 'test');
end;
There are other ways, like subclassing the edit control and having the new class respond to broadcasted messages.
Answer from D. Heffernan is already good, I'm trying to make it easier to understand for beginner.
In this code, we do "typecast" TEdit to TComponent by command: aEdit := TEdit(aComponent), because TEdit is inherited from TComponent.
What you get from iteration (for ...) is TComponent, not TEdit. You get TEdit by "typecast" it.
procedure TForm2.Button1Click(Sender: TObject);
var
i : Integer;
aComponent : TComponent;
aEdit : TEdit;
begin
for i := 0 to ComponentCount-1 do
begin
aComponent := Components[i];
if aComponent is TEdit then
begin
aEdit := TEdit(aComponent);
aEdit.Text := 'Done';
end;
end;
end;

Add menu item to unit's tab context menu in Delphi IDE using ToolsAPI

I am looking to find out which services/interface I need to use to add an item to the right-click menu of a source file in the Delphi IDE.
For example, if I right-click on a unit's tab, it has items to "Close page", "Close all other pages", "Properties", etc. I want to add custom items to that menu, if possible.
I looked over the ToolsAPI unit but I have no clue where to begin. I assume there's an interface I can use to enumerate items and add items, but I dont know where to start looking.
If that's not possible, I'd settle for the code editor's context menu.
Maybe there's some samples online for this, but I'm still looking and have found none.
Any help appreciated.
Remy Lebeau has pointed you in exactly the right directions with his link to
the GExperts guide.
If you've not done this sort of stuff before, it can still
be a bit of a performance to get started on writing your own IDE add-in, so
I've set out below a minimal example of how to add an item to the code editor's
pop-up menu.
What you do, obviously, is to create a new package, add the unit below to it,
and then install the package in the IDE. The call to Register in the unit
does what's necessary to install the new item in the editor pop-up menu.
Make sure that the code editor is open at the time you install the package. The
reason is that, as you'll see, the code checks whether there is an active editor
at the time. I've left how to ensure that the pop-up item gets added even if there
is no code editor active at the time. Hint: if you look at the ToolsAPI.Pas unit for whichever
version of Delphi you're using, you'll find that it includes various kinds of notifier,
and you can use a notification from at least one of them to defer checking if there
is an editor active until one is likely to be.
Btw, the code adds the menu item to the context menu which pops up over the editor window itself rather than the active tab. Part of the fun with IDE add-ins is the fun of experimenting to see if you can get exactly what you want. I haven't tried it myself, but I doubt that adding the menu item to the context menu of one of the editor tabs would be that difficult - seeing as the Delphi IDE is a Delphi app, as you can see from the code below, you can use FindComponent (or just iterate over a Components collection) to find what you want. However, it is better, if you can, to locate things via the ToolsAPI interfaces. See Update below.
interface
uses
Classes, Windows, Menus, Dialogs, ToolsAPI;
type
TIDEMenuItem = class(TNotifierObject, IOTAWizard, IOTAMenuWizard)
function GetName: string;
function GetIDString: string;
function GetMenuText: string;
function GetState: TWizardState;
procedure Execute;
end;
TIDEMenuHandler = class(TObject)
procedure HandleClick(Sender: TObject);
end;
procedure Register;
implementation
var
MenuItem: TMenuItem;
IDEMenuHandler: TIDEMenuHandler;
EditorPopUpMenu : TPopUpMenu;
procedure TIDEMenuItem.Execute;
begin
ShowMessage('Execute');
end;
function TIDEMenuItem.GetIDString: string;
begin
Result := 'IDEMenuItemID';
end;
function TIDEMenuItem.GetMenuText: string;
begin
Result := 'IDEMenuItemText';
end;
function TIDEMenuItem.GetName: string;
begin
Result := 'IDEMenuItemName';
end;
function TIDEMenuItem.GetState: TWizardState;
begin
Result := [wsEnabled];
end;
procedure TIDEMenuHandler.HandleClick(Sender: TObject);
begin
ShowMessage(TIDEMenuItem(Sender).GetName + ' Clicked');
end;
procedure AddIDEMenu;
var
NTAServices: INTAServices40;
EditorServices: IOTAEditorServices;
EditView: IOTAEditView;
begin
NTAServices := BorlandIDEServices as INTAServices40;
EditorServices := BorlandIDEServices as IOTAEditorServices;
EditView := EditorServices.TopView;
if Assigned(EditView) then begin
EditorPopUpMenu := TPopUpMenu(EditView.GetEditWindow.Form.FindComponent('EditorLocalMenu'));
Assert(EditorPopUpMenu <>Nil);
IDEMenuHandler := TIDEMenuHandler.Create;
MenuItem := TMenuItem.Create(Nil);
MenuItem.Caption := 'Added IDE editor menu item';
MenuItem.OnClick := IDEMenuHandler.HandleClick;
EditorPopUpMenu.Items.Add(MenuItem)
end
else
ShowMessage('Code editor not active');
end;
procedure RemoveIDEMenu;
begin
if MenuItem <> Nil then begin
EditorPopUpMenu.Items.Remove(MenuItem);
FreeAndNil(MenuItem);
IDEMenuHandler.Free;
end;
end;
procedure Register;
begin
RegisterPackageWizard(TIDEMenuItem.Create);
AddIDEMenu;
end;
initialization
finalization
RemoveIDEMenu;
end.
Update: The following code finds the TabControl of the editor window and adds the menu item to its context menu. However, note that it does not account for there being a second editor window open.
procedure AddIDEMenu;
var
NTAServices: INTAServices40;
EditorServices: IOTAEditorServices;
EditView: IOTAEditView;
TabControl : TTabControl;
function FindTabControl(AComponent : TComponent) : TTabControl;
var
i : Integer;
begin
Result := Nil;
if CompareText(AComponent.ClassName, 'TXTabControl') = 0 then begin
Result := TTabControl(AComponent);
exit;
end
else begin
for i := 0 to AComponent.ComponentCount - 1 do begin
if CompareText(AComponent.Components[i].ClassName, 'TXTabControl') = 0 then begin
Result := TTabControl(AComponent.Components[i]);
exit;
end
else begin
Result := FindTabControl(AComponent.Components[i]);
if Result <> Nil then
exit;
end;
end;
end;
end;
begin
NTAServices := BorlandIDEServices as INTAServices40;
EditorServices := BorlandIDEServices as IOTAEditorServices;
EditView := EditorServices.TopView;
if Assigned(EditView) then begin
TabControl := FindTabControl(EditView.GetEditWindow.Form);
Assert(TabControl <> Nil, 'TabControl not found');
EditorPopUpMenu := TabControl.PopupMenu;
Assert(EditorPopUpMenu <> Nil, 'PopUP menu not found');
//EditorPopUpMenu := TPopUpMenu(EditView.GetEditWindow.Form.FindComponent('EditorLocalMenu'));
Assert(EditorPopUpMenu <>Nil);
IDEMenuHandler := TIDEMenuHandler.Create;
MenuItem := TMenuItem.Create(Nil);
MenuItem.Caption := 'Added IDE editor menu item';
MenuItem.OnClick := IDEMenuHandler.HandleClick;
EditorPopUpMenu.Items.Add(MenuItem)
end
else
ShowMessage('No editor active');
end;

Delphi 2007 - Systemwide Hot key is NOT "system-wide" if setting "MainFormOnTaskBar := True"

I have a Delphi 2007 project that has run fine on Windos XP, Vista and "7" for years. It was an upgrade from Delphi 5 thus "MainFormOnTaskBar" was "false" by default (I never changed it in DPR). In this scenario, the system-wide hot key worked "system-wide" with following code in main form's OnCreate event handler.
HotKey_xyz := GlobalAddAtom('Hotkey_xyz');
if NOT RegisterHotKey(Self.Handle, HotKey_xyz, MOD_CONTROL, VK_F12) then
ShowMessage('Unable to register Control-F12 as system-wide hot key') ;
(I have GlobalDeleteAtom() and UnregisterHotKey() in Form.OnDestroy as expected.)
Now, I need a Form to show its own button on Taskbar, so I set "Application.MainFormOnTaskBar := True" in DPR. This works as expected. However, this has the side-effect that Control-F12 does NOT work system-wide, it works ONLY IF my application has focus (so, it is NOT "system-wide" anymore.)
I have extensively searched the 'Net have found many articles regarding how/why "MainFormOnTaskBar" affects certain subform/modal form behaviors. However, I have found nothing regarding its effect on a "System-Wide Hot Key" issue that I describe above. I have tested and retested my application with MainFormOnTaskBar set to true and false while all else remains exactly the same. I can positively verify that the above described issue with System-wide hot key relates to MainFormOnTaskBar flag.
I will greatly appreciate any guidance regarding a work-around. I do need BOTH - a system-wide hot key AND a form with its own button on taskbar.
Thank You very much.
TApplication.MainFormOnTaskbar has no effect on system-wide hotkeys at all. I can positively confirm that. I am able to receive WM_HOTKEY messages regardless of what MainFormOnTaskbar is set to, regardless of whether the app is focused or not, etc. So whatever you are seeing is not what you think is happening.
Most likely, the Form's Handle is simply being recreated behind your back after you have called RegisterHotKey(), so you lose the HWND that would receive the WM_HOTKEY messages. Instead of using the OnCreate event, you should override the Form's CreateWindowHandle() and DestroyWindowHandle() methods instead to ensure the hot key is always registered for the Form's current HWND no matter what happens to it (you should always do that whenever you tie any kind of data to the Form's Handle), eg:
type
TForm1 = class(TForm)
private
HotKey_xyz: WORD;
procedure WMHotKey(var Message: TMessage); message WM_HOTKEY;
protected
procedure CreateWindowHandle(const Params: TCreateParams); override;
procedure DestroyWindowHandle; override;
end;
procedure TForm1.CreateWindowHandle(const Params: TCreateParams);
begin
inherited;
HotKey_xyz := GlobalAddAtom('Hotkey_xyz');
if HotKey_xyz <> 0 then
RegisterHotKey(Self.Handle, HotKey_xyz, MOD_CONTROL, VK_F12);
end;
procedure TForm1.DestroyWindowHandle(const Params: TCreateParams);
begin
if HotKey_xyz <> 0 then
begin
UnregisterHotKey(Self.Handle, HotKey_xyz);
GlobalDeleteAtom(HotKey_xyz);
HotKey_xyz := 0;
end;
inherited;
end;
procedure TForm1.WMHotKey(var Message: TMessage);
begin
...
end;
A better option is to use AllocateHWnd() to allocate a separate dedicated HWND just for handling the hot key messages (then you can use the OnCreate and OnDestroy events again), eg:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
HotKey_xyz: WORD;
HotKeyWnd: HWND;
procedure HotKeyWndProc(var Message: TMessage);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
HotKeyWnd := AllocateHwnd(HotKeyWndProc);
HotKey_xyz := GlobalAddAtom('Hotkey_xyz');
if HotKey_xyz <> 0 then
RegisterHotKey(HotKeyWnd, HotKey_xyz, MOD_CONTROL, VK_F12);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if HotKey_xyz <> 0 then
begin
UnregisterHotKey(HotKeyWnd, HotKey_xyz);
GlobalDeleteAtom(HotKey_xyz);
HotKey_xyz := 0;
end;
if HotKeyWnd <> 0 then
begin
DeallocateHWnd(HotKeyWnd);
HotKeyWnd := 0;
end;
end;
procedure TForm1.HotKeyWndProc(var Message: TMessage);
begin
if Message.Msg = WM_HOTKEY then
begin
...
end else
Message.Result := DefWindowProc(HotKeyWnd, Message.Msg, Message.WParam, Message.LParam);
end;

Why doesn't my cursor change to an Hourglass in my FindDialog in Delphi?

I am simply opening my FindDialog with:
FindDialog.Execute;
In my FindDialog.OnFind event, I want to change the cursor to an hourglass for searches through large files, which may take a few seconds. So in the OnFind event I do this:
Screen.Cursor := crHourglass;
(code that searches for the text and displays it) ...
Screen.Cursor := crDefault;
What happens is while searching for the text, the cursor properly changes to the hourglass (or rotating circle in Vista) and then back to the pointer when the search is completed.
However, this only happens on the main form. It does not happen on the FindDialog itself. The default cursor remains on the FindDialog during the search. While the search is happening if I move the cursor over the FindDialog it changes to the default, and if I move it off and over the main form it becomes the hourglass.
This does not seem like what is supposed to happen. Am I doing something wrong or does something special need to be done to get the cursor to be the hourglass on all forms?
For reference, I'm using Delphi 2009.
I guess the reason for this has got sth. to do with Find Dialog being not a form but a Dialog (a Common Dialog).
You can try setting the class cursor (does not have an effect on the controls of the dialog);
procedure TForm1.FindDialog1Find(Sender: TObject);
begin
SetClassLong(TFindDialog(Sender).Handle, GCL_HCURSOR, Screen.Cursors[crHourGlass]);
try
Screen.Cursor := crHourglass;
try
// (code that searches for the text and displays it) ...
finally
Screen.Cursor := crDefault;
end;
finally
SetClassLong(TFindDialog(Sender).Handle, GCL_HCURSOR, Screen.Cursors[crDefault]);
end;
end;
EDIT
An alternative could be to subclass the FindDialog during the search time and respond to WM_SETCURSOR messages with "SetCursor". If we prevent further processing of the message the controls on the dialog won't set their own cursors.
type
TForm1 = class(TForm)
FindDialog1: TFindDialog;
...
private
FSaveWndProc, FWndProc: Pointer;
procedure FindDlgProc(var Message: TMessage);
...
end;
....
procedure TForm1.FormCreate(Sender: TObject);
begin
FWndProc := classes.MakeObjectInstance(FindDlgProc);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
classes.FreeObjectInstance(FWndProc);
end;
procedure TForm1.FindDialog1Find(Sender: TObject);
begin
FSaveWndProc := Pointer(SetWindowLong(FindDialog1.Handle, GWL_WNDPROC,
Longint(FWndProc)));
try
Screen.Cursor := crHourGlass;
try
// (code that searches for the text and displays it) ...
finally
Screen.Cursor := crDefault;
end;
finally
if Assigned(FWndProc) then
SetWindowLong(FindDialog1.Handle, GWL_WNDPROC, Longint(FSaveWndProc));
// SendMessage(FindDialog1.Handle, WM_SETCURSOR, FindDialog1.Handle,
// MakeLong(HTNOWHERE, WM_MOUSEMOVE));
SetCursor(Screen.Cursors[crDefault]);
end;
end;
procedure TForm1.FindDlgProc(var Message: TMessage);
begin
if Message.Msg = WM_SETCURSOR then begin
SetCursor(Screen.Cursors[crHourGlass]);
Message.Result := 1;
Exit;
end;
Message.Result := CallWindowProc(FSaveWndProc, FindDialog1.Handle,
Message.Msg, Message.WParam, Message.LParam);
end;
Try adding Application.ProcessMessages; after you set the cursor.
If this works, be sure to call your Mother, help an old lady cross the street, or maybe plant a tree. Otherwise, the devil will own another little piece of your soul.

Resources