home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 13
/
mediashare_13.zip
/
mediashare_13
/
ZIPPED
/
PROGRAM
/
WTJ9403.ZIP
/
FOLEY
/
DLLMETER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-04-07
|
12KB
|
431 lines
{$S-,R-,V-,I-,B-,F-,W-,A-,G+,X+,N+}
{$C MOVEABLE,DEMANDLOAD,DISCARDABLE}
{*********************************************************}
{* DLLMETER.PAS 1.00 *}
{* Copyright (c) Brian Foley 1993. *}
{* All rights reserved. *}
{*********************************************************}
library DllMeter;
{-Sample meter control written with DLLWIN}
uses
Strings, WinTypes, WinProcs, CustCntl, DllWin;
{$R DLLMETER.RES}
const
MeterClassName = 'dllMeterControl';
{special messages for meter controls}
mm_SetMeterValue = wm_User+0;
mm_SetLeftColor = wm_User+1;
mm_SetRightColor = wm_User+2;
type
TMeterControl = object(TDllWin)
MeterValue : Word; {meter value to display}
rgbLeft : LongInt; {color for left side}
rgbRight : LongInt; {color for right side}
Font : THandle; {font to draw with}
constructor Init(HW : hWnd; PCS : PCreateStruct);
procedure Paint(PaintDC : HDC; var PaintInfo : TPaintStruct); virtual;
procedure wmEraseBkGnd(var Msg : TMessage);
virtual wm_First+wm_EraseBkGnd;
procedure wmSetFont(var Msg : TMessage);
virtual wm_First+wm_SetFont;
procedure wmGetDlgCode(var Msg : TMessage);
virtual wm_First+wm_GetDlgCode;
procedure mmSetMeterValue(var Msg : TMessage);
virtual wm_First+mm_SetMeterValue;
procedure mmSetLeftColor(var Msg : TMessage);
virtual wm_First+mm_SetLeftColor;
procedure mmSetRightColor(var Msg : TMessage);
virtual wm_First+mm_SetRightColor;
procedure Redraw(Now : Boolean);
end;
{Miscellaneous routines}
function HiWord(L : LongInt) : Word;
inline(
$58/ {pop ax ;ignore low word}
$58); {pop ax ;pop high word into AX}
function LoWord(L : LongInt) : Word;
inline(
$58/ {pop ax ;pop low word into AX}
$5A); {pop dx ;ignore high word}
function IsWorkshopWindow(HW : HWnd): Boolean;
var
Parent : HWnd;
ClassName : array[0..80] of Char;
begin
Parent := HW;
repeat
HW := Parent;
Parent := GetParent(HW);
until Parent = 0;
GetClassName(HW, ClassName, SizeOf(ClassName));
IsWorkshopWindow := StrIComp(ClassName, 'rwswnd') = 0;
end;
{TMeterControl}
constructor TMeterControl.Init(HW : hWnd; PCS : PCreateStruct);
begin
TDllWin.Init(HW, PCS);
if IsWorkshopWindow(HW) then
MeterValue := 50
else
MeterValue := 0;
rgbLeft := GetSysColor(color_Highlight);
rgbRight := GetSysColor(color_HighlightText);
Font := 0;
end;
procedure TMeterControl.Paint(PaintDC : HDC; var PaintInfo : TPaintStruct);
var
CR : TRect;
MemDC : hDC;
hCBM : hBitmap;
DivLine, X, Y, SLen : Integer;
S : array[0..4] of Char;
procedure FillSide(Left, Right : Integer; TColor, BColor : LongInt);
var
ClipR : TRect;
begin
if Left <> Right then begin
{set the clipping rectangle}
ClipR := CR;
ClipR.Left := Left;
ClipR.Right := Right;
{set the colors}
SetTextColor(MemDC, TColor);
SetBkColor(MemDC, BColor);
ExtTextOut(MemDC, X, Y, eto_Clipped+eto_Opaque, @ClipR, S, SLen, nil);
end;
end;
begin
GetClientRect(hWindow, CR);
{create a compatible display context and bitmap}
MemDC := CreateCompatibleDC(PaintDC);
hCBM := CreateCompatibleBitmap(PaintDC, CR.Right, CR.Bottom);
SelectObject(MemDC, hCBM);
{select our font into it}
if Font <> 0 then
SelectObject(MemDC, Font);
{convert the meter value to a string}
wvsprintf(S, '%d%%', MeterValue);
{get ready to draw text}
SLen := StrLen(S);
X := CR.Right div 2;
Y := (CR.Bottom-HiWord(GetTextExtent(MemDC, S, SLen))) div 2;
SetTextAlign(MemDC, ta_Center+ta_Top);
{calculate position of dividing line between the two sides}
DivLine := (MeterValue*LongInt(CR.Right)) div 100;
{fill in both sides}
FillSide(0, DivLine, rgbRight, rgbLeft);
FillSide(DivLine, CR.Right, rgbLeft, rgbRight);
{copy everything to the original display context}
BitBlt(PaintDC, 0, 0, CR.Right, CR.Bottom, MemDC, 0, 0, SrcCopy);
{dispose of the bitmap and first display context}
DeleteDC(MemDC);
DeleteObject(hCBM);
end;
procedure TMeterControl.wmEraseBkGnd(var Msg : TMessage);
begin
{do nothing}
end;
procedure TMeterControl.wmSetFont(var Msg : TMessage);
begin
Font := Msg.wParam;
if Msg.lParam <> 0 then
Redraw(False);
end;
procedure TMeterControl.wmGetDlgCode(var Msg : TMessage);
begin
Msg.Result := dlgc_Static;
end;
procedure TMeterControl.mmSetMeterValue(var Msg : TMessage);
begin
if Msg.wParam > 100 then
MeterValue := 100
else
MeterValue := Msg.wParam;
Redraw(True);
end;
procedure TMeterControl.mmSetLeftColor(var Msg : TMessage);
begin
rgbLeft := Msg.lParam;
Redraw(False);
end;
procedure TMeterControl.mmSetRightColor(var Msg : TMessage);
begin
rgbRight := Msg.lParam;
Redraw(False);
end;
procedure TMeterControl.Redraw(Now : Boolean);
begin
InvalidateRect(hWindow, nil, False);
if Now then
UpdateWindow(hWindow);
end;
{Resource Workshop design interface}
type
PParamRec = ^TParamRec;
TParamRec =
record
CtlStyle : THandle;
IdToStr : TIdToStr;
StrToId : TStrToId;
end;
function MeterControlInfo : THandle; export;
{-Return information about the capabilities of the meter control class}
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;
wCtlTypes := 1;
StrCopy(szClass, MeterClassName);
szTitle[0] := #0;
with ctType[0] do begin
{set the default dimensions for the control (in dialog units)}
wWidth := 57;
wHeight := 12;
{set the name of the control}
StrCopy(szDescr, 'Meter Control');
{set the default window style}
dwStyle := ws_Child+ws_Border+ws_Visible;
{load the toolbit for the Tools palette}
hToolBit := LoadBitmap(hInstance, 'METER_TOOLBIT');
{load the drop cursor}
hDropCurs := LoadCursor(hInstance, 'METER_CURSOR');
end;
end;
GlobalUnlock(hInfo);
end;
MeterControlInfo := hInfo;
end;
function MeterControlDlg(hWindow : hWnd;
Message : Word;
wParam : Word;
lParam : Longint) : Longint; export;
{-Style dialog's dialog hook. Used by the dialog and called when the
control is double-clicked inside the dialog editor.}
const
Prop = 'Prop';
var
hRec : THandle;
Rec : PParamRec;
Style : PRWCtlStyle;
S : array[0..256] of Char;
begin
MeterControlDlg := 0;
case Message of
wm_InitDialog:
begin
hRec := Word(lParam);
Rec := GlobalLock(hRec);
Style := GlobalLock(Rec^.CtlStyle);
SetProp(hWindow, Prop, hRec);
{Set control id}
with Rec^, Style^ do begin
IdToStr(wId, S, SizeOf(S));
SetDlgItemText(hWindow, 101, S);
Str(Integer(wID), S);
SetDlgItemText(hWindow, 102, S);
end;
GlobalUnlock(Rec^.CtlStyle);
GlobalUnlock(hRec);
end;
wm_Command:
case wParam of
id_Cancel:
EndDialog(hWindow, 0);
id_Ok:
begin
hRec := GetProp(hWindow, Prop);
Rec := GlobalLock(hRec);
Style := GlobalLock(Rec^.CtlStyle);
{get control ID}
with Rec^, Style^ do begin
{Get control id}
GetDlgItemText(hWindow, 101, S, SizeOf(S));
wId := StrToId(S);
end;
GlobalUnlock(Rec^.CtlStyle);
GlobalUnlock(hRec);
EndDialog(HWindow, 1);
end;
end;
wm_Destroy:
RemoveProp(hWindow, Prop);
end;
end;
function MeterControlStyle(hWindow : hWnd;
CtlStyle : THandle;
StrToId : TStrToId;
IdToStr : TIdToStr) : Bool; export;
{-This function will bring up a dialog box to modify the style of a meter
control. Called when the field is double-clicked in the dialog editor.}
var
hRec : THandle;
Rec : PParamRec;
hFocus : hWnd;
begin
MeterControlStyle := False;
{allocate a TParamRec}
hRec := GlobalAlloc(gmem_Share, SizeOf(TParamRec));
if hRec <> 0 then begin
{initialize the TParamRec}
Rec := GlobalLock(hRec);
Rec^.IdToStr := IdToStr;
Rec^.StrToId := StrToId;
Rec^.CtlStyle := CtlStyle;
GlobalUnlock(hRec);
{save the focus}
hFocus := GetFocus;
{execute the style dialog}
MeterControlStyle :=
Bool(DialogBoxParam(hInstance, 'Meter_Dialog', hWindow,
@MeterControlDlg, hRec));
{restore the focus}
if hFocus <> 0 then
SetFocus(hFocus);
{deallocate the TParamRec}
GlobalFree(hRec);
end;
end;
function ControlFlags(Style : LongInt;
Buff : PChar;
BuffLength : Word) : Word; export;
{-Called to decompose the style double word into the .RC script expression
that it represents}
type
TCharArray = array[0..255] of Char;
PCharArray = ^TCharArray;
begin
Str(Word(Style), PCharArray(Buff)^);
ControlFlags := System.hInstance;
end;
function ListClasses(szAppName : PChar;
wVersion : Word;
fnLoad : TLoad;
fnEdit : TEdit) : THandle; export;
{-Called by Resource Workshop to retrieve the information necessary
to edit the custom controls contained in this DLL}
const
NumClasses = 1;
var
hClasses : THandle;
ClassList : PCtlClassList;
begin
hClasses := GlobalAlloc(gmem_Share or gmem_ZeroInit,
SizeOf(Integer)+(SizeOf(TRWCtlClass)*NumClasses));
if hClasses <> 0 then begin
ClassList := GlobalLock(hClasses);
with ClassList^ do begin
nClasses := 1;
with Classes[0] do begin
fnInfo := MeterControlInfo;
fnStyle := MeterControlStyle;
fnFlags := ControlFlags;
end;
end;
GlobalUnlock(hClasses);
end;
ListClasses := hClasses;
end;
{registration stuff}
const
MeterClassRec : TClassRec = (
ClassName : MeterClassName;
VmtLink : Ofs(TypeOf(TMeterControl)^);
Init : @TMeterControl.Init;
Next : nil);
procedure Register;
{-Register the dllMeter class}
var
Class : TWndClass;
begin
with Class do begin
Style := cs_HRedraw or cs_VRedraw or cs_GlobalClass;
lpfnWndProc := @TDllWndFunc;
cbClsExtra := 0;
cbWndExtra := SizeOf(PDllWin);
hInstance := System.hInstance;
hIcon := 0;
hCursor := LoadCursor(0, idc_Arrow);
hbrBackground := color_Window+1;
lpszMenuName := nil;
lpszClassName := MeterClassName;
end;
RegisterClass(Class);
end;
procedure ForceLoad; export;
{-Dummy routine called to force DLLMETER to be loaded}
begin
end;
exports
ForceLoad index 1,
ListClasses index 2;
begin
Register;
AddWindowClass(MeterClassRec);
end.