home *** CD-ROM | disk | FTP | other *** search
/ Media Share 13 / mediashare_13.zip / mediashare_13 / ZIPPED / PROGRAM / WTJ9403.ZIP / FOLEY / DLLMETER.PAS < prev    next >
Pascal/Delphi Source File  |  1993-04-07  |  12KB  |  431 lines
  1. {$S-,R-,V-,I-,B-,F-,W-,A-,G+,X+,N+}
  2. {$C MOVEABLE,DEMANDLOAD,DISCARDABLE}
  3.  
  4. {*********************************************************}
  5. {*                  DLLMETER.PAS 1.00                    *}
  6. {*           Copyright (c) Brian Foley 1993.             *}
  7. {*                 All rights reserved.                  *}
  8. {*********************************************************}
  9.  
  10. library DllMeter;
  11.   {-Sample meter control written with DLLWIN}
  12.  
  13. uses
  14.   Strings, WinTypes, WinProcs, CustCntl, DllWin;
  15.  
  16. {$R DLLMETER.RES}
  17.  
  18. const
  19.   MeterClassName   = 'dllMeterControl';
  20.  
  21.   {special messages for meter controls}
  22.   mm_SetMeterValue = wm_User+0;
  23.   mm_SetLeftColor  = wm_User+1;
  24.   mm_SetRightColor = wm_User+2;
  25. type
  26.   TMeterControl = object(TDllWin)
  27.     MeterValue : Word;     {meter value to display}
  28.     rgbLeft    : LongInt;  {color for left side}
  29.     rgbRight   : LongInt;  {color for right side}
  30.     Font       : THandle;  {font to draw with}
  31.  
  32.     constructor Init(HW : hWnd; PCS : PCreateStruct);
  33.     procedure Paint(PaintDC : HDC; var PaintInfo : TPaintStruct); virtual;
  34.     procedure wmEraseBkGnd(var Msg : TMessage);
  35.       virtual wm_First+wm_EraseBkGnd;
  36.     procedure wmSetFont(var Msg : TMessage);
  37.       virtual wm_First+wm_SetFont;
  38.     procedure wmGetDlgCode(var Msg : TMessage);
  39.       virtual wm_First+wm_GetDlgCode;
  40.     procedure mmSetMeterValue(var Msg : TMessage);
  41.       virtual wm_First+mm_SetMeterValue;
  42.     procedure mmSetLeftColor(var Msg : TMessage);
  43.       virtual wm_First+mm_SetLeftColor;
  44.     procedure mmSetRightColor(var Msg : TMessage);
  45.       virtual wm_First+mm_SetRightColor;
  46.     procedure Redraw(Now : Boolean);
  47.   end;
  48.  
  49. {Miscellaneous routines}
  50.  
  51.   function HiWord(L : LongInt) : Word;
  52.     inline(
  53.       $58/   {pop ax ;ignore low word}
  54.       $58);  {pop ax ;pop high word into AX}
  55.  
  56.   function LoWord(L : LongInt) : Word;
  57.     inline(
  58.       $58/   {pop ax ;pop low word into AX}
  59.       $5A);  {pop dx ;ignore high word}
  60.  
  61.   function IsWorkshopWindow(HW : HWnd): Boolean;
  62.   var
  63.     Parent : HWnd;
  64.     ClassName : array[0..80] of Char;
  65.   begin
  66.     Parent := HW;
  67.     repeat
  68.       HW := Parent;
  69.       Parent := GetParent(HW);
  70.     until Parent = 0;
  71.     GetClassName(HW, ClassName, SizeOf(ClassName));
  72.     IsWorkshopWindow := StrIComp(ClassName, 'rwswnd') = 0;
  73.   end;
  74.  
  75. {TMeterControl}
  76.  
  77.   constructor TMeterControl.Init(HW : hWnd; PCS : PCreateStruct);
  78.   begin
  79.     TDllWin.Init(HW, PCS);
  80.     if IsWorkshopWindow(HW) then
  81.       MeterValue := 50
  82.     else
  83.       MeterValue := 0;
  84.     rgbLeft := GetSysColor(color_Highlight);
  85.     rgbRight := GetSysColor(color_HighlightText);
  86.     Font := 0;
  87.   end;
  88.  
  89.   procedure TMeterControl.Paint(PaintDC : HDC; var PaintInfo : TPaintStruct);
  90.   var
  91.     CR : TRect;
  92.     MemDC : hDC;
  93.     hCBM : hBitmap;
  94.     DivLine, X, Y, SLen : Integer;
  95.     S : array[0..4] of Char;
  96.  
  97.     procedure FillSide(Left, Right : Integer; TColor, BColor : LongInt);
  98.     var
  99.       ClipR : TRect;
  100.     begin
  101.       if Left <> Right then begin
  102.         {set the clipping rectangle}
  103.         ClipR := CR;
  104.         ClipR.Left := Left;
  105.         ClipR.Right := Right;
  106.  
  107.         {set the colors}
  108.         SetTextColor(MemDC, TColor);
  109.         SetBkColor(MemDC, BColor);
  110.         ExtTextOut(MemDC, X, Y, eto_Clipped+eto_Opaque, @ClipR, S, SLen, nil);
  111.       end;
  112.     end;
  113.  
  114.   begin
  115.     GetClientRect(hWindow, CR);
  116.  
  117.     {create a compatible display context and bitmap}
  118.     MemDC := CreateCompatibleDC(PaintDC);
  119.     hCBM := CreateCompatibleBitmap(PaintDC, CR.Right, CR.Bottom);
  120.     SelectObject(MemDC, hCBM);
  121.  
  122.     {select our font into it}
  123.     if Font <> 0 then
  124.       SelectObject(MemDC, Font);
  125.  
  126.     {convert the meter value to a string}
  127.     wvsprintf(S, '%d%%', MeterValue);
  128.  
  129.     {get ready to draw text}
  130.     SLen := StrLen(S);
  131.     X := CR.Right div 2;
  132.     Y := (CR.Bottom-HiWord(GetTextExtent(MemDC, S, SLen))) div 2;
  133.     SetTextAlign(MemDC, ta_Center+ta_Top);
  134.  
  135.     {calculate position of dividing line between the two sides}
  136.     DivLine := (MeterValue*LongInt(CR.Right)) div 100;
  137.  
  138.     {fill in both sides}
  139.     FillSide(0, DivLine, rgbRight, rgbLeft);
  140.     FillSide(DivLine, CR.Right, rgbLeft, rgbRight);
  141.  
  142.     {copy everything to the original display context}
  143.     BitBlt(PaintDC, 0, 0, CR.Right, CR.Bottom, MemDC, 0, 0, SrcCopy);
  144.  
  145.     {dispose of the bitmap and first display context}
  146.     DeleteDC(MemDC);
  147.     DeleteObject(hCBM);
  148.   end;
  149.  
  150.   procedure TMeterControl.wmEraseBkGnd(var Msg : TMessage);
  151.   begin
  152.     {do nothing}
  153.   end;
  154.  
  155.   procedure TMeterControl.wmSetFont(var Msg : TMessage);
  156.   begin
  157.     Font := Msg.wParam;
  158.     if Msg.lParam <> 0 then
  159.       Redraw(False);
  160.   end;
  161.  
  162.   procedure TMeterControl.wmGetDlgCode(var Msg : TMessage);
  163.   begin
  164.     Msg.Result := dlgc_Static;
  165.   end;
  166.  
  167.   procedure TMeterControl.mmSetMeterValue(var Msg : TMessage);
  168.   begin
  169.     if Msg.wParam > 100 then
  170.       MeterValue := 100
  171.     else
  172.       MeterValue := Msg.wParam;
  173.     Redraw(True);
  174.   end;
  175.  
  176.   procedure TMeterControl.mmSetLeftColor(var Msg : TMessage);
  177.   begin
  178.     rgbLeft := Msg.lParam;
  179.     Redraw(False);
  180.   end;
  181.  
  182.   procedure TMeterControl.mmSetRightColor(var Msg : TMessage);
  183.   begin
  184.     rgbRight := Msg.lParam;
  185.     Redraw(False);
  186.   end;
  187.  
  188.   procedure TMeterControl.Redraw(Now : Boolean);
  189.   begin
  190.     InvalidateRect(hWindow, nil, False);
  191.     if Now then
  192.       UpdateWindow(hWindow);
  193.   end;
  194.  
  195. {Resource Workshop design interface}
  196.  
  197. type
  198.   PParamRec = ^TParamRec;
  199.   TParamRec =
  200.     record
  201.       CtlStyle : THandle;
  202.       IdToStr  : TIdToStr;
  203.       StrToId  : TStrToId;
  204.     end;
  205.  
  206.   function MeterControlInfo : THandle; export;
  207.     {-Return information about the capabilities of the meter control class}
  208.   var
  209.     hInfo : THandle;
  210.     Info  : PRWCtlInfo;
  211.   begin
  212.     hInfo := GlobalAlloc(gmem_Share or gmem_ZeroInit, SizeOf(TRWCtlInfo));
  213.     if hInfo <> 0 then begin
  214.       Info := GlobalLock(hInfo);
  215.       with Info^ do begin
  216.         wVersion := $100;
  217.         wCtlTypes := 1;
  218.         StrCopy(szClass, MeterClassName);
  219.         szTitle[0] := #0;
  220.  
  221.         with ctType[0] do begin
  222.           {set the default dimensions for the control (in dialog units)}
  223.           wWidth :=  57;
  224.           wHeight := 12;
  225.  
  226.           {set the name of the control}
  227.           StrCopy(szDescr, 'Meter Control');
  228.  
  229.           {set the default window style}
  230.           dwStyle := ws_Child+ws_Border+ws_Visible;
  231.  
  232.           {load the toolbit for the Tools palette}
  233.           hToolBit := LoadBitmap(hInstance, 'METER_TOOLBIT');
  234.  
  235.           {load the drop cursor}
  236.           hDropCurs := LoadCursor(hInstance, 'METER_CURSOR');
  237.         end;
  238.       end;
  239.       GlobalUnlock(hInfo);
  240.     end;
  241.  
  242.     MeterControlInfo := hInfo;
  243.   end;
  244.  
  245.   function MeterControlDlg(hWindow : hWnd;
  246.                            Message : Word;
  247.                            wParam  : Word;
  248.                            lParam  : Longint) : Longint; export;
  249.     {-Style dialog's dialog hook. Used by the dialog and called when the
  250.       control is double-clicked inside the dialog editor.}
  251.   const
  252.     Prop = 'Prop';
  253.   var
  254.     hRec : THandle;
  255.     Rec : PParamRec;
  256.     Style : PRWCtlStyle;
  257.     S : array[0..256] of Char;
  258.   begin
  259.     MeterControlDlg := 0;
  260.     case Message of
  261.       wm_InitDialog:
  262.         begin
  263.           hRec := Word(lParam);
  264.           Rec := GlobalLock(hRec);
  265.           Style := GlobalLock(Rec^.CtlStyle);
  266.           SetProp(hWindow, Prop, hRec);
  267.  
  268.           {Set control id}
  269.           with Rec^, Style^ do begin
  270.             IdToStr(wId, S, SizeOf(S));
  271.             SetDlgItemText(hWindow, 101, S);
  272.  
  273.             Str(Integer(wID), S);
  274.             SetDlgItemText(hWindow, 102, S);
  275.           end;
  276.  
  277.           GlobalUnlock(Rec^.CtlStyle);
  278.           GlobalUnlock(hRec);
  279.         end;
  280.       wm_Command:
  281.         case wParam of
  282.           id_Cancel:
  283.             EndDialog(hWindow, 0);
  284.           id_Ok:
  285.             begin
  286.               hRec := GetProp(hWindow, Prop);
  287.               Rec := GlobalLock(hRec);
  288.               Style := GlobalLock(Rec^.CtlStyle);
  289.  
  290.               {get control ID}
  291.               with Rec^, Style^ do begin
  292.                 {Get control id}
  293.                 GetDlgItemText(hWindow, 101, S, SizeOf(S));
  294.                 wId := StrToId(S);
  295.               end;
  296.  
  297.               GlobalUnlock(Rec^.CtlStyle);
  298.               GlobalUnlock(hRec);
  299.               EndDialog(HWindow, 1);
  300.             end;
  301.         end;
  302.       wm_Destroy:
  303.         RemoveProp(hWindow, Prop);
  304.     end;
  305.   end;
  306.  
  307.   function MeterControlStyle(hWindow  : hWnd;
  308.                              CtlStyle : THandle;
  309.                              StrToId  : TStrToId;
  310.                              IdToStr  : TIdToStr) : Bool; export;
  311.     {-This function will bring up a dialog box to modify the style of a meter
  312.       control. Called when the field is double-clicked in the dialog editor.}
  313.   var
  314.     hRec : THandle;
  315.     Rec : PParamRec;
  316.     hFocus : hWnd;
  317.   begin
  318.     MeterControlStyle := False;
  319.  
  320.     {allocate a TParamRec}
  321.     hRec := GlobalAlloc(gmem_Share, SizeOf(TParamRec));
  322.     if hRec <> 0 then begin
  323.       {initialize the TParamRec}
  324.       Rec := GlobalLock(hRec);
  325.       Rec^.IdToStr := IdToStr;
  326.       Rec^.StrToId := StrToId;
  327.       Rec^.CtlStyle := CtlStyle;
  328.       GlobalUnlock(hRec);
  329.  
  330.       {save the focus}
  331.       hFocus := GetFocus;
  332.  
  333.       {execute the style dialog}
  334.       MeterControlStyle :=
  335.         Bool(DialogBoxParam(hInstance, 'Meter_Dialog', hWindow,
  336.                             @MeterControlDlg, hRec));
  337.  
  338.       {restore the focus}
  339.       if hFocus <> 0 then
  340.         SetFocus(hFocus);
  341.  
  342.       {deallocate the TParamRec}
  343.       GlobalFree(hRec);
  344.     end;
  345.   end;
  346.  
  347.   function ControlFlags(Style      : LongInt;
  348.                         Buff       : PChar;
  349.                         BuffLength : Word) : Word; export;
  350.     {-Called to decompose the style double word into the .RC script expression
  351.       that it represents}
  352.   type
  353.     TCharArray = array[0..255] of Char;
  354.     PCharArray = ^TCharArray;
  355.   begin
  356.     Str(Word(Style), PCharArray(Buff)^);
  357.     ControlFlags := System.hInstance;
  358.   end;
  359.  
  360.   function ListClasses(szAppName : PChar;
  361.                        wVersion  : Word;
  362.                        fnLoad    : TLoad;
  363.                        fnEdit    : TEdit) : THandle; export;
  364.     {-Called by Resource Workshop to retrieve the information necessary
  365.       to edit the custom controls contained in this DLL}
  366.   const
  367.     NumClasses = 1;
  368.   var
  369.     hClasses : THandle;
  370.     ClassList : PCtlClassList;
  371.   begin
  372.     hClasses := GlobalAlloc(gmem_Share or gmem_ZeroInit,
  373.                             SizeOf(Integer)+(SizeOf(TRWCtlClass)*NumClasses));
  374.     if hClasses <> 0 then begin
  375.       ClassList := GlobalLock(hClasses);
  376.       with ClassList^ do begin
  377.         nClasses := 1;
  378.         with Classes[0] do begin
  379.           fnInfo  := MeterControlInfo;
  380.           fnStyle := MeterControlStyle;
  381.           fnFlags := ControlFlags;
  382.         end;
  383.       end;
  384.       GlobalUnlock(hClasses);
  385.     end;
  386.     ListClasses := hClasses;
  387.   end;
  388.  
  389. {registration stuff}
  390.  
  391. const
  392.   MeterClassRec : TClassRec = (
  393.     ClassName : MeterClassName;
  394.     VmtLink   : Ofs(TypeOf(TMeterControl)^);
  395.     Init      : @TMeterControl.Init;
  396.     Next      : nil);
  397.  
  398.   procedure Register;
  399.     {-Register the dllMeter class}
  400.   var
  401.     Class : TWndClass;
  402.   begin
  403.     with Class do begin
  404.       Style         := cs_HRedraw or cs_VRedraw or cs_GlobalClass;
  405.       lpfnWndProc   := @TDllWndFunc;
  406.       cbClsExtra    := 0;
  407.       cbWndExtra    := SizeOf(PDllWin);
  408.       hInstance     := System.hInstance;
  409.       hIcon         := 0;
  410.       hCursor       := LoadCursor(0, idc_Arrow);
  411.       hbrBackground := color_Window+1;
  412.       lpszMenuName  := nil;
  413.       lpszClassName := MeterClassName;
  414.     end;
  415.     RegisterClass(Class);
  416.   end;
  417.  
  418.   procedure ForceLoad; export;
  419.     {-Dummy routine called to force DLLMETER to be loaded}
  420.   begin
  421.   end;
  422.  
  423. exports
  424.   ForceLoad   index 1,
  425.   ListClasses index 2;
  426.  
  427. begin
  428.   Register;
  429.   AddWindowClass(MeterClassRec);
  430. end.
  431.