When a file is double-clicked, I want it to open in the running instance of my Firemonkey app. For the moment, I am just trying to get the code working in Win32 but ultimately I want similar behavior in OSX.
I have the following code in my .dpr. I found the part relating to the mutex on https://forums.embarcadero.com/message.jspa?messageID=873440 and it works fine in suppressing the opening of a second instance.
var
OneInstanceMutex: THandle = 0;
MessageManager: TMessageManager;
Message: TMessage;
function InstanceAlreadyExists(const MutexName: string): Boolean;
begin
Result := False;
// .. This mutex will be freed when the application closes!
OneInstanceMutex := CreateMutex (nil, FALSE, PChar(MutexName) );
if OneInstanceMutex <> 0 then
begin
if GetLastError() = ERROR_ALREADY_EXISTS then
begin
// Found another instance
Result := True;
end;
end
else
begin
if GetLastError() = ERROR_ACCESS_DENIED then
begin
// Found another instance
Result := True;
end;
end;
end;
begin
if InstanceAlreadyExists('MyApp.exe') then
begin
MessageManager := TMessageManager.DefaultManager;
Message := TMessage<UnicodeString>.Create(ParamStr(1));
MessageManager.SendMessage(nil, Message, True);
Exit;
end;
Application.Initialize;
In the main form, in the FormCreate event, I have
procedure TMyMainForm.FormCreate(Sender: TObject);
var
SubscriptionId: Integer;
MessageManager: TMessageManager;
begin
....
MessageManager := TMessageManager.DefaultManager;
SubscriptionId := MessageManager.SubscribeToMessage(TMessage<UnicodeString>,
procedure(const Sender: TObject; const M: TMessage)
begin
ShowMessage((M as TMessage<UnicodeString>).Value);
end);
// I'm expecting the above to show the filename to be opened
// but no message appears
....
end;
With one instance already running, when I double-clicking on a file, I'm expecting the line
ShowMessage((M as TMessage<UnicodeString>).Value);
to display the filename to be opened but no message appears.
BTW, I have correctly associated the file extension with my app so that the .dpr is receiving ParamStr(1). It's just that the broadcasting of this string to the already running instance isn't working.
Related
I created a program to get a file from FTP servers every 5 seconds.
(I'm using Delphi 7)
To do this I did an IdFTP array.
Everything looks like OK, but when the file doesn't exist, the application crashes.
Message: Project FTPGETFIle.exe raised exception class EldProtocolReplyError with message 'File not found'
Creating array from INI file:
IFTP[i] := TIdFTP.Create(nil);
IFTP[i].Host := IniFile.hostn[i];
IFTP[i].Username := IniFile.usern;
IFTP[i].Password := IniFile.password;
IFTP[i].Port := IniFile.FTPPort;
IFTP[i].OnConnected := FTPConnect;
IFTP[i].OnDisconnected := FTPDisconnect;
IFTP[i].OnStatus := FTPStatus;
IFTP[i].Passive := True;
Get file timer:
procedure TfrmMain.Timer1Timer(Sender: TObject);
var
i : Integer;
begin
for i := 1 to IniFile.nftp do
begin
if pingIP(IniFile.hostn[i]) then
begin
if IFTP[i].Connected then
begin
writelog ('Get file '+IniFile.FTPFile[i]+' and save to '+IniFile.OutputF[i]);
try
IFTP[i].Get (IniFile.FTPFile[i],IniFile.OutputF[i],true, false);
except
on E:EIdFileNotFound do
writelog(E.Message);
on E:EIdProtocolReplyError do
writelog(E.Message);
on E:Exception do
writelog(e.Message);
end;
end;
end
else
writelog(IniFile.hostn[i]+' is not recheable!');
end;
end;
Can someone help me to treat this "file not found"?
Trying to navigate using WebBrowser component automatically through code it doesn't work. The navigation includes the login page and after that some other pages. The first page button login works fine. On second page the next button needed an application.processmessages before executing to make it work. On the next/third page I cannot make automatically the next button to work.
CODE:
//CLICK BUTTON
function clickForm1(WebBrowser: TWebBrowser; FieldName: string): Boolean;
var
i, j: Integer;
FormItem: Variant;
begin
Result := False;
//no form on document
if WebBrowser.OleObject.Document.all.tags('FORM').Length = 0 then
begin
Exit;
end;
//count forms on document
for I := 0 to WebBrowser.OleObject.Document.forms.Length - 1 do
begin
FormItem := WebBrowser.OleObject.Document.forms.Item(I);
for j := 0 to FormItem.Length - 1 do
begin
try
//when the fieldname is found, try to fill out
if FormItem.Item(j).Name = FieldName then
begin
FormItem.Item(j).click;
Result := True;
end;
except
Exit;
end;
end;
end;
end;
//SEARCH INSIDE THE MEMO
procedure TForm2.Button7Click(Sender: TObject);
var
i: Integer;
a: string;
begin
Memo1.Lines.Add('');
Memo1.Lines.Text := ' ' + Memo1.Lines.Text;
for i := 0 to Length(Memo1.Lines.Text) - Length(edit7.Text) do
begin
a := Copy(Memo1.Lines.Text, i, Length(edit7.Text));
if CheckBox1.Checked = True then //FIND CASE Sensitive
begin
if a = edit7.Text then
begin
find := True;
x := 2;
Memo1.Lines.Text := Copy(Memo1.Lines.Text, 2, Length(Memo1.Lines.Text) - 1);
Memo1.SetFocus;
Memo1.SelStart := i - 2;
Memo1.SelLength := Length(edit7.Text);
break;
end;
end
else
begin
if lowercase(a) = lowercase(edit7.Text) then
begin
Memo1.Lines.Text := Copy(Memo1.Lines.Text, 2, Length(Memo1.Lines.Text) - 1);
find := True;
x := 2;
Memo1.SetFocus;
Memo1.SelStart := i - 2;
Memo1.SelLength := Length(edit7.Text);
break;
end;
end;
end;
end;
//HTML TO MEMO
procedure TForm2.Button6Click(Sender: TObject);
var
iall : IHTMLElement;
begin
if Assigned(WebBrowser1.Document) then
begin
iall := (WebBrowser1.Document AS IHTMLDocument2).body;
while iall.parentElement <> nil do
begin
iall := iall.parentElement;
end;
memo1.Text := iall.outerHTML;
end;
end;
procedure TForm2.WebBrowser1DocumentComplete(ASender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
Document: IHtmlDocument2;
CurWebrowser : IWebBrowser;
TopWebBrowser: IWebBrowser;
WindowName : string;
ovElements: OleVariant;
i: Integer;
begin
CurWebrowser := pDisp as IWebBrowser;
TopWebBrowser := (ASender as TWebBrowser).DefaultInterface;
if CurWebrowser=TopWebBrowser then
begin
button6.Click; // HTML TO MEMO
TRY
button7.Click; //SEARCH LOGIN FORM
if find=true then Begin
clickForm1(WebBrowser1, 'move'); //CLICK LOGIN BUTTON
End Else begin Null; End;
FINALLY find:=false; END;
TRY
button8.Click; //SEARCH HOME (AFTER LOGIN) FORM
if find1=true then Begin
Application.ProcessMessages;//NEEDED IN ORDER THE BUTTON TO BE PRESSED.
clickForm1(WebBrowser1, 'refresh'); //CLICK NEXT PAGE BUTTON
End;
FINALLY find1:=false;END;
TRY
button9.Click; //SEARCH WORKLIST FORM
if find2=true then Begin
clickForm1(WebBrowser1, 'next'); //CLICK NEW FORM BUTTON
End;
FINALLY find2:=false;END;
end;
end;
I'm not sure how much you know about working with Event Handlers in code.
Objects like Forms and WebBrowsers typically have one or more event properties that are used to define what happens when the event occurs. So, an event property is a property of an object that can hold the information necessary to invoke (call) a procedure (or function, but not usually) of the same object or another one. The procedure to call has to have the right "signature" for the type definition of the event. If it does then an "event handler" can be assigned to the event property in code, as I'll show below.
One can use event properties and event-handling code in Delphi in a simple way, without knowing any of this, just by going to the Events tab of the Object Inspector and double-clicking next to one of the event names. What that actually does is to create a new handler procedure and to assign it to the corresponding event property of the object (well, not quite, actually that assignment is done at run-time when the host form is loaded).
What I mean by "signature" is the routine type (procedure or function) and its list of parameters, and their types, in its definition.
So, for a WebBrowser, the signature of the OnDocumentComplete event is
procedure (Sender: TObject; const pDisp: IDispatch; var URL: OLEVariant);
The clever thing is that you can assign the OnDocumentComplete property to
any procedure of an object that has the exact same signature. The event type for the WB's OnDocumentComplete is defined in the import unit ShDocVw, btw
So, let's suppose you write three methods that contain the code you want to run
when the WB completes loading URLs A, B and C, respectively:
procedure TForm1.DocCompleteA(Sender: TObject; const
pDisp: IDispatch; var URL: OLEVariant);
begin
// Do your stuff for arrival at site/page A here
// Then update NavigationOK flag to reflect if you succeeded or failed
if NavigationOK then begin
WebBrowser1.OnDocumentComplete := DocCompleteB;
// Now navigate to site/page B
end
else
WebBrowser1.OnDocumentComplete := Nil;
end;
procedure TForm1.DocCompleteB(Sender: TObject; const
pDisp: IDispatch; var URL: OLEVariant);
begin
end;
procedure TForm1.DocCompleteC(Sender: TObject; const
pDisp: IDispatch; var URL: OLEVariant);
begin
end;
Then, you can assign the WB's OnDocumentComplete property to each of them in turn,
with something like the code at the end of DocCompleteA which updates the WB's OnDocumentComplete to the code needed for B, and so on, in turn. The NavigationOK variable is just a flag to indicate that our navigation stays "on course" as it progresses. If it gets set to false because something went wrong, we set the WB's OnDocumentComplete to Nil, so that it does nothing next time the event occurs.
Then, you can kick off the whole "tour" of sites with something like this:
procedure TForm1.NavigateSites;
begin
NavigationOK := True;
WebBrowser1.OnDocumentComplete := DocCompleteA;
WebBrowser1.Navigate(...); // Navigate to site A
end;
Of course, you don't have to do the updating of the WB's OnDocumentComplete property and navigation to the next URL in the current DocCompleteX. In fact, it's probably clearer if you do those if a higher level procedure like the NavigateSites one, and more easily maintainable, which can be important if you're navigating others' sites, which are apt to be changed without any prior warning.
When I try to check the validity of a zip file an exception is raised that the process can not access the file because it is being used by another process, yet the code in Open1.Click opens the zip file with no problem. Is there something wrong in Valid1Click?
procedure TForm1.Valid1Click(Sender: TObject);
{ Is the zip file valid. }
var
iZipFile: TZipFile;
iZipFilename: string;
iValid: Boolean;
begin
Screen.Cursor := crHourGlass;
try
{ Create the TZipFile Class }
iZipFile := TZipFile.Create;
try
if FileExists(ZipFilename1.Text) then
begin
iZipFilename := ZipFilename1.Text;
{ Open zip file for reading }
iZipFile.Open(iZipFilename, zmRead);
iValid := iZipFile.IsValid(iZipFilename);
if iValid then
MessageBox(0, 'The zip file is valid.', 'Check Zip File',
MB_ICONINFORMATION or MB_OK)
else
MessageBox(0, 'The zip file is NOT valid.', 'Check Zip File',
MB_ICONWARNING or MB_OK);
end
else
begin
MessageBox(0, 'The zip file does not exist.', 'Warning',
MB_ICONWARNING or MB_OK);
end;
{ Close the zip file }
iZipFile.Close;
finally
iZipFile.Free;
end;
finally
Screen.Cursor := crDefault;
end;
end;
procedure TForm1.Open1Click(Sender: TObject);
{ Open zip file. }
var
i: integer;
iZipFile: TZipFile;
iFilename: string;
iDateTime: TDateTime;
iCompressedSize: cardinal;
iUnCompressedSize: cardinal;
iCRC32: cardinal;
iCompressionMethod: word;
iFileComment: string;
iListItem: TlistItem;
begin
if OpenDialog1.Execute then
begin
if FileExists(OpenDialog1.FileName) then
begin
iZipFile := TZipFile.Create;
try
ListView1.Items.Clear;
ZipFilename1.Text := OpenDialog1.FileName;
try
iZipFile.Open(ZipFilename1.Text, zmReadWrite);
for i := 0 to iZipFile.FileCount - 1 do
begin
iFilename := iZipFile.FileNames[i];
iListItem := ListView1.Items.Add;
iListItem.Caption := iFilename;
iDateTime := FileDateToDateTime
(iZipFile.FileInfo[i].ModifiedDateTime);
iListItem.SubItems.Add(DateTimeToStr(iDateTime)); { 0 }
iCompressedSize := iZipFile.FileInfo[i].CompressedSize;
iListItem.SubItems.Add(FormatByteSize(iCompressedSize)); { 1 }
iUnCompressedSize := iZipFile.FileInfo[i].UncompressedSize;
iListItem.SubItems.Add(FormatByteSize(iUnCompressedSize)); { 2 }
iCRC32 := iZipFile.FileInfo[i].CRC32;
iListItem.SubItems.Add(IntToStr(iCRC32)); { 3 }
iCompressionMethod := iZipFile.FileInfo[i].CompressionMethod;
iListItem.SubItems.Add
(ZipCompressionToStr(iCompressionMethod)); { 4 }
iFileComment := iZipFile.Comment;
iListItem.SubItems.Add(iFileComment); { 5 }
end;
iZipFile.Close;
except
on E: Exception do
begin
ShowMessage(E.ClassName + #10#13 + E.Message);
end;
end;
finally
iZipFile.Free;
end;
end;
end;
You have these lines the wrong way round:
iZipFile.Open(iZipFilename, zmRead);
iValid := iZipFile.IsValid(iZipFilename);
The first line locks the file, and so the second line fails. You will have to call IsValid before calling Open.
Having said that, since you use zmRead, it should be possible for the call to IsValid to open the file again because the call to Open used fmOpenRead. So I suspect that there may be a bug in the ZIP file code, or the file stream code, in the version of Delphi that you are using. All the same, calling IsValid before Open is sure to work.
In fact, IsValid is a class method. You should call it like this:
iValid := TZipFile.IsValid(iZipFilename);
It comes to the same thing in the end, but it makes it clear to the reader of the code that the method call does not rely on the state of an instance.
In fact I personally would simply do away with the call to IsValid and go straight to calling Open. If that fails, I believe that a meaningful error message will be raised.
Update
Looks like you don't want to open the file at all, and just want to check its validity. In which case, you don't need an instance, you don't call the constructor, and you just use a single call to TZipFile.IsValid.
procedure TForm1.Valid1Click(Sender: TObject);
begin
Screen.Cursor := crHourGlass;
try
if FileExists(ZipFilename1.Text) then
begin
if TZipFile.IsValid(ZipFilename1.Text) then
...
finally
Screen.Cursor := crDefault;
end;
end;
As David Heffernan stated initially : it should be possible to use isValid after TZipFile::Open(filename, mode), since one would expect opening a file read only would not block it for others to read.
When using the Open-method based on a fileNAME (another one exists for reading f from a TFileStream), it internally creates a fileStream, and while it does specify fmOpenRead, it does not set a share mode on opening this stream.
See this blog post for an example on how this can be avoided by first creating a TFileStream yourself in which you specify the share mode explicitly :
https://www.digon.be/community/blog/TZipFile-problem-accessing-open-files-even-with-TZipMode-zmRead
I am working on a component, using Delphi 2006, the component retrieves system information and writes to file.
The requirement is such that I have to incorporate a global exception handler in the component, so when the exception occurs it will be caught and my custom message will be shown to the user.
procedure Tmy.GlobalExceptionHandlerThis(Sender : TObject; E : Exception );
begin
//catch the exception and show the message
TakeScreenShotAndSaveInapplicationFolder;
MessageDlg('Exception has Occured , Detail '+E.Message,mtError,[mbOK],0);
end;
This works fine but according to the requirement I have to capture the errorscreen shot (This is to find visually the form where the exception popped up)
So I did this, with take screenshot code from delphigeist.com:
procedure TakeScreenShotAndSaveInapplicationFolder;
var
thisBitmap: TBitmap;
sDate : string;
begin
DateSeparator :='_';
TimeSeparator:='_';
sDate :=DateTimeToStr(now);
thisBitmap := TBitmap.Create;
ScreenshotArea(thisBitmap, Screen.DesktopRect, True);
thisBitmap.SaveToFile(ExtractFilePath(Application.ExeName)+sDate+'.jpg');
FreeAndNil(thisBitmap);
end;
Problem:
When the exception occurs, I want to take the screen shot of the message also but with my code the this happens
Can anyone tell me how I can get the screen shot like this?
That is along the form get the message
MessageDlg('Exception has Occured, Detail ' + E.Message,mtError,[mbOK],0);
is modal, so after the message I can't take the screen shot. And before I can't also,
so when can I take the screen shot right when the exception message is displayed?
procedure Tmy.GlobalExceptionHandlerThis(Sender : TObject; E : Exception );
begin
//catch the exception and show the message
TakeScreenShotAndSaveInapplicationFolder;
MessageDlg('Exception has Occured , Detail '+E.Message,mtError,[mbOK],0);
TakeScreenShotAndSaveInapplicationFolder;
end;
Modify this message box (a wrapper around Windows.MessageBox), as follows:
{ TAwMessageBox }
type
TAwMessageBox = class(TObject)
private
FCaption: String;
FFlags: Cardinal;
FHookProc: TFarProc;
FText: String;
FWndHook: HHOOK;
function Execute: Integer;
procedure HookProc(var Message: THookMessage);
end;
function TAwMessageBox.Execute: Integer;
begin
try
try
FHookProc := MakeHookInstance(HookProc);
FWndHook := SetWindowsHookEx(WH_CALLWNDPROCRET, FHookProc, 0,
GetCurrentThreadID);
Result := Application.MessageBox(PChar(FText), PChar(FCaption), FFlags);
finally
if FWndHook <> 0 then
UnhookWindowsHookEx(FWndHook);
if FHookProc <> nil then
FreeHookInstance(FHookProc);
end;
except
Result := 0;
end;
end;
procedure TAwMessageBox.HookProc(var Message: THookMessage);
var
Data: PCWPRetStruct;
Title: array[0..255] of Char;
begin
with Message do
if nCode < 0 then
Result := CallNextHookEx(FWndHook, nCode, wParam, lParam)
else
Result := 0;
if Message.nCode = HC_ACTION then
begin
Data := PCWPRetStruct(Message.lParam);
if (Data.message = WM_ACTIVATE) and (LoWord(Data.wParam) = WA_INACTIVE) then
begin
ZeroMemory(#Title, SizeOf(Title));
GetWindowText(Data.hwnd, #Title, SizeOf(Title));
if String(Title) = FCaption then
begin
TakeScreenShotAndSaveInapplicationFolder;
UnhookWindowsHookEx(FWndHook);
FWndHook := 0;
FreeHookInstance(FHookProc);
FHookProc := nil;
end;
end;
end;
end;
function MsgBox(const Text: String; Flags: Cardinal;
const Caption: String): Integer;
begin
with TAwMessageBox.Create do
try
FCaption := Caption;
FFlags := Flags;
FText := Text;
Result := Execute;
finally
Free;
end;
end;
Testing code and screen shot:
procedure TForm1.ApplicationEvents1Exception(Sender: TObject; E: Exception);
begin
MsgBox('Exception has occured. Details:'#13#10#13#10 + E.Message,
MB_OK or MB_ICONERROR, 'Error');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
raise Exception.Create('Test exception');
end;
Message dialogs (and exception dialogs) are modal so the first TakeScreenShotAndSaveInApplicationFolder call will execute before it displays and the second will not execute until after it has closed.
You could create your own message dialog which captures the screen as part of it's Show routine, but I'd suggest that you should look at what the customer wants, rather than what they have asked for and get a better solution.
From the sounds of it, they want to be able to see exactly what state the application was in at the time of the error. This means screengrab + error details, and I don't see why the error details need to be part of the screengrab specifically.
Why don't you look at using a 3rd party error logging system (MadExcept, JclDebug) and extend it to capture a screenshot of the application without the error message?
This would give you just as much information (more, due to the additional info that the exception logs can produce), without the headache of trying to screenshot error dialogs when they're raised.
Also, I'd question grabbing the entire desktop screen. It's prone to inadvertently grabbing sensitive information on background windows.
Reference Links:
Jcl - http://sourceforge.net/projects/jcl/
MadExcept - http://madshi.net/madExceptDescription.htm
Use your own custom form to show the error dialog and let that form control the screenshottaking.
i managed to get what i wanted, after going through #NGLN idea(answer above),and #Pieter B idea for taking screen shot by the form itself..
so i used the Open-Source-SynTaskDialog to display my exception message like this
procedure Tmy.GlobalExceptionHandlerThis(Sender : TObject; E : Exception );
begin
var Task: TTaskDialog;
begin
Task.Title:='Error message';
Task.Inst := 'An error/exception has occured';
Task.Content := 'the details are ...';
Task.Execute([],0,[],tiError ,tfiShield ,200);
end;
And inside the SynTaskDialog.pas i did this
procedure TTaskDialogForm.ButtonClick(Sender: TObject);
begin
TakeScreenShotAndSaveInapplicationFolder; {<--take the snap shot here..!!!}
if (Sender<>nil) and Sender.InheritsFrom(TSynButton) then
with TSynButton(Sender) do begin
self.Tag := Tag;
if Tag in [mrOk..mrNo] then
self.ModalResult := Tag;
Close;
end;
end;
this i did on button click as onshow the the snap shot was only half
I have a delphi app that runs minimized to a tray icon. When the tray icon is double clicked the app opens a non-modal user interface form.
I have added logic to the app to detect whether it is already running. If it isn't running, it starts up and miminizes itself to the tray.
If it is already running, I want it to pass control to the first instance of itself and open the non-modal form, and then exit (the second instance). What's the best way to do this?
TIA
R
The recommended method of detecting another instance of a given application is for that application to create a named mutex or lock a file in a well known location, so that the second instance will trigger an error when you try to create the same mutex or lock the same file. Once you know there's another instance running, you can find the process handle for that instance and send it a message to restore if its minimized.
Microsoft way is not flawless, so i do prefer old school:
const WM_KNOCK_KNOCK = WM_USER + 42;
{ or WM_USER + 265 or any number you like, consult PSDK documentation why WM_USER range }
{ or do RegisterWindowMessage }
{...}
procedure TMainForm.FormCreate(Sender: TObject);
var
Window: HWND;
begin
Window := FindWindow(PChar({MainForm.}ClassName), nil);
{
i neither remember how it works exactly nor have time to investigate right now,
so quick and dirty validity test follows:
}
Assert(not (HandleAllocated and (Window = Handle)), 'failed, use fallback');
{
if Window <> 0 then
begin
PostMessage(Window, WM_KNOCK_KNOCK, 0, 0);
Halt;
end;
{ regular initialization }
end;
Now, WM_KNOCK_KNOCK message handler of first instance performs wakeup routine.
i have little clue what exactly you do when you receive WM_LBUTTONUP (or perhaps WM_LBUTTONDBLCLK) in your Shell_NotifyIcon wrapper (Application.Restore, maybe?). As, Chris Thornton said, there is no such state as 'minimized to tray', it is artifical.
Fallback: if assertion fails, note what code depends only on class function ClassName so could be easily moved out of FormCreate and invoked before Application creates it.
program Only_One_Mutex;
//undefine this {.$define useMutex} to make it a multi instance app.
{$define useMutex}
uses
Forms,
Windows,
Messages,
MainForm in 'MainForm.pas' {frmMain};
{$R *.res}
{$ifdef useMutex}
var
Mutex : THandle;
{$endif}
function pBuffStr( Var S1: String; S:String ): PChar;
begin
FillChar(S1,SizeOf(S1),#0); {clear out the destination string}
S1:= S+#0; {set it equal the source}
Result:= #S1[1]; {result is a PChar pointer }
end;
procedure WindowToTop( WN: String );
var
iTitle: integer;
S1,S : String;
Done: Boolean;
begin
Done:= False;
While NOT Done do begin
if Pos(';',WN) > 0 then begin
S:= Copy(WN,1,Pos(';',WN)-1);
WN:= Copy(WN,Pos(';',WN)+1,Length(WN));
end else begin
S:= WN;
Done:= True;
end; {if Pos}
iTitle:= FindWindow( nil, pBuffStr(S1,S) );
if iTitle <> 0 then
if NOT SetForegroundWindow( iTitle ) then
GetLastError();
Application.ProcessMessages;
end; {while NOT Done}
end;
procedure RestoreWindow( WN: String );
var
iTitle: integer;
Dest, S : String;
Done: Boolean;
begin
Done:= False;
While NOT Done do begin
if Pos(';',WN) > 0 then begin {is there more than ONE name}
S:= Copy(WN,1,Pos(';',WN)-1); {copy the first name of the original}
WN:= Copy(WN,Pos(';',WN)+1,Length(WN)); {reduce the original string}
end else begin
S:= WN; {only one name, so copy it}
Done:= True; {this loop is done}
end; {if Pos}
iTitle:= FindWindow( nil, pBuffStr(Dest,S) ); {search for the window name}
if iTitle <> 0 then {if found, then restore it}
DefWindowProc(iTitle, WM_SYSCOMMAND, SC_RESTORE, SC_RESTORE);
end; {while NOT Done}
end;
//=================================================================
procedure AppRun;
begin
Application.Initialize;
Application.Title := 'Only One Prog';
Application.CreateForm(TfrmMain, frmMain);
Application.Run;
end;
begin
{$ifdef useMutex}
//global var declarations in the mainform.
{=====================================================================}
//ATitle MUST match the assigned Application.Title in AppRun
//and Application.Title can "NOT" be a constant or var.
ATitle := 'Only One Prog';
{ THIS IS HOW IT KEEPS THE SECOND INSTANCE FROM STARTING,
by using a MUTEX, and a MAINFORM window title }
//any text appender will work.
AMutex := ATitle + ' Mutex Thu, Jul/12/2012';
//mainform's caption
ACaption := ATitle + ', Mainform Caption';
//a label on the mainform
ALabel := ATitle + ', MainForm Label-using mutex';
{=====================================================================}
Mutex := CreateMutex(nil, True, PAnsiChar( AMutex ));
if (GetLastError = ERROR_ALREADY_EXISTS) then begin
try
RestoreWindow( ACaption );
WindowToTop( ACaption ); //main form's name
finally
CloseHandle(Mutex);
end;
end else
if (Mutex <> 0)
AND (GetLastError <> ERROR_ALREADY_EXISTS)
then begin
try
AppRun;
finally
CloseHandle(Mutex);
end;
end;
{$else}
//global var declarations in the mainform.
{=====================================================================}
ATitle := 'More than One'; //global declaration in the mainform.
//mainform's caption - THIS IS HOW IT KEEPS THE SECOND INSTANCE FROM STARTING
ACaption := ATitle + ', Mainform Caption';//global declaration in the mainform.
//a label on the mainform
ALabel := ATitle + ', MainForm Label-multi exe'; //global declaration in the mainform.
{=====================================================================}
AppRun;
{$endif}
end.
unit MainForm;
interface
uses
Windows, Messages, SysUtils,
Variants, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls, LblEffct;
type
TfrmMain = class(TForm)
le1: TLabelEffect;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
//these GLOBAL vars, are assigned values in the program source (.dpr) file.
ATitle,
ACaption,
ALabel,
AMutex :String;
implementation
{$R *.dfm}
procedure TfrmMain.FormCreate(Sender: TObject);
begin
Caption := ACaption; //used to ID this form...
le1.Caption := ALabel;
end;
end.