delphi component to animate show/hide controls during runtime - delphi

In Delphi I show/hide controls during runtime and it does not look good as controls suddenly appear or disappear , so any one know a component that can do the show/hide (using visible property) but with some sort of animation ?
thanks

Give it a go with AnimateWindow. Only for WinControls, well, it doesn't look stunning anyway:
procedure TForm1.Button1Click(Sender: TObject);
begin
if Button2.Visible then
AnimateWindow(Button2.Handle, 250, AW_HIDE or AW_VER_NEGATIVE or AW_SLIDE)
else
AnimateWindow(Button2.Handle, 250, AW_VER_POSITIVE or AW_SLIDE);
Button2.Visible := not Button2.Visible; // synch with VCL
end;
edit: A threaded version to hide show multiple controls simultaneously:
type
TForm1 = class(TForm)
..
private
procedure AnimateControls(Show: Boolean; Controls: array of TWinControl);
procedure OnAnimateEnd(Sender: TObject);
public
end;
implementation
..
type
TAnimateThr = class(TThread)
protected
procedure Execute; override;
public
FHWnd: HWND;
FShow: Boolean;
constructor Create(Handle: HWND; Show: Boolean);
end;
{ TAnimateThr }
constructor TAnimateThr.Create(Handle: HWND; Show: Boolean);
begin
FHWnd := Handle;
FShow := Show;
FreeOnTerminate := True;
inherited Create(True);
end;
procedure TAnimateThr.Execute;
begin
if FShow then
AnimateWindow(FHWnd, 250, AW_VER_POSITIVE or AW_SLIDE)
else
AnimateWindow(FHWnd, 250, AW_HIDE or AW_VER_NEGATIVE or AW_SLIDE);
end;
{ Form1 }
procedure TForm1.OnAnimateEnd(Sender: TObject);
begin
FindControl(TAnimateThr(Sender).FHWnd).Visible := TAnimateThr(Sender).FShow;
end;
procedure TForm1.AnimateControls(Show: Boolean; Controls: array of TWinControl);
var
i: Integer;
begin
for i := Low(Controls) to High(Controls) do
with TAnimateThr.Create(Controls[i].Handle, Show) do begin
OnTerminate := OnAnimateEnd;
Resume;
end;
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
AnimateControls(not Button1.Visible,
[Button1, Button2, Button3, Edit1, CheckBox1]);
end;
 

Related

Delphi XE4 IDE, how to always hide the bottom panes of the Object Inspector

