cpwtplot.pas

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

      NewFont := CreateFont (Trunc (LF.FHeight * Pr.pt),
                          0, 0, 0, LF.FWeight,
                          LF.FItalic, 0, 0, ANSI_CHARSET, Out_Default_Precis,
                          Clip_Default_Precis, Default_Quality,
                          Variable_Pitch or ff_Swiss, LF.FName);
      SelectObject (hdcMeta, NewFont);
      NewPen := CreatePen (ps_Solid, Trunc (Pr.Pt * LF.LWidth), RGB(0,0,0));
      SelectObject (hdcmeta, NewPen);

      { Draw picture }
      TP.SetDC (hdcMeta);
      TP.PrintTrees (CurTree, True, LF.ShowNumber);


      if Disk then begin
         { Create metafile on disk }
         {$IFDEF OLDMETA}
      	DeleteMetafile (CloseMetafile (hdcMeta));
         WriteMetafile (DiskFileName, 'TREE.WMF',
            xPage, yPage, Trunc(Pr.pt * 72));}
         {$ELSE}

         ThehMF := CloseMetaFile (hdcMeta);
         if not WriteMetaFile (DiskFileName, ThehMF,
                              xPage, yPage, Trunc (Pr.pt * 72)) then
            BWCCMessageBox (HWindow, 'Unable to create metafile.',
           'Trees Print Preview', mb_OK or mb_IconExclamation);
         {$ENDIF}
         end
      else begin
         { Copy metafile to clipboard }
         ThehMF := ClosemetaFile (hdcmeta);
         hGMem  := GlobalAlloc (gHnd, SizeOf (TMetaFilePict));
         lpMFP  := GlobalLock (hGMem);
         with lpMFP^ do begin
            mm   := mm_Anisotropic;
            xExt := xPage;
            yEXt := yPage;
            hMF  := Thehmf;
            end;
         GlobalUnLock (hGMem);
         OpenClipboard (HWindow);
         EmptyClipboard;
         SetClipBoardData (cf_MetaFilePict, hGMem);
         CloseClipBoard;
         end;

      { clean up }
      DeleteObject (NewPen);
      DeleteObject (NewFont);


      SetCursor (OldCursor);
   end;


{-----------------------------IDPrintPage----------------------------------}

   { Print this page using banding }
   procedure PVWindow.IDPrintPage (var Msg:TMessage);
   const
      szAppName:PChar='COMPONENT - Trees Print';
   var
      OldFont, TmpFont : HFont;
      OldPen, TmpPen   : HPen;
      lpfnPrintDlgProc,
      lpfnAbortProc    : TFarProc;
      Rect             : TRect;
      MyAbortProc      : TAbortProc;
   begin
      TmpFont := CreateFont (Trunc (LF.FHeight * Pr.pt),
                          0, 0, 0, LF.FWeight,
                          LF.FItalic, 0, 0, ANSI_CHARSET, Out_Default_Precis,
                          Clip_Default_Precis, Default_Quality,
                          Variable_Pitch or ff_Swiss, LF.FName);
      OldFont := SelectObject (hdcPrn, TmpFont);

      TP.SetDC (hdcPrn);
      TP.Coordinates (hdcPrn);

      TmpFont := SelectObject (hdcPrn, OldFont);
      DeleteObject (TmpFont);

      { Create pen and font }
      with LF do begin
         TmpPen  := MakePen  (Trunc (Pr.Pt * LWidth));
         TmpFont := MakeFont (Trunc (FHeight * Pr.Pt), FWeight,FItalic,ANSI_Charset,FQuality,FName);
         end;

      bError           := False;
      EnableWindow (HWindow, False);

      { set up abort proc }
      bUserAbort       := False;
      lpfnPrintDlgProc := MakeProcInstance(@PrintDlgProc, HInstance);
      hDlgPrint        := CreateDialog (HInstance, 'TREES_PRINT_DIALOG',
                                        HWindow, lpfnPrintDlgProc);
      lpfnAbortProc    := MakeProcInstance(@AbortProc, HInstance);
      MyAbortProc      := TAbortProc(lpfnAbortProc);
      Escape (hdcPrn, SetAbortProc, 0, lpfnAbortProc, NIL);

      { Print...}
      if (Escape (hdcPrn, StartDoc, Strlen (szAppName),
         szAppname, NIL)) > 0 then begin
         Escape (hdcPrn, NextBand, 0, NIL, @Rect);
         while (not IsRectEmpty (Rect) and not bUserAbort
            and not bError) do begin

