📄 cpwtbx.pas
字号:
{*******************************************************************
* *
* COMPONENT for MS DOS and Windows source code. *
* *
* (c) 1992, Roderic D. M. Page *
* *
* Language: Turbo Pascal (Pascal with object-oriented extensions) *
* Compiler: Turbo Pascal 6.0 (MS DOS) *
* Turbo Pascal for Windows 1.0 (WINDOWS) *
* *
* Notes: Program interface is currently Windows specific. *
* *
*******************************************************************}
unit cpwtbx;
{* A simple tool box with bitmapped buttons that toggle.
To use firstly create the tool box window:
TB := CreateWindow('rodToolBox', 'Tools',
WS_CHILD or WS_VISIBLE or ws_ClipSiblings
0, 0,
96 + GetSystemMetrics (sm_CYBorder),
96 + GetSystemMetrics (sm_CYCaption)
+ GetSystemMetrics (sm_CYBorder),
HWindow, 100, HInstance, nil);
then add as many buttons (each 32x32 pixels) as required. Each
button requires one bitmap (32x32) with the id 1000 + the
button id.
Button1 := CreateWindow('rodToolBoxButton', nil,
WS_CHILD or WS_VISIBLE,
0, 0,
32, 32,
TB, 401, HInstance, nil);
Finally, set the default tool.
SendMessage (TB, um_SetTool, 401, 0);
3 Oct 1992 Written.
7 Jan 1993 Modified to display a small caption bar using code from:
Edson, D. 1992. Dave's top ten list of tricks, hints, and
techniques for programming in Windows. Microsoft
Systems Journal, Oct. 1992: 31-53.
Traps wm_NCHITTEST message to allow user to move window.
Paints a fake caption bar.
*}
interface
uses
WinTypes, Winprocs, Strings, cpheader, spinco, cpwcontl;
const
um_SetTool = wm_User + 100;
um_NewMode = wm_User + 101;
um_NewBlock = wm_User + 15;
id_TreeNumber = 104;
id_TreeSpin = 103;
id_Block = 102;
id_BlockName = 105;
id_Shade = 106;
function ToolBoxButtonProc (HWindow: HWnd; Message: word;
wParam: word; lParam: longint):longint;
function ToolBoxProc (HWindow: HWnd; Message: word;
wParam: word; lParam: longint):longint;
function SpeedBarProc (HWindow: HWnd; message, wparam:word; lParam: longint):longint;
procedure Create3DEffect (DC :HDC; var Rect : TRect; thickness : integer);
implementation
const
ofState = 0;
ofSize = 2; { Amount of window extra bytes to use }
bsDown = $0001;
bsDisabled = $0002;
function ToolBoxButtonProc (HWindow: HWnd; Message: word;
wParam: word; lParam: longint):longint;
var
PS: TPaintStruct;
h : HWnd;
function Get(Ofs: Integer): Word;
begin
Get := GetWindowWord(HWindow, Ofs);
end;
procedure SetWord(Ofs: Integer; Val: Word);
begin
SetWindowWord(HWindow, Ofs, Val);
end;
function State: Word;
begin
State := Get(ofState);
end;
function GetState(AState: Word): Boolean;
begin
GetState := (State and AState) = AState;
end;
procedure Paint(DC: HDC);
var
MemDC : HDC;
Bits,
Oldbitmap : HBitmap;
R : TRect;
begin
Bits := LoadBitmap (HInstance,PChar(1000 + GetDlgCtrlID (HWindow)));
{ Draw bitmap }
MemDC := CreateCompatibleDC(DC);
OldBitmap := SelectObject(MemDC, Bits);
BitBlt(DC, 0, 0, 32, 32,
MemDC, 0, 0, srcCopy);
Bits := SelectObject(MemDC, OldBitmap);
DeleteObject (Bits);
DeleteDC(MemDC);
{ Invert if button has been pressed }
if GetState (bsDown) then begin
GetClientRect (HWindow, R);
InvertRect (DC, R);
end;
end;
procedure Repaint;
var
DC: HDC;
begin
DC := GetDC(HWindow);
Paint(DC);
ReleaseDC(HWindow, DC);
end;
procedure SetState(AState: Word; Enable: Boolean);
var
OldState: Word;
begin
OldState := State;
if Enable then
SetWord(ofState, State or AState)
else SetWord(ofState, State and not AState);
if State <> OldState then
Repaint;
end;
{ True if lPoint is in window's client area. }
function InMe(lPoint: Longint): Boolean;
var
R : TRect;
Point: TPoint absolute lPoint;
begin
GetClientRect(HWindow, R);
InflateRect(R, -1, -1);
InMe := PtInRect(R, Point);
end;
begin
ToolBoxButtonProc := 0;
case Message of
wm_Paint:
begin
BeginPaint(HWindow, PS);
Paint (Ps.hdc);
EndPaint(HWindow, PS);
end;
wm_LButtonDown:
begin
if InMe (lParam) and not GetState(bsDown) then begin
SetState (bsDown, True);
{ Inform parent that button has been pressed. }
SendMessage(GetParent(HWindow), wm_Command, GetDlgCtrlID(HWindow),
Longint(HWindow));
end;
end;
bm_SetCheck:
SetState (bsDown, (wParam <> 0));
bm_GetCheck:
ToolBoxButtonProc := Integer (GetState (bsDown));
else
ToolBoxButtonProc := DefWindowProc(HWindow, Message, wParam, lParam);
end;
end;
{--------------------------ToolBoxProc--------------------------------------}
function ToolBoxProc (HWindow: HWnd; Message: word;
wParam: word; lParam: longint):longint;
var
CurTool : word;
PS : TPaintStruct;
Rect : TRect;
CaptionBrush : HBrush;
OldPen : HPen;
Point : TPoint;
OldFont : HFont;
Width : word;
szCaption : array[0..128] of char;
begin
ToolBoxProc := 0;
case Message of
um_SetTool:
begin
CurTool := GetWindowWord (HWindow, 0);
if (CurTool <> 0) then
SendMessage (GetDlgItem (HWindow, CurTool), bm_SetCheck, 0, 0);
SendMessage (GetDlgItem (HWindow, wParam), bm_SetCheck, 1, 0);
SetWindowWord (HWindow, 0, wParam);
end;
wm_Paint:
begin
BeginPaint (HWindow, PS);
{ Draw fake title bar }
GetClientRect (HWindow, Rect);
Rect.Bottom := Rect.top + GetSystemMetrics (sm_CYCaption) div 2;
CaptionBrush := CreateSolidBrush (GetSysColor (color_ActiveCaption));
FillRect (PS.hDC, Rect, CaptionBrush);
DeleteObject (CaptionBrush);
{ Write caption }
{ This doesn't work v. well as font is 9 pixels heigh and
doesn't fit into rectangel v. well. }
(* OldFont := SelectObject (PS.hDC,
CreateFont (-1 * (GetSystemMetrics (sm_CYCaption) div 2 - 2),
0, 0, 0, fw_Bold, 0, 0, 0,
ANSI_Charset, Out_Character_Precis,
Clip_Default_Precis, Proof_Quality,
Variable_Pitch or ff_Swiss, 'Helv'));
GetWindowText (HWindow, szCaption, Sizeof (szCaption));
Width := LoWord (GetTextExtent (PS.hDC, szCaption, SizeOf (szCaption)));
SetBKMode (PS.hDC, Transparent);
SetTextColor (PS.hDC, GetSysColor (color_CaptionText));
ExtTextOut (PS.hDC,
Rect.Left + (Rect.right - Rect.left - Width) div 2,
-1, eto_Clipped,
@Rect,
szCaption,
Strlen (szCaption),
NIL);
SelectObject (PS.hDC, OldFont);
*)
{ Draw line under caption }
OldPen := SelectObject (PS.hDC, GetStockObject (Black_Pen));
MoveTo (PS.hDC, Rect.left, Rect.Bottom);
LineTo (PS.hDC, Rect.right, Rect.Bottom);
SelectObject (PS.hDC, OldPen);
EndPaint (HWindow, PS);
end;
wm_NCHITTEST:
begin
GetClientRect (HWindow, Rect);
Rect.Bottom := Rect.top + GetSystemMetrics (sm_CYCaption) div 2;
Point.x := integer (LoWord (lParam));
Point.y := integer (HiWord (lParam));
ScreenToClient (HWindow, Point);
if PtInRect (Rect, Point) then
ToolBoxProc := HTCAPTION
else
ToolBoxProc := DefWindowProc (HWindow, message, wParam, lParam);
end;
wm_Command:
begin
CurTool := GetWindowWord (HWindow, 0);
SendMessage (GetDlgItem (HWindow, CurTool), bm_SetCheck, 0, 0);
SetWindowWord (HWindow, 0, wParam);
{ Notify parent of new tool }
Sendmessage (GetParent (HWindow), um_NewMode, wParam, 0);
end;
else
ToolBoxProc := DefWindowProc (HWindow, message, wParam, lParam);
end;
end;
procedure Create3DEffect (DC :HDC; var Rect : TRect; thickness : integer);
var
i, x1, y1, x2, y2 : integer;
NewBrush, OldBrush : HBrush;
NewPen, OldPen : HPen;
begin
x1 := Rect.left;
y1 := rect.top;
x2 := rect.right;
y2 := rect.bottom;
SelectObject(DC, GetStockObject(BLACK_PEN));
NewBrush := CreateSolidBrush(RGB(192, 192, 192));
OldBrush := SelectObject(DC, NewBrush);
Rectangle(DC, x1, y1, x2, y2);
SelectObject(DC, GetStockObject(WHITE_PEN));
for i := 1 to thickness do begin
MoveTo(DC, x1 + i, y1 + i); LineTo(DC, x1 + i, y2 - 1);
MoveTo(DC, x1 + i, y1 + i); LineTo(DC, x2 - 1, y1 + i);
end;
NewPen := CreatePen(PS_SOLID, 1, RGB(128,128,128));
OldPen := SelectObject(DC, NewPen);
for i := 1 to thickness do begin
MoveTo(DC, x1 + i, y2 - 1 - i);
LineTo(DC, x2 - 1, y2 - 1 - i);
MoveTo(DC, x2 - 1 - i, y2 - 2);
LineTo(DC, x2 - 1 - i, y1 + i);
end;
NewBrush := SelectObject(DC, OldBrush);
DeleteObject(NewBrush);
NewPen := SelectObject(DC, OldPen);
DeleteObject(NewPen);
end;
function SpeedBarProc (HWindow: HWnd; message, wparam:word; lParam: longint):longint;
var
DC : HDC;
ps : TPaintStruct;
rect : TREct;
begin
SpeedBarProc := 0;
case message of
um_NewValue:
SendMessage (GetParent(HWindow), um_NewValue,
SendMessage (GetDlgItem (HWindow, id_TreeSpin),
SPNM_GETCRNTVALUE, 0, 0), 0);
wm_Command:
if (wParam = id_Block) then begin
if (Hiword(lParam) = lbn_SelChange) then
SendMessage (GetParent(HWindow), um_NewBlock,
SendMessage (GetDlgItem (HWindow, id_Block),
cb_GetCurSel, 0, 0), 0);
end
else SpeedBarproc := DefWindowProc (HWindow, message, wParam, lParam);
wm_Paint:
begin
GetClientRect(HWindow, rect);
DC := BeginPaint (HWindow, ps);
Create3DEffect (DC, Rect, 1);
EndPaint (HWindow, ps);
end;
wm_CtlColor:
begin
if (HiWord(lParam) = ctlcolor_Static) then begin
SetBKColor (wParam, GetSysColor (color_BtnFace));
SetTextColor (wParam, RGB(0,0,0));
SpeedBarProc := GetStockObject (ltgray_Brush);
end
else
SpeedBarProc := DefWindowProc(HWindow, message, wParam, lParam);
end;
else SpeedBarProc := DefWindowProc(HWindow, message, wParam, lParam);
end;
end;
var
Class, Class4: TWndClass;
begin
with Class do
begin
lpszClassName := 'rodToolBoxButton';
hCursor := LoadCursor(0, idc_Arrow);
lpszMenuName := nil;
style := cs_HRedraw or cs_VRedraw;
lpfnWndProc := TFarProc(@ToolBoxButtonProc);
hInstance := System.hInstance;
hIcon := 0;
cbWndExtra := ofSize;
cbClsExtra := 0;
hbrBackground := 0;
end;
RegisterClass(Class);
with Class do
begin
lpszClassName := 'rodToolBox';
hCursor := LoadCursor(0, idc_Arrow);
lpszMenuName := nil;
style := cs_HRedraw or cs_VRedraw;
lpfnWndProc := TFarProc(@ToolBoxProc);
hInstance := System.hInstance;
hIcon := 0;
cbWndExtra := SizeOf (word);
cbClsExtra := 0;
hbrBackground := color_BtnFace + 1;
end;
RegisterClass(Class);
with Class do
begin
lpszClassName := 'rodSpeedBar';
hCursor := LoadCursor(0, idc_Arrow);
lpszMenuName := nil;
style := cs_HRedraw or cs_VRedraw;
lpfnWndProc := TFarProc(@SpeedBarProc);
hInstance := System.hInstance;
hIcon := 0;
cbWndExtra := SizeOf (word);
cbClsExtra := 0;
hbrBackground := 0;
end;
RegisterClass(Class);
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -