如何不让程序起第二个应用程序？

[supertigar]

由于应用程序占用了端口，在起同样的应用程序的时候会报错，如何限制不让它起第二个应用程序？

[zdq801104]

procedure TFrm_Main.SpeedButton1Click(Sender: TObject);
var
HWndCalculator : HWnd;
begin
HWndCalculator := FindWindow(nil, 'P_PublicHouse');
if HWndCalculator<>0 then
begin
application.message('此程序已经启动');
exit;
end;
end;

[kencharles]

Cold_Yeti(荒原独歌)， weizi2000(秋风啊-秋的叹息)两人的方法都可行呀！

[lyg]

用findwindow函数不可行，因为可能碰到两个不同的程序有相同的窗口标题，容易引起软件之间的冲突，同意Cold_Yeti(荒原独歌)的做法。

[dzt1]

只需3行代码：
CreateMutex(nil,true,'我的程序');
if GetLastError = ERROR_ALREADY_EXISTS then
Application.Terminate;
将这段程序加在程序的FormCreate中就可以了！

[demongz]

delphi的socketserver列子

CreateMutex(nil, True, 'SCKTSRVR');
if GetLastError = ERROR_ALREADY_EXISTS then
begin
MessageBox(0, PChar(SAlreadyRunning), SApplicationName, MB_ICONERROR);
Halt;
end;

[WGYKING]

学习

[ghy412]

学习！

[fj218]

uses这个单元即可

unit RunOne;

interface

const
MI_QUERYWINDOWHANDLE = 1;
MI_RESPONDWINDOWHANDLE = 2;

MI_ERROR_NONE = 0;
MI_ERROR_FAILSUBCLASS = 1;
MI_ERROR_CREATINGMUTEX = 2;

// Call this function to determine if error occurred in startup.
// Value will be one or more of the MI_ERROR_* error flags.
function GetMIError: Integer;

implementation

uses Forms, Windows, SysUtils;

const
UniqueAppStr = 'ShuanYuan_SoftWare';

var
MessageId: Integer;
WProc: TFNWndProc;
MutHandle: THandle;
MIError: Integer;

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

function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint):
Longint; stdcall;
begin
Result := 0;
// If this is the registered message...
if Msg = MessageID then
begin
case wParam of
MI_QUERYWINDOWHANDLE:
// A new instance is asking for main window handle in order
// to focus the main window, so normalize app and send back
// message with main window handle.
begin
if IsIconic(Application.Handle) then
begin
Application.MainForm.WindowState := wsNormal;
Application.Restore;
end;
PostMessage(HWND(lParam), MessageID, MI_RESPONDWINDOWHANDLE,
Application.MainForm.Handle);
end;
MI_RESPONDWINDOWHANDLE:
// The running instance has returned its main window handle,
// so we need to focus it and go away.
begin
SetForegroundWindow(HWND(lParam));
Application.Terminate;
end;
end;
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_ERROR_FAILSUBCLASS;
end;

procedure DoFirstInstance;
// This is called only for the first instance of the application
begin
// Create the mutex with the (hopefully) unique string
MutHandle := CreateMutex(nil, False, UniqueAppStr);
if MutHandle = 0 then
MIError := MIError or MI_ERROR_CREATINGMUTEX;
end;

procedure BroadcastFocusMessage;
// This is called when there is already an instance running.
var
BSMRecipients: DWORD;
begin
// Prevent main form from flashing
Application.ShowMainForm := False;
// Post message to try to establish a dialogue with previous instance
BSMRecipients := BSM_APPLICATIONS;
BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
@BSMRecipients, MessageID, MI_QUERYWINDOWHANDLE,
Application.Handle);
end;

procedure InitInstance;
begin
SubClassApplication; // hook application message loop
MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
if MutHandle = 0 then
// Mutex object has not yet been created, meaning that no previous
// instance has been created.
DoFirstInstance
else
BroadcastFocusMessage;
end;

initialization
MessageID := RegisterWindowMessage(UniqueAppStr);
InitInstance;
finalization
// Restore old application window procedure
if WProc <> Nil then
SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
if MutHandle <> 0 then CloseHandle(MutHandle); // Free mutex
end.

[Cold_Yeti]

program CNCGIS;

uses
Forms,
Controls,
......

{$R *.RES}
var
HMuTex:HWnd;
Ret:Integer;

begin

//使程序只运行一次 Added by HGB
HMuTex:=CreateMuTex(nil,false,'Mutex_JSTRD_Application');
Ret:=GetLastError;
if Ret <> Error_Already_Exists then
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
.....
Application.Run;
end
else
begin
ReleaseMuTex(HMuTex);
MessageBox(0,'程序已经启动！','提示信息',MB_ICONINFORMATION);
end;

end.

[楚人无衣]

改写.dpr文件：
var
aHandle: THandle;

{$R *.res}

begin
Application.Initialize;
aHandle := FindWindow(nil, '我的程序');
if aHandle <> 0 then
begin
if IsIconic(aHandle) then
SendMessage(aHandle, WM_SYSCOMMAND, SC_RESTORE, 0);
SetForeGroundWindow(aHandle);
Application.Terminate;
Exit;
end;

Application.Title := '我的程序';
Application.CreateForm(TfrmSec, frmSec);
Application.Run;
end.

[pengxuan]

同意楼上

[beyondtkl]

。。。 搜索一下 例子也是非常多哦

[wenjianyao]

findwindows函数