rod.pas

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

library Grid2;

{$R GRID2.RES}

uses
   WinTypes,
   WinProcs,
   Strings,
   CustCntl,  { custom controls }
   GridCo;

const
   ofSize            = 8;  { Amount of window extra bytes to use }
   GWW_TOTALX        = 0;
   GWW_TOTALY        = 2;
   GWW_X             = 4;
   GWW_Y             = 6;

   { Meter control sends wm_CtlColor message to parent window
     with the following identifier in HIWORD of the lParam. }
   CtlColor_Grid    = 100;



function GridWinFn2(HWindow: HWnd; Message: Word; wParam: Word;
  lParam: Longint): Longint; export;
var
  DC: HDC;
  NewPen, OldPen: HPen;
  rcClient: TRect;
  PS: TPaintStruct;
  Brush : HBrush;

  wGridX,          { cur x }
  wGridY,          { cur y }
  wGridXX,         { max x }
  wGridYY : word;  { max y }
  Oldr2,
  pixels_cols,
  pixels_rows,
  i, j,
  x,y,
  newx, newy,
  oldx, oldy: integer;


begin
  GridWinFn2 := 0;
  case Message of
    wm_GetDlgCode:
       GridWinFn2 := dlgc_Static;
    wm_Create:
      begin
         SendMessage (HWindow, mm_SetGridSize, 10, 10);
         SendMessage (HWindow, mm_SetGrid, 1, 1);
      end;
    wm_Paint:
      begin
         BeginPaint (HWindow, PS);
         GetClientRect (HWindow, rcClient);

        { Send wm_CtlColor message to parent in case parent wants to
          use a different color in meter control }
         Brush := SendMessage (GetParent (HWindow), wm_CtlColor, PS.hDC,
                              MakeLong (HWindow, CtlColor_Grid));

         { Always use brush returned by parent to
           paint the background. }
         FillRect (PS.hDC, PS.rcPaint, Brush);

         { Get cooridintes of grid and selected cell. }
         wGridX  := GetWindowWord (HWindow, GWW_X);
         wGridY  := GetWindowWord (HWindow, GWW_Y);
         wGridXX := GetWindowWord (HWindow, GWW_TOTALX);
         wGridYY := GetWindowWord (HWindow, GWW_TOTALY);

         { pixels per row and column }
         pixels_cols := rcClient.right  div pred(wGridXX);
         pixels_rows := rcClient.bottom div pred(wGridYY);

         { Draw selected cells }
         x := pixels_cols * wGridX;
         y := pixels_rows * wGridY;


         { Paint selected area }
         Brush := GetStockObject (LtGray_Brush);
         rcClient.right  := x;
         rcClient.bottom := y;
         FillRect (PS.hDC, rcClient, Brush);

         NewPen := CreatePen (ps_solid, 1, RGB(0,0,0));
         Oldpen := SelectObject (PS.hDC, NewPen);

         { Draw grid }
         for i := 1 to Pred (wGridXX) do begin
            MoveTo (PS.hDC, i * pixels_cols, 0);
            LineTo (PS.hDC, i * pixels_cols, PS.rcPaint.bottom);
            end;
         for i := 1 to Pred (wGridYY) do begin
            MoveTo (PS.hDC, 0, i * pixels_rows);
            LineTo (PS.hDC, PS.rcPaint.right, i * pixels_rows);
            end;


         NewPen := SelectObject (PS.hDC, OldPen);
         DeleteObject (NewPen);
         EndPaint(HWindow, PS);
      end;

   wm_LButtonDown:
      begin
         { Compute coordinates }
         GetClientRect (HWindow, rcClient);
         wGridX  := GetWindowWord (HWindow, GWW_X);
         wGridY  := GetWindowWord (HWindow, GWW_Y);
         wGridXX     := GetWindowWord (HWindow, GWW_TOTALX);
         wGridYY     := GetWindowWord (HWindow, GWW_TOTALY);
         pixels_cols := rcClient.right  div pred(wGridXX);
         pixels_rows := rcClient.bottom div pred(wGridYY);

         { Old extent of x and y }
         oldx := pixels_cols * wGridX;
         oldy := pixels_rows * wGridY;


         { New x and y }
         x := LoWord (lParam) div pixels_cols + 1; { x cell }
         y := HiWord (lParam) div pixels_rows + 1; { y cell }
         SetWindowWord(HWindow, GWW_X, x);
         SetWindowWord(HWindow, GWW_Y, y);

         { extent of new x and y cells. }

         newx := x * pixels_cols;
         newy := y * pixels_rows;

         if (newx < Oldx) then
            rcClient.right := oldx
         else rcClient.right := newx;
         if (newy < Oldy) then
            rcClient.bottom := oldy
         else rcClient.bottom := newy;

         InvalidateRect (HWIndow, @rcClient, True);
         UpdateWindow (HWindow);
         SendMessage (GetParent(HWindow), mm_NewGrid, x, y);
      end;
   mm_SetGridSize:
      { Set size of grid }
      begin
         SetWindowWord(HWindow, GWW_TOTALX, wParam);
         SetWindowWord(HWindow, GWW_TOTALY, lParam);
         InvalidateRect (HWindow, NIL, False);
         UpDateWindow (HWindow);
      end;
   mm_SetGrid:
      begin
         SetWindowWord(HWindow, GWW_X, wParam);
         SetWindowWord(HWindow, GWW_Y, lParam);
         InvalidateRect (HWindow, NIL, True);
         UpDateWindow (HWindow);
      end;
   mm_GetGridX:
      GridWinFn2 := GetWindowWord (HWindow, GWW_X);
   mm_GetGridY:
      GridWinFn2 := GetWindowWord (HWindow, GWW_Y);
  else
    GridWinFn2 := DefWindowProc(HWindow, Message, wParam, lParam);
  end;
end;


{ ==============================================================
  Custom contol interface routines.
  ============================================================== }

{ GridInfo ---------------------------------------------------
   Return the information about the capabilities of the
   meter class.
  -------------------------------------------------------------- }
function Grid2Info: THandle; export;
var
  hInfo: THandle;
  Info: PRWCtlInfo;
begin
  hInfo := GlobalAlloc(gmem_Share or gmem_ZeroInit,
    SizeOf(TRWCtlInfo));
  if hInfo <> 0 then
  begin
    Info := GlobalLock(hInfo);
    with Info^ do
    begin
      wVersion := $101;         { Version 1.00 }
      wCtlTypes := 1;           { 1 type }
      StrCopy(szClass, 'Grid2');
      StrCopy(szTitle, 'Grid2');

      with ctType[0] do
      begin
	wWidth  := 40 and not $8000;  { dialog units, so turn MSB off }
	wHeight := 40 and not $8000;
	StrCopy(szDescr, 'Grid2');
	dwStyle := ws_Border or ws_Child;
	hToolBit := LoadBitmap(HInstance, MakeIntResource(btGridBits));
	hDropCurs := LoadCursor(HInstance, MakeIntResource(crGridCurs));
      end;

    end;
    GlobalUnlock(hInfo);
  end;
  Grid2Info := hInfo;
end;

type
  PParamRec = ^TParamRec;
  TParamRec = record
    CtlStyle: THandle;
    IdToStr: TIdToStr;
    StrToId: TStrToId;
  end;

{ GridStyleDlg -----------------------------------------------
    Style dialog's dialog hook.  Used by the dialog and called
    when the control is double-clicked inside the dialog
    editor.
  -------------------------------------------------------------- }
function Grid2StyleDlg(HWindow: HWnd; Message: Word; wParam: Word;
  lParam: Longint): Longint; export;
const
  Prop = 'Prop';
var
  hRec: THandle;
  Rec: PParamRec;
  Style: PCtlStyle;
  S: array[0..256] of Char;
  Radio: Integer;
begin
  case Message of
    wm_InitDialog:
      begin
	hRec := LoWord(lParam);
	Rec := GlobalLock(hRec);
	Style := GlobalLock(Rec^.CtlStyle);
	SetProp(HWindow, Prop, hRec);
	with Rec^, Style^ do
	begin
	  { Set control id }
	  IdToStr(wId, S, SizeOf(S));
	  SetDlgItemText(HWindow, idControlId, S);
        end;
	GlobalUnlock(Rec^.CtlStyle);
	GlobalUnlock(hRec);
      end;
    wm_Command:
      case wParam of
	idCancel:
	  EndDialog(HWindow, 0);
	idOk:
	  begin
	    hRec := GetProp(HWindow, Prop);
	    Rec := GlobalLock(hRec);
	    Style := GlobalLock(Rec^.CtlStyle);
	    with Rec^, Style^ do
	    begin
	      { Get control id }
	      GetDlgItemText(HWindow, idControlId, S, SizeOf(S));
	      wId := StrToId(S);
	    end;
	    GlobalUnlock(Rec^.CtlStyle);
	    GlobalUnlock(hRec);
	    EndDialog(HWindow, 1);
          end;
        idControlID:
          if HiWord (lParam) = en_Change then begin
             GetDlgItemText (HWindow, idControlId, S, SizeOf(S));
             if (StrLen(S) > 0) then
                EnableWindow (GetDlgItem(HWindow, idOK), True)
             else  EnableWindow (GetDlgItem(HWindow, idOK), False);
             end;
      else
	Grid2StyleDlg := 0;
      end;
    wm_Destroy:
      RemoveProp(HWindow, Prop);
  else
    Grid2StyleDlg := 0;
  end;
end;

{ GridStyle --------------------------------------------------
    The function will bring up a dialog box to modify the style
    of the button.  Called when the button is double-clicked in
    the dialog editor.
  -------------------------------------------------------------- }
function Grid2Style(hWindow: HWnd; CtlStyle: THandle;
  StrToId: TStrToId; IdToStr: TIdToStr): Bool; export;
var
  hRec: THandle;
  Rec: PParamRec;
  hFocus: HWnd;
begin
  Grid2Style := False;
  hRec := GlobalAlloc(gmem_Share, SizeOf(TParamRec));
  if hRec <> 0 then
  begin
    Rec := GlobalLock(hRec);
    Rec^.IdToStr := IdToStr;
    Rec^.StrToId := StrToId;
    Rec^.CtlStyle := CtlStyle;
    GlobalUnlock(hRec);

    hFocus := GetFocus;
    Grid2Style := Bool(DialogBoxParam(HInstance,
      MakeIntResource(idGridDlg), HWindow, @Grid2StyleDlg,
      hRec));
    if hFocus <> 0 then SetFocus(hFocus);
    GlobalFree(hRec);
  end;
end;

{ GridFlags --------------------------------------------------
    Called to decompose the style double word into the .RC
    script expression that it represents.  This only needs to
    decompose the style bits added to the style double word,
    it need not decompose the, for example, the ws_XXX bits.
    The expression returned must be a valid .RC expression
    (i.e. C syntax, case sensitive).
  -------------------------------------------------------------- }
function Grid2Flags(Style: LongInt; Buff: PChar;
  BuffLength: Word): Word; export;
begin
   Buff[0]    := #0;   { Meter has no addition style bits }
   Grid2Flags := 0;
end;

{ ListClasses --------------------------------------------------
    Called by Resource Workshop retrieve the information
    necessary to edit the custom controls contain in this DLL.
    This is an alternative to the Microsoft xxxStyle convention.
  -------------------------------------------------------------- }
function ListClasses(szAppName: PChar; wVersion: Word;
  fnLoad: TLoad; fnEdit: TEdit): THandle; export;
var
  hClasses: THandle;
  Classes: PCtlClassList;
begin
  hClasses := GlobalAlloc(gmem_Share or gmem_ZeroInit,
    SizeOf(Integer) + SizeOf(TRWCtlClass));
  if hClasses <> 0 then
  begin
    Classes := GlobalLock(hClasses);
    with Classes^ do
    begin
      nClasses := 1;
      with Classes[0] do
      begin
	fnInfo  := Grid2Info;
	fnStyle := Grid2Style;
	fnFlags := Grid2Flags;
      end;
    end;
    GlobalUnlock(hClasses);
  end;
  ListClasses := hClasses;
end;

exports
  ListClasses,
  GridWinFn2;

var
  Class: TWndClass;

begin
  with Class do
  begin
    lpszClassName := 'Grid2';
    hCursor       := LoadCursor(0, idc_Arrow);
    lpszMenuName  := nil;
    style         := cs_HRedraw or cs_VRedraw or cs_GlobalClass;
    lpfnWndProc   := TFarProc(@GridWinFn2);
    hInstance     := System.hInstance;
    hIcon         := 0;
    cbWndExtra    := ofSize;
    cbClsExtra    := 0;
    hbrBackground := 0;
  end;
  RegisterClass(Class);
end.