Author: Tomas Rutkauskas
I want to create a component that has scrollbars (vertical/ horizontal). I tried to
get the tricks from TCustomGrid but it doesn't work when I try to set a range/
position value to one of the scrollbars.
Answer:
This example uses an interposer class for convenience (mine, I just wanted to avoid
the hassle of creating and installing a proper component for this example) but you
should be able to adapt it for a proper component.
1 { Example for fitting a panel with scrollbars }
2
3 unit Unit1;
4
5 interface
6
7 uses
8 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
9 ComCtrls, StdCtrls, ExtCtrls;
10
11 type
12 TPanel = class(Extctrls.TPanel)
13 private
14 procedure WMVScroll(var msg: TWMSCROLL); message WM_VSCROLL;
15 procedure WMHScroll(var msg: TWMSCROLL); message WM_HSCROLL;
16 procedure WMGetDlgCode(var msg: TWMGetDlgCode); message WM_GETDLGCODE;
17 procedure HandleScrollbar(var msg: TWMSCROLL; bar: Integer);
18 protected
19 procedure CreateParams(var params: TCreateParams); override;
20 procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
21 override;
22 procedure KeyDown(var Key: Word; Shift: TShiftState); override;
23 end;
24
25 TForm1 = class(TForm)
26 Panel1: TPanel;
27 procedure FormCreate(Sender: TObject);
28 private
29 { Private declarations }
30 public
31 { Public declarations }
32 end;
33
34 var
35 Form1: TForm1;
36
37 implementation
38
39 {$R *.DFM}
40
41 { TPanel }
42
43 procedure TPanel.CreateParams(var params: TCreateParams);
44 begin
45 inherited;
46 params.Style := params.Style or WS_VSCROLL or WS_HSCROLL;
47 end;
48
49 procedure TForm1.FormCreate(Sender: TObject);
50 var
51 si: TScrollInfo;
52 begin
53 si.cbSize := Sizeof(TScrollInfo);
54 si.fMask := SIF_ALL or SIF_DISABLENOSCROLL;
55 si.nMin := 0;
56 si.nMax := 3 * panel1.clientheight;
57 si.nPage := panel1.clientheight div 2;
58 si.nPos := 0;
59 SetScrollInfo(panel1.handle, SB_VERT, si, true);
60 si.nMax := 2 * panel1.clientwidth;
61 si.nPage := panel1.clientwidth div 2;
62 SetScrollInfo(panel1.handle, SB_HORZ, si, true);
63 end;
64
65 procedure TPanel.HandleScrollbar(var msg: TWMSCROLL; bar: Integer);
66 var
67 si: TScrollInfo;
68 begin
69 msg.result := 0;
70 si.cbSize := Sizeof(TscrollInfo);
71 si.fMask := SIF_ALL;
72 GetScrollInfo(Handle, bar, si);
73 si.fMask := SIF_POS;
74 { For simplicities sake we use 1/10 of the page size as small scroll
75 increment and the page size as large scroll increment }
76 case msg.ScrollCode of
77 SB_TOP: si.nPos := si.nMin;
78 SB_BOTTOM: si.nPos := si.nMax;
79 SB_LINEUP: Dec(si.nPos, si.nPage div 10);
80 SB_LINEDOWN: Inc(si.nPos, si.nPage div 10);
81 SB_PAGEUP: Dec(si.nPos, si.nPage);
82 SB_PAGEDOWN: Inc(si.nPos, si.nPage);
83 SB_THUMBTRACK, SB_THUMBPOSITION: si.nPos := msg.Pos;
84 SB_ENDSCROLL: Exit;
85 end;
86 si.fMask := SIF_POS;
87 if si.nPos < si.nMin then
88 si.nPos := si.nMin;
89 if si.nPos > si.nMax then
90 si.nPos := si.nMax;
91 SetScrollInfo(Handle, bar, si, true);
92 { Fire a scroll notification off here to allow client to scroll content of panel }
93 end;
94
95 procedure TPanel.KeyDown(var Key: Word; Shift: TShiftState);
96
97 procedure Scroll(scrollcode, message: Cardinal);
98 begin
99 Perform(message, scrollcode, 0);
100 end;
101
102 const
103 scrollkind: array[Boolean] of Cardinal = (WM_VSCROLL, WM_HSCROLL);
104 begin
105 inherited;
106 { Ignoring shift state for arrow keys here for simplicities sake }
107 case Key of
108 VK_UP: Scroll(SB_LINEUP, WM_VSCROLL);
109 VK_LEFT: Scroll(SB_LINEUP, WM_HSCROLL);
110 VK_DOWN: Scroll(SB_LINEDOWN, WM_VSCROLL);
111 VK_RIGHT: Scroll(SB_LINEDOWN, WM_HSCROLL);
112 VK_NEXT: Scroll(SB_PAGEDOWN, scrollkind[ssCtrl in Shift]);
113 VK_PRIOR: Scroll(SB_PAGEUP, scrollkind[ssCtrl in Shift]);
114 VK_HOME: Scroll(SB_TOP, scrollkind[ssCtrl in Shift]);
115 VK_END: Scroll(SB_BOTTOM, scrollkind[ssCtrl in Shift]);
116 end;
117 Key := 0;
118 end;
119
120 procedure TPanel.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
121 begin
122 inherited;
123 if (Button = mbLeft) and CanFocus and not Focused then
124 SetFocus;
125 end;
126
127 procedure TPanel.WMGetDlgCode(var msg: TWMGetDlgCode);
128 begin
129 msg.result := DLGC_WANTARROWS;
130 end;
131
132 procedure TPanel.WMHScroll(var msg: TWMSCROLL);
133 begin
134 HandleScrollbar(msg, SB_HORZ);
135 end;
136
137 procedure TPanel.WMVScroll(var msg: TWMSCROLL);
138 begin
139 HandleScrollbar(msg, SB_VERT);
140 end;
141
142 end.
|
