cpwdial.pas

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

{ Update edit window to reflect cuurent choice of labeling }
procedure AllTreesDlg.IDLabeled (var Msg:TMessage);
begin
   if (SendMessage (GetDlgItem (HWindow,id_Labeled),
      bm_GetCheck, 0,0) <> 0) then begin
      { labeled trees }
      if (SendMessage (GetDlgItem (HWindow,id_Rooted),
         bm_GetCheck, 0,0) <> 0) then
         { rooted }
         Sendmessage (GetDlgItem (HWindow, id_Leaves),
                      um_AdjustRange, 3,7)
      else
         { unrooted }
         Sendmessage (GetDlgItem (HWindow, id_Leaves),
                      um_AdjustRange, 4,8)
      end
   else begin
      { unlabeled trees }
      if (SendMessage (GetDlgItem (HWindow,id_Rooted),
         bm_GetCheck, 0,0) <> 0) then
         { rooted }
         Sendmessage (GetDlgItem (HWindow, id_Leaves),
                      um_AdjustRange, 3,15)
      else
         { unrooted }
         Sendmessage (GetDlgItem (HWindow, id_Leaves),
                      um_AdjustRange, 4,19)
      end;

end;


{**********************}
{                      }
{  RandTreesDlg        }
{                      }
{**********************}

procedure RandTreesDlg.SetUpWindow;
begin
   TDialog.SetUpWindow;
   Rooted := true;
end;


procedure RandTreesDlg.IDLeaves (var Msg:TMessage);
var
   i: integer;
   mini : integer;
begin
   if (Msg.lParamHi = en_Change) then begin
      i := SendMessage (Msg.lParamLo, um_GetValue, 0, 0);
      if Rooted then
         mini := 3
      else mini := 4;
      if ((i < mini) or (i > MAXLEAVES)) then
         SendDlgItemMessage (HWindow, id_OK, wm_Enable, 0, 0)
      else SendDlgItemMessage (HWindow, id_OK, wm_Enable, 1, 0);
      end;
end;

procedure RandTreesDlg.IDntrees (var Msg:TMessage);
var
   i: integer;
begin
   if (Msg.lParamHi = en_Change) then begin
      i := SendMessage (Msg.lParamLo, um_GetValue, 0, 0);
      if ((i < 1) or (i > 10000)) then
         SendDlgItemMessage (HWindow, id_OK, wm_Enable, 0, 0)
      else SendDlgItemMessage (HWindow, id_OK, wm_Enable, 1, 0);
      end;
end;

{ This works around the bug in Borland buttons that sends
  id_OK messages even if button is disabled. }
procedure RandTreesDlg.OK (var Msg:TMessage);
begin
   if (SendMessage (Msg.lParamLo, bm_getState, 0, 0) and $0001 = $0001) then
      MessageBeep(0)
   else TDialog.OK (Msg);
end;


{ Ensure that user hasn't requested more trees than can be stored,
  and that edit fields are ok. }
function RandTreesDlg.CanClose:Boolean;
var
   x1, x2, x3, x4: longint;
   buf:array[0..200] of char;
   Can : Boolean;
begin
   Can := True;

   { First check that all editors are OK... }
   { get contents }
   x1 := SendMessage (GetDlgItem(HWindow,id_NTrees), um_GetValue,0,0);
   x2 := SendMessage (GetDlgItem(HWindow,id_Leaves), um_GetValue,0,0);
   x4 := SendMessage (GetDlgItem(HWindow,id_Seed), um_GetValue,0,0);

   { check }
   if (x1 < 0) or (x1 > 10000) then
      Can := False
   else begin
      if ((Rooted and (x2 < 3)) or (not Rooted and (x2 < 4)))
         then Can := False
      else begin
         { check seed if user wants a seed }
         if (SendMessage (GetDlgItem (HWindow,id_UserSeed),
            bm_GetCheck, 0,0) <> 0) then
            Can := (x4 > 0);

         {$IFDEF NEWBUFFER}
         {$ELSE}
         { now check memory requirements }
         if Can then begin
            x3 := x1 * (x2 + 2);
            if (x3 > T_MAXBYTES) then begin
               wvsprintf(buf,'The memory required to store these trees exceeds the size of the tree buffer (184320 bytes).',
                   x3);
               BWCCMessageBox (HWindow, buf,'Error',mb_IconStop);
               Can := false;
               end;
            end;
         {$ENDIF}
         end;
      end;
   CanClose := Can;
end;

{-----------------------------IDRooted-------------------------------------}

{ Dendrograms are only available if rooted trees
  have been selected, and adjust the minimum no.
  of leaves. }
procedure RandTreesDlg.IDRooted (var Msg:TMessage);
begin
   if (SendMessage (GetDlgItem (HWindow,id_Rooted),
      bm_GetCheck, 0,0) <> 0) then begin
      { rooted }
      Rooted := true;
      EnableWindow (GetDlgItem (HWindow, id_Dendrogram), True);
      SendMessage (GetDlgItem (HWindow, id_Leaves), um_AdjustRange, 3, MAXLEAVES);
      end
   else begin
      Rooted := false;
      { unrooted, dendrograms aren't allowed }
      if (SendMessage (GetDlgItem (HWindow,id_Dendrogram),
         bm_GetCheck, 0,0) <> 0) then begin
         { dendrogram is clicked, so move choice }
         SendMessage (GetDlgItem (HWindow,id_Labeled),
            bm_SetCheck, 1,0);
         SendMessage (GetDlgItem (HWindow,id_Dendrogram),
            bm_SetCheck, 0,0);
         end;
      EnableWindow (GetDlgItem (HWindow, id_Dendrogram), False);
      SendMessage (GetDlgItem (HWindow, id_Leaves), um_AdjustRange, 4, MAXLEAVES);
      end;
end;

{**********************}
{                      }
{  ConsensusDlg        }
{                      }
{**********************}

{ Ensure that user has requested at least one consensus tree. }
function ConsensusDlg.CanClose:Boolean;
var
   Count : integer;
begin
   Count := 0;
   if (SendMessage (GetDlgItem (HWindow,id_Strict),
      bm_GetCheck, 0,0) <> 0) then
      Inc (Count);
   if (SendMessage (GetDlgItem (HWindow,id_Majority),
      bm_GetCheck, 0,0) <> 0) then
      Inc (Count);
   if (SendMessage (GetDlgItem (HWindow,id_SemiStrict),
      bm_GetCheck, 0,0) <> 0) then
      Inc (Count);
   if (SendMessage (GetDlgItem (HWindow,id_Nelson),
      bm_GetCheck, 0,0) <> 0) then
      Inc (Count);
   if (SendMessage (GetDlgItem (HWindow,id_Adams),
      bm_GetCheck, 0,0) <> 0) then
      Inc (Count);

   CanClose := (Count > 0);
end;

{**********************}
{                      }
{  TreeOrderDlg        }
{                      }
{**********************}

constructor TreeOrderDlg.Init (AParent: PWindowsObject;
                               ATitle:PChar;
                               AHelpID:longint;
                               CanLLR:Boolean);
begin
   CPWDialog.Init (AParent, ATitle, AHelpID);
   LLROn := CanLLR;
end;

procedure TreeOrderDlg.SetUpWindow;
begin
   TDialog.SetUpWindow;
   if not LLROn then
      EnableWindow (GetDlgItem (HWindow, id_LLR), False);
end;



{----}

constructor TreesSaveDlg.Init (AParent: PWindowsObject;
                               ATitle, FileName, Comments: PChar);
begin
   TFileDialog.Init (AParent, ATitle, FileName);
   lpszComments := Comments;
end;

function TreesSaveDlg.CanClose:Boolean;
var
   CloseOK: Boolean;
   AMsg : array[0..128] of char;
   MsgDialog : PDialog;
begin
   CloseOK := TFileDialog.CanClose;
   if CloseOK then
      if Exist (FilePath) then begin
         StrCopy (AMsg, 'Overwrite existing ');
         StrCat (AMsg, FilePath);
         StrCat (AMsg, ' ?');
         CloseOK := (BWCCMessageBox (HWindow, AMsg, 'COMPONENT',mb_IconQuestion or mb_YesNoCancel) = id_Yes);
			end
		else begin
			if not ValidPath (FilePath) then begin
				BWCCMessageBox (HWIndow, 'Invalid file or path.', 'COMPONENT',
					mb_IconInformation);
				CloseOK := False;
				end
			else CloseOK := True;
         end;
   CanClose := CloseOK;
end;



{-----------------------------OK-------------------------------------------}

{ Override TDialog.OK to format the edit control's text so
  that any word-wrapped lines are terminated with a
  carriage return/line feed sequence. }
procedure CommentsDialog.OK (var Msg:TMessage);
begin
   SendMessage (GetDlgItem (HWindow, id_CommentsBox), em_FmtLines, 1, 0);
   TDialog.OK (Msg);
end;

{-----------------------------IDComments-----------------------------------}

procedure TreesSaveDlg.IDComments (var Msg:TMessage);
var
   P: PCommentsDialog;
   E: PEdit;
begin
   P := new(PCommentsDialog, Init (@Self, 'ADD_COMMENTS_DIALOG', HELPID_NULL));
   E := new(PEdit, InitResource (P, id_CommentsBox, COMMENTSLEN));
   P^.TransferBuffer := lpszComments;
   Application^.ExecDialog (P);
end;



{**********************}
{                      }
{  HSearchDialog       }
{                      }
{**********************}


constructor HSearchDialog.Init (AParent: PWindowsObject; ATitle: PChar;
                            AHelpID: longint; UserMoreThanOne: Boolean);
begin
   CPWDialog.Init (AParent, ATitle, AHelpID);
   MoreThanOne := UserMoreThanOne;
end;

procedure HSearchDialog.SetUpWindow;
begin
   TDialog.SetUpWindow;
   if not MoreThanOne then begin
      EnableWindow (GetDlgItem (HWindow, id_AllBlocks), False);
      EnableWindow (GetDlgItem (HWindow, id_CurrentBlock), False);
      end;
end;

{**********************}
{                      }
{  TAboutDialog        }
{                      }
{**********************}

{ Display user information }
procedure TAboutDialog.SetUpWindow;
begin
   TDialog.SetUpWindow;
   SetDlgItemText (HWindow, id_UserName, szUserName);
   SetDlgItemText (HWindow, id_UserLoc, szUserLoc);
   SetDlgItemText (HWindow, id_Version, szVersion);
end;



{**********************}
{                      }
{  TUserDialog         }
{                      }
{**********************}

{ Get UserInfo }

{-----------------------------IDUserName-----------------------------------}

procedure TUserDialog.IDUserName (var Msg:TMessage);
begin
   EnableWindow (GetDlgItem (HWindow, id_OK),
      (SendMessage (GetDlgItem (HWindow, id_UserName),
      em_LineLength, 0, 0) <> 0) and
      (SendMessage (GetDlgItem (HWindow, id_UserLoc),
      em_LineLength, 0, 0) <> 0));
end;

{-----------------------------IDUserLoc------------------------------------}

procedure TUserDialog.IDUserLoc (var Msg:TMessage);
begin
   EnableWindow (GetDlgItem (HWindow, id_OK),
      (SendMessage (GetDlgItem (HWindow, id_UserName),
      em_LineLength, 0, 0) <> 0) and
      (SendMessage (GetDlgItem (HWindow, id_UserLoc),
      em_LineLength, 0, 0) <> 0));
end;


{ TFileMode}

{-----------------------------IDUserName-----------------------------------}

procedure TFileModeDialog.IDEditMode (var Msg:TMessage);
begin
	EndDlg (id_EditMode);
end;

{-----------------------------IDUserLoc------------------------------------}

procedure TFileModeDialog.IDTreeMode (var Msg:TMessage);
begin
	EndDlg (id_TreeMode);
end;


{**********************}
{                      }
{  TAboutTreesDialog   }
{                      }
{**********************}

{ Display user information }
procedure TAboutTreesDialog.SetUpWindow;
begin
   TDialog.SetUpWindow;
   { Set ANSI fixed pitch system font. }
   SendMessage (HWindow, wm_SetFont,
               GetStockObject (OEM_FIXED_FONT), 1);
end;


end.