I've tried to accept files that are dragged and dropped to a Form from the File Explorer but it doesn't work. My WM_DROPFILES handler is never called. I'm running Windows 8 if that makes any difference.
Here's a simple example of what I do (I just have a TMemo on the form):
type
TForm1 = class(TForm)
Memo1: TMemo;
private
{ Private declarations }
procedure WMDROPFILES(var msg : TWMDropFiles) ; message WM_DROPFILES;
procedure CreateWnd; override;
procedure DestroyWnd; override;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.CreateWnd;
begin
inherited;
DragAcceptFiles(Handle, True);
end;
procedure TForm1.DestroyWnd;
begin
inherited;
DragAcceptFiles(Handle, false);
end;
procedure TForm1.WMDROPFILES(var msg: TWMDropFiles);
var
i, fileCount: integer;
fileName: array[0..MAX_PATH] of char;
begin
fileCount:=DragQueryFile(msg.Drop, $FFFFFFFF, fileName, MAX_PATH);
for i := 0 to fileCount - 1 do
begin
DragQueryFile(msg.Drop, i, fileName, MAX_PATH);
Memo1.Lines.Add(fileName);
end;
DragFinish(msg.Drop);
end;
Most likely you are running your application elevated. Probably because you are running Delphi elevated. In Vista and later, low privilege processes cannot send messages to higher privilege processes. This MSDN blog explains more.
If you are running your Delphi IDE elevated, I urge you to stop doing so. There's very seldom a need to do so for standard desktop application development.
As Remy points out, your DestroyWnd is incorrect. You are destroying the window handle before calling DragAcceptFiles. Simply reverse the order. Personally I'd use WindowHandle in both CreateWnd and DestroyWnd. The Handle property creates the window handle if it is not assigned and so masks such errors.
procedure TForm1.CreateWnd;
begin
inherited;
DragAcceptFiles(WindowHandle, True);
end;
procedure TForm1.DestroyWnd;
begin
DragAcceptFiles(WindowHandle, false);
inherited;
end;
Related
I wrote a simple component that monitors a folder and triggers an event when it detects changes. It works well... apparently. But I'm not sure of one thing. From time to time, the main thread may need to update the monitored path and I'm not sure if I've done this right. It is about the SetNewPath procedure. This is executed from the main thread and it changes the UpdatePath variable from the other thread. It is possible to create an conflict when the main thread writes to UpdatePath and the component thread tries to read its value in the Execute cycle ?
FolderMonitor.pas
unit FolderMonitor;
interface
uses
SysUtils, Windows, Classes, ExtCtrls;
type
TOnFolderChange = procedure(Sender: TObject) of object;
TFolderMonitor = class(TThread)
private
MainWait: THandle;
UpdatePath: Boolean;
TimeOut: Cardinal;
FPath: String;
FOnFolderChange: TOnFolderChange;
procedure DoOnFolderChange;
procedure SetNewPath(Path:String);
protected
procedure Execute; override;
public
constructor Create(const FolderPath: String; OnFolderChangeHandler: TOnFolderChange);
destructor Destroy; override;
procedure Unblock;
property Path: String read FPath write SetNewPath;
property OnFolderChange: TOnFolderChange read FOnFolderChange write FOnFolderChange;
end;
implementation
constructor TFolderMonitor.Create(const FolderPath: String; OnFolderChangeHandler: TOnFolderChange);
begin
inherited Create(True);
FOnFolderChange:=OnFolderChangeHandler;
FPath:=FolderPath;
UpdatePath:=false;
FreeOnTerminate:=false;
MainWait:=CreateEvent(nil,true,false,nil);
Resume;
end;
destructor TFolderMonitor.Destroy;
begin
CloseHandle(MainWait);
inherited;
end;
procedure TFolderMonitor.DoOnFolderChange;
begin
if Assigned(FOnFolderChange) then
Synchronize(procedure
begin
FOnFolderChange(Self);
end);
end;
procedure TFolderMonitor.Unblock;
begin
PulseEvent(MainWait);
end;
procedure TFolderMonitor.SetNewPath(Path:String);
begin
FPath:=Path;
UpdatePath:=true;
PulseEvent(MainWait);
end;
procedure TFolderMonitor.Execute;
var Filter,WaitResult: Cardinal;
WaitHandles: array[0..1] of THandle;
begin
Filter:=FILE_NOTIFY_CHANGE_DIR_NAME + FILE_NOTIFY_CHANGE_FILE_NAME + FILE_NOTIFY_CHANGE_SIZE;
WaitHandles[0]:=MainWait;
WaitHandles[1]:=FindFirstChangeNotification(PWideChar(FPath),false,Filter);
TimeOut:=INFINITE;
while not Terminated do begin
if UpdatePath then begin
if WaitHandles[1]<>INVALID_HANDLE_VALUE then FindCloseChangeNotification(WaitHandles[1]);
WaitHandles[1]:=FindFirstChangeNotification(PWideChar(FPath),false,Filter);
TimeOut:=INFINITE;
UpdatePath:=false;
end;
if WaitHandles[1] = INVALID_HANDLE_VALUE
then WaitResult:=WaitForSingleObject(WaitHandles[0],INFINITE)
else WaitResult:=WaitForMultipleObjects(2,#WaitHandles,false,TimeOut);
case WaitResult of
WAIT_OBJECT_0: Continue;
WAIT_OBJECT_0+1: TimeOut:=200;
WAIT_TIMEOUT: begin DoOnFolderChange; TimeOut:=INFINITE; end;
end;
if WaitHandles[1] <> INVALID_HANDLE_VALUE then
FindNextChangeNotification(WaitHandles[1]);
end;
if WaitHandles[1] <> INVALID_HANDLE_VALUE then
FindCloseChangeNotification(WaitHandles[1]);
end;
end.
UnitMain.pas
unit UnitMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, FolderMonitor;
type
TForm1 = class(TForm)
Memo1: TMemo;
Edit1: TEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure OnFolderChange(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
end;
var
Form1: TForm1;
Mon: TFolderMonitor;
X: integer;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
X:=0;
Mon:=TFolderMonitor.Create('D:\Test',OnFolderChange);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Mon.Terminate;
Mon.Unblock;
Mon.WaitFor;
Mon.Free;
end;
procedure TForm1.OnFolderChange(Sender: TObject);
begin
inc(x);
Memo1.Lines.Add('changed! '+IntToStr(x));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Mon.Path:=Edit1.Text;
end;
end.
You have a variable shared between multiple threads, with one thread modifying the variable. This scenario is known as a data race.
Some races may be benign. This one is not. If one thread modifies the variable whilst another thread reads it, errors may occur. Because the data type is complex (pointer to heap allocated array of characters) it is quite possible for the reading thread to attempt to read from deallocated memory.
For a complex type like this you need to use a mutual exclusion lock whenever you access the value. All reads and writes must be serialised by the lock. Use a critical section or a monitor.
To ensure that you don't ever perform unprotected access it is wise to enforce this rule in code. For example, my TThreadSafe<T> described here: Generic Threadsafe Property
Is it possible in Delphi to just save the breakpointss in the .DSK file for a project and no other Desktop settings?
Most of the .DSK gets in the way, but not being able to save debug breakpoints is a real pain (especially when they are conditionally or actions are attached).
I've never come across an IDE facility to save only the breakpoint-related settings in the .Dsk file.
For amusement, I thought I'd try and implement something via an IDE add-in using OTA notifications. The code below runs fine installed into a package installed in D7, and the IDE seems quite happy to re-open a project whose .Dsk file has been processed by it (and the breakpoints get set!).
As you can see, it catches an OTA notifier's FileNotification event when called with a NotifyCode of ofnProjectDesktopSave, which happens just after the IDE has saved the .Dsk file (initially with the extension '.$$$', which I faile to notice when first writing this). It then reads the saved file file, and and prepares an updated version from which all except a specified list of sections are removed. The user then has the option to save the thinned-out file back to disk. I've used a TMemIniFile to do most of the processing simply to minimize the amount of code needed.
I had zero experience of writing an OTA notifier when I read your q, but the GE Experts FAQ referenced below was immensely helpful, esp the example notifier code.
Normally, deleting a project's .Dsk file is harmless, but use this code with caution as it has not been stress-tested.
Update: I noticed that the filename received by TIdeNotifier.FileNotification event actually has an extension of '.$$$'. I'm not quite sure why that should be, but seemingly the event is called before the file is renamed to xxx.Dsk. I thought that would require a change to how
to save the thinned-out version, but evidently not.
Update#2: Having used a folder-monitoring utility to see what actually happens, it turns out that the desktop-save notification the code receives is only the first of a number of operations related to the .Dsk file. These include renaming any existing version of the .Dsk file as a .~Dsk file and finally saving the .$$$ file as the new .Dsk file.
unit DskFilesu;
interface
{$define ForDPK} // undefine to test in regular app
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls, IniFiles, TypInfo
{$ifdef ForDPK}
, ToolsApi
{$endif}
;
{$ifdef ForDPK}
{
Code for OTA TIdeNotifier adapted from, and courtesy of, the link on http://www.gexperts.org/open-tools-api-faq/#idenotifier
}
type
TIdeNotifier = class(TNotifierObject, IOTANotifier, IOTAIDENotifier)
protected
procedure AfterCompile(Succeeded: Boolean);
procedure BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
procedure FileNotification(NotifyCode: TOTAFileNotification;
const FileName: string; var Cancel: Boolean);
end;
{$endif}
type
TDskForm = class(TForm)
edDskFileName: TEdit;
SpeedButton1: TSpeedButton;
OpenDialog1: TOpenDialog;
lbSectionsToKeep: TListBox;
lbDskSections: TListBox;
moDskFile: TMemo;
btnSave: TButton;
procedure btnSaveClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
private
procedure GetSectionsToKeep;
function GetDskFileName: String;
procedure SetDskFileName(const Value: String);
function GetDskFile: Boolean;
protected
public
DskIni : TMemIniFile;
property DskFileName : String read GetDskFileName write SetDskFileName;
end;
var
NotifierIndex: Integer;
DskForm: TDskForm;
{$ifdef ForDPK}
procedure Register;
{$endif}
implementation
{$R *.DFM}
{$ifdef ForDPK}
procedure Register;
var
Services: IOTAServices;
begin
Services := BorlandIDEServices as IOTAServices;
Assert(Assigned(Services), 'IOTAServices not available');
NotifierIndex := Services.AddNotifier(TIdeNotifier.Create);
end;
{$endif}
procedure DskPopUp(FileName : String);
var
F : TDskForm;
begin
F := TDskForm.Create(Application);
try
F.DskFileName := FileName;
F.ShowModal;
finally
F.Free;
end;
end;
function TDskForm.GetDskFileName: String;
begin
Result := edDskFileName.Text;
end;
procedure TDskForm.SetDskFileName(const Value: String);
begin
edDskFileName.Text := Value;
if Assigned(DskIni) then
FreeAndNil(DskIni);
btnSave.Enabled := False;
DskIni := TMemIniFile.Create(DskFileName);
DskIni.ReadSections(lbDskSections.Items);
GetSectionsToKeep;
end;
procedure TDskForm.btnSaveClick(Sender: TObject);
begin
DskIni.UpdateFile;
end;
procedure TDskForm.FormCreate(Sender: TObject);
begin
lbSectionsToKeep.Items.Add('watches');
lbSectionsToKeep.Items.Add('breakpoints');
lbSectionsToKeep.Items.Add('addressbreakpoints');
if not IsLibrary then
DskFileName := ChangeFileExt(Application.ExeName, '.Dsk');
end;
procedure TDskForm.GetSectionsToKeep;
var
i,
Index : Integer;
SectionName : String;
begin
moDskFile.Lines.Clear;
for i := lbDskSections.Items.Count - 1 downto 0 do begin
SectionName := lbDskSections.Items[i];
Index := lbSectionsToKeep.Items.IndexOf(SectionName);
if Index < 0 then
DskIni.EraseSection(SectionName);
end;
DskIni.GetStrings(moDskFile.Lines);
btnSave.Enabled := True;
end;
function TDskForm.GetDskFile: Boolean;
begin
OpenDialog1.FileName := DskFileName;
Result := OpenDialog1.Execute;
if Result then
DskFileName := OpenDialog1.FileName;
end;
procedure TDskForm.SpeedButton1Click(Sender: TObject);
begin
GetDskFile;
end;
{$ifdef ForDPK}
procedure RemoveNotifier;
var
Services: IOTAServices;
begin
if NotifierIndex <> -1 then
begin
Services := BorlandIDEServices as IOTAServices;
Assert(Assigned(Services), 'IOTAServices not available');
Services.RemoveNotifier(NotifierIndex);
end;
end;
function MsgServices: IOTAMessageServices;
begin
Result := (BorlandIDEServices as IOTAMessageServices);
Assert(Result <> nil, 'IOTAMessageServices not available');
end;
procedure TIdeNotifier.AfterCompile(Succeeded: Boolean);
begin
end;
procedure TIdeNotifier.BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
begin
Cancel := False;
end;
procedure TIdeNotifier.FileNotification(NotifyCode: TOTAFileNotification;
const FileName: string; var Cancel: Boolean);
begin
Cancel := False;
// Note: The FileName passed below has an extension of '.$$$'
if NotifyCode = ofnProjectDesktopSave then
DskPopup(FileName);
end;
initialization
finalization
RemoveNotifier;
{$endif}
end.
This question already has answers here:
Cross-application drag-and-drop in Delphi
(2 answers)
Closed 8 years ago.
I am trying to drag and drop a video file (like .avi) from desktop But ı can not take it to the my program.But when ı try to drag and drop inside my program it works fine.For ex: I have an edittext and a listbox inside my pro and ı can move text that inside edittext to listbox.I could not get what is the difference ??
I take the video using openDialog.But ı wanna change it with drag and drop.
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
MediaPlayer1.DeviceType:=dtAutoSelect;
MediaPlayer1.FileName := OpenDialog1.FileName;
Label1.Caption := ExtractFileExt(MediaPlayer1.FileName);
MediaPlayer1.Open;
MediaPlayer1.Display:=Self;
MediaPlayer1.DisplayRect := Rect(panel1.Left,panel1.Top,panel1.Width,panel1.Height);
panel1.Visible:=false;
MediaPlayer1.Play;
end;
end;
Here is a simple demo how to drag&drop files from Windows Explorer into a ListBox (for Delphi XE):
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
protected
procedure WMDropFiles(var Msg: TMessage); message WM_DROPFILES;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses ShellAPI;
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Handle, True);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DragAcceptFiles(Handle, False);
end;
procedure TForm1.WMDropFiles(var Msg: TMessage);
var
hDrop: THandle;
FileCount: Integer;
NameLen: Integer;
I: Integer;
S: string;
begin
hDrop:= Msg.wParam;
FileCount:= DragQueryFile (hDrop , $FFFFFFFF, nil, 0);
for I:= 0 to FileCount - 1 do begin
NameLen:= DragQueryFile(hDrop, I, nil, 0) + 1;
SetLength(S, NameLen);
DragQueryFile(hDrop, I, Pointer(S), NameLen);
Listbox1.Items.Add (S);
end;
DragFinish(hDrop);
end;
end.
You can also use DropMaster from Raize software.
You can catch the WM_DROPFILES message.
First, set that your form will "accept" files from dragging in the FormCreate procedure:
DragAcceptFiles(Self.Handle, True);
After, declare the procedure in the desired form class:
procedure WMDropFiles(var Msg: TMessage); message WM_DROPFILES;
Finally, fill the procedure body as follows:
procedure TForm1.WMDropFiles(var Msg: TMessage);
begin
// do your job with the help of DragQueryFile function
DragFinish(Msg.WParam);
end
Alternatively, check out "The Drag and Drop Component Suite for Delphi" by Anders Melander. It works as-is with 32-bit and with some tweaking can be made to work with 64-bit as well (read the blog - it has been upgraded by 3rd parties).
The following works perfectly (Delphi 7):
procedure TMainForm.SayIt(s:string); // s is the string to be spoken
var
voice: OLEVariant;
begin
memo1.setfocus;
voice := CreateOLEObject ('SAPI.SpVoice');
voice.Voice := voice.GetVoices.Item(combobox1.ItemIndex); // current voice selected
voice.volume := tbVolume.position;
voice.rate := tbRate.position;
voice.Speak (s, SVSFDefault);
end;
The above works in "sync" mode (SVSFDefault flag), but if I change the flag to SVSFlagsAsync in an attempt to play the sound in async mode, no soud is produced. No error messages are given, but nothing is played on the speakers.
What might the problem be? I have the SpeechLib_TLB unit in Delphi's Imports folder.
EDIT: This is in Windows XP
Thanks,
Bruno.
When you uses the SVSFlagsAsync flag, the voice stream is queued in an internal buffer and stay waiting to be executed by the speech service, So I think which you issue is related to the lifetime of the voice object, because is a local variable , the instance is destroyed before to execute the sound.
As workaround you can wait for the sound, using the WaitUntilDone method
voice.Speak (s, SVSFlagsAsync);
repeat Sleep(100); until voice.WaitUntilDone(10);
or declare the voice variable in you form definition.
TMainForm = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
voice: OLEVariant;
procedure SayIt(const s:string);
end;
var
MainForm: TMainForm;
implementation
uses
ComObj;
{$R *.dfm}
procedure TMainForm.SayIt(const s:string); // s is the string to be spoken
const
SVSFDefault = 0;
SVSFlagsAsync = 1;
SVSFPurgeBeforeSpeak= 2;
begin
memo1.setfocus;
voice.Voice := voice.GetVoices.Item(combobox1.ItemIndex); // current voice selected
voice.volume := tbVolume.position;
voice.rate := tbRate.position;
voice.Speak (s, SVSFlagsAsync {or SVSFPurgeBeforeSpeak});
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
SayIt('Hello');
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
voice := CreateOLEObject('SAPI.SpVoice');
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
voice := Unassigned;
end;
end.
As additional note, since you are using late binding you don't need the SpeechLib_TLB unit.
i have developed application for read information from card reader. Here i have used timer for get the information each five second, so every five second the user interface getting slow
because it's get the information from reader. how to run the timer in background with out affecting user interface
unit frmVistorreg;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms;
type
thread1=class(TThread)
private
FEvent: THandle;
protected
procedure Execute; override;
public
procedure MyTerminate;
end;
TForm3 = class(TForm)
txt_name: TEdit;
txt_cardno.Text TEdit;
private
public
end;
var
Form3: TForm3;
implementation
{$R *.dfm}
procedure thread1.Execute;
var
idcard_info :array[0..1024*5] of byte;
flag :Integer;
portflag :Integer;
st :TStrings;
str :string;
begin
FEvent:= CreateEvent(nil, False, false, nil);
try
while not Terminated do begin
if MainForm.PortFlag=0 then
begin
Form3.Label11.Caption:='port has been successfully opened';
Form3.Label11.Font.Color :=32768;
flag := GetIdCardInfo(#idcard_info[0],1024*5,5);
str := byteArray2Str(#idcard_info[0],1024*5);
if(flag=0) then
begin
st := TStringList.Create;
try
SplitStr('^_^',str,st);
Form3.txt_name.Text := st.Strings[0];
Form3.txt_cardno.Text := st.Strings[5];
finally
st.Free;
end;
end;
end
else
begin
Form3.Label11.Caption:='Please open the port';
Form3.Label11.Font.Color:=clRed;
end;
if WaitForSingleObject(FEvent, 500) <> WAIT_TIMEOUT // 5 seconds timeout
then Terminate;
end;
finally
CloseHandle(FEvent);
end;
end;
procedure thread1.MyTerminate;
begin
SetEvent(FEvent);
end;
procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction);
var
Objthread1:thread1;
begin
Objthread1.MyTerminate;
Action := caFree;
end;
procedure TForm3.FormCreate(Sender: TObject);
var
Objthread1:thread1;
begin
Objthread1:=thread1.Create(false);
end;
end.
when i close the form have error like
Project MDIAPP.exe raised exception class EAccessViolation with message 'Access violation at address 0051B9F1 in module 'MDIAPP.exe'. Read of address 00000198'.
how can i solve this.
You need not a timer component for that, you need a background thread. A simplest solution is to use Sleep function in the thread:
unit Unit2;
interface
uses
Classes;
type
TMyThread = class(TThread)
protected
procedure Execute; override;
end;
implementation
procedure TMyThread.Execute;
begin
while not Terminated do begin
// do your processing here
Sleep(5000); // wait 5 seconds
end;
end;
end.
A better approach is to use WaitForSingleObject and an event instead of Sleep to be able to terminate your background thread immediately without 5 seconds delay:
unit Unit2;
interface
uses
Windows, Classes;
type
TMyThread = class(TThread)
private
FEvent: THandle;
protected
procedure Execute; override;
public
procedure MyTerminate;
end;
implementation
procedure TMyThread.Execute;
begin
FEvent:= CreateEvent(nil, False, False, nil);
try
while not Terminated do begin
// do your processing here
// ..
if WaitForSingleObject(FEvent, 5000) <> WAIT_TIMEOUT // 5 seconds timeout
then Terminate;
end;
finally
CloseHandle(FEvent);
end;
end;
procedure TMyThread.MyTerminate;
begin
SetEvent(FEvent);
end;
end.
To terminate TMyThread instance on closing a form call MyTerminate method from OnClose event handler of a form.
And yes, it is interesting to know what error message you receive, not just 'showing error'.