meter.pas

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

{**********************************************}
{                                              }
{    METER.PAS                                 }
{                                              }
{    Custom meter control DLL based on         }
{    Jeffrey M. Richter's Meter.C source       }
{    code in "Windows 3: A developer's guide," }
{    M&T Books, 1991                           }
{                                              }
{**********************************************}

{* Written 9 Oct 1991

   How to use:

   With Whitewater Resource Toolkit:
   --------------------------------

   1.  Select Custom Control

   2.  Place control in dialog box

   3.  Double click on control to get Item Attributes dialog box

   4.  Click on style button to get Custom Control Attrributes
       dialog box. Check "Visible" and "Border" check boxes, and
       make Class "Meter"

   In application:
   ==============

   Source code:
   -----------

   Include:
   ($I Meter.Inc)

   Declare:

   const
     DLLName = 'meter.DLL';
     em_DLLNotFound = 1;

   Init:

      Lib := LoadLibrary(DLLName);
      if Lib < 32 then Status := em_DLLNotFound;
      TApplication.Init(AName);


   Done:
      TApplication.Done;
      FreeLibrary(Lib);

   Error:

   begin
      case ErrorCode of
         em_DLLNotFound:
         MessageBox(0, DLLName + ' not found. Please compile METER.PAS ' +
         'before executing this application.', 'Fatal error',
         mb_Ok or mb_IconStop);
      else
         TApplication.Error(ErrorCode);
   end;


   Use:
   ---


   1. To tell meter how many parts (say 10) in job:

      SendDlgItemMessage (hDlg, id_Meter, mm_SetPartsInJob, 10, 0);

   2. To tell meter that some more work has been done:

      SendDlgItemMessage (hDlg, id_Meter, mm_SetPartsComplete, 3, 0);


    2 Dec 1991: Modified to work with Resource Workshop

*}

library Meter;

uses
   WinTypes,
   WinProcs,
   Strings,
   CustCntl,  { custom controls }
   MeterCo;   { meter constants }

{$R METERDLG.RES} { meter style dialog resource }

const
   ofSize            = 4;  { Amount of window extra bytes to use }
   GWW_PARTSINJOB    = 0;
   GWW_PARTSCOMPLETE = 2;

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


function MeterWinFn(HWindow: HWnd; Message: Word; wParam: Word;
  lParam: Longint): Longint; export;
var
  rcClient,
  rcPrcnt        : TRect;
  PS             : TPaintStruct;
  OldBrush, Brush          : HBrush;
  OldValue,
  wPartsInJob,
  wPartsComplete : word;
  ArgList        : longint;
  szPercentage   : array[0..10] of char;
  dwColor        : longint;
  x : real;

begin
  MeterWinFn := 0;
  case Message of
    wm_GetDlgCode:
       MeterWinFn := dlgc_Static;
    wm_Create:
      begin
         SendMessage (HWindow, mm_SetPartsInJob, 1, 0);
         SendMessage (HWindow, mm_SetPartsComplete, 0, 0);
      end;
    wm_Paint:
      begin
        wPartsInJob    := SendMessage (HWindow, mm_GetPartsInJob, 0, 0);
        wPartsComplete := SendMessage (HWindow, mm_GetPartsComplete, 0, 0);
        if (wPartsInJob = 0) then begin
           wPartsInJob    := 1;
           wPartsComplete := 0;
           end;

        x := wPartsComplete / wPartsInJob;
        ArgList := Trunc (100 * x);
        wvsprintf (szPercentage, '%d%%', ArgList);
        BeginPaint(HWindow, PS);


        { Set up default foreground and background text colors }
        SetBkColor (PS.hDC, GetSysColor (color_BtnFace));
{        SetTextColor (PS.hDC, GetSysColor (color_WindowText));}

        { 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_Meter));}
        Brush := CreateSolidBrush (RGB(0,0,255));
        SetTextColor (PS.hDC, RGB(0,0,255));

        { Always use brush returned by parent }
        OldBrush := SelectObject (PS.hDC, Brush);

        SetTextAlign (PS.hDC, ta_Center or ta_Top);

        { Invert foreground and background colors }
        dwColor := GetBkColor (PS.hDC);
        SetBkColor (PS.hDC, SetTextColor (PS.hDC, dwColor));

        { Set rectangle to include only left
          percentage of window }
        GetClientRect (HWindow, rcClient);
        SetRect (rcPrcnt, 0, 0, (rcClient.right * wPartsComplete) div
                 wPartsInJob, rcClient.bottom);

        { Output the percentage value in the window. Function
          also paints left part of window. }
        ExtTextOut (PS.hDC, rcClient.right div 2,
                    (rcClient.bottom -
                    HiWord (GetTextExtent(PS.hDC, 'X',1))) div 2,
                    eto_Opaque or eto_Clipped, @rcPrcnt,
                    szPercentage, StrLen (szPercentage), NIL);

        { Adjust rectangle so it include remaining percentage of
          window. }
        rcPrcnt.left := rcPrcnt.right;
        rcPrcnt.right := rcClient.right;

        { Invert foreground and background colors }
        dwColor := GetBkColor (PS.hDC);
        SetBkColor (PS.hDC, SetTextColor (PS.hDC, dwColor));

        { Output the percentage a second time in the window.
          Function also paints right part of window. }
        ExtTextOut (PS.hDC, rcClient.right div 2,
                    (rcClient.bottom -
                    HiWord (GetTextExtent(PS.hDC, 'X',1))) div 2,
                    eto_Opaque or eto_Clipped, @rcPrcnt,
                    szPercentage, StrLen (szPercentage), NIL);

        Brush := SelectObject (PS.hDC, OldBrush);
        DeleteObject (Brush);
        EndPaint(HWindow, PS);
      end;
   mm_SetPartsInJob:
      begin
         SetWindowWord(HWindow, GWW_PartsInJob, wParam);
         InvalidateRect (HWindow, NIL, False);
         UpDateWindow (HWindow);
      end;
   mm_GetPartsInJob:
      MeterWinFn := GetWindowWord (HWindow, GWW_PartsInJob);
   mm_SetPartsComplete:
      begin
(*         { original code }
         SetWindowWord(HWindow, GWW_PartsComplete, wParam);
         InvalidateRect (HWindow, NIL, False);
         UpDateWindow (HWindow);
*)

         wPartsComplete := GetWindowWord (HWIndow, GWW_PartsComplete);
         wPartsInJob    := GetWindowWord (HWindow, GWW_PartsInJob);
         if (wPartsInJob = 100) then begin
            { must be a new value }
            SetWindowWord(HWindow, GWW_PartsComplete, wParam);
            InvalidateRect (HWindow, NIL, False);
            UpDateWindow (HWindow);
            end
         else begin
            OldValue := Trunc (100 * (wPartsComplete / wPartsInJob));
            if (Trunc (100 * (wParam / wPartsInJob)) <> OldValue)
               or (wParam = 0) { to ensure window is painted when created }
               then begin
               SetWindowWord(HWindow, GWW_PartsComplete, wParam);
               InvalidateRect (HWindow, NIL, False);
               UpDateWindow (HWindow);
               end;
            end;

      end;
   mm_GetPartsComplete:
      MeterWinFn := GetWindowWord (HWindow, GWW_PartsComplete);
  else
    MeterWinFn := DefWindowProc(HWindow, Message, wParam, lParam);
  end;
end;


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

{ MeterInfo ---------------------------------------------------
   Return the information about the capabilities of the
   meter class.
  -------------------------------------------------------------- }
function MeterInfo: 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 := $100;         { Version 1.00 }
      wCtlTypes := 1;           { 1 type }
      StrCopy(szClass, 'Meter');
      StrCopy(szTitle, 'Meter');

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

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

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

{ MeterStyleDlg -----------------------------------------------
    Style dialog's dialog hook.  Used by the dialog and called
    when the control is double-clicked inside the dialog
    editor.
  -------------------------------------------------------------- }
function MeterStyleDlg(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
	MeterStyleDlg := 0;
      end;
    wm_Destroy:
      RemoveProp(HWindow, Prop);
  else
    MeterStyleDlg := 0;
  end;
end;

{ MeterStyle --------------------------------------------------
    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 MeterStyle(hWindow: HWnd; CtlStyle: THandle;
  StrToId: TStrToId; IdToStr: TIdToStr): Bool; export;
var
  hRec: THandle;
  Rec: PParamRec;
  hFocus: HWnd;
begin
  MeterStyle := 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;
    MeterStyle := Bool(DialogBoxParam(HInstance,
      MakeIntResource(idMeterDlg), HWindow, @MeterStyleDlg,
      hRec));
    if hFocus <> 0 then SetFocus(hFocus);
    GlobalFree(hRec);
  end;
end;

{ MeterFlags --------------------------------------------------
    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 MeterFlags(Style: LongInt; Buff: PChar;
  BuffLength: Word): Word; export;
begin
   Buff[0]    := #0;   { Meter has no addition style bits }
   MeterFlags := 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  := MeterInfo;
	fnStyle := MeterStyle;
	fnFlags := MeterFlags;
      end;
    end;
    GlobalUnlock(hClasses);
  end;
  ListClasses := hClasses;
end;

exports
  ListClasses,
  MeterWinFn;

var
  Class: TWndClass;

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