关于程序只运行一次的问题

【 tulaoshi.com - 编程语言 】

　　//从论坛上copy来，事先自己并未验证

　　引用秋风兄的代码：
　　  Application.Title := 'PerRecord';
　　  Application.Initialize;
　　  mHandle := Windows.CreateMutex(nil, true, 'PerRecord');
　　  if mHandle 0 then
　　  begin
　　    if GetLastError = Windows.ERROR_ALREADY_EXISTS then
　　    begin
　　      fHandle := FindWindow('TfrmLogin', nil);
　　      if fHandle = 0 then
　　        fHandle := FindWindow('TfrmPer', nil);
　　      if fHandle 0 then
　　      begin
　　        ShowWindow(fHandle, SW_SHOW);
　　        SetForeGroundWindow(fHandle);
　　      end;
　　      Windows.ReleaseMutex(mHandle);
　　      Halt;
　　    end;
　　  end;

　　  Application.CreateForm(TdmPer, dmPer);
　　  Application.CreateForm(TfrmPer, frmPer);
　　  Application.Run;
　　

　　第二个

　　http://dev.csdn.net/article/20/20379.shtm 看都没有看，来不及了，有待考证

　　第三个

　　回复人： fj218(洞庭风) ( ) 信誉：103

　　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.
　　

　　第四个

　　据说这个简单明了，有待我来考证

　　回复人： fei19790920(饭桶的马甲（抵制日货）) ( ) 信誉：103 得分: 0

　　program Project1;

　　uses
　　  Forms,windows,
　　  Unit1 in 'Unit1.pas' {Form1};

　　var hw:hwnd;

　　{$R *.RES}
　　begin
　　  Application.Initialize;
　　  application.title:='test';//名字自己定义
　　  CreateMutex(nil, false, 'ADManager');
　　  if GetLastError ERROR_ALREADY_EXISTS then
　　  begin
　　    Application.CreateForm(TForm1, Form1);
　　    Application.Run;
　　  end;
　　end.
　　

　　第五个

　　好像和上一个类似，但是感觉严谨，学习一下

　　回复人： zdq801104(我很笨，但是我不傻！) ( ) 信誉：90

　　看看这个吧，编译已经通过了
　　unit Unit1;

　　interface

　　uses
　　  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
　　  Dialogs, ExtCtrls, StdCtrls, CheckLst;

　　type
　　  TForm1 = class(TForm)
　　  private
　　    { Private declarations }
　　  public
　　    { Public declarations }
　　  end;

　　var
　　  Form1: TForm1;
　　  //保存Mutex句柄
　　  mHandle:THandle;
　　  PreviousInstanceWindow:HWnd;
　　  Project:String;
　　  AppName:String;
　　implementation

　　{$R *.dfm}
　　initialization
　　  //定义自己的项目名称，作为要创建的互斥区名，最好有自己的特点以防止重复
　　  Project:='RunOnlyOnce_MyProject';
　　  //将lpMutexAttributes设为nil,bInitialOwner设为True(即本程序拥有该互斥区)
　　  mHandle:=CreateMutex(nil,True,PChar(Project));
　　  if GetLastError=ERROR_ALREADY_EXISTS then
　　   //该互斥区已存在则表明已有本程序的另一个实例在运行
　　    begin
　　      ShowMessage('已经有该程序在运行');
　　      //保存程序标题
　　      AppName:=Application.Title;
　　      //不显示本窗口
　　      Application.ShowMainForm:=False;
　　      //改变程序标题，以使函数FindWindow找到的是前一个实例窗口
　　      Application.Title:='destroy me';
　　      //寻找前一个实例窗口句柄
　　      PreviousInstanceWindow:=FindWindow(nil,PChar(AppName));
　　      //已经找到
　　      if PreviousInstanceWindow0 then
　　      //如果该窗口最小化则恢复
　　         if IsIconic(PreviousInstanceWindow) then
　　           ShowWindow(PreviousInstanceWindow,SW_RESTORE)
　　        else
　　        //如果程序在后台则将其放到前台
　　         SetForegroundWindow(PreviousInstanceWindow);
　　         //中止本实例
　　        Application.Terminate;
　　      end;
　　    finalization
　　    //该互斥区对象仍存在则关闭对象
　　      if mHandle0 then
　　        CloseHandle(mHandle);
　　end.
　　

　　以上都是delphi版的，我爱delphi，可是我却没有办法用，项目都是vb的。讨厌vb却没有办法

　　下面这个是vb的，绝对好用，不是我写的，转自谁，也找不到了，谢谢那天帮助我的兄台！！

　　模块里面

　　Option Explicit

　　Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
　　Private Declare Function AttachThreadInput Lib "user32" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
　　Private Declare Function GetForegroundWindow Lib "user32" () As Long
　　Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
　　Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
　　Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
　　Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

　　Private Const SW_SHOW = 5
　　Private Const SW_RESTORE = 9

　　Public Const WM_CONTEXTMENU = &H7B ''菜单弹出

　　
　　''在有一个实例运行的情况下把该实例拉到前台，不允许运行两个实例
　　Public Function ForceForegroundWindow(ByVal hWnd As Long) As Boolean
　　   Dim ThreadID1 As Long
　　   Dim ThreadID2 As Long
　　   Dim nRet As Long

　　   If hWnd = GetForegroundWindow() Then
　　      ForceForegroundWindow = True
　　   Else
　　      ThreadID1 = GetWindowThreadProcessId(GetForegroundWindow, ByVal 0&)
　　      ThreadID2 = GetWindowThreadProcessId(hWnd, ByVal 0&)
　　      If ThreadID1 ThreadID2 Then
　　         Call AttachThreadInput(ThreadID1, ThreadID2, True)
　　         nRet = SetForegroundWindow(hWnd)
　　         Call AttachThreadInput(ThreadID1, ThreadID2, False)
　　      Else
　　         nRet = SetForegroundWindow(hWnd)
　　      End If
　　      If IsIconic(hWnd) Then
　　         Call ShowWindow(hWnd, SW_RESTORE)
　　      Else
　　         Call ShowWindow(hWnd, SW_SHOW)
　　      End If
　　      ForceForegroundWindow = CBool(nRet)
　　   End If
　　End Function

　　sub main或者是主窗体，这里用的是sub main主窗体相应调整

　　If App.PrevInstance = True Then

　　    Dim lngPreHandle As Long
　　   
　　    lngPreHandle = FindWindow(vbNullString, "欢迎登录上海时代航运MIS！") ''找登陆窗口，找到就是把登陆拉最前面
　　   
　　    If CBool(lngPreHandle) Then
　　       
　　        ForceForegroundWindow lngPreHandle
　　           
　　        End
　　           
　　    End If

　　    lngPreHandle = FindWindow(vbNullString, "时代航运管理信息系统") ''找不到登陆窗口，就找主窗口，把主窗口拉前面
　　   
　　    If CBool(lngPreHandle) Then
　　       
　　        ForceForegroundWindow lngPreHandle
　　           
　　        End
　　           
　　    End If
　　   
　　    End ''本来不可能存在既没有登陆窗口又没有主窗口的情况，但是为了以防万一，还是再这里多一个end
　　   
　　End If
　　

　　vb的这个不严谨，通过findwindow的名字都不严谨，只是我的窗口名字还算牛，一般不会重复，有时间要多研究delphi的，找一个严谨的方法。