Api

How Can I Prevent Multiple Instances of My Application?

Solution 1

This is the way I do it:

In the begin..end block of the .dpr:

begin
  if HPrevInst <>0 then begin
    ActivatePreviousInstance;
    Halt;
  end;
end;

Here is the unit I use:

unit PrevInst;

interface

uses
  WinProcs,
  WinTypes,
  SysUtils;

type
  PHWnd = ^HWnd;

function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; export;

procedure ActivatePreviousInstance;

implementation

function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool;
var
  ClassName : array[0..30] of char;
begin
  Result := true;
  if GetWindowWord(Wnd, GWW_HINSTANCE) = HPrevInst then begin
    GetClassName(Wnd, ClassName, 30);
    if STRIComp(ClassName,'TApplication')=0 then begin
      TargetWindow^ := Wnd;
      Result := false;
    end;
  end;
end;

procedure ActivatePreviousInstance;
var
  PrevInstWnd: HWnd;
begin
  PrevInstWnd := 0;
  EnumWindows(@EnumApps,LongInt(@PrevInstWnd));
  if PrevInstWnd <> 0 then
    if IsIconic(PrevInstWnd) then
      ShowWindow(PrevInstWnd,SW_Restore)
    else
      BringWindowToTop(PrevInstWnd);
end;

end.

Solution 2

Taken from Delphi 2 Developers Guide by Pacheco and Teixeira with heavy modifications.

Usage: In the Project source change to the following

if InitInstance then
  begin
     Application.Initialize;
     Application.CreateForm(TFrmSelProject, FrmSelProject);
     Application.Run;
  end;
unit multinst;
{
  Taken from Delphi 2 Developers Guide by Pacheco and Teixeira
  With heavy Modifications.

  Usage:
  In the Project source change to the following

  if InitInstance then
  begin
     Application.Initialize;
     Application.CreateForm(TFrmSelProject, FrmSelProject);
     Application.Run;
  end;

   That's all folks ( I hope ;()
}


interface

uses Forms, Windows, Dialogs, SysUtils;

const
  MI_NO_ERROR          = 0;
  MI_FAIL_SUBCLASS     = 1;
  MI_FAIL_CREATE_MUTEX = 2;

{ Query this function to determine if error occurred in startup. }
{ Value will be one or more of the MI_* error flags. }

function GetMIError: Integer;
Function InitInstance : Boolean;

implementation

const
  UniqueAppStr : PChar;   {Change for every Application}

var
  MessageId: Integer;
  WProc: TFNWndProc = Nil;
  MutHandle: THandle = 0;
  MIError: Integer = 0;


function GetMIError: Integer;
begin
  Result := MIError;
end;

function NewWndProc(Handle: HWND; Msg: Integer; wParam,
                    lParam: Longint): Longint; StdCall;
begin

  { If this is the registered message... }
  if Msg = MessageID then begin
    { if main form is minimized, normalize it }
    { set focus to application }
    if IsIconic(Application.Handle) then begin
      Application.MainForm.WindowState := wsNormal;
      ShowWindow(Application.Mainform.Handle, sw_restore);
    end;
    SetForegroundWindow(Application.MainForm.Handle);
  end
  { Otherwise, pass message on to old window proc }
  else
    Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;

procedure SubClassApplication;
begin
  { We subclass Application window procedure so that }
  { Application.OnMessage remains available for user. }
  WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
                                    Longint(@NewWndProc)));
  { Set appropriate error flag if error condition occurred }
  if WProc = Nil then
    MIError := MIError or MI_FAIL_SUBCLASS;
end;

procedure DoFirstInstance;
begin
  SubClassApplication;
  MutHandle := CreateMutex(Nil, False, UniqueAppStr);
  if MutHandle = 0 then
    MIError := MIError or MI_FAIL_CREATE_MUTEX;
end;

procedure BroadcastFocusMessage;
{ This is called when there is already an instance running. }
var
  BSMRecipients: DWORD;
begin
  { Don't flash main form }
  Application.ShowMainForm := False;
  { Post message and inform other instance to focus itself }
  BSMRecipients := BSM_APPLICATIONS;
  BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
                         @BSMRecipients, MessageID, 0, 0);
end;

Function InitInstance : Boolean;
begin
  MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
  if MutHandle = 0 then
  begin
    { Mutex object has not yet been created, meaning that no previous }
    { instance has been created. }
    ShowWindow(Application.Handle, SW_ShowNormal);
    Application.ShowMainForm:=True;
    DoFirstInstance;
    result := True;
  end
  else
  begin
    BroadcastFocusMessage;
    result := False;
  end;
end;

initialization

begin
   UniqueAppStr := Application.Exexname;
   MessageID := RegisterWindowMessage(UniqueAppStr);
   ShowWindow(Application.Handle, SW_Hide);
   Application.ShowMainForm:=FALSE;
end;

finalization
begin
  if WProc <> Nil then
    { Restore old window procedure }
    SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
end;
end.

Solution 3

VAR MutexHandle:THandle;
Var UniqueKey  : string;

FUNCTION IsNextInstance:BOOLEAN;
BEGIN
 Result:=FALSE;
 MutexHandle:=0;
 MutexHandle:=CREATEMUTEX( NIL,TRUE, UniqueKey);
 IF MutexHandle<>0 THEN
  BEGIN
   IF GetLastError=ERROR_ALREADY_EXISTS THEN
    BEGIN
     Result:=TRUE;
     CLOSEHANDLE(MutexHandle);
     MutexHandle:=0;
    END;
  END;
END;

begin
  CmdShow:=SW_HIDE;
  MessageId:=RegisterWindowMessage(zAppName);
  Application.Initialize;
  IF IsNextInstance
   THEN
     PostMessage(HWND_BROADCAST, MessageId,0,0)
   ELSE
    BEGIN
     Application.ShowMainForm:=FALSE;
     Application.CreateForm(TMainForm, MainForm);
     MainForm.StartTimer.Enabled:=TRUE;
    Application.Run;
    END;
  IF MutexHandle<>0 THEN CLOSEHANDLE(MutexHandle);
end.

in MainForm you need add code for process private message

PROCEDURE TMainForm.OnAppMessage( VAR M:TMSG; VAR Ret:BOOLEAN );
BEGIN
 IF M.Message=MessageId THEN
  BEGIN
   Ret:=TRUE;
// BringWindowToTop  !!!!!!!!
  END;
END;

INITIALIZATION
 ShowWindow(Application.Handle, SW_Hide);
END.

Performing an action when Windows shuts down a Delphi app

I did a little investigation, and here is what seems to be happening:

Normally, when you exit a Delphi application by using the system menu or by calling the Form's Close method, the following event handlers are called:

1. FormCloseQuery - the default action sets the variable CanClose=TRUE so form close will continue.
2. FormClose
3. FormDestroy

If the application is active and you attempt to exit Windows, the event handlers are called in the following sequence:

1. FormCloseQuery
2. FormDestroy

The FormClose method never seems to be called.

Here is the flow of events when the user chooses to end the Windows session:

1. Windows sends out a WM_QUERYENDSESSION message to all application windows one by one and awaits a response
2. Each application window receives the message and returns a non-zero value if it is OK to terminate, or 0 if it is not OK to terminate.
3. If any application returns 0, the Windows session is not ended, otherwise, Windows sends a WM_ENDSESSION message to all application windows
4. Each Application Window responds with a TRUE value indicating that Windows can terminate any time after all applications have returned from processing this message. This appears to be the location of the Delphi problem: Delphi applications seem to return TRUE and the FormDestroy method is called immediately, bypassing the FormClose method.
5. Windows exits

One solution is to respond to the WM_QUERYENDSESSION message in the Delphi application and prevent Windows from exiting by returning a 0 result. This can't be done in the FormCloseQuery method because there is no way to determine the source of the request (it can either be the result of the WM_QUERYENDSESSION message or the user just simply closing the application).

Another solution is to respond to the WM_QUERYENDSESSION message by calling the same cleanup procedure you call in the FormClose method.

Example:

unit Unit1;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,
Dialogs;
type
  TForm1 = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
  {---------------------------------------------------------------}
  { Custom procedure to respond to the WM_QUERYENDSESSION message }
  {---------------------------------------------------------------}
  procedure WMQueryEndSession(
             var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;
  public
    { Public declarations }
  end;
var
  Form1    : TForm1;

implementation
{$R *.DFM}

{---------------------------------------------------------------}
{ Custom procedure to respond to the WM_QUERYENDSESSION message }
{ The application will only receive this message in the event   }
{ that Windows is requesing to exit.                            }
{---------------------------------------------------------------}
procedure TForm1.WMQueryEndSession(var Message: TWMQueryEndSession);
begin
  inherited;         { let the inherited message handler respond first }
  {--------------------------------------------------------------------}
  { at this point, you can either prevent windows from closing...      }
  { Message.Result:=0;                                                 }
  {---------------------------or---------------------------------------}
  { just call the same cleanup procedure that you call in FormClose... }
  { MyCleanUpProcedure;                                                }
  {--------------------------------------------------------------------}
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  MyCleanUpProcedure;
end;

end.

I have not tested this code, but I think it will work correctly. Let me know how it turns out!

Windows API about Printer

>> I want to obtain the values (left, right, top, bottom) of "unprintable area" from the printer.

In August Delphi Developer "Take Control of your printer with a custom Delphi Class":

To get the Left and Top Printer Margins use the Windows Escape Function with the parameter GETPRINTINGOFFSET.

var
  pntMargins : TPoint;
begin
  { @ means " the address of the variable" }
  Escape(Printer.Handle, GETPRINTINGOFFSET,0,nil,@prntMargins);
end;

Getting the Right and Bottom Margins aren't quite so straightforward. There isn't an equivalent Escape call. You obtain these values by getting the physical width (physWidth) and height (physHeight) of the page, the printable width (PrintWidth) and height (PrintHeight) of the page, and then carrying out the following sums:

RightMargin    := physWidth  - PrintWidth  - LeftMargin
BottomMargin := physHeight - PrintHeight - TopMargin

The physical page size is found using Escape, this time with the GETPHYSPAGESIZE parameter. The point pntPageSize contains the page width in pntPageSize.x and page height in pntPageSize.y

var
  pntPageSize : TPoint;
begin
   Escape(Printer.Handle, GETPHYSPAGESIZE,o,nil,@pntPageSize);
end;

Getting DOS Variables

I assume you mean environment variables?

The GetEnvironmentStrings function returns the address of the environment block for the current process. Each environment variable is null terminated. The set of strings is double null terminated.

The GetEnvironmentVariable function retrieves the value of the specified variable from the environment block of the calling process. The value is in the form of a null-terminated string of characters.

GetModuleFileName

Here is an answer for you. I have used this on many occasions and it works well.

procedure TForm1.Button1Click(Sender: TObject);
var
   szFileName : array[0..49] of char;
   szModuleName : array[0..19] of char;
   iSize : integer;
begin
   StrPCopy(szModuleName, 'NameOfModule');
   iSize := GetModuleFileName(GetModuleHandle(szModuleName),szFileName,
                  SizeOf(szFileName));
   if iSize > 0 then
      ShowMessage('Full path name is : ' + StrPas(szFileName))
   else
      ShowMessage('Path of module not found');
end;

Setting time system with Delphi

"Vitor Martins" <nop47019@mail.telecom.pt wrote:


How can I set the clock system time and date in a program  with Delphi 2.0
in Win 95

This works for us:

//******************************************************************************
//Public function SetPCSystemTime changes the system date and time.
//Parameter(s): tDati  The new date and time
//Returns:      True if successful
//              False if not
//******************************************************************************
function SetPCSystemTime(tDati: TDateTime): Boolean;
var
   tSetDati: TDateTime;
   vDatiBias: Variant;
   tTZI: TTimeZoneInformation;
   tST: TSystemTime;
begin
   GetTimeZoneInformation(tTZI);
   vDatiBias := tTZI.Bias / 1440;
   tSetDati := tDati + vDatiBias;
   with tST do
   begin
        wYear := StrToInt(FormatDateTime('yyyy', tSetDati));
        wMonth := StrToInt(FormatDateTime('mm', tSetDati));
        wDay := StrToInt(FormatDateTime('dd', tSetDati));
        wHour := StrToInt(FormatDateTime('hh', tSetDati));
        wMinute := StrToInt(FormatDateTime('nn', tSetDati));
        wSecond := StrToInt(FormatDateTime('ss', tSetDati));
        wMilliseconds := 0;
   end;
   SetPCSystemTime := SetSystemTime(tST);
end;

How do I execute a program and have my code wait until it is finished?

From: Noel Rice <nrice@ix.netcom.com>

uses Wintypes,WinProcs,Toolhelp,Classes,Forms;

Function WinExecAndWait(Path : string; Visibility : word) : word;
var
  InstanceID : THandle;
  PathLen : integer;
begin
  { inplace conversion of a String to a PChar }
  PathLen := Length(Path);
  Move(Path[1],Path[0],PathLen);
  Path[PathLen] := #00;
  { Try to run the application }
  InstanceID := WinExec(@Path,Visibility);
  if InstanceID < 32 then { a value less than 32 indicates an Exec error }
     WinExecAndWait := InstanceID

  else begin
    Repeat
      Application.ProcessMessages;
    until Application.Terminated or (GetModuleUsage(InstanceID) = 0);
    WinExecAndWait := 32;
  end;
end;

function WinExecAndWait32(FileName:String; Visibility : integer):integer;
var
  zAppName:array[0..512] of char;
  zCurDir:array[0..255] of char;
  WorkDir:String;
  StartupInfo:TStartupInfo;
  ProcessInfo:TProcessInformation;
begin
  StrPCopy(zAppName,FileName);
  GetDir(0,WorkDir);
  StrPCopy(zCurDir,WorkDir);
  FillChar(StartupInfo,Sizeof(StartupInfo),#0);
  StartupInfo.cb := Sizeof(StartupInfo);

  StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow := Visibility;
  if not CreateProcess(nil,
    zAppName,                      { pointer to command line string }
    nil,                           { pointer to process security attributes }
    nil,                           { pointer to thread security attributes }
    false,                         { handle inheritance flag }
    CREATE_NEW_CONSOLE or          { creation flags }
    NORMAL_PRIORITY_CLASS,
    nil,                           { pointer to new environment block }
    nil,                           { pointer to current directory name }
    StartupInfo,                   { pointer to STARTUPINFO }
    ProcessInfo) then Result := -1 { pointer to PROCESS_INF }

  else begin
    WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
    GetExitCodeProcess(ProcessInfo.hProcess,Result);
  end;
end;

{ This code came from Lloyd's help file! Ldelphi.zip }

disable Ctrl-Alt-Del

From: Richard Leigh <rleigh@deakin.edu.au>

The program should be nice and small so it can load before a user can hit CTRL-ALT-DEL.

My Solution :

Compile a single WIN32API call into a small .exe in delphi.

The Program :

program small;

{written by Richard Leigh, Deakin Univesity 1997}

uses
  WinProcs;

{$R *.RES}

var
   Dummy : integer;

begin
  Dummy := 0;
  {Disable ALT-TAB}
  SystemParametersInfo( SPI_SETFASTTASKSWITCH, 1, @Dummy, 0);
  {Disable CTRL-ALT-DEL}
  SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @Dummy, 0);
end.

Please email me and tell me if you liked this page.