cpwdial.pas

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

      procedure IDUserLoc (var Msg:TMessage);
         virtual id_First + id_UserLoc;
		end;

	PFileModeDialog = ^TFileModeDialog;
   TFileModeDialog = object(TDialog)
      procedure IDEditMode (var Msg:TMessage);
         virtual id_First + id_EditMode;
      procedure IDTreeMode (var Msg:TMessage);
         virtual id_First + id_TreeMode;
      end;


implementation

const
   PRUNE_LIMIT   = 3;
   INGROUP_LIMIT = 2;


{-----------------------------MyListBox------------------------------------}

{ Override TListBox.Transfer. This is necessary as TListBox does not
  transfer the list box contents. }
function MyListBox.Transfer(DataPtr:Pointer; TransferFlag:word):word;
var
   Data         : PMyTransferData;
   DataStrings  : PStrCollection;
   DataSelected : integer;
   i,
   j            : integer;
   st           : array[0..MAXLENGTH] of char;
begin
   case TransferFlag of
      tf_SetData : Transfer := TListBox.Transfer(DataPtr, TransferFlag);
      tf_SizeData: Transfer := TListBox.Transfer(DataPtr, TransferFlag);
      tf_GetData :
         { Override TListBox method by returning the current
           list box contents in DataPtr. This overwrites
           the user supplied data. }
         begin
            Data        := PMyTransferData(DataPtr);   { typecast DataPtr }
            DataStrings := PStrCollection(Data^.D1);   { get first field }

            DataStrings^.FreeAll;  		       { clear user data }

            i := GetCount;                             { fill user data with }
            j := 0;                                    { list box contents }
            while (j < i) do begin
               GetString (st, j);
               DataStrings^.Insert (StrNew(st));
               Inc (j);
               end;

            { now call TListBox method }
            Transfer := TListBox.Transfer (DataPtr, TransferFlag);
         end;
      end;
end;



{**********************}
{                      }
{  TwoBoxDialog object }
{                      }
{**********************}

{-----------------------------TwoBoxDialog---------------------------------}


procedure TwoBoxDialog.SetLimit;
begin
   Limit := PRUNE_LIMIT;
end;

procedure TwoBoxDialog.SetUpWindow;
var
   Count: integer;
begin
   TDialog.SetUpWindow;
   SetLimit;
   { Only enable right box if it has any leaves }
   Count := SendDlgItemMsg(id_DeletedLB, lb_GetCount, 0, Longint(0));
   if (Count > 0) then
      EnableRight (True);

   Count := SendDlgItemMsg(id_NonDeletedLB, lb_GetCount, 0, Longint(0));
   if (Count <= Limit) then
      EnableLeft (False);
end;


procedure TwoBoxDialog.EnableLeft (Flag:Bool)   ;
begin
   EnableWindow(GetDlgItem(HWindow, id_NonDeletedLB), Flag);
   EnableWindow(GetDlgItem(HWindow, id_NonDeleted),Flag);
   EnableWindow(GetDlgItem(HWindow, id_Delete), Flag);
end;

procedure TwoBoxDialog.EnableRight (Flag:Bool);
begin
   EnableWindow(GetDlgItem(HWindow, id_DeletedLB), Flag);
   EnableWindow(GetDlgItem(HWindow, id_Deleted),Flag);
   EnableWindow(GetDlgItem(HWindow, id_Restore), Flag);
end;

procedure TwoBoxDialog.Delete (Idx:word);
var
   Count:integer;
   SelectedText: array[0..MAXLENGTH] of Char;
begin
   { Get selected text }
   SendDlgItemMsg(id_NonDeletedLB, lb_GetText, Idx, LongInt(@SelectedText));
   { Send text to right list box }
   SendDlgItemMsg(id_DeletedLB, lb_AddString, 0, LongInt(@SelectedText));
   { Delete text from left list box }
   SendDlgItemMsg(id_NonDeletedLB, lb_DeleteString, Idx, LongInt(@SelectedText));

   { Disabled delete button & box if not enough leaves left }
   Count := SendDlgItemMsg(id_NonDeletedLB, lb_GetCount, 0, Longint(0));
   if (Count <= Limit) then
      EnableLeft (False);

   { If its the first left deleted, enable the right box }
   Count := SendDlgItemMsg(id_DeletedLB, lb_GetCount, 0, Longint(0));
   if (Count = 1) then
      EnableRight (True);
