1 unit Unit1;
2
3 interface
4
5 uses
6 Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
7 System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
8 ATScrollBar, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.ExtCtrls, Math,
9 Vcl.AppEvnts, System.UITypes;
10
11 type
12 TMemo = class(Vcl.StdCtrls.TMemo)
13 private
14 procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
15 procedure WMVScroll(var Msg: TWMHScroll); message WM_VSCROLL;
16 procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
17 procedure WMDropFiles(var Msg: TWMDropFiles); message WM_DROPFILES;
18 end;
19
20 TForm1 = class(TForm)
21 Memo1: TMemo;
22 ATVScrollbar: TATScrollbar;
23 PanelRight: TPanel;
24 cbWordWrap: TCheckBox;
25 ATHScrollbar: TATScrollbar;
26 PanelMemo: TPanel;
27 ApplicationEvents1: TApplicationEvents;
28 Button1: TButton;
29 FontDialog1: TFontDialog;
30 RadioGroup1: TRadioGroup;
31 cbDark: TCheckBox;
32 procedure ATVScrollbarChange(Sender: TObject);
33 procedure FormMouseWheel(Sender: TObject; Shift: TShiftState;
34 WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
35 procedure FormCreate(Sender: TObject);
36 procedure cbWordWrapClick(Sender: TObject);
37 procedure ATHScrollbarChange(Sender: TObject);
38 procedure FormResize(Sender: TObject);
39 procedure ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
40 procedure Button1Click(Sender: TObject);
41 procedure RadioGroup1Click(Sender: TObject);
42 procedure Memo1Change(Sender: TObject);
43 procedure cbDarkClick(Sender: TObject);
44 private
45 procedure UpdateScrollbar;
46 procedure SetScrollWidth(EndSpace:integer=15);
47 { Private declarations }
48 public
49 { Public declarations }
50 end;
51
52 var
53 Form1: TForm1;
54 const
55 CustomSB = 0;
56 SystemSB = 1;
57 BothSB = 2;
58
59 implementation
60
61 uses ShellAPI;
62
63 {$R *.dfm}
64
65 {TMEMO FUNCTIONS}
66
LineHeightnull67 function LineHeight(Memo: TObject): Integer;
68 var
69 DC: HDC;
70 SaveFont: HFONT;
71 TextMetric: TTextMetric;
72 EditRect: TRect;
73 begin
74
75 Result := 0;
76
77 if Memo is TMemo then
78 with Memo as TMemo do
79 begin
80 DC := GetDC(0);
81 SaveFont := SelectObject(DC, Font.Handle);
82 GetTextMetrics(DC, TextMetric);
83 SelectObject(DC, SaveFont);
84 ReleaseDC(0, DC);
85
86 Perform(EM_GETRECT, 0, LPARAM(@EditRect));
87 Result := TextMetric.tmHeight;
88 end;
89
90 end;
91
GetTextMetricnull92 function GetTextMetric(Memo: TObject): TTextMetric;
93 var
94 DC: HDC;
95 SaveFont: HFONT;
96 TextMetric: TTextMetric;
97 EditRect: TRect;
98 begin
99
100 //Result := nil;
101
102 if Memo is TMemo then
103 with Memo as TMemo do
104 begin
105 DC := GetDC(0);
106 SaveFont := SelectObject(DC, Font.Handle);
107 GetTextMetrics(DC, TextMetric);
108 SelectObject(DC, SaveFont);
109 ReleaseDC(0, DC);
110
111 Perform(EM_GETRECT, 0, LPARAM(@EditRect));
112 Result := TextMetric;
113 end;
114
115 end;
116
GetVisibleLineCountnull117 function GetVisibleLineCount(Memo: TObject): Integer;
118 var
119 DC: HDC;
120 SaveFont: HFONT;
121 TextMetric: TTextMetric;
122 EditRect: TRect;
123 begin
124
125 Result := 0;
126
127 if Memo is TMemo then
128 with Memo as TMemo do
129 begin
130 DC := GetDC(0);
131 SaveFont := SelectObject(DC, Font.Handle);
132
133 GetTextMetrics(DC, TextMetric);
134 SelectObject(DC, SaveFont);
135 ReleaseDC(0, DC);
136
137 Perform(EM_GETRECT, 0, LPARAM(@EditRect));
138
139 Result := (EditRect.Bottom - EditRect.Top) div TextMetric.tmHeight;
140
141 end;
142
143 end;
144
ContentRectnull145 function ContentRect(Memo: TObject): TRect;
146 var
147 EditRect: TRect;
148 Canvas: TControlCanvas;
149 i: integer;
150 S: string;
151 Begin
152 Canvas:= TControlCanvas.Create;
153 try
154 i := 0;
155 if Memo is TRichEdit then
156 begin
157 S := TRichEdit(Memo).Text;
158 Canvas.Control := TRichEdit(Memo);
159 Canvas.Font := TRichEdit(Memo).Font;
160 if TRichEdit(Memo).WordWrap then i := DT_WORDBREAK;
161 TRichEdit(Memo).Perform(EM_GETRECT, 0, LPARAM(@EditRect));
162 end;
163 if Memo is TMemo then
164 begin
165 S := TMemo(Memo).Text;
166 Canvas.Control := TMemo(Memo);
167 Canvas.Font := TMemo(Memo).Font;
168 if TMemo(Memo).WordWrap then i := DT_WORDBREAK;
169 TMemo(Memo).Perform(EM_GETRECT, 0, LPARAM(@EditRect));
170 end;
171
172 DrawText(Canvas.Handle,
173 PChar(S),//Memo.Text),
174 Length(S),//(Memo.Text),
175 EditRect,
176 DT_LEFT or i or DT_CALCRECT);
177
178 Result := EditRect;
179
180 finally
181 Canvas.Free;
182 end;
183 end;
184
185 procedure TMemo.WMDropFiles(var Msg: TWMDropFiles);
186 var
187 DropH: HDROP; // drop handle
188 //DroppedFileCount: Integer; // number of files dropped
189 FileNameLength: Integer; // length of a dropped file name
190 FileName: string; // a dropped file name
191 I: Integer; // loops thru all dropped files
192 DropPoint: TPoint; // point where files dropped
193 begin
194 inherited;
195 // Store drop handle from the message
196 DropH := Msg.Drop;
197 try
198 // Get count of files dropped
199 //DroppedFileCount := DragQueryFile(DropH, $FFFFFFFF, nil, 0);
200 // Get name of each file dropped and process it
201 for I := 0 to 0 do//Pred(DroppedFileCount) do
202 begin
203 // get length of file name
204 FileNameLength := DragQueryFile(DropH, I, nil, 0);
205 // create string large enough to store file
206 // (Delphi allows for #0 terminating character automatically)
207 SetLength(FileName, FileNameLength);
208 // get the file name
209 DragQueryFile(DropH, I, PChar(FileName), FileNameLength + 1);
210 // process file name (application specific)
211 // ... processing code here
212 //ShowMessage(FileName);
213 Clear;
214 Form1.ATVScrollbar.Position := 0;
215 Form1.ATHScrollbar.Position := 0;
216 Form1.ATHScrollbar.Max := 0;
217 Lines.LoadFromFile(FileName);
218 Form1.UpdateScrollbar;
219 SetFocus;
220 end;
221 // Optional: Get point at which files were dropped
222 DragQueryPoint(DropH, DropPoint);
223 // ... do something with drop point here
224 finally
225 // Tidy up - release the drop handle
226 // don't use DropH again after this
227 DragFinish(DropH);
228 end;
229 // Note we handled message
230 Msg.Result := 0;
231 Form1.Caption := 'ATScrollBar Memo Demo - ' + ExtractFileName(FileName);
232 Form1.PanelMemo.Invalidate;
233
234 end;
235
236 procedure TMemo.CNCommand(var Message: TWMCommand);
237 var
238 FirstVisibleLine, SBHPos: integer;
239 const
240 EndSpace = 12; //slight space for breathing room at end of scroll
241 begin
242
243 if Form1.RadioGroup1.ItemIndex = SystemSB then //custom SBs not used
244 exit;
245
246 //These messages let the memo scroll the custom scrollbar(s):
247
248 case Message.NotifyCode of
249 EN_VSCROLL :
250 begin
251 //OutputDebugString('EN_VSCROLL')
252 FirstVisibleLine := Perform(EM_GETFIRSTVISIBLELINE, 0, 0);
253
254 if assigned(Form1.ATVScrollbar) then
255 if Form1.ATVScrollbar.Position <> FirstVisibleLine then
256 Form1.ATVScrollbar.Position := FirstVisibleLine;
257 end;
258 EN_HSCROLL :
259 begin
260 //OutputDebugString('EN_HSCROLL')
261 SBHPos := Min(
262 (((CaretPos.X) * GetTextMetric(Self).tmAveCharWidth) -
263 Form1.ATHScrollbar.PageSize) + EndSpace,
264 Form1.ATHScrollbar.Max -
265 Form1.ATHScrollbar.PageSize + EndSpace);
266
267 Form1.ATHScrollbar.Position := SBHPos;
268
269 Invalidate;
270 end;
271 end;
272
273 inherited;
274
275 end;
276
277 procedure TMemo.WMHScroll(var Msg: TWMHScroll);
278 var
279 SInfo: TScrollInfo;
280 begin
281 //OutputDebugString('WM_HSCROLL') ;
282 inherited;
283
284 //Note: this is used in the demo to sync AT SB pos with system SB. Probably
285 //would not be used in a normal app but useful here:
286 if ScrollBars <> ssNone then
287 begin
288 SInfo.cbSize := SizeOf(SInfo);
289 SInfo.fMask := SIF_ALL;
290 GetScrollInfo(Handle, SB_HORZ, SInfo);
291 Form1.ATHScrollbar.Position := SInfo.nPos ;
292 exit;
293 end;
294
295 end;
296
297 procedure TMemo.WMVScroll(var Msg: TWMHScroll);
298 var
299 SInfo: TScrollInfo;
300 begin
301 //OutputDebugString('WM_HSCROLL') ;
302 inherited;
303
304 //Note: this is used in the demo to sync AT SB pos with system SB. Probably
305 //would not be used in a normal app but useful here:
306 if ScrollBars <> ssNone then
307 begin
308 SInfo.cbSize := SizeOf(SInfo);
309 SInfo.fMask := SIF_ALL;
310 GetScrollInfo(Handle, SB_VERT, SInfo);
311 Form1.ATVScrollbar.Position := SInfo.nPos ;
312 exit;
313 end;
314
315 end;
316
317 {MAIN FORM}
318
319 procedure TForm1.Button1Click(Sender: TObject);
320 begin
321 FontDialog1.Font := Memo1.Font;
322 if FontDialog1.Execute then
323 begin
324 Memo1.Font := FontDialog1.Font;
325 end;
326 UpdateScrollbar;
327 end;
328
329 procedure TForm1.SetScrollWidth(EndSpace:integer);
330 var
331 i, startLine, endLine, endPos: integer;
332 begin
333
334 if not Memo1.WordWrap then
335 begin
336 startLine := Memo1.Perform( EM_GETFIRSTVISIBLELINE,0,0 );
337 endLine := startLine + GetVisibleLineCount(Memo1);
338 for i := startLine to endLine do
339 begin
340 endPos :=
341 (Length(Memo1.Lines[i]) * GetTextMetric(Memo1).tmAveCharWidth) +
342 (EndSpace * GetTextMetric(Memo1).tmAveCharWidth);
343 if ATHScrollbar.Max < endPos then
344 ATHScrollbar.Max := endPos;
345 end;
346 ATHScrollbar.Visible :=
347 (Memo1.ClientWidth < ATHScrollbar.Max) and
348 (RadioGroup1.ItemIndex <> SystemSB)
349 end;
350
351 end;
352
353 procedure TForm1.UpdateScrollbar;
354 var
355 VisibleLineCount: integer;
356 NeedVert, NeedHorz: boolean;
357 SS: TScrollStyle;
358 begin
359
360 VisibleLineCount := GetVisibleLineCount(Memo1);
361
362 NeedVert := (Memo1.Lines.Count > VisibleLineCount);
363 NeedHorz :=
364 (not Memo1.WordWrap) and
365 (Memo1.ClientWidth < ATHScrollbar.Max); //ContentRect(Memo1).Width);
366
367 SS := ssNone;
368
369 if NeedVert then
370 SS := ssVertical;
371 if NeedHorz then
372 SS := ssHorizontal;
373 if NeedVert and NeedHorz then
374 SS := ssBoth;
375
376 {TMEMO}
377
378 // SYSTEM ///////
379 case RadioGroup1.ItemIndex of
380
381 CustomSB: begin // Custom Only
382 Memo1.ScrollBars := ssNone;
383 end;
384
385 SystemSB: begin // System Only
386 Memo1.ScrollBars := SS;
387 end;
388
389 BothSB: begin // System and Custom
390 Memo1.ScrollBars := SS;
391 end;
392
393 end;
394
395 // END SYSTEM ///////
396
397 // VERTICAL CUSTOM ///////
398
399 ATVScrollbar.Visible :=
400 NeedVert and (RadioGroup1.ItemIndex <> SystemSB);
401
402 if ATVScrollbar.Visible then
403 ATHScrollbar.Margins.Right := ATVScrollbar.Width
404 else
405 ATHScrollbar.Margins.Right := 0;
406
407 ATVScrollbar.Min:= 0;
408
409 ATVScrollbar.LargeChange := 3;
410 ATVScrollbar.PageSize := GetVisibleLineCount(Memo1);
411 ATVScrollbar.Max := Memo1.Lines.Count + 1;
412
413 // END VERTICAL CUSTOM ///////
414
415 // HORIZONTAL CUSTOM ///////
416 ATHScrollbar.Visible :=
417 NeedHorz and (RadioGroup1.ItemIndex <> SystemSB);
418
419 ATHScrollbar.Min:= 0;
420 //Minimum scroll arrow movement:
421 ATHScrollbar.SmallChange := GetTextMetric(Memo1).tmMaxCharWidth;
422 ATHScrollbar.LargeChange := ATHScrollbar.SmallChange * 3;
423
424 ATHScrollbar.PageSize := Memo1.ClientWidth;
425 //ATHScrollbar.Max := ContentRect(Memo1).Width + EndSpace;
426
427 SetScrollWidth;
428
429 // END HORIZONTAL CUSTOM ///////
430
431 ATVScrollbar.Invalidate;
432 ATHScrollbar.Invalidate;
433
434 //Wordwrap change apparently recreates window so we have to reset this here
435 //or file drops stop working:
436 DragAcceptFiles( Memo1.Handle, True );
437
438 end;
439
440 procedure TForm1.ApplicationEvents1Idle(Sender: TObject; var Done: Boolean);
441 var
442 FirstVisibleLine: integer;
443 begin
444
445 exit; //debug
446
447 if GetAsyncKeyState(VK_LBUTTON) > 0 then
448 begin
449 exit;
450 end;
451
452 FirstVisibleLine := Memo1.Perform(EM_GETFIRSTVISIBLELINE, 0, 0);
453
454 if ATVScrollbar.Position <> FirstVisibleLine then
455 ATVScrollbar.Position := FirstVisibleLine;
456
457 end;
458
459 procedure TForm1.cbWordWrapClick(Sender: TObject);
460 begin
461
462 Memo1.WordWrap := cbWordWrap.Checked;
463 //if Memo1.WordWrap then Memo1.ScrollBars := ssVertical
464 //else Memo1.ScrollBars := ssBoth;
465
466 Memo1.SetFocus;
467 UpdateScrollbar;
468
469 end;
470
471 procedure TForm1.cbDarkClick(Sender: TObject);
472 begin
473
474 if cbDark.Checked then
475 begin
476 Memo1.Color := $00323232;
477 Memo1.Font.Color := clWhite;
478 PanelRight.Color := clGray;
479 ATScrollbarTheme.ColorBG := $006c7073;
480 ATScrollbarTheme.ColorThumbFill := clGray;
481 ATScrollbarTheme.ColorThumbBorder := clWhite;
482 ATScrollbarTheme.ColorThumbFillOver := $000066ca;
483 ATScrollbarTheme.ColorThumbFillPressed := clSilver;
484 ATScrollbarTheme.ColorArrowFillOver:= $000066ca;
485 end
486 else
487 begin
488 Memo1.Color := clWindow;
489 Memo1.Font.Color := clWindowText;
490 PanelRight.Color := Memo1.Color;
491 ATScrollbarTheme.ColorBG := $d0d0d0;
492 ATScrollbarTheme.ColorThumbFill := $c0c0c0;
493 ATScrollbarTheme.ColorThumbBorder := $808080;
494 ATScrollbarTheme.ColorThumbFillOver := $d0d0d0;
495 ATScrollbarTheme.ColorThumbFillPressed := $e0c0c0;
496 ATScrollbarTheme.ColorArrowFillOver:= $d0d0d0;
497 end;
498
499 ATVScrollbar.Invalidate;
500 ATHScrollbar.Invalidate;
501
502 PanelMemo.Color := Memo1.Color;
503
504 end;
505
506 procedure TForm1.FormCreate(Sender: TObject);
507 var
508 aRect: TRect;
509 begin
510
511 DragAcceptFiles( Memo1.Handle, True );
512
513 ATScrollbarTheme.ThumbMinSize := GetSystemMetrics( SM_CXHTHUMB );
514
515 aRect := Rect(0,0,Memo1.ClientHeight, Memo1.ClientWidth);
516 Memo1.Perform(EM_SETRECT,0,Longint(@aRect));
517
518 Memo1.Clear;
519 Memo1.Lines.Add('Memo1: Drag and drop text files to open in the memo.');
520 Memo1.Lines.Add('');
521 Memo1.Lines.Add('Note: Every component is different, so what works here for ' +
522 'a TMemo may not work for a different component.');
523 Memo1.Lines.Add('');
524 Memo1.Lines.Add('Drag and Drop a text file on this TMemo to open.');
525
526 end;
527
528 type
529 TControlHack = class(TControl);
530 procedure TForm1.FormMouseWheel(Sender: TObject; Shift: TShiftState;
531 WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
532 var
533 i: Integer;
534 c: TControlHack;
535 begin
536
537 for i:=0 to ComponentCount-1 do
538 if Components[i] is TControl then begin
539 c:=TControlHack(Components[i]);
540 if PtInRect(c.ClientRect,c.ScreenToClient(MousePos)) then
541 begin
542 Handled:=c.DoMouseWheel(shift,WheelDelta,MousePos);
543
544 if (c = TControlHack(Memo1)) or (c = TControlHack(ATVScrollbar)) then
545 begin
546 if Memo1.CanFocus and Memo1.Showing then Memo1.SetFocus;
547 if not Memo1.Focused then exit;
548 if WheelDelta < 120 then //in [scPageDown, scLineDown] then
549 begin
550 //Memo1.Perform(EM_SCROLL,SB_LINEDOWN,0) //one line down
551 Memo1.Perform(EM_LineSCROLL,0, 1 );
552 //ATVScrollbar.Position := ATVScrollbar.Position + 3;
553 end
554 else //if ScrollCode in [scPageUp, scLineUp] then
555 begin
556 //Memo1.Perform(EM_SCROLL,SB_LINEUP,0); //one line up
557 Memo1.Perform(EM_LineSCROLL,0, -1 );
558 //ATVScrollbar.Position := ATVScrollbar.Position - 3;
559 end;
560 end;
561 end;
562 end;
563
564 //if ATVScrollbar.Position <> (Memo1.Perform(EM_GETFIRSTVISIBLELINE, 0, 0)) then
565 // ATVScrollbar.Position := Memo1.Perform(EM_GETFIRSTVISIBLELINE, 0, 0);
566
567 end;
568
569 procedure TForm1.FormResize(Sender: TObject);
570 begin
571 UpdateScrollbar;
572 end;
573
574 procedure TForm1.Memo1Change(Sender: TObject);
575 begin
576 UpdateScrollbar;
577 end;
578
579 procedure TForm1.RadioGroup1Click(Sender: TObject);
580 begin
581
582 UpdateScrollbar;
583
584 end;
585
586 procedure TForm1.ATVScrollbarChange(Sender: TObject);
587 begin
588
589 SetScrollWidth;
590 SendMessage(Memo1.Handle, WM_VSCROLL ,MAKEWPARAM( SB_THUMBTRACK,
591 ATVScrollbar.Position) ,0);
592
593
594 end;
595
596 procedure TForm1.ATHScrollbarChange(Sender: TObject);
597 begin
598
599 SendMessage(Memo1.Handle, WM_HSCROLL,MAKEWPARAM( SB_THUMBTRACK,
600 ATHScrollbar.Position ) ,0);
601
602 end;
603
604
605 end.
606