setup.pas

生物信息学中的遗传数据分析的delphi源码。

               while (Result = id_Retry) do begin
                  { Let user retry to copy file. }
                  Error :=CopyFile (F[i].Name);
                  if (Error <> 0) then
                     Result := MessageBox (HWindow, AMsg, 'SetUp',
                              mb_IconInformation or mb_RetryCancel)
                  else Result := id_OK;
                  end;
               case Result of
                  id_OK     : State := st_OK;
                  id_Cancel : State := st_ERROR;
                  end; { case }
               end; { }
            end;

            if (State = st_OK) then
               SendDlgItemMessage (PS^.HWindow, id_Meter,
                    mm_SetPartsComplete, i, 0);
         end; { if st=stOK }
      end; { while }


   EnableWindow(HWindow, True);
   PS^.Show (sw_Hide);


   { Next step }
   case State of
      st_ERROR:
        { File copying errors are fatal. }
        begin
           StrCopy (AMsg, 'Setup was unable to install the software');
           StrCat (AMsg, #10);
           StrCat (AMsg, 'You must run Setup again before using the application');
           MessageBox (HWindow,
              AMsg, 'SetUp Error - File Copy',  mb_OK or mb_IconInformation);
           TDlgWindow.OK (Msg);{Destroy;}
        end;
      st_CANCELLED:
        { User cancelled. }
        begin
           StrCopy (AMsg, 'Setup has not completed installing the software');
           StrCat (AMsg, #10);
           StrCat (AMsg, 'Are you sure you want to cancel?');

           if MessageBox (HWindow, AMsg,
             'SetUp', mb_YesNo or mb_IconQuestion) = id_Yes then
                 TDlgWindow.OK (Msg);{Destroy;}
        end;
     st_OK:
        { Everything OK so far. }
        begin
           { Create group in Program manager }
           { Establish DDE link }
           if (InitiateDDE <> 0) then begin
              MessageBox (HWindow,
                 'Setup has installed the software but could not add the application to the Program Manager.',
                 'SetUp Error - InitiateDDE', mb_IconInformation);
              TDlgWindow.OK (Msg);{Destroy;}
              end
           else begin
               if CreateGroup then begin
                  MessageBox (HWindow,
                     'Software has been successfully installed.',
                       'SetUp', mb_IconInformation);
                  TDlgWindow.OK (Msg);{Destroy;}
                  end
               else begin
                  MessageBox(HWindow,
                     'Setup has installed the software but could not add the application to the Program Manager.',
                     'SetUp Error - DDE execute', mb_IconExclamation or mb_Ok);
                  TDlgWindow.OK (Msg);{Destroy;}
                  end;
               end;
        end;
   end; { case State of }
end;

{-----------------------------InitiateDDE----------------------------------}

{ Initiate a DDE conversation with the Program Manager.
  Return 0 if successful. }
function WelcomeDlg.InitiateDDE:integer;
var
  AppAtom, TopicAtom: TAtom;
begin
  PendingMessage := wm_DDE_Initiate;
  AppAtom := GlobalAddAtom('PROGMAN');
  TopicAtom := GlobalAddAtom('PROGMAN');
  SendMessage(HWnd(-1), wm_DDE_Initiate, HWindow,
    MakeLong(AppAtom, TopicAtom));
  GlobalDeleteAtom(AppAtom);
  GlobalDeleteAtom(TopicAtom);
  PendingMessage := 0;
  if ServerWindow = 0 then
     InitiateDDE := -1
  else begin
     InitiateDDE := 0;
     ShowWindow (ServerWindow, sw_Restore);
{     EnableWindow (ServerWindow, False);}
     end;
end;

{-----------------------------TerminateDDE---------------------------------}

{ Terminate the DDE conversation. Send the wm_DDE_Terminate message
  only if the server window still exists. }
procedure WelcomeDlg.TerminateDDE;
var
  W: HWnd;
begin
  W := ServerWindow;
  ServerWindow := 0;
  if IsWindow(W) then begin
     PostMessage(W, wm_DDE_Terminate, HWindow, 0);
{     EnableWindow (W, True);}
	  end;
end;

{-----------------------------CreateGroup----------------------------------}

{ If a DDE link hasbeen established (ServerWindow <> 0) and there
  is no DDE message currently pending (PendingMessage = 0), build
  a list of Program Manager commands, and submit the commands
  using a wm_DDE_Execute message. To build the command list, first
  calculate the total length of the list, then allocate a global
  memory block of that size, and finally store the command list
  as a null-terminated string in the memory block.
}
function WelcomeDlg.CreateGroup:Boolean;
const
  sCreateGroup = '[CreateGroup(%s)]';
  sAddItem     = '[AddItem(%s,%s,%s)]';
var
  Executed: Boolean;
  I, L: Integer;
  HCommands: THandle;
  PName, PCommands: PChar;
  Name: array[0..100] of Char;
  szTemp1, szTemp2 : array[0..63] of char;
  Arg : array[0..2] of PChar;
  x:longint;
begin
   Executed := False;
   if (ServerWindow <> 0) and (PendingMessage = 0) then begin
      L := StrLen (szGroupName) + Length (sCreateGroup) -1;

      for i := 1 to FILES do
         if F[i].InPM then begin
            { Compute length of PM command. }
            Inc (L, StrLen (DestPath) + 1 + StrLen (F[i].Name) + StrLen (F[i].PMText)
                    + StrLen (F[i].PMIcon) + Length (sAddItem) -1);
            if not F[i].WinIcon then
               Inc (L, StrLen (DestPath) + 1);
            end;
      HCommands := GlobalAlloc(gmem_Moveable or gmem_DDEShare, L);
      if HCommands <> 0 then begin
         StrCopy (Name, szGroupName);
         PName := Name;
         PCommands := GlobalLock(HCommands);
         WVSPrintF(PCommands, sCreateGroup, PName);

         { Add file names here }
         for i := 1 to Files do
            if F[i].InPM then begin
               StrCopy (szTemp1, DestPath);
               StrCat (szTemp1, '\');
               StrCat (szTemp1, F[i].Name);
               Arg[0] := szTemp1;
               Arg[1] := F[i].PMText;
               if not F[i].WinIcon then begin
                  StrCopy (szTemp2, DestPath);
                  StrCat (szTemp2, '\');
                  StrCat (szTemp2, F[i].PMIcon);
                  Arg[2] := szTemp2;
                  end
               else Arg[2] := F[i].PMIcon;
               wvsprintf (Name, sAddItem, Arg);
               StrCat (PCommands, Name);
               end;

         end;
      GlobalUnlock(HCommands);
      if PostMessage(ServerWindow, wm_DDE_Execute, HWindow,
         MakeLong(0, HCommands)) then begin
         PendingMessage := wm_DDE_Execute;
         Executed := True;
      end else GlobalFree(HCommands);
      end;
    CreateGroup := Executed;
end;

{-----------------------------WMDDEAck-------------------------------------}

{ wm_DDE_Ack message response method. If the current DDE message
  is a wm_DDE_Initiate, store off the window handle of the window
  that responded. If more than one window responds, terminate all
  conversations but the first. If the current DDE message is a
  wm_DDE_Execute, free the command string memory block, focus our
  window, and clear the list box. }
procedure WelcomeDlg.WMDDEAck(var Msg: TMessage);
begin
  case PendingMessage of
    wm_DDE_Initiate:
      begin
        if ServerWindow = 0 then
          ServerWindow := Msg.WParam
        else
          PostMessage(Msg.WParam, wm_DDE_Terminate, HWindow, 0);
        GlobalDeleteAtom(Msg.LParamLo);
        GlobalDeleteAtom(Msg.LParamHi);
      end;
    wm_DDE_Execute:
      begin
        GlobalFree(Msg.LParamHi);
        PendingMessage := 0;
        SetFocus(HWindow);
      end;
  end;
end;

{-----------------------------WMDDETerminate-------------------------------}

{ wm_DDE_Terminate message response method. If the window signaling
  termination is our server window (the Program Manager), terminate
  the DDE conversation. Otherwise ignore the wm_DDE_Terminate. }
procedure WelcomeDlg.WMDDETerminate(var Msg: TMessage);
begin
  if Msg.WParam = ServerWindow then TerminateDDE;
end;

{-----------------------------WMDestroy------------------------------------}

{ wm_Destroy message response method. Terminate the DDE link and
  call the inherited WMDestroy. }
procedure WelcomeDlg.WMDestroy(var Msg: TMessage);
begin
  TerminateDDE;
  TDialog.WMDestroy(Msg);
end;


{ MyApplication }
procedure MyApplication.InitMainWindow;
begin
   StrCopy (DestPath, szDefDir);
	MainWindow := New(PWelcomeDlg, Init(NIL, MakeIntResource(DLG_WELCOME), DestPath));
end;


procedure ReadInformation;
type
   states= (st_UNDEFINED, st_SKIP, st_TERMINATED, st_FILES, st_DISKS,
            st_APPLICATION);
var
   st: states;
   fcount : integer;
   p, q:PChar;
   x, code : integer;
	szLine : array[0..100] of char;
	i:integer;

   procedure GetLine (s:PChar);
   var
      ch : char;
      i  : integer;
      q  : pChar;
   begin
      read (infile, ch);
      i := 0;
      s[i] := ch;
      repeat
         read (infile,ch);
         Inc(i);
         s[i] := ch;
      until (ch = #10);
      s[i] := #0;

      { strip leading blanks }
      i := 0;
      while (s[i] = ' ') or (s[i] = #9) do
         Inc (i);
      q := @s[i];
      StrCopy (s, q);
   end;

   procedure StripLeading (s:PChar);
   var
     i:integer;
     q:PChar;
   begin
      { strip leading blanks }
      i := 0;
      while (s[i] = ' ') or (s[i] = #9) do
         Inc (i);
      q := @s[i];
      StrCopy (s, q);
   end;


   procedure StripTrailing (s:PChar);
   var
     q:PChar;
   begin
      q := StrEnd (s);
      Dec(q);
      while (q^ = ' ') or (q^ = #9) or (q^ = #13) do
         Dec (q);
      Inc(q);
      q^ := #0;
   end;

   function NextToken (var P: PChar; C:PChar):PChar;
   const
      Next:PChar = NIL;
   var
      There : PChar;
   begin
      if (P <> NIL) then begin
         Next := P;
         There := StrPos (P, C);
         if (There <> NIL) then begin
            There^ := #0;
            P := @There[1];
            end;
         end;
      NextToken := Next;
   end;


begin
   files := 0;
   disks := 0;
   st := st_UNDEFINED;
   while (st <> st_TERMINATED) do begin
      repeat
         GetLine (szLine);
      until (szLine[0] <> ';') and (szLine[0] <> #13);

      if (szLine[0] = '[') then
         st := st_UNDEFINED;

      case st of

         st_UNDEFINED:
            begin
               if (StrPos (szLine, '[End]') <> NIL) then
                  st := st_TERMINATED;
               if (StrPos (szLine, '[Disks]') <> NIL) then
                  st := st_DISKS;
               if (StrPos (szLine, '[Files]') <> NIL) then
                  st := st_FILES;
               if (StrPos (szLine, '[Application]') <> NIL) then
                  st := st_APPLICATION;
            end;

         st_APPLICATION:
            begin
               p := @szLine;
               q := NextToken (p, '=');
               StripTrailing (p);
               if (StrPos (szLine, 'AppName') <> NIL) then
                  StrCopy (szAppName, p);
               if (StrPos (szLine, 'DefDir') <> NIL) then
                  StrCopy (szDefDir, p);
               if (StrPos (szLine, 'DefPMGroup') <> NIL) then
                  StrCopy (szGroupName, p);
               if (StrPos (szLine, 'SpaceNeeded') <> NIL) then
                  Val (p, SpaceNeeded, Code);
            end;

         st_DISKS:
            begin
               Inc (disks);
               p := @szLine;
               q := NextToken (p, '=');
               Val (q, x, code);
               StrCopy (Disk[x], p);
            end;

         st_FILES:
            begin
               Inc (files);
               { file name }
               p := @szLine;
               q := NextToken (p, ',');
					StripTrailing (q);
               StrCopy (F[files].Name, q);

               { disk number }
					q := NextToken (p, ',');
					StripLeading (q);
               Val (q, F[files].Disk, code);

               { add to PM? }
               if (StrPos (p, ',') <> NIL) then begin
                  q := NextToken (p, ',');
                  F[files].InPM := (StrPos (q, 'Y') <> NIL);
                  end
               else F[files].InPM := (StrPos (p, 'Y') <> NIL);

               { PM text }
               q := NextToken (p, ',');
               StripTrailing (q);
               StrCopy (F[files].PMText, q);


               { use an existing Windows icon? }
               q := NextToken (p, ',');
               F[files].WinIcon := (StrPos (q, 'Y') <> NIL);


               { icon file name }
               StripTrailing (p);
               StripLeading (p);
               StrCopy (F[files].PMIcon, p);
            end;

         st_TERMINATED: begin end;
         end;
		end;
end;


constructor MyApplication.Init (AName:PChar);
var
   lpszTemp: PChar;
   DLLName : array[0..fsPathName] of char;
   szTemp: array[0..100] of char;
   i, n : integer;
   InfoName : array[0..fsPathName] of char;


begin
   { Get drive application is found on }
   GetModuleFileName (HInstance, SourcePath, SizeOf(SourcePath));
   lpszTemp  := StrRScan (SourcePath, '\') +1;
   lpszTemp^ := #0;

   { Load the custom control DLL }
   StrCopy (DLLName, SourcePath);
   StrCat (DLLName, 'METER.DLL');
   Lib := LoadLibrary(DLLName);
   if Lib < 32 then
      Status := em_DLLNotFound;



   StrCopy (InfoName, SourcePath);
   StrCat (InfoName, 'SETUP.INF');
   assign (infile, InfoName);
   reset (infile);

   ReadInformation;
   close (infile);


   { This must go here! }
   TApplication.Init (AName);
end;

procedure MyApplication.Error(ErrorCode: Integer);
begin
  case ErrorCode of
    em_DLLNotFound:
      MessageBox(0, 'Setup cannot find the METER.DLL file.', 'Fatal error',
                 mb_Ok or mb_IconStop);
    else TApplication.Error (ErrorCode);
    end;
end;


destructor MyApplication.Done;
begin
   TApplication.Done;
   FreeLibrary (Lib);
   UnLockResource (hDlgRes);
   FreeResource(hDlgRes);
end;


var
  MyApp: MyApplication;


begin
   MyApp.Init('Setup');
   MyApp.Run;
   MyApp.Done;
end.