The two panes located at the bottom of the Obeject Inspector has no use at all, and it's consuming screen estates unnecessarily, as illustrated in the screenshot below. How to disable that two panes even after restarting the IDE? Built-in options or third party plugins would be OK with me. Thanks.
The XE4 code below shows how to hide the items you want to remove: They are instances
of the classes THotCommands and TDescriptionPane.
Update The original version of this answer required a package including an add-in form and a button to refresh the Object Inspector to hide the two
unwanted items. In the code below, I've removed the form entirely and the hiding of the items should now be fully automatic. To achieve this, I replaced the previous IDENotifier by a DesignNotification object and use its
SelectionChanged event to invoke the code which hides the THotCommands and TDescriptionPane controls. TDesignNotification implements the IDesignNotification interface in DesignIntf.Pas
The other detail which turned out to be critical to getting the hiding process to work automatically is to set the Height of the THotCommands and TDescriptionPane controls to 0, because the IDE seems to reset their Visible property to True after the component selection in the OI is changed. Fortunately, whatever code does that does not also reset their Heights to a non-zero value.
Obviously, to use you add a unit containing the code to a package (.Dpk) file and then compile and install the package in the IDE.
Code:
interface
uses
[...]ToolsApi, DesignIntf;
type
TDesignNotification = class(TInterfacedObject, IDesignNotification)
procedure ItemDeleted(const ADesigner: IDesigner; AItem: TPersistent);
procedure ItemInserted(const ADesigner: IDesigner; AItem: TPersistent);
procedure ItemsModified(const ADesigner: IDesigner);
procedure SelectionChanged(const ADesigner: IDesigner;
const ASelection: IDesignerSelections);
procedure DesignerOpened(const ADesigner: IDesigner; AResurrecting: Boolean);
procedure DesignerClosed(const ADesigner: IDesigner; AGoingDormant: Boolean);
constructor Create;
destructor Destroy; override;
private
procedure HideItems;
procedure HideFormItems(Form: TForm);
end;
var
DesignNotification : TDesignNotification;
implementation
procedure SetUp;
begin
DesignNotification := TDesignNotification.Create;
RegisterDesignNotification(DesignNotification);
end;
constructor TDesignNotification.Create;
begin
inherited Create;
end;
procedure TDesignNotification.DesignerClosed(const ADesigner: IDesigner;
AGoingDormant: Boolean);
begin
end;
procedure TDesignNotification.HideFormItems(Form : TForm);
var
j,
l : Integer;
Panel : TPanel;
C : TComponent;
HideCount : Integer;
procedure HideControl(AControl : TControl);
begin
AControl.Height := 0; // This is necessary because the IDE seems to reset
// Visible to True when the Object Inspector is refreshed.
AControl.Visible := False;
end;
begin
HideCount := 0;
for j := 0 to Form.ComponentCount - 1 do begin
C := Form.Components[j];
if C is TPanel then begin
Panel := TPanel(C);
for l := 0 to Panel.ControlCount - 1 do begin
if CompareText(Panel.Controls[l].ClassName, 'TDescriptionPane') = 0 then begin
HideControl(Panel.Controls[l]);
Inc(HideCount);
end
else
if CompareText(Panel.Controls[l].ClassName, 'THotCommands') = 0 then begin
HideControl(Panel.Controls[l]);
Inc(HideCount);
end;
if HideCount >= 2 then // we're done
exit;
end;
end;
end;
end;
procedure TDesignNotification.HideItems;
var
i : Integer;
Form : TForm;
begin
for i := 0 to Screen.FormCount - 1 do begin
Form := Screen.Forms[i];
if CompareText(Form.ClassName, 'TPropertyInspector') = 0 then begin
HideFormItems(Form);
Break;
end;
end;
end;
procedure TDesignNotification.DesignerOpened(const ADesigner: IDesigner;
AResurrecting: Boolean);
begin
end;
var
DestroyCount : Integer;
destructor TDesignNotification.Destroy;
begin
Inc(DestroyCount);
inherited;
end;
procedure TDesignNotification.ItemDeleted(const ADesigner: IDesigner;
AItem: TPersistent);
begin
end;
procedure TDesignNotification.ItemInserted(const ADesigner: IDesigner;
AItem: TPersistent);
begin
end;
procedure TDesignNotification.ItemsModified(const ADesigner: IDesigner);
begin
end;
procedure TDesignNotification.SelectionChanged(const ADesigner: IDesigner;
const ASelection: IDesignerSelections);
var
C : TComponent;
begin
// This can get called with ADesigner = Nil
if ADesigner = Nil then
exit;
C := ADesigner.Root;
if C <> Nil then begin
HideItems;
end
end;
initialization
SetUp;
finalization
if DesignNotification <> Nil then begin
UnRegisterDesignNotification(DesignNotification);
end;
end.

How to make GIF animate on "please, wait form"?