{            Rectangle (hdcPrn, Rect.left, Rect.top, Rect.right, Rect.bottom);}

            { Set hdcPrn with current user settings. }
            OldFont := SelectObject (hdcPrn, TmpFont);
            OldPen  := SelectObject (hdcPrn, TmpPen);

            MyAbortProc (hdcPrn, 0);

            TP.PrintTrees (CurTree, False, LF.ShowNumber);

            MyAbortProc (hdcPrn, 0);

            if (Escape (hdcPrn, NextBand, 0, NIL, @Rect) < 0) then
               bError := True;
            end;
         end
      else bError := True;

      { Check for errors }
      if not bError then
         if bUserAbort then
            Escape (hdcPrn, AbortDoc, 0, NIL, NIL)
         else Escape (hdcPrn, EndDoc, 0, NIL, NIL);

      { If user didn't abort then remove dialog box }
      if not bUserAbort then begin
         EnableWindow (HWindow, True);
         DestroyWindow (hDlgPrint);
         end;

      { clean up }
      FreeProcInstance (lpfnPrintDlgProc);
      FreeProcInstance (lpfnAbortproc);
      DeleteObject (TmpFont);
      DeleteObject (TmpPen);

      { Report any errors }
      if bError then
         BWCCMessageBox (HWindow, 'Unable to print trees.',
           'Trees Print Preview', mb_OK or mb_IconExclamation);
   end;


{-----------------------------IDPrintAll-----------------------------------}

   { print all pages }
   procedure PVWindow.IDPrintAll (var Msg:TMessage);
   const
      szAppName:PChar='Preview';
   var
      OldFont, TmpFont : HFont;
      OldPen, TmpPen   : HPen;
      lpfnPrintDlgProc,
      lpfnAbortProc    : TFarProc;
      Pages : integer;
   begin
      { Set hdcPrn with current user settings. }
      TmpFont := MakeFont (Trunc (LF.FHeight * Pr.Pt), LF.FWeight,LF.FItalic,ANSI_Charset,LF.FQuality,LF.FName);
      OldFont := SelectObject (hdcPrn, TmpFont);


      TP.SetDC (hdcPrn);
      TP.Coordinates (hdcprn);

      TmpFont := SelectObject (hdcPrn, OldFont);
      DeleteObject (TmpFont);



      bError := False;
      EnableWindow (HWindow, False);
      { set up abort proc }
      bUserAbort       := False;
      lpfnPrintDlgProc := MakeProcInstance(@PrintDlgProc, HInstance);
      hDlgPrint        := CreateDialog (HInstance, 'TREES_PRINT_DIALOG',
                                        HWindow, lpfnPrintDlgProc);
      lpfnAbortProc    := MakeProcInstance(@AbortProc, HInstance);
      Escape (hdcPrn, SetAbortProc, 0, lpfnAbortProc, NIL);

      TP.SaveCurTree;
      Pages := 0;
      if (Escape (hdcPrn, StartDoc, Strlen (szAppName), szAppname, NIL)) > 0
         then begin

         while (Pages < TP.NumPages)
            and not bError
            and not bUserAbort do begin

           { Set hdcPrn with current user settings. }
           with LF do begin
              TmpPen  := MakePen  (Trunc (Pr.Pt * LWidth));
              TmpFont := MakeFont (Trunc (FHeight * Pr.Pt), FWeight,FItalic,ANSI_Charset,FQuality,FName);
              end;
            OldFont := SelectObject (hdcPrn, TmpFont);
            OldPen  := SelectObject (hdcPrn, TmpPen);



(*            TP.SetDC (hdcPrn);*)
            TP.PrintNextPage (LF.ShowNumber);{ (hdcPrn)};

            { clean up hdcPrn }
            TmpFont := SelectObject (hdcPrn, OldFont);
            TmpPen  := SelectObject (hdcPrn, OldPen);
            DeleteObject (TmpFont);
            DeleteObject (TmpPen);

            if (Escape (hdcPrn, NewFrame, 0, NIL, NIL) < 0) then
               bError := True;
            Inc (Pages);
            end;

         if not bError then
            Escape (hdcPrn, EndDoc, 0, NIL, NIL);
         end; {if}
      TP.RestoreCurTree;

      { If user didn't abort then remove dialog box }
      if not bUserAbort then begin
         EnableWindow (HWindow, True);
         DestroyWindow (hDlgPrint);
         end;

      { clean up }
      FreeProcInstance (lpfnPrintDlgProc);
      FreeProcInstance (lpfnAbortproc);

{      TmpFont := SelectObject (hdcPrn, OldFont);
      TmpPen  := SelectObject (hdcPrn, OldPen);
      DeleteObject (TmpFont);
      DeleteObject (TmpPen);}

     { Report any errors }
     if bError then
        MessageBox (HWindow, 'Unable to print trees.',
           'Trees Print Preview', mb_OK or mb_IconExclamation);
   end;
{-----------------------------IDNextPage-----------------------------------}
   { respond to next page button }
   procedure PVWindow.IDNextPage (var Msg:TMessage);
   begin
      if TP.MorePages (FORWARDS) then begin
         CurTree := TP.NextStartTree (FORWARDS);
         RepaintPage;
         { ensure back button is enabled }
         EnableWindow (GetDlgItem (HWindow, id_LastPage), True);
         { disable button if no more pages }
         if not TP.MorePages (FORWARDS) then begin
            { if this button has the focus, shift the focus }
            if (GetDlgItem (HWindow, id_NextPage) = GetFocus) then
               SetFocus (GetDlgItem(Hwindow, id_LastPage));
            EnableWindow (GetDlgItem (HWindow, id_NextPage), False);
            end;
         end;
   end;

{-----------------------------IDLastPage-----------------------------------}
   { respond to last page button }
   procedure PVWindow.IDLastPage (var Msg:TMessage);
   begin
      if TP.MorePages (BACKWARDS) then begin
         CurTree := TP.NextStartTree (BACKWARDS);
         RepaintPage;
         { ensure next button is enabled }
         EnableWindow (GetDlgItem (HWindow, id_NextPage), True);
         { disable button if no more pages }
         if not TP.MorePages (BACKWARDS) then begin
            { if this button has the focus, shift the focus }
            if (GetDlgItem (HWindow, id_LastPage) = GetFocus) then
               SetFocus (GetDlgItem(Hwindow, id_NextPage));
            EnableWindow (GetDlgItem (HWindow, id_LastPage), False);
            end;
         end;
   end;

{-----------------------------IDLayout-------------------------------------}
   { Display a layout dialog }
   procedure PVWindow.IDLayout (var Msg: TMessage);
   var
      LBuf : LayBuf;
      PL: PLayoutDlg;
      s1,
      s2,
      s3: PStatic;
      c1 : PCheckBox;
      nx,
      ny : integer;
   begin
      with LBuf do begin
         Str (LF.xtrees, szX);
         Str (LF.yTrees, szY);
         Str (LF.xTrees * LF.yTrees, szXY);
         if LF.ShowNumber then
            chk1 := bf_Checked
         else chk1 := bf_UnChecked;   
         end;
      PL := new(PLayoutDlg, Init (@Self, 'LAYOUT_DIALOG'));
      s1 := new(PStatic, InitResource (PL, id_xTrees, 5));
      s2 := new(PStatic, InitResource (PL, id_yTrees, 5));
      s3 := new(PStatic, InitResource (PL, id_TreesPerPage, 5));
      c1 := new(PCheckBox, InitResource (PL, id_ShowTreeNumbers));
      PL^.TransferBuffer := @LBuf;
      if (Application^.ExecDialog (PL) = id_OK) then begin
         nx := atoi (LBuf.szx);
         ny := atoi (LBuf.szy);
         if (nx <> LF.xTrees) or (ny <> LF.yTrees) then begin
            LF.xTrees := nx;
            LF.yTrees := ny;
            TP.Repaginate (LF.xTrees, LF.yTrees);
            CurTree := 1;
            { reset page buttons }
            EnableWindow (GetDlgItem (HWindow, id_LastPage), False);
            if not TP.MorePages (FORWARDS) then
               EnableWindow (GetDlgItem(HWindow,id_NextPage), False)
            else EnableWindow (GetDlgItem(HWindow,id_NextPage), True);
            end;
         { Numbering of trees }
         LF.ShowNumber := ((LBuf.chk1 and bf_Checked) = bf_Checked);
         RepaintPage;
         end;
   end;


{-----------------------------IDStyle--------------------------------------}
   { Display a style dialog }
   procedure PVWindow.IDStyle (var Msg:TMessage);
   type
      StyleBuffer=record
         r1, r2, r3, r4,r5: word;
         end;
   var
      PS: PDialog;
      p1, p2, p3, p4, p5 : PRadioButton;
      SBuf: StyleBuffer;
      Changed : Boolean;
   begin
      PS := new(PDialog, Init (@Self, 'TREE_STYLE_DIALOG'));
      p1 := new(PRadioButton, InitResource (PS, id_Angle));
      p2 := new(PRadioButton, InitResource (PS, id_Slant));
      p3 := new(PRadioButton, InitResource (PS, id_1pt));
      p4 := new(PRadioButton, InitResource (PS, id_3pt));
      p5 := new(PRadioButton, InitResource (PS, id_5pt));
      with SBuf do begin
         case LF.TStyle of
            tp_Rectangle:
               begin
                  r1 := bf_Checked; r2 := bf_UnChecked;
               end;
            tp_Slant:
                begin
                  r1 := bf_UnChecked; r2 := bf_Checked;
               end;
            end;
         r3 := bf_UnChecked;
         r4 := bf_UnChecked;
         r5 := bf_UnChecked;
         case LF.LWidth of
            line_thin   : r3 := bf_Checked;
            line_medium : r4 := bf_Checked;
            line_thick  : r5 := bf_Checked;
            end;
         end;
      PS^.TransferBuffer := @SBuf;
      if Application^.ExecDialog (PS) = id_OK then begin
         Changed := False;
         if (SBuf.r1 = bf_Checked) then begin
            Changed   := Changed or (LF.TStyle <> tp_Rectangle);
            LF.TStyle := tp_Rectangle;
            end
         else begin
            Changed   := Changed or (LF.TStyle <> tp_Slant);
            LF.TStyle := tp_Slant;
            end;
         if (SBuf.r3 = bf_Checked) then begin
            Changed := Changed or (LF.LWidth <> line_thin);
            LF.LWidth := line_thin;
            end
         else begin
            if (SBuf.r4 = bf_Checked) then begin
               Changed := Changed or (LF.LWidth <> line_medium);
               LF.LWidth := line_medium;
               end
            else begin
               Changed := Changed or (LF.LWidth <> line_thick);
               LF.LWidth := line_thick;
               end;
            end;
         if Changed then begin
            ScreenPen  := MakePen  (Trunc(PtsToScreenPixels(LF.LWidth)));
            TP.SetStyle (LF.TStyle);
            RepaintPage;
            end;
         end;
   end;



   procedure PVWindow.IDFonts (var Msg:TMessage);
   type
      FontsBuffer = record
         Fonts: PStrCollection;
         AFont: array[0..lf_FaceSize-1] of char;
         Sizes: PStrCollection;
         ASize: array[0..SizeDigits-1] of char;
         Italics,
         Bold : word;
         end;
   var
      FBuf    : FontsBuffer;
      PF      : PDialog;
      Changed : Boolean;
      FSize   : integer;
      FontCombo,
      SizeCombo : PComboBox;
      Chk1,
      Chk2      : PCheckBox;
   begin
      with FBuf do begin
         Fonts := pFonts;
         StrCopy (AFont, LF.FName);
         Sizes := pSizes;
         Str (LF.FHeight:2, ASize);
         if (LF.FItalic <> 0) then
            Italics := bf_Checked
         else Italics := bf_UnChecked;
         if (LF.FWeight <> fw_Normal) then
            Bold := bf_Checked
         else Bold := bf_UnChecked;
         end;


      PF := new(PDialog, Init(@Self, 'FONT_DIALOG'));
      FontCombo :=new(PComboBox, InitResource (PF, id_Font, lf_FaceSize));
      SizeCombo :=new(PComboBox, InitResource (PF, id_Size, SizeDigits));
      Chk1 := new(PCheckbox, InitResource (PF, id_Italics));
      Chk2 := new(PCheckbox, InitResource (PF, id_Bold));

      PF^.TransferBuffer := @FBuf;
      if (Application^.ExecDialog (PF) = id_OK) then begin
         Changed := False;
         if (StrComp (LF.FName, FBuf.AFont) <> 0) then
            StrCopy (LF.FName, FBuf.AFont);
         FSize := atoi (FBuf.ASize);
         if (LF.FHeight <> FSize) then begin
            Changed := True;
            LF.FHeight := FSize;
            end;
         if (FBuf.Italics = bf_Checked) then begin
            Changed := Changed or (LF.FItalic = 0);
            LF.FItalic := 1;
            end
         else begin
            Changed := Changed or (LF.FItalic = 1);
            LF.FItalic := 0;
            end;
         if (FBuf.Bold = bf_Checked) then begin
            Changed := Changed or (LF.FWeight = fw_Normal);
            LF.FWeight := fw_Bold;
            end
         else begin
            Changed := Changed or (LF.FWeight = fw_Bold);
            LF.FWeight := fw_Normal;
            end;
         if Changed then begin
            with LF do
               ScreenFont := MakeFont (PtsToScreenPixels(LF.FHeight), FWeight,
                                       FItalic,OEM_Charset,FQuality,'Modern');
            RepaintPage;
            end;
         end;
   end;

begin
end.