cpwtplot.pas

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

      else CellGapX := 0;

      { Size of cell in pixels. Allow for left and
        right paper margins, and let total space between
        tree cells to sum to one Margin width.  }
      xCell := (xPage - (CellGapX * Pred(xTrees)))
               div xTrees;
      yCell := (yPage - (CellGapY * Pred(yTrees)))
               div yTrees;


      yOffset := INDENT;
      xOffset := INDENT;

      with PlotInfo do begin
         Ox     := 0; { dummy values }
         Oy     := 0;
         wx     := xCell;
         hy     := yCell;
         xLeaf  := wx - MaxlabelSpace (DC);
         yLeaf  := hy / Pred (P^.CurBlock^.Leaves);
         xLabel := LoWord(GetTextExtent(DC, 'X',1));
         end;

      GetTextMetrics (DC, tm);
      with tm do
         PlotInfo.yLabel :=
          (tmAscent - tmInternalLeading) div 2 + tmInternalLeading;
   end;

{-----------------------------PrintTrees-----------------------------------}

   { Print a page of trees starting from StartTree.
     UpDate CurTree. }
   procedure TreePlotter.PrintTrees (StartTree:integer; IsMetaFile,
             ShowNumber: Boolean);
   var
      i, j, k,m, x, y, TreeCount:integer;
      T:TREEOBJ;
      Buf:array[0..10] of char;
      Number:longint;
      tm: TTextMetric;

      {$IFDEF LETTERS}
      NewFont, OldFont : HFont;
      {$ENDIF}

   begin

      i := 0;
      j := Pred(StartTree);
      while (i < TreesPerPage) and (j < P^.CurBlock^.TotalTrees) do begin
         { cell's posn on page for jth tree }
(*         x := i mod xTrees;
         y := i div xTrees; *)

         { compute cell origin w.r.t to page coordinates }
         { 9 Jul 1992 }
         {
             xOffset
             |
            InchMarginX
            >|      <
  yOffset----+---------------------------------
             |Origin of page
             |
             |     +------------------+----+-----
             |     | cell 0           |    |  cell 1
             |     |                  |    |
             |     |                  |    |
             |     |                  |    |
             |     |<----wx---------->|    |
             |                        |    |
                                     >|    |<
                                     CellGapX

         }
         with PlotInfo do begin
            OX := xOffSet + InchMarginX + ((i mod xTrees) * (wx + CellGapX));
            OY := yOffset + InchMarginY + ((i div xTrees) * (hy + CellGapY));
            end;

         if ShowNumber then begin
            { display tree number }


            {$IFDEF LETTERS}
            { fix for letters }
            buf[0] := '(';
            buf[1] := chr (97 + j);
            buf[2] := ')';
            buf[3] := #0;
            NewFont := CreateFont (Trunc (12 * Res),
                          0, 0, 0, fw_Normal,
                          0, 0, 0, ANSI_CHARSET, Out_Default_Precis,
                          Clip_Default_Precis, Default_Quality,
                          Variable_Pitch or ff_Swiss, 'Univers');
            Oldfont := SelectObject (hdcPlot, NewFont);
            {$ELSE}
            Number := Succ(j);
            wvsprintf (buf, '%d',Number);
            {$ENDIF}

            if (Style = tp_Slant) then
               with PlotInfo do
                  TextOut (hdcPlot, OX, OY, buf, Strlen(buf))
            else begin
               if IsMetaFile then
                  y := 2 * PlotInfo.hFont
               else begin
                  GetTextMetrics (hdcPlot, tm);
                  y := 2 * tm.tmHeight;
                  end;
               with PlotInfo do
                  TextOut (hdcPlot, OX, OY - y, buf, Strlen(buf));
               end;
            end;


         {$IFDEF LETTERS}
         NewFont := SelectObject (hdcPlot, OldFont);
         DeleteObject (NewFont);
         {$ENDIF}

         { print tree }
         with P^.CurBlock^ do begin
            GetTree (Succ(j), T, True);
            T.TreePlot (hdcPlot, PlotInfo, L, Style);
            T.Done;
            end;
         Inc (i);
         Inc (j);
         end;
      CurTree := StartTree;
   end;

   procedure TreePlotter.PrintNextPage (ShowNumber: Boolean);{ (DC: HDC)}
   begin
      PrintTrees (CurTree, False, ShowNumber);
      Curtree := NextStartTree (FORWARDS);
   end;

   procedure TreePlotter.SaveCurTree;
   begin
      OldCurTree := CurTree;
      CurTree    := 1;
   end;

   procedure TreePlotter.RestoreCurTree;
   begin
      CurTree := OldCurTree;
   end;

   function TreePlotter.NumPages:integer;
   begin
      NumPages := Pages;
   end;


{-----------------------------MorePages------------------------------------}

   { True if the are still pages to come }
   function TreePlotter.MorePages (d:DIRECTION):Boolean;
   begin
      case d of
         BACKWARDS: MorePages := (CurTree > 1);
         FORWARDS:  MorePages := ((CurTree + TreesPerPage)
                                 <= P^.CurBlock^.TotalTrees);
         end;
   end;

{-----------------------------NextStartTree--------------------------------}

   { The next tree in the top left corner }
   function TreePlotter.NextStartTree (d:DIRECTION):integer;
   begin
      case d of
         BACKWARDS: CurTree := CurTree - TreesPerPage;
         FORWARDS:  CurTree := CurTree + TreesPerPage;
         end;
      NextStartTree := CurTree;
   end;

{**********************}
{                      }
{  New preview window  }
{                      }
{**********************}


   constructor PVWindow.Init (AParent:PWindowsObject; ATitle:PChar;
                  AHelpID:longint; PPtr: PPROFILE);
   var
     mmMargin : integer;
   begin
      CPWDialog.Init (AParent, ATitle, AHelpID);

      { profile }
      P := PPtr;
      CurTree := 1;

      { compute page display coordinates in screen pixels,
        based on printer information }
      hdcPrn := DefPrinterDC;

      { Set up printer data }
      pFonts := new(PStrCollection, Init(MaxNumFonts, 5));
      GetPrinterFonts (hdcPrn, pFonts);
      pSizes := new(PStrCollection, Init (10,1));
      GetPrinterFontSizes(hdcPrn, pSizes);




      GetPrinterInfo (hdcprn,PR);

      {$IFDEF LETTERS}
      Res := Pr.Pt;
      {$ENDIF}

      Portrait := (Pr.Orientation = dmorient_Portrait); {12/3/93}
      InchMargin := Trunc(Pr.Pt * 72.0);      { 1" margin in printer pixels }
      mmMargin   := 25;                       { same in mm }
      with Pr do begin
         { size of page image in pixels on screen }
         if Orientation = dmorient_Portrait then begin
            x := trunc (MaxPageDim * (wPaper / hPaper));
            y := MaxPageDim;
            end
         else begin
            y :=

trunc (MaxPageDim * (hPaper / wPaper));
            x := MaxPageDim;
            end;
         { Margins in pixels }
         ox := Trunc ((mmMargin / wPaper) * x);
         oy := Trunc ((mmMargin / hPaper) * y);
         end;
   end;

   destructor PVWindow.Done;
   begin
      CPWDialog.Done;
      DeleteDC (hdcPrn);
      DeleteObject (ScreenFont);
      DeleteObject (ScreenPen);
      Dispose (pFonts, Done);
      Dispose (pSizes, Done);
   end;


   procedure PVWindow.SetUpWindow;
   begin
      CPWDialog.SetUpWindow;

      with LF do begin
         StrCopy (LF.FName,pFonts^.At(0));
         FHeight := atoi (pSizes^.At (0));
         FItalic := 0;
         FWeight := fw_Normal;
         LWidth := line_thin;
         TStyle := tp_Rectangle;
         xTrees := 1;
         yTrees := 1;
         FQuality := Proof_Quality;
         ShowNumber := true;
         end;

      { Create current drawing tools for the screen }
      with LF do begin
         ScreenPen  := MakePen  (Trunc(PtsToScreenPixels(LF.LWidth)));
         ScreenFont := MakeFont (PtsToScreenPixels(LF.FHeight), FWeight, FItalic,
                                 OEM_Charset,FQuality,'Modern');
         end;

      { Initialise tree plotter }
      TP.Init (P, INDENT + ox, INDENT + oy,LF.xTrees, LF.yTrees, LF.TStyle);

      { Set buttons correctly }
      EnableWindow (GetDlgItem (HWindow, id_LastPage), False);
      if not TP.MorePages (FORWARDS) then
         EnableWindow (GetDlgItem(HWindow,id_NextPage), False);
   end;

   { Force window to repaint page by invalidating that
     area of the window. }
   procedure PVWindow.RepaintPage;
   var
      r: TRect;
   begin
      GetClientRect (HWindow, r);
      r.left   := INDENT;
      r.top    := INDENT;
      r.right  := INDENT + x;
      r.bottom := INDENT + y;
      InvalidateRect (HWindow,@r, true);
   end;

   function PVWindow.PtsToScreenPixels (Item:integer):integer;
   begin
      PtsToScreenPixels := Trunc(y/Pr.yPixels * Pr.Pt * Item);
   end;

   procedure PVWindow.PaintPage;
   begin
      MessageBox (HWindow, 'PaintPage','PV',mb_IconInformation);
   end;

   procedure PVWindow.WMPaint (var Msg:TMessage);
   var
      OldPen: HPen;
      OldFont:HFont;
      TmpPen: HPen;
      OldBrush, NewBrush: HBrush;
      PaintInfo : TPaintStruct;
      x1,y1:integer;
      r1, r2: TRect;

      WaitCursor,
      OldCursor: HCursor;

   begin
      WaitCursor := LoadCursor (0, idc_Wait);
      OldCursor  := SetCursor (WaitCursor);

      PaintDC := BeginPaint (HWindow, PaintInfo);

      { Fill in part of screen in gray to highlight the page }
      GetClientRect (HWindow, r1);
      NewBrush := CreateSolidBrush (GetSysColor (color_AppWorkSpace));
      FillRect (PaintDC, r1, NewBrush);
      DeleteObject (NewBrush);

      SetBkMode (PaintDC, Transparent);
      SetTextColor (PaintDC, RGB(000,000,000));


      { Draw page }
      TmpPen := CreatePen (ps_solid, 1, RGB(0,0,0));
      OldPen := SelectObject (PaintDC, TmpPen);
      Rectangle (PaintDC, INDENT, INDENT, x + INDENT, y + INDENT);
      TmpPen := SelectObject (PaintDC, OldPen);
      DeleteObject (TmpPen);


      {$IFDEF PRINT_AREA}
      { For debugging, display the printable area on the page}
      TmpPen := CreatePen (ps_dot, 1, RGB(0,0,0));
      OldPen := SelectObject (PaintDC, TmpPen);
      Rectangle (PaintDC, Indent + ox, Indent + oy, Indent + x-ox, Indent + y-oy);
      TmpPen := SelectObject (PaintDC, OldPen);
      DeleteObject (TmpPen);
      {$ENDIF}


      { Draw shadow under page }
      TmpPen := CreatePen (ps_solid, ShadowH, RGB(0,0,0));
      OldPen := SelectObject (PaintDC, TmpPen);
      MoveTo (PaintDC, INDENT + ShadowInd, y + INDENT + ShadowOff);
      LineTo (PaintDC, x + INDENT + ShadowOff, y + INDENT + ShadowOff);
      MoveTo (PaintDC, INDENT + x + ShadowOff, INDENT + ShadowInd);
      LineTo (PaintDC, INDENT + x + ShadowOff, INDENT + y);
      TmpPen := SelectObject (PaintDC, OldPen);
      DeleteObject (TmpPen);

      { Select font for labels }
      OldFont := SelectObject (PaintDC, ScreenFont);
      OldPen  := SelectObject (PaintDC, ScreenPen);

      { Draw trees }
      TP.SetDC  (PaintDC);

      { Trees are drawn in the printable area of the page, which
        is

         <--> INDENT

       (0,0) Origin of client rect.
         *----------------------------------
         |
         |   <-----------x--------->
         |   +---------------------+
         |   |                     |  oy
         |   |      +-------+      |
         |   |<-ox->|       |<-ox->|
      }

      TP.ScreenCoordinates (PaintDC,x-ox-ox,y-oy-oy);
      TP.PrintTrees (CurTree, False, LF.ShowNumber);

      { Clean up }
      ScreenFont := SelectObject(PaintDC,OldFont);
      ScreenPen  := SelectObject (PaintDC,OldPen);
      EndPaint (HWindow, PaintInfo);
      ReleaseDC (HWindow, PaintDC);

      { Reset TP dc to printer }
      TP.SetDC (hdcPrn);

      SetCursor (OldCursor);
   end;

   procedure PVWindow.IDClose (var Msg: TMessage);
   begin
      EndDlg (id_Cancel);
   end;



   procedure PVWindow.IDCopy (var Msg: TMessage);
      { Copy tree picture to Clipboard }
   begin
      TreeMetaFile (False, NIL);
   end;


   procedure PVWindow.IDWMFFile (var Msg: TMessage);
      { Save tree picture to disk file }
   var
      FileName : array[0..fsPathName] of char;
   begin
      StrCopy(FileName, '*.WMF');
      if Application^.ExecDialog(New(PSaveFileDialog,
         Init(@Self, 'WMF_FILE_SAVE_DIALOG', FileName))) = id_Ok then
         TreeMetaFile (True, FileName);
   end;


   procedure PVWindow.TreeMetaFile (Disk : Boolean; DiskFileName : PChar);
   var
      hdcMeta : HDC;
      ThehMF : THandle;
      hGMem  : TGlobalHandle;
      lpMFP  : PMetaFilePict;
      xPage,
      yPage  : integer;
      NewPen : HPen;
      OldFont, NewFont : HFont;
      OldCursor : HCursor;
      temp : integer;
   begin
      OldCursor := SetCursor (LoadCursor (0, idc_Wait));

      if Disk then
         {$IFDEF OLDMETA}
         hdcMeta := CreateMetafile ('TREE.WMF')
         {$ELSE}
         hdcMeta := CreateMetaFile (nil)
         {$ENDIF}
      else hdcMeta := CreateMetafile (NIL);

      { use paper as a guide to coordinates }
      xPage := GetDeviceCaps (hdcPrn, HorzRes);
      yPage := GetDeviceCaps (hdcPrn, VertRes);
{      if not Portrait then begin
         temp := xPage;
         xPage := yPage;
         yPage := temp;
         end;}

      { set extent }
      SetWindowExt (hdcMeta, xPage, yPage);
      SetWindowOrg (hdcMeta, 0, 0);

      { compute coordinates based on printing to paper }
      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);
      OldFont := SelectObject (hdcPrn, NewFont);

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

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


      { ensure }
      TP.PlotInfo.hFont := Trunc (Pr.PT * LF.FHeight);

      { Create pen and font }