I would like make a quick non-closable modal dialog, that pops up while do some tasks and goes away when tasks finish.
There are some inherent difficulties:
Don't block the main UI thread;
Don't leave system ghosts windows;
Move tasks to running into a separate thread;
Allow update the waiting message to the user;
Handling exceptions from thread to the application;
Show animated GIF in the dialog;
How to get around these pitfalls?
Below, a practical example of how I would use it:
TWaiting.Start('Waiting, loading something...');
try
Sleep(2000);
TWaiting.Update('Making something slow...');
Sleep(2000);
TWaiting.Update('Making something different...');
Sleep(2000);
finally
TWaiting.Finish;
end;
type
TWaiting = class(TForm)
WaitAnimation: TImage;
WaitMessage: TLabel;
WaitTitle: TLabel;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
strict private
class var FException: Exception;
private
class var WaitForm : TWaiting;
class procedure OnTerminateTask(Sender: TObject);
class procedure HandleException;
class procedure DoHandleException;
public
class procedure Start(const ATitle: String; const ATask: TProc);
class procedure Status(AMessage : String);
end;
implementation
{$R *.dfm}
procedure TWaiting.FormCreate(Sender: TObject);
begin
TGIFImage(WaitAnimation.Picture.Graphic).Animate := True;
end;
procedure TWaiting.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
class procedure TWaiting.Start(const ATitle: String; const ATask: TProc);
var
T : TThread;
begin
if (not Assigned(WaitForm))then
WaitForm := TWaiting.Create(nil);
T := TThread.CreateAnonymousThread(
procedure
begin
try
ATask;
except
HandleException;
end;
end);
T.OnTerminate := OnTerminateTask;
T.Start;
WaitForm.WaitTitle.Caption := ATitle;
WaitForm.ShowModal;
DoHandleException;
end;
class procedure TWaiting.Status(AMessage: String);
begin
TThread.Synchronize(TThread.CurrentThread,
procedure
begin
if (Assigned(WaitForm)) then
begin
WaitForm.WaitMessage.Caption := AMessage;
WaitForm.Update;
end;
end);
end;
class procedure TWaiting.OnTerminateTask(Sender: TObject);
begin
if (Assigned(WaitForm)) then
begin
WaitForm.Close;
WaitForm := nil;
end;
end;
class procedure TWaiting.HandleException;
begin
FException := Exception(AcquireExceptionObject);
end;
class procedure TWaiting.DoHandleException;
begin
if (Assigned(FException)) then
begin
try
if (FException is Exception) then
raise FException at ReturnAddress;
finally
FException := nil;
ReleaseExceptionObject;
end;
end;
end;
end.
Usage:
procedure TFSales.FinalizeSale;
begin
TWaiting.Start('Processing Sale...',
procedure
begin
TWaiting.Status('Sending data to database');
Sleep(2000);
TWaiting.Status('Updating Inventory');
Sleep(2000);
end);
end;

Keep values from the beforepost event to the afterpost event

I am writing this question for Delphi 2007, but I'm pretty sure that this is a common problem in all kind of languages.
So, I have a project where I need to keep informations about the old and new value of certain fields (which are given in the BeforePost event of the dataset I'm working with) and use them in the AfterPost event.
For now, I have been using global variables, but there is already so many of them in the project that this is becoming a real issue when it comes to managing documentation and/or comments.
Basically, I am asking if there is a better way (in Delphi 2007 or in general) to keep the informations from the BeforePost event of a Dataset and get them back in the AfterPost event.
first create a new Custom Data Source
TDataRecord = array of record
FieldName: string;
FieldValue: Variant;
end;
TMyDataSource = class(TDataSource)
private
LastValues: TDataRecord;
procedure MyDataSourceBeforePost(DataSet: TDataSet);
procedure SetDataSet(const Value: TDataSet);
function GetDataSet: TDataSet;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetLastValue(FieldName: string): Variant;
property MyDataSet: TDataSet read GetDataSet write SetDataSet;
end;
{ TMyDataSource }
constructor TMyDataSource.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TMyDataSource.Destroy;
begin
SetLength(LastValues, 0);
inherited Destroy;
end;
function TMyDataSource.GetDataSet: TDataSet;
begin
Result := DataSet;
end;
procedure TMyDataSource.SetDataSet(const Value: TDataSet);
begin
DataSet := Value;
DataSet.BeforePost := MyDataSourceBeforePost;
end;
procedure TMyDataSource.MyDataSourceBeforePost(DataSet: TDataSet);
var
i: integer;
begin
SetLength(LastValues, DataSet.FieldCount);
for i:=0 to DataSet.FieldCount-1 do
begin
LastValues[i].FieldName := DataSet.Fields.Fields[i].FieldName;
LastValues[i].FieldValue := DataSet.Fields.Fields[i].OldValue;
end;
end;
function TMyDataSource.GetLastValue(FieldName: string): Variant;
var
i: integer;
begin
Result := Null;
for i:=0 to Length(LastValues)-1 do
if SameText(FieldName, LastValues[i].FieldName) then
begin
Result := LastValues[i].FieldValue;
break;
end;
end;
and after override application Data Source
TForm1 = class(TForm)
private
MyDataSource: TMyDataSource;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ADOQuery1.Active := true;
MyDataSource := TMyDataSource.Create(Self);
MyDataSource.MyDataSet := ADOQuery1;
DBGrid1.DataSource := MyDataSource;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MyDataSource.Free;
end;
procedure TForm1.ADOQuery1AfterPost(DataSet: TDataSet);
var
AValue: Variant;
begin
AValue := MyDataSource.GetLastValue('cname');
if not VarIsNull(AValue) then;
end;

Can not press enter in more than one twebbrowser

I have seen the below msghandler code in several places now as the solution to not being able to press Enter in a twebbrowser. This solution does work as long as you're only dealing with one twebbrowser. I've provided a complete unit here for discussion. If you take two twebbrowsers and make one of them the "active" browser (see code) and navigate them each to a site for example that has a username, password and button you can enter the data in the "active" browser and press Enter successfully. If you try to use the non "active" browser not only can you not press Enter but use of tab fails as well. Whichever browser you press Enter in first is the one that will continue to work so it seems to have nothing to do with order of creation of the browsers.
How do I make my additional browsers function?
unit Main_Form;
interface
uses
Winapi.Windows, Winapi.Messages, Vcl.Controls, Vcl.Forms,
ActiveX, Vcl.OleCtrls, SHDocVw, System.Classes, Vcl.StdCtrls;
type
TForm1 = class(TForm)
NavigateBrowsers: TButton;
WebBrowser1: TWebBrowser;
WebBrowser2: TWebBrowser;
MakeBrowser1Active: TButton;
MakeBrowser2Active: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormDeactivate(Sender: TObject);
procedure NavigateBrowsersClick(Sender: TObject);
procedure MakeBrowser1ActiveClick(Sender: TObject);
procedure MakeBrowser2ActiveClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure MsgHandler(var Msg: TMsg; var Handled: Boolean);
end;
var
Form1: TForm1;
ActiveBrowser: TWebBrowser;
FOleInPlaceActiveObject: IOleInPlaceActiveObject;
SaveMessageHandler: TMessageEvent;
implementation
{$R *.dfm}
procedure TForm1.MakeBrowser1ActiveClick(Sender: TObject);
begin
ActiveBrowser := WebBrowser1;
end;
procedure TForm1.MakeBrowser2ActiveClick(Sender: TObject);
begin
ActiveBrowser := WebBrowser2;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Application.OnMessage := SaveMessageHandler;
FOleInPlaceActiveObject := nil;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
//Handle messages
SaveMessageHandler := Application.OnMessage;
Application.OnMessage := MsgHandler;
end;
procedure TForm1.FormDeactivate(Sender: TObject);
begin
Application.OnMessage := SaveMessageHandler;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FOleInPlaceActiveObject := nil;
end;
procedure TForm1.NavigateBrowsersClick(Sender: TObject);
begin
WebBrowser1.Navigate(''); //supply own
WebBrowser2.Navigate(''); //supply own
end;
procedure TForm1.MsgHandler(var Msg: TMsg; var Handled: Boolean);
const
StdKeys = [VK_BACK, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT];
var
IOIPAO: IOleInPlaceActiveObject;
Dispatch: IDispatch;
begin
//Exit if webbrowser object is nil
if ActiveBrowser = nil then
begin
Handled := False;
Exit;
end;
Handled:=(IsDialogMessage(ActiveBrowser.Handle, Msg) = True);
if (Handled) and (not ActiveBrowser.Busy) then
begin
if FOleInPlaceActiveObject = nil then
begin
Dispatch := ActiveBrowser.Application;
if Dispatch <>nil then
begin
Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
if iOIPAO <>nil then
FOleInPlaceActiveObject := iOIPAO;
end;
end;
if FOleInPlaceActiveObject <>nil then
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
(Msg.wParam in StdKeys) then
//nothing - do not pass on StdKeys
else
FOleInPlaceActiveObject.TranslateAccelerator(Msg);
end;
end;
initialization
OleInitialize(nil);
finalization
OleUninitialize;
end.
I faced the same problem as you and I use a similar message handler, FOleInPlaceActiveObject is not really needed:
procedure TForm1.MsgHandler(var Msg: TMsg; var Handled: Boolean);
const
StdKeys = [VK_BACK, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT];
var
IOIPAO: IOleInPlaceActiveObject;
begin
try
if Assigned(ActiveBrowser) then
begin
Handled:=(IsDialogMessage(ActiveBrowser.Handle, Msg) = True);
if Handled then
begin
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and (Msg.wParam in StdKeys) then
begin
//nothing - do not pass on Backspace, Left, Right, Up, Down arrows
end
else
begin
IOIPAO := (ActiveBrowser.Application as IOleInPlaceActiveObject);
if Assigned(IOIPAO)then
IOIPAO.TranslateAccelerator(Msg)
end;
end;
end;
except
Handled := False;
end;
end;
After days of searching for an answer it appears I have found something that works the same day I posted the question here. Go figure! For everyone's benefit, here is what worked.
All I had to do was assign the browser as the active control when either the user changed tabs or at the time of new tab creation. The reason for the count check in the pagecontrolchange procedure is to keep from getting a list index out of bounds on initial tab creation at startup. I do realize I probably need to change my ObjectLists over to Generics, ;)
procedure TForm1.PageControl1Change(Sender: TObject);
begin
if PageControl1.PageCount = MyBrowsersObjectList.Count then // Not adding a page
begin
ActiveBrowser := MyBrowsersObjectList[PageControl1.ActivePageIndex] as TWebBrowser;
ActiveControl := ActiveBrowser;
end;
end;
procedure TForm1.CreateBrowserTab(APage: TAdvOfficePage; NavigateTo: String);
begin
APage.Caption := 'Loading...';
ActiveBrowser := TWebBrowser.Create(nil);
MyBrowsersObjectList.Add(ActiveBrowser);
TControl(ActiveBrowser).Parent := APage;
ActiveBrowser.Align := alClient;
ActiveBrowser.RegisterAsBrowser := True;
ActiveBrowser.Tag := BrowserTabs.ActivePageIndex;
ActiveBrowser.Navigate(NavigateTo);
ActiveControl := ActiveBrowser;
end;

TTreeView selection glitch while dragging a node

I'm implementing drag-and-drop functionality to a TTreeView. On a OnStartDrag Event of it, I'm creating the DragOcject of my derived class:
TTreeDragControlObject = class(TDragObject)
private
FDragImages: TDragImageList;
FText: String;
protected
function GetDragImages: TDragImageList; override;
end;
procedure TfrmMain.tvTreeStartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
DragObject := TTreeDragControlObject.Create;
TTreeDragControlObject(DragObject).FText := tvTree.Selected.Text;
end;
And this is my override GetDragImages function of my DragObcject:
function TTreeDragControlObject.GetDragImages: TDragImageList;
var
Bmp: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
Bmp := TBitmap.Create;
try
Bmp.Width := Bmp.Canvas.TextWidth(FText) + 25;
Bmp.Height := Bmp.Canvas.TextHeight(FText);
Bmp.Canvas.TextOut(25, 0, FText);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
FDragImages.SetDragImage(FDragImages.Add(Bmp, nil), 0, 0);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
Everything works fine except it has a painting glitch while dragging over the tree nodes:
How can I avoid this behavior?
Based on #Sean's and #bummi's answers I would post the entire code and conclusions that worked for me in D5.
On WinXP XPManifest is not a must - Hide/ShowDragImage are needed.
On Win7 XPManifest is needed. Hide/ShowDragImage are not a must.
Conclusion - use both XPManifest and HideDragImage and ShowDragImage to ensure TV will work both on XP/Win7.
type
TTreeDragControlObject = class(TDragControlObject)
private
FDragImages: TDragImageList;
FText: String;
protected
function GetDragImages: TDragImageList; override;
public
destructor Destroy; override;
procedure HideDragImage; override;
procedure ShowDragImage; override;
property DragText: string read FText write FText;
end;
TForm1 = class(TForm)
TreeView1: TTreeView;
procedure TreeView1StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure TreeView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure TreeView1EndDrag(Sender, Target: TObject; X, Y: Integer);
private
FDragObject: TTreeDragControlObject;
public
end;
...
{ TTreeDragControlObject}
destructor TTreeDragControlObject.Destroy;
begin
FDragImages.Free;
inherited;
end;
procedure TTreeDragControlObject.HideDragImage;
begin
GetDragImages.HideDragImage;
end;
procedure TTreeDragControlObject.ShowDragImage;
begin
GetDragImages.ShowDragImage;
end;
function TTreeDragControlObject.GetDragImages: TDragImageList;
var
Bmp: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
Bmp := TBitmap.Create;
try
Bmp.Width := Bmp.Canvas.TextWidth(FText) + 25;
Bmp.Height := Bmp.Canvas.TextHeight(FText);
Bmp.Canvas.TextOut(25, 0, FText);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
FDragImages.SetDragImage(FDragImages.Add(Bmp, nil), 0, 0);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
{ TForm1 }
procedure TForm1.TreeView1StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
FDragObject := TTreeDragControlObject.Create(TTreeView(Sender));
FDragObject.DragText := TTreeView(Sender).Selected.Text;
DragObject := FDragObject;
end;
procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := Source is TTreeDragControlObject;
end;
procedure TForm1.TreeView1EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
FDragObject.Free;
end;
Note that in your code both FDragImages and var DragObject are leaking memory. I'd suggest using TDragControlObject instead of TDragObject (does your tvTreeEndDrag fire at all now? - it did not fire for me)
Using TXPManifest fixes this bug in D7.
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, XPMan, ComCtrls;
additional:
procedure Win7UpdateFix(Form: TForm; CharCode: Word);
var i: Integer;
begin
if Assigned(Form) and (Win32MajorVersion >= 6) and (Win32Platform = VER_PLATFORM_WIN32_NT) then //Vista, Win7
begin
case CharCode of
VK_MENU, VK_TAB: //Alt or Tab
begin
for i := 0 to Form.ComponentCount-1 do
begin
if Form.Components[i] is TWinControl then
begin
//COntrols that disappear - Buttons, Radio buttons, Checkboxes
if (Form.Components[i] is TButton)
or (Form.Components[i] is TRadioButton)
or (Form.Components[i] is TCheckBox) then
TWinControl(Form.Components[i]).Invalidate;
end;
end;
end;
end;
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key=VK_MENU then
begin
Win7UpdateFix(Self,key)
end;
end;
This same behaviour occurs in Delphi 2010 and TXPManifest does not fix it. By co-incidence I recently and independently came across this same problem in a Delphi 2010 application. The solution is to implement the HideDragImage()/ShowDragImage() methods like so ...
TTreeDragControlObject = class(TDragObject)
private
FDragImages: TDragImageList;
FText: String;
protected
function GetDragImages: TDragImageList; override;
public
procedure HideDragImage; override;
procedure ShowDragImage; override;
end;
... and then ...
procedure TTreeDragControlObject.HideDragImage;
begin
FDragImages.HideDragImage
end;
procedure TTreeDragControlObject.ShowDragImage;
begin
FDragImages.ShowDragImage
end;
The conseequence of this is that the windows API function ImageList_DragShowNolock() is called just before and after the drag image is painted ( via windows message TVM_SELECTITEM( TVGN_DROPHILITE)) . Without this function being called, the drag image is not properly painted. The need for ImageList_DragShowNolock(False/True) delimiting TVM_SELECTITEM+TVGN_DROPHILITE is a poorly documented feature, and if other forums are to judge, is a common cause for complaint.

Resources