end;

{ Move text left to right }
procedure TwoBoxDialog.DeleteButton (var Msg:TMessage);
var
  Idx : Integer;
begin
   { Get index of selected text }
   Idx := SendDlgItemMsg(id_NonDeletedLB, lb_GetCurSel, 0, LongInt(0));

   { if Idx < 0 then no item is selected }
   if (Idx >= 0) then
      Delete (Idx);
end;


{ Move a label from left to right box if user double clicks on label }
procedure TwoBoxDialog.LeftListBox(var Msg: TMessage);
var
  Idx: integer;
begin
  if Msg.LParamHi = lbn_DblClk then begin
    { Get index of selected text }
    Idx := SendDlgItemMsg(id_NonDeletedLB, lb_GetCurSel, 0, LongInt(0));
    Delete (Idx);
    end;
end;

procedure TwoBoxDialog.Restore (Idx:word);
var
   Count: integer;
   SelectedText: array[0..MAXLENGTH] of Char;
begin
    { Get selected text }
    SendDlgItemMsg(id_DeletedLB, lb_GetText, Idx, LongInt(@SelectedText));
    { Send text to left list box }
    SendDlgItemMsg(id_NonDeletedLB, lb_AddString, 0, LongInt(@SelectedText));
    { Delete text from right list box }
    SendDlgItemMsg(id_DeletedLB, lb_DeleteString, Idx, LongInt(@SelectedText));

   { Disabled restore button & box if not enough leaves left }
   Count := SendDlgItemMsg(id_DeletedLB, lb_GetCount, 0, Longint(0));
   if (Count = 0) then
      EnableRight (False);

   { If there are now enough leaves then enable left box }
   Count := SendDlgItemMsg(id_NonDeletedLB, lb_GetCount, 0, Longint(0));
   if (Count = Succ (Limit)) then
      EnableLeft (True);
end;

procedure TwoBoxDialog.RestoreButton (var Msg:TMessage);
var
  Idx : Integer;
  SelectedText: array[0..MAXLENGTH] of Char;
begin
    { Get index of selected text }
    Idx := SendDlgItemMsg(id_DeletedLB, lb_GetCurSel, 0, LongInt(0));

    { if Idx < 0 then no item is selected }
    if (Idx >= 0) then
       Restore (Idx);
end;

{ Move a label from right to left box if user double clicks }
procedure TwoBoxDialog.RightListBox(var Msg: TMessage);
var
  Idx : Integer;
  SelectedText: array[0..MAXLENGTH] of Char;
begin
  if Msg.LParamHi = lbn_DblClk then begin
    { Get index of selected text }
    Idx := SendDlgItemMsg(id_DeletedLB, lb_GetCurSel, 0, LongInt(0));
    Restore (Idx);
    end;
end;

{-----------------------------TwoBoxDialogOutGrp---------------------------}

procedure TwoBoxDialogOutGrp.SetLimit;
begin
   Limit := INGROUP_LIMIT;
end;


procedure ProfileDialog.HandleMsg (var Msg:TMessage);
begin
   if (Msg.lParamHi = lbn_SelChange) or (Msg.lParamHi = lbn_DblClk) then
      EnableWindow(GetDlgItem(HWindow, id_OK), True);

end;

{**********************}
{                      }
{  SelectTreesDialog   }
{                      }
{**********************}

procedure SelectTreesDialog.SetUpWindow;
begin
   CPWDialog.SetUpWindow;
   if (SendMessage (GetDlgItem (HWindow,id_ShowAll), bm_GetCheck, 0,0) <> 0)
      then
      SendMessage (GetDlgItem (HWindow, id_ShowFromTo), bm_SetCheck, 0, 0);
end;


