cpwdlg.pas

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

{*********************************************}
{                                             }
{    COMPONENT for MS DOS and MS WINDOWS      }
{                                             }
{    Source code for Turbo Pascal 6.0 and     }
{    Turbo Pasacal for Windows 1.0 compilers. }
{                                             }
{    (c) 1991, Roderic D. M. Page             }
{                                             }
{*********************************************}

{*

   A basic dialog box with a help button. By deriving
   most (eventually all) dialogs from this object a
   simple help system can be implemented.

   30 Jul 1992 Supports TPW 1.5 
*}

{$I CPDIR.INC}

unit cpwdlg;

interface

uses
   WinTypes,
   WinProcs,
   Strings,
   {$IFDEF BWCC}
   BWCC,
   {$IFDEF VER10}
   WObjectB,
   StdDlgsB,
   {$ELSE}
   WObjects,
   StdDlgs,
   {$ENDIF} {VER10}
   {$ELSE}
   WObjects,
   StdDlgs,
   {$ENDIF} {BWCC}
   cpwvars,    { has global variable szHelpFileName and help id consts }
   cpfile;

const
   MsgID=101;

   id_Replace = 11;
   id_Append  = 10;
type
   PCPWDialog = ^CPWDialog;
   CPWDialog = object(TDialog)
      HelpContextID : longint;
      constructor Init(Aparent:PWindowsObject; ATitle: PChar; AHelpID:longint);
      {$ifdef BWCC}
      procedure DialogHelp(var Msg: TMessage); virtual id_First + IdHelp;
      {$else}
      function DialogHelp(var Msg: TMessage); virtual id_First + Id_Help;
      {$endif}
      end;

   PMessageDialog = ^MessageDialog;
   MessageDialog = object(CPWDialog)
      constructor Init(Aparent:PWindowsObject; ATitle: PChar; AHelpID:longint;
                     AMsg:PChar);
      procedure SetUpWindow;virtual;
      procedure Yes(var Msg:TMessage);virtual id_First + id_Yes;
      procedure No (var Msg:TMessage);virtual id_First + id_No;
      procedure IDReplace (var Msg:TMessage);
         virtual id_First + id_Replace;
      procedure IDAppend (var Msg:TMessage);
         virtual id_First + id_Append;
      private
      TheMsg : PChar;
      end;


   {---File dialogs---}

   { A file dialog that ensures the file being
     opened exists. }
   POpenFileDialog = ^TOpenFileDialog;
   TOpenFileDialog = object(TFileDialog)
      function CanClose:Boolean;virtual;
		end;

	PImportDialog = ^TImportFileDialog;
   TImportFileDialog = object (TOpenFileDialog)
      HelpContextID : longint;
      constructor Init(Aparent:PWindowsObject; ATitle: PChar;
             FileName:PChar;AHelpID:longint);
      {$ifdef BWCC}
      procedure DialogHelp(var Msg: TMessage); virtual id_First + IdHelp;
      {$else}
      function DialogHelp(var Msg: TMessage); virtual id_First + Id_Help;
      {$endif}
      procedure SetupWindow;virtual;
      end;


   { A file dialog that checks the file that will
     be saved doesn't already exist. }
   PSaveFileDialog = ^TSaveFileDialog;
   TSaveFileDialog = object(TFileDialog)
      function CanClose:Boolean;virtual;
      end;

   PExportDialog = ^TExportFileDialog;
   TExportFileDialog = object (TSaveFileDialog)
      HelpContextID : longint;
      constructor Init(Aparent:PWindowsObject; ATitle: PChar;
             FileName:PChar;AHelpID:longint);
      {$ifdef BWCC}
      procedure DialogHelp(var Msg: TMessage); virtual id_First + IdHelp;
      {$else}
      function DialogHelp(var Msg: TMessage); virtual id_First + Id_Help;
      {$endif}
      procedure SetupWindow;virtual;
      end;


implementation

{-----------------------------Init-----------------------------------------}

constructor CPWDialog.Init (AParent:PWindowsObject; ATitle:PChar; AHelpID:longint);
begin
   TDialog.Init (AParent, ATitle);
   HelpContextID := AHelpID;
end;

{-----------------------------DialogHelp-----------------------------------}

{ Call WinHelp for this dialog. }
procedure CPWDialog.DialogHelp(var Msg: TMessage);
var
   Buf: array[0..80] of char;
   HelpOK :Bool;
begin
   if (HelpContextID <> HELPID_NULL) then begin
      HelpOK := WinHelp (HWindow, szHelpFileName, help_Context, HelpContextID);
      if not HelpOK then begin
         wvsprintf (buf, 'Call to WinHelp failed. HelpContextID = %d', HelpContextID);
         BWCCMessageBox(HWindow,buf,'Help',mb_OK or mb_IconInformation);
         end;
      end
   else
      BWCCMessageBox(HWindow,'No help available (HelpContextID = HELP_NULL)','Help',mb_OK or mb_IconInformation);
end;


constructor MessageDialog.Init (AParent:PWindowsObject; ATitle:PChar; AHelpID:longint; AMsg:Pchar);
begin
   CPWDialog.Init (AParent, ATitle, AHelpID);
   TheMsg := AMsg;
end;

procedure MessageDialog.SetUpWindow;
begin
   TDialog.SetUpWindow;
   SetWindowText (GetDlgItem (HWindow, MsgID), TheMsg);
end;


{ Respond to yes button. }
procedure MessageDialog.Yes (var Msg:TMessage);
begin
   CanClose;
   EndDlg (id_Yes);
end;

{ Respond to no button. }
procedure MessageDialog.No (var Msg:TMessage);
begin
   CanClose;
   EndDlg (id_No);
end;

{ Respond to no button. }
procedure MessageDialog.IDReplace (var Msg:TMessage);
begin
   CanClose;
   EndDlg (id_Replace);
end;

{ Respond to no button. }
procedure MessageDialog.IDAppend (var Msg:TMessage);
begin
   CanClose;
   EndDlg (id_Append);
end;


function TOpenFileDialog.CanClose:Boolean;
var
   ReOpenBuff: TOFStruct;
   Buf       : array[0..128] of char;
begin
   StrUpper (FilePath);
   if TFileDialog.CanClose then begin
      if (OpenFile (FilePath, ReOpenBuff,of_Read or of_Exist) = -1)
         then begin
         wvsprintf (buf, 'File %s not found.', FilePath);
         {$IFDEF BWCC}
         BWCCMessageBox (HWindow, buf, szAppName, mb_IconInformation);
         {$ELSE}
         MessageBox (HWindow, buf, szAppName, mb_IconInformation);
         {$ENDIF}
         CanClose := False;
         end
      else CanClose := True
      end
   else Canclose := False;
end;

function TSaveFileDialog.CanClose:Boolean;
var
   ReOpenBuff: TOFStruct;
   Buf       : array[0..128] of char;
   Result    : integer;
begin
   StrUpper (FilePath);
   if TFileDialog.CanClose then begin
      if Exist (FilePath) then begin
         StrCopy (Buf, 'Overwrite existing ');
         StrCat (Buf, FilePath);
         StrCat (Buf, ' ?');
         CanClose := (MessageBox (HWindow, Buf, 'COMPONENT',mb_IconQuestion or mb_YesNoCancel) = id_Yes);
			end
		else begin
			if not ValidPath (FilePath) then begin
				MessageBox (HWIndow, 'Invalid file or path.', 'COMPONENT',
					mb_IconInformation);
				CanClose := False;
				end
			else CanClose := True;
         end;
      end
   else Canclose := False;
end;


{-----------------------------Init-----------------------------------------}

constructor TExportFileDialog.Init (AParent:PWindowsObject; ATitle:PChar;
                                   FileName:PChar;AHelpID:longint);
begin
   TSaveFileDialog.Init (AParent, ATitle, FileName);
   HelpContextID := AHelpID;
end;


{-----------------------------DialogHelp-----------------------------------}

{ Call WinHelp for this dialog. }
procedure TExportFileDialog.DialogHelp (var Msg: TMessage);
var
   Buf    : array[0..80] of char;
   HelpOK :Bool;
begin
   if (HelpContextID <> HELPID_NULL) then begin
      HelpOK := WinHelp (HWindow, szHelpFileName, help_Context, HelpContextID);
      if not HelpOK then begin
         wvsprintf (buf, 'Call to WinHelp failed. HelpContextID = %d', HelpContextID);
         BWCCMessageBox(HWindow,buf,'Help',mb_OK or mb_IconInformation);
         end;
      end
   else
      BWCCMessageBox(HWindow,'No help available (HelpContextID = HELP_NULL)','Help',mb_OK or mb_IconInformation);
end;


procedure TExportFileDialog.SetUpWindow;
begin
   { First call TDialog.SetUpWindow to set up the transfer buffer. }
   TDialog.SetUpWindow;
   TFileDialog.SetUpWindow;
end;


{-----------------------------Init-----------------------------------------}

constructor TImportFileDialog.Init (AParent:PWindowsObject; ATitle:PChar;
                                   FileName:PChar;AHelpID:longint);
begin
   TOpenFileDialog.Init (AParent, ATitle, FileName);
   HelpContextID := AHelpID;
end;


{-----------------------------DialogHelp-----------------------------------}

{ Call WinHelp for this dialog. }
procedure TImportFileDialog.DialogHelp (var Msg: TMessage);
var
   Buf    : array[0..80] of char;
   HelpOK :Bool;
begin
   if (HelpContextID <> HELPID_NULL) then begin
      HelpOK := WinHelp (HWindow, szHelpFileName, help_Context, HelpContextID);
      if not HelpOK then begin
         wvsprintf (buf, 'Call to WinHelp failed. HelpContextID = %d', HelpContextID);
         BWCCMessageBox(HWindow,buf,'Help',mb_OK or mb_IconInformation);
         end;
      end
   else
      BWCCMessageBox(HWindow,'No help available (HelpContextID = HELP_NULL)','Help',mb_OK or mb_IconInformation);
end;


procedure TImportFileDialog.SetUpWindow;
begin
   { First call TDialog.SetUpWindow to set up the transfer buffer. }
   TDialog.SetUpWindow;
   TFileDialog.SetUpWindow;
end;






end.