How do I allow dragging files for specific control(s) in Delphi - windows

I would like to accept files as soon as someone drops a file to a specific control (e.g. TMemo). I started with this example: http://delphi.about.com/od/windowsshellapi/a/accept-filedrop.htm and modified it like this:
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles( Memo1.Handle, True ) ;
end;
This allows the control to show the dragging icon but the proper WM_DROPFILES message is not getting called because DragAcceptFiles needs a (Parent?)windowhandle. I could determine the MemoHandle in the WMDROPFILES procedure but I don't how, plus the dragging cursor applies for all the controls now. How do I allow dragging for a specific control (and block other controls from dragging)?

You should indeed pass the window handle of the memo control, but then you also need to listen to the WM_DROPFILES message sent to it:
unit Unit5;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ShellAPI;
type
TMemo = class(StdCtrls.TMemo)
protected
procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES;
procedure CreateWnd; override;
procedure DestroyWnd; override;
end;
TForm5 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
procedure TForm5.FormCreate(Sender: TObject);
begin
end;
{ TMemo }
procedure TMemo.CreateWnd;
begin
inherited;
DragAcceptFiles(Handle, true);
end;
procedure TMemo.DestroyWnd;
begin
DragAcceptFiles(Handle, false);
inherited;
end;
procedure TMemo.WMDropFiles(var Message: TWMDropFiles);
var
c: integer;
fn: array[0..MAX_PATH-1] of char;
begin
c := DragQueryFile(Message.Drop, $FFFFFFFF, fn, MAX_PATH);
if c <> 1 then
begin
MessageBox(Handle, 'Too many files.', 'Drag and drop error', MB_ICONERROR);
Exit;
end;
if DragQueryFile(Message.Drop, 0, fn, MAX_PATH) = 0 then Exit;
Text := fn;
end;
end.
The example above only accept a single file dropped. The file name will be put in the memo control. But you can also allow a multiple selection to be dropped:
var
c: integer;
fn: array[0..MAX_PATH-1] of char;
i: Integer;
begin
c := DragQueryFile(Message.Drop, $FFFFFFFF, fn, MAX_PATH);
Clear;
for i := 0 to c - 1 do
begin
if DragQueryFile(Message.Drop, i, fn, MAX_PATH) = 0 then Exit;
Lines.Add(fn);
end;

Related

EOutOfResources exception when trying to restore tray icon

I'm getting an EOutOfResources exception 'Cannot remove shell notification icon' when trying to implement code to restore the tray icon after an Explorer crash/restart. My code is based on the old solution found here. The exception occurs when trying to hide the trayicon. Why does the Delphi XE code below not work?
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ImgList, ExtCtrls;
type
TForm1 = class(TForm)
TrayIcon1: TTrayIcon;
ImageListTray: TImageList;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
protected
procedure WndProc(var Message: TMessage); Override;
public
{ Public declarations }
end;
var
Form1: TForm1;
msgTaskbarRestart : Cardinal; {custom systemwide message}
implementation
{$R *.dfm}
//ensure systray icon recreated on explorer crash
procedure TForm1.FormCreate(Sender: TObject);
begin
msgTaskbarRestart := RegisterWindowMessage('TaskbarCreated');
end;
procedure TForm1.WndProc(var Message: TMessage);
begin
if (msgTaskbarRestart <> 0) and (Message.Msg = msgTaskbarRestart) then begin
TrayIcon1.Visible := False; {Destroy the systray icon here}//EOutOfResources exception here
TrayIcon1.Visible := True; {Replace the systray icon}
Message.Result := 1;
end;
inherited WndProc(Message);
end;
end.
The TTrayIcon.Visible property setter raises EOutOfResources when a NIM_DELETE request fails:
procedure TCustomTrayIcon.SetVisible(Value: Boolean);
begin
if FVisible <> Value then
begin
FVisible := Value;
...
if not (csDesigning in ComponentState) then
begin
if FVisible then
...
else if not (csLoading in ComponentState) then
begin
if not Refresh(NIM_DELETE) then
raise EOutOfResources.Create(STrayIconRemoveError); // <-- HERE
end;
...
end;
end;
end;
Where Refresh() is just a call to the Win32 Shell_NotifyIcon() function:
function TCustomTrayIcon.Refresh(Message: Integer): Boolean;
...
begin
Result := Shell_NotifyIcon(Message, FData);
...
end;
When you receive the TaskbarCreated message, your previous icons are no longer present in the Taskbar, so Shell_NotifyIcon(NIM_DELETE) returns False. When the Taskbar is (re-)created, you are not supposed to try to remove old icons at all, only re-add new icons with Shell_NotifyIcon(NIM_ADD) as needed.
TTrayIcon has a public Refresh() method, but that uses NIM_MODIFY instead of NIM_ADD, so that will not work in this situation, either:
procedure TCustomTrayIcon.Refresh;
begin
if not (csDesigning in ComponentState) then
begin
...
if Visible then
Refresh(NIM_MODIFY);
end;
end;
However, you don't actually need to handle the TaskbarCreated message manually when using TTrayIcon, because it already handles that message internally for you, and it will call Shell_NotifyIcon(NIM_ADD) if Visible=True:
procedure TCustomTrayIcon.WindowProc(var Message: TMessage);
...
begin
case Message.Msg of
...
else
if (Cardinal(Message.Msg) = RM_TaskBarCreated) and Visible then
Refresh(NIM_ADD); // <-- HERE
end;
end;
...
initialization
...
TCustomTrayIcon.RM_TaskBarCreated := RegisterWindowMessage('TaskbarCreated');
end.
If, for some reason, that is not working correctly, and/or you need to handle TaskbarCreated manually, then I would suggest calling the protected TCustomTrayIcon.Refresh() method directly, eg:
type
TTrayIconAccess = class(TTrayIcon)
end;
procedure TForm1.WndProc(var Message: TMessage);
begin
if (msgTaskbarRestart <> 0) and (Message.Msg = msgTaskbarRestart) then begin
if TrayIcon1.Visible then begin
// TrayIcon1.Refresh;
TTrayIconAccess(TrayIcon1).Refresh(NIM_ADD);
end;
Message.Result := 1;
end;
inherited WndProc(Message);
end;
Otherwise, simply don't use TTrayIcon at all. It is known to be buggy. I have seen a lot of people have a lot of problems with TTrayIcon over the years. I would suggest using Shell_NotifyIcon() directly instead. I have never had any problems using it myself.

Free Pascal / Lazarus : Why is the "FormCloseQuery" Event not called in my example?

I wrote a small testprogram to try out the FormCreate and the FormCloseQuery procedure. The FormCreate works fine, but the FormCloseQuery just doesn't want to execute. Did I overlook something? Pressing the "X" on a form-window or using the close method, both doesn't work!
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
(...)
procedure TForm1.FormCreate(Sender: TObject);
beginn
//gets executed without problems
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
case MessageDlg('Question', mtConfirmation, [mbyes, mbno, mbcancel], 0) of
mrYes:
begin
ShowMessage('yes');
CanClose := true;
end;
mrNo:
begin
ShowMessage('no');
CanClose := true;
end;
else
begin
ShowMessage('cancel');
CanClose := true;
end;
end;
end;
Here's the full code:
The lpr-File:
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
The Unit-File:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
ShowMessage('FormCreate Procedure wurde gestartet');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
case MessageDlg('Question', mtConfirmation, [mbyes, mbno, mbcancel], 0) of
mrYes:
begin
ShowMessage('yes');
CanClose := true;
end;
mrNo:
begin
ShowMessage('no');
CanClose := true;
end;
else
begin
ShowMessage('cancel');
CanClose := true;
end;
end;
end;
end.
The solution is/was to hook up the form's OnCloseQuery event of the form to this procedure. Here's a short description how to do it:
Bring up and select the form (in my case "Form1: TForm1") in the object inspector (see explanation below).
In the object inspector go to the tab "events"
Locate the "OnCloseQuery"-Event and select "FormCloseQuery" if you already declared and written the procedure as it was the case in my example. (If you haven't declared/implemented it double click in the dropdown box or click on the button next to it, the one with the three dots, an an empty "OnCloseQuery"-procedure procedure will be added automatically. The code editor will jump directly to the new procedure.)
To bring up / select the form in the object inspector, open the object inspector (F11). If you are looking at the code editor bring up the form first (F12) and click on it. This should bring it up in the object inspector. Make sure the form (the top element in the list) is selected and none of it's components (like buttons etc.).
Here's another explanation: http://www.delphigroups.info/2/b2/444056.html

Delphi: ListView (vsReport) single column header caption with custom font color?

In a ListView with vsReport ViewStyle, how can I customize the font color of just any single column header caption? For example (the second column header caption has a red font color):
I would handle the NM_CUSTOMDRAW header notification code and respond to this notification message with the CDRF_NEWFONT return code at the CDDS_ITEMPREPAINT rendering stage. The following code shows how to extend list view controls to have the event for specifying header item font color:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, CommCtrl, StdCtrls;
type
TGetHeaderItemFontColorEvent = procedure(Sender: TCustomListView;
ItemIndex: Integer; var FontColor: TColor) of object;
TListView = class(ComCtrls.TListView)
private
FHeaderHandle: HWND;
FOnGetHeaderItemFontColor: TGetHeaderItemFontColorEvent;
procedure WMNotify(var AMessage: TWMNotify); message WM_NOTIFY;
protected
procedure CreateWnd; override;
published
property OnGetHeaderItemFontColor: TGetHeaderItemFontColorEvent read
FOnGetHeaderItemFontColor write FOnGetHeaderItemFontColor;
end;
type
TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
private
procedure GetHeaderItemFontColor(Sender: TCustomListView;
ItemIndex: Integer; var FontColor: TColor);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TListView }
procedure TListView.CreateWnd;
begin
inherited;
FHeaderHandle := ListView_GetHeader(Handle);
end;
procedure TListView.WMNotify(var AMessage: TWMNotify);
var
FontColor: TColor;
NMCustomDraw: TNMCustomDraw;
begin
if (AMessage.NMHdr.hwndFrom = FHeaderHandle) and
(AMessage.NMHdr.code = NM_CUSTOMDRAW) then
begin
NMCustomDraw := PNMCustomDraw(TMessage(AMessage).LParam)^;
case NMCustomDraw.dwDrawStage of
CDDS_PREPAINT:
AMessage.Result := CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT:
begin
FontColor := Font.Color;
if Assigned(FOnGetHeaderItemFontColor) then
FOnGetHeaderItemFontColor(Self, NMCustomDraw.dwItemSpec, FontColor);
SetTextColor(NMCustomDraw.hdc, ColorToRGB(FontColor));
AMessage.Result := CDRF_NEWFONT;
end;
else
AMessage.Result := CDRF_DODEFAULT;
end;
end
else
inherited;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
ListView1.OnGetHeaderItemFontColor := GetHeaderItemFontColor;
end;
procedure TForm1.GetHeaderItemFontColor(Sender: TCustomListView;
ItemIndex: Integer; var FontColor: TColor);
begin
case ItemIndex of
0: FontColor := clRed;
1: FontColor := clGreen;
2: FontColor := clBlue;
end;
end;
end.
The whole project you can download from here. Here's the result of the above example:
You can get the native header control from the listview and then mark the specific item of your column as owner drawn. You only need to change the text color (if you don't remove the string flag) when the header item requests to be drawn. The drawing message will be sent to the header's parent - the listview, hence you need to handle the message there. See here for owner drawn header controls.
Example code:
type
TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
...
private
FLVHeader: HWND;
FSaveLVWndProc: TWndMethod;
procedure LVWndProc(var Msg: TMessage);
procedure SetHeaderItemStyle(Index: Integer);
end;
..
uses commctrl;
..
procedure TForm1.FormCreate(Sender: TObject);
begin
FLVHeader := ListView_GetHeader(ListView1.Handle);
SetHeaderItemStyle(1);
FSaveLVWndProc := ListView1.WindowProc;
ListView1.WindowProc := LVWndProc;
end;
procedure TForm1.SetHeaderItemStyle(Index: Integer);
var
HeaderItem: THDItem;
begin
HeaderItem.Mask := HDI_FORMAT or HDI_TEXT or HDI_LPARAM;
Header_GetItem(FLVHeader, 1, HeaderItem);
HeaderItem.Mask := HDI_FORMAT;
HeaderItem.fmt := HeaderItem.fmt or HDF_OWNERDRAW;
Header_SetItem(FLVHeader, 1, HeaderItem);
end;
procedure TForm1.LVWndProc(var Msg: TMessage);
begin
FSaveLVWndProc(Msg); // thanks to #Kobik (cause SO if called later then WM_NOTIFY case on some (all other then mine?) machines)
case Msg.Msg of
WM_DRAWITEM:
if (TWmDrawItem(Msg).DrawItemStruct.CtlType = ODT_HEADER) and
(TWmDrawItem(Msg).DrawItemStruct.hwndItem = FLVHeader) and
(TWmDrawItem(Msg).DrawItemStruct.itemID = 1) then
SetTextColor(TWmDrawItem(Msg).DrawItemStruct.hDC, ColorToRGB(clRed));
WM_NOTIFY:
if (TWMNotify(Msg).NMHdr.hwndFrom = FLVHeader) and
(TWMNotify(Msg).NMHdr.code = HDN_ITEMCHANGED) then
// also try 'HDN_ENDTRACK' if it doesn't work as expected
SetHeaderItemStyle(1);
WM_DESTROY: ListView1.WindowProc := FSaveLVWndProc;
end;
end;

how can i free a Tpanel That have a TbitBtn that calls to free the Tpanel

I create a Custom Tpanel and inside I put various Custom Components ...
procedure Panel_Comp(Location: TWinControl; NumOfComp: Integer;Left,Top,Height,width:Integer);
begin
MyPanel := TsPanel.Create(Conf);
MyPanel.Name := 'MyPanel' + IntToStr(NumOfComp);
MyPanel.Parent := Location;
MyPanel.Left := Left;
MyPanel.Top := Top;
MyPanel.Height := Height;
MyPanel.Width := width;
MyPanel.Caption := '';
end;
and i call it like this
Panel_Comp(Conf.ScrollBox1,1,8,10,70,322);
in the same logic i put inside the new panel other custom components including a tBitbtn the have a onclick event..
procedure BitBtn_Comp(Location: TWinControl; NumOfComp: Integer; Left,Top,Height,Width,ImageNum: Integer);
begin
MyBitBtn := TBitBtn.Create(Conf);
......
MyBitBtn.tag := NumOfComp;
MyBitBtn.OnClick:= Conf.CloseCurrentPanel;
end;
In the main Forn The TConf.CloseCurrentPanel;
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).tag);
TPanel(panelComp).Free;
Application.ProcessMessages;
end;
When I call that I get access violation...
I think is something that I must free all the components inside the panel before free the panel but how I free the BitBtn before the panel and continue the action of the click event?
Here is the FindComponetEx function instead you need it...
function FindComponentEx(const Name: string): TComponent;
var
FormName: string;
CompName: string;
P: Integer;
Found: Boolean;
Form: TForm;
I: Integer;
begin
// Split up in a valid form and a valid component name
P := Pos('.', Name);
if P = 0 then
begin
raise Exception.Create('No valid form name given');
end;
FormName := Copy(Name, 1, P - 1);
CompName := Copy(Name, P + 1, High(Integer));
Found := False;
// find the form
for I := 0 to Screen.FormCount - 1 do
begin
Form := Screen.Forms[I];
// case insensitive comparing
if AnsiSameText(Form.Name, FormName) then
begin
Found := True;
Break;
end;
end;
if Found then
begin
for I := 0 to Form.ComponentCount - 1 do
begin
Result := Form.Components[I];
if AnsiSameText(Result.Name, CompName) then Exit;
end;
end;
Result := nil;
end;
The AV occurs because you are destroying a component (MyBitBtn) while it is still handling Windows messages. The solution is to postpone the destruction until later via PostMessage, similar to this:
unit Unit1;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
StdCtrls;
const
UM_DESTROYPANEL = WM_APP + 623; // some "unique" number; UM = user message
type
TConf = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
strict private
procedure UMDestroyPanel(var Message: TMessage); message UM_DESTROYPANEL;
public
{ Public-Deklarationen }
end;
var
Conf: TConf;
implementation
{$R *.dfm}
procedure TConf.Button1Click(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, 0, 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
begin
Panel1.Free;
end;
end.
If needed you can use wParam and lParam to pass through parameters like so:
procedure TConf.Button1Click(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, WPARAM(Panel1), 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
begin
TObject(Message.WParam).Free;
end;
EDIT:
In your situation I'd probably rewrite TConf.CloseCurrentPanel like this:
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).Tag);
PostMessage(Handle, UM_DESTROYPANEL, WPARAM(panelComp), 0);
end;
Alternatively you can pass through the Tag (might be the better solution because there's less casting involved):
procedure TConf.CloseCurrentPanel(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, TBitBtn(Sender).Tag, 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(Message.WParam));
panelComp.Free;
end;
AFAICT the Application.ProcessMessages isn't needed.
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).tag);
//Where you need to determine 'PanelComp' if there are.
if Assigned(panelComp) and (PanelComp is TPanel) then
TPanel(panelComp).Free;
Application.ProcessMessages;
end;

How do I close open OLE dialogs

I have a function that closes all the forms in the application apart from the main form
procedure CloseOpenForms(const Component: TComponent);
var
i: Integer;
begin
for i := 0 to pred(Component.ComponentCount) do
begin
CloseOpenForms(Component.Components[i]);
if Component.Components[i] is TForm then
begin
TForm(Component.Components[i]).OnCloseQuery := nil;
TForm(Component.Components[i]).Close;
end;
end;
end;
Called from the main form:
CloseOpenForms(Self);
It works fine as long as there are no active OLE dialogs (e.g. TJvObjectPickerDialog).
How can I force these non modal OLE dialogs to close?
JVCL passes the application handle to 'hwndParent' parameter of IDSObjectPicker.InvokeDialog, hence the dialog is owned (not like 'owner' as in VCL, but more like popup parent) by the application window. Then you can enurate windows to find out the ones owned by the application window and post them a close command.
procedure CloseOpenForms(const AComponent: TComponent);
function CloseOwnedWindows(wnd: HWND; lParam: LPARAM): BOOL; stdcall;
begin
Result := TRUE;
if (GetWindow(wnd, GW_OWNER) = HWND(lParam)) and (not IsVCLControl(wnd)) then
begin
if not IsWindowEnabled(wnd) then // has a modal dialog of its own
EnumWindows(#CloseOwnedWindows, wnd);
SendMessage(wnd, WM_CLOSE, 0, 0);
end;
end;
procedure CloseOpenFormsRecursive(const RecComponent: TComponent);
var
i: Integer;
begin
for i := 0 to pred(RecComponent.ComponentCount) do
begin
CloseOpenFormsRecursive(RecComponent.Components[i]);
if RecComponent.Components[i] is TForm then
begin
TForm(RecComponent.Components[i]).OnCloseQuery := nil;
TForm(RecComponent.Components[i]).Close;
end;
end;
end;
begin
EnumWindows(#CloseOwnedWindows, Application.Handle);
CloseOpenFormsRecursive(AComponent)
end;

Resources