{ user has clicked on From input box }
procedure SelectTreesDialog.IDFrom (var Msg:TMessage);
begin
   { Check the id_ShowFromTo button }
   SendMessage (GetDlgItem (HWindow, id_ShowFromTo), bm_SetCheck, 1, 0);
   SendMessage (GetDlgItem (HWindow, id_ShowAll), bm_SetCheck, 0, 0);
end;

{ user has clicked on To input box }
procedure SelectTreesDialog.IDTo (var Msg:TMessage);
begin
   { Check the id_ShowFromTo button }
   SendMessage (GetDlgItem (HWindow, id_ShowFromTo), bm_SetCheck, 1, 0);
   SendMessage (GetDlgItem (HWindow, id_ShowAll), bm_SetCheck, 0, 0);
end;


{**********************}
{                      }
{  T2TDialog           }
{                      }
{**********************}

constructor T2TDialog.Init (AParent: PWindowsObject; ATitle: PChar;
                            AHelpID: longint;
                            F:word);
begin
   TOptionsDialog.Init (AParent, ATitle, AHelpID);
   Buttons := F;
end;

procedure T2TDialog.SetUpWindow;
begin
   TOptionsDialog.SetUpWindow;
   if (Buttons and Q_Q) = Q_Q then
      EnableWindow (GetDlgItem (HWindow, id_Quartets), False);
   if ((Buttons and flg_NNI) <> $0) then
      EnableWindow (GetDlgItem (HWindow, id_NNI), False);
   if (Buttons and flg_SubTree) = flg_Subtree then
      EnableWindow (GetDlgItem (HWindow, id_GSubTree), False);
end;

{**********************}
{                      }
{  CTWDialog           }
{                      }
{**********************}


constructor CTWDialog.Init (AParent: PWindowsObject; ATitle: PChar;
                            AHelpID: longint; F:word);
begin
   CPWDialog.Init (AParent, ATitle, AHelpID);
   Buttons := F;
end;

procedure CTWDialog.SetUpWindow;
begin
   TDialog.SetUpWindow;
   if (Buttons and tc_NNI) = tc_NNI then
      EnableWindow (GetDlgItem (HWindow, id_NNI), False);
   if (Buttons and tc_Subtree) = tc_SubTree then
      EnableWindow (GetDlgItem (HWindow, id_GSubTree), False);
end;



{**********************}
{                      }
{  AllTreesDlg         }
{                      }
{**********************}

{-----------------------------SetUpWindow----------------------------------}

{ Connect the edit window with its spin button }
procedure AllTreesDlg.SetUpWindow;
begin
   Rooted := True;
   TDialog.SetUpWindow;
   SendMessage (GetDlgItem(HWindow, id_Leaves), um_SetSpin,
                GetDlgItem (HWindow, id_Spin), 0);
end;

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

{ Update edit window ranges to reflect current choice of tree type. }
procedure AllTreesDlg.IDRooted (var Msg:TMessage);
begin
   if (SendMessage (GetDlgItem (HWindow,id_Rooted),
      bm_GetCheck, 0,0) <> 0) then begin
      { rooted trees }
      Rooted := true;
      if (SendMessage (GetDlgItem (HWindow,id_Labeled),
         bm_GetCheck, 0,0) <> 0) then
         { labeled }
         Sendmessage (GetDlgItem (HWindow, id_Leaves),
                      um_AdjustRange, 3,7)
      else
         { unlabeled }
         Sendmessage (GetDlgItem (HWindow, id_Leaves),
                      um_AdjustRange, 3,15)
      end
   else begin
      { urooted trees }
      Rooted := False;
      if (SendMessage (GetDlgItem (HWindow,id_Labeled),
         bm_GetCheck, 0,0) <> 0) then
         { labeled }
         Sendmessage (GetDlgItem (HWindow, id_Leaves),
                      um_AdjustRange, 4,8)
      else
         { unlabeled }
         Sendmessage (GetDlgItem (HWindow, id_Leaves),
                      um_AdjustRange, 4,19)
      end;

end;

procedure AllTreesDlg.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;

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



{-----------------------------IDLabeled------------------------------------}