1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213: 214: 215: 216: 217: 218: 219: 220: 221: 222: 223: 224: 225: 226: 227: 228: 229: 230: 231: 232: 233: 234: 235: 236: 237: 238: 239: 240: 241: 242: 243: 244: 245: 246: 247: 248: 249: 250: 251: 252: 253: 254: 255: 256: 257: 258: 259: 260: 261: 262: 263: 264: 265: 266: 267: 268: 269: 270: 271: 272: 273: 274: 275: 276: 277: 278: 279: 280: 281: 282: 283: 284: 285: 286: 287: 288: 289: 290: 291: 292: 293: 294: 295: 296: 297: 298: 299: 300: 301: 302: 303: 304: 305: 306: 307: 308: 309: 310: 311: 312: 313: 314: 315: 316: 317: 318: 319: 320: 321: 322: 323: 324: 325: 326: 327: 328: 329: 330: 331: 332: 333: 334: 335: 336: 337: 338: 339: 340: 341: 342: 343: 344: 345: 346: 347: 348: 349: 350: 351: 352: 353: 354: 355: 356: 357: 358: 359: 360: 361: 362: 363: 364: 365: 366: 367: 368: 369: 370: 371: 372: 373: 374: 375: 376: 377: 378: 379: 380: 381: 382: 383: 384: 385: 386: 387: 388: 389: 390: 391: 392: 393: 394: 395: 396: 397: 398: 399: 400: 401: 402: 403: 404: 405: 406: 407: 408: 409: 410: 411: 412: 413: 414: 415: 416: 417: 418: 419: 420: 421: 422: 423: 424: 425: 426: 427: 428: 429: 430: 431: 432: 433: 434: 435: 436: 437: 438: 439: 440: 441: 442: 443: 444: 445: 446: 447: 448: 449: 450: 451: 452: 453: 454: 455: 456: 457: 458: 459: 460: 461: 462: 463: 464: 465: 466: 467: 468: 469: 470: 471: 472: 473: 474: 475: 476: 477: 478: 479: 480: 481: 482: 483: 484: 485: 486: 487: 488: 489: 490: 491: 492: 493: 494: 495: 496: 497: 498: 499: 500: 501: 502: 503: 504: 505: 506: 507: 508: 509: 510: 511: 512: 513: 514: 515: 516: 517: 518: 519: 520: 521: 522: 523: 524: 525: 526: 527: 528: 529: 530: 531: 532: 533: 534: 535: 536: 537: 538: 539: 540: 541: 542: 543: 544: 545: 546: 547: 548: 549: 550: 551: 552: 553: 554: 555: 556: 557: 558: 559: 560: 561: 562: 563: 564: 565: 566: 567: 568: 569: 570: 571: 572: 573: 574: 575: 576: 577: 578: 579: 580: 581: 582: 583: 584: 585: 586: 587: 588: 589: 590: 591: 592: 593: 594: 595: 596: 597: 598: 599: 600: 601: 602: 603: 604: 605: 606: 607: 608: 609: 610: 611: 612: 613: 614: 615: 616: 617: 618: 619: 620: 621: 622: 623: 624: 625: 626: 627: 628: 629: 630: 631: 632: 633: 634: 635: 636: 637: 638: 639: 640: 641: 642: 643: 644: 645: 646: 647: 648: 649: 650: 651: 652: 653: 654: 655: 656: 657: 658: 659: 660: 661: 662: 663: 664: 665: 666: 667: 668: 669: 670: 671: 672: 673: 674: 675: 676: 677: 678:
|
unit EnhancedCtrl;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Menus, ComCtrls, StdCtrls, ShellAPI, CommCtrl, ExtCtrls, ClipBrd, Forms;
type TEnhancedCtrl = class(TGraphicControl) private FMove, FSystemMenu, FFullConstraints, FTransparent, FHideTitleBar, FActive, Start: Boolean; FRoundCornerX, FRoundCornerY: Byte; FControl: TWinControl; FLeft, FTop, FRight, FBottom: Word; FLinkLabel: TLabel; FBackGrdColor1, FBackGrdColor2: TColor; protected procedure Paint; override; procedure SetMove(const Value: Boolean); procedure SetSystemMenu(const Value: Boolean); procedure SetFullConstraints(const Value: Boolean); procedure SetTransparent(const Value: Boolean); procedure SetHideTitleBar(const Value: Boolean); procedure SetActive(const Value: Boolean); procedure SetLinkLabel(Value: TLabel); procedure SetRoundCornerX(Value: Byte); procedure SetRoundCornerY(Value: Byte); procedure SetLeft(Value: Word); procedure SetTop(Value: Word); procedure SetRight(Value: Word); procedure SetBottom(Value: Word); procedure SetControl(Value: TWinControl); procedure SetBackGrdColor1(Value: TColor); procedure SetBackGrdColor2(Value: TColor); procedure DrawGradient(Canvas: TCanvas; Color1, Color2: TColor; Rect: TRect); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; procedure ScreenShot; procedure ToolTip(hwnd: DWORD; IconType: Integer; Text, Title: String); procedure MenuRight(const Value: Byte); procedure CursorRect(Value: Boolean); property CanMove: Boolean read FMove write SetMove; property EnableSystemMenu: Boolean read FSystemMenu write SetSystemMenu; property FullConstraints: Boolean read FFullConstraints write SetFullConstraints; property Transparent: Boolean read FTransparent write SetTransparent; property HideTitleBar: Boolean read FHideTitleBar write SetHideTitleBar; property Active: Boolean read FActive write SetActive; property LinkLabel: TLabel read FLinkLabel write SetLinkLabel; property RoundCornerX: Byte read FRoundCornerX write SetRoundCornerX; property RoundCornerY: Byte read FRoundCornerY write SetRoundCornerY; property RoundWinLeft: Word read FLeft write SetLeft; property RoundWinTop: Word read FTop write SetTop; property RoundWinRight: Word read FRight write SetRight; property RoundWinBottom: Word read FBottom write SetBottom; property Control: TWinControl read FControl write SetControl; property BackGrdColor1: TColor read FBackGrdColor1 write SetBackGrdColor1; property BackGrdColor2: TColor read FBackGrdColor2 write SetBackGrdColor2; property Align; property OnClick; property OnDblClick; property OnResize; property ShowHint; property OnMouseDown; property OnMouseMove; property OnMouseUp; property Enabled; property PopupMenu; end;
procedure Register;
implementation
procedure TEnhancedCtrl.Paint; var region: HRgn; begin inherited Paint;
Control := Parent;
try FLeft := RoundWinLeft; FTop := RoundWinTop; FRight := RoundWinRight; FBottom := RoundWinBottom;
if not (csDesigning in ComponentState) then with Owner as TForm do begin Region := CreateEllipticRgn(FLeft,FTop,FRight,FBottom); SetWindowRgn(Handle, region, True); end; except ; end;
if not (FBackGrdColor1 = Parent.Brush.Color) or not (FBackGrdColor2 = Parent.Brush.Color) then if not (csDesigning in ComponentState) then DrawGradient(Canvas, FBackGrdColor1, FBackGrdColor2, ClientRect);
Canvas.Brush.Color := Color; Canvas.Pen.Color := clBlack;
with Canvas do begin Pen.Style := psDash; Brush.Style := bsClear; if csDesigning in ComponentState then Rectangle(0, 0, Width, Height) else FillRect(ClipRect); end;
if FTransparent then SetTransparent(FTransparent); end;
procedure TEnhancedCtrl.SetMove(const Value: Boolean); begin if Value then if not (LinkLabel = nil) then SetLinkLabel(nil); FMove := Value; end;
procedure TEnhancedCtrl.SetSystemMenu(const Value: Boolean); begin FSystemMenu := Value; if Value then PopupMenu := nil; end;
procedure TEnhancedCtrl.SetFullConstraints(const Value: Boolean); begin FFullConstraints := Value;
if not Value then SetTransparent(False);
if not FFullConstraints or not FActive then exit;
FHideTitleBar := HideTitleBar;
with Owner as TForm do try Constraints.MaxHeight := Height; Constraints.MinHeight := Height; Constraints.MaxWidth := Width; Constraints.MinWidth := Width; except ; end; end;
procedure TEnhancedCtrl.SetTransparent(const Value: Boolean); var Margin, X, Y, CtlX, CtlY: Integer; ClientRgn, FullRgn, CtlRgn: HRGN; begin if not ((Owner as TForm).Menu = nil) and Value then if Parent is TForm then (Owner as TForm).Menu := nil;
FTransparent := Value;
if Value then SetFullConstraints(True);
if (csDesigning in ComponentState) or not FActive then exit;
try if not FTransparent then begin with Parent do begin FullRgn := CreateRectRgn(0, 0, Width, Height); CombineRgn(FullRgn, FullRgn, FullRgn, RGN_COPY); SetWindowRgn(Handle, FullRgn, True); end; exit; end; except exit; end;
try with Parent do begin Margin := (Width - ClientWidth) div 2; FullRgn := CreateRectRgn(0, 0, Width, Height); X := Margin; Y := Height - ClientHeight - Margin; ClientRgn := CreateRectRgn(X, Y, X + ClientWidth, Y + ClientHeight); CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF);
CtlX := X + Left+Width; CtlY := Y + Top+Height; CtlRgn := CreateRectRgn(CtlX, CtlY, CtlX + Width, CtlY + Height); CombineRgn(FullRgn, FullRgn, CtlRgn, RGN_OR); SetWindowRgn(Handle, FullRgn, True); end; except ; end; end;
procedure TEnhancedCtrl.SetHideTitleBar(const Value: Boolean); var Style: Longint; begin FHideTitleBar := Value; if (csDesigning in ComponentState) or not FActive then exit;
try if not FHideTitleBar then begin with Owner as TForm do begin if BorderStyle = bsNone then Exit; Style := GetWindowLong(Handle, GWL_STYLE); if (Style and WS_CAPTION) <> WS_CAPTION then begin case BorderStyle of bsSingle, bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style or WS_CAPTION or WS_BORDER); bsDialog: SetWindowLong(Handle, GWL_STYLE, Style or WS_CAPTION or DS_MODALFRAME or WS_DLGFRAME); end; Height := Height + GetSystemMetrics(SM_CYCAPTION); Refresh; end; exit; end; end; except exit; end;
try with Owner as TForm do begin if BorderStyle = bsNone then Exit; Style := GetWindowLong(Handle, GWL_STYLE); if (Style and WS_CAPTION) = WS_CAPTION then begin case BorderStyle of bsSingle, bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style and (not (WS_CAPTION)) or WS_BORDER); bsDialog: SetWindowLong(Handle, GWL_STYLE, Style and (not (WS_CAPTION)) or DS_MODALFRAME or WS_DLGFRAME); end; Height := Height - GetSystemMetrics(SM_CYCAPTION); Refresh; end; end; except ; end; end;
procedure TEnhancedCtrl.SetActive(const Value: Boolean); begin FActive := Value; end;
procedure TEnhancedCtrl.SetLinkLabel(Value: TLabel); begin if not Active then exit;
if not (Value = nil) then begin SetMove(False); FLinkLabel := Value; FLinkLabel.SendToBack; FLinkLabel.Font.Color := clBlue; FLinkLabel.Font.Style := FLinkLabel.Font.Style+[fsUnderline]; end else FLinkLabel := nil; end;
procedure TEnhancedCtrl.ScreenShot; var DeskWnd: HWnd; DeskDC: HDC; DeskCv: TCanvas; R: TRect; W, H: Integer; Bmp: TBitmap; begin if not FActive then exit;
Bmp := TBitmap.Create; DeskWnd := GetDesktopWindow; DeskDC := GetWindowDC(DeskWnd); DeskCv := TCanvas.Create; DeskCv.Handle := DeskDC; W := Screen.Width; H := Screen.Height; R := Bounds(0, 0, W, H); try Bmp.HandleType := bmDIB; Bmp.PixelFormat := pf24Bit; Bmp.Width := W; Bmp.Height := H; Bmp.Canvas.CopyMode := cmSrcCopy; Bmp.Canvas.CopyRect(R, DeskCv, R); finally DeskCv.Free; ReleaseDC(DeskWnd, DeskDC); end;
ClipBoard.Assign(Bmp); Bmp.Free; end;
procedure TEnhancedCtrl.ToolTip(hwnd: DWORD; IconType: Integer; Text, Title: String); var Item: THandle; Rect: TRect; lpti: PToolInfo; hTooltip: Cardinal; ti: TToolInfo; buffer : array[0..255] of char; const TTS_BALLOON = $40; TTM_SETTITLE = (WM_USER + 32); begin if not FActive then exit;
hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON, Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Application.Handle, 0, hInstance, nil); if hToolTip <> 0 then begin SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE); ti.cbSize := SizeOf(TToolInfo); ti.uFlags := TTF_SUBCLASS; ti.hInst := hInstance; end;
Item := hWnd; if (Item <> 0) and (Windows.GetClientRect(Item, Rect)) then begin lpti := @ti; lpti.hwnd := Item; lpti.Rect := Rect; lpti.lpszText := PChar(Text); SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti)); FillChar(buffer, SizeOf(buffer), #0); lstrcpy(buffer, PChar(Title)); if (IconType > 3) or (IconType < 0) then IconType := 0; SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer)); end; end;
procedure TEnhancedCtrl.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited;
if not Active or (FLinkLabel = nil) then exit;
try if ((X >= LinkLabel.Left) and (X < LinkLabel.Left+LinkLabel.Width)) and ((Y >= LinkLabel.Top) and (Y < LinkLabel.Top+LinkLabel.Height)) then ShellExecute(Application.Handle, 'open', PChar(LinkLabel.Caption), nil, nil, SW_ShowNormal); except ; end;
FLinkLabel.BringToFront; end;
procedure TEnhancedCtrl.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited;
if not Active or (FLinkLabel = nil) then exit;
if ((X >= LinkLabel.Left) and (X < LinkLabel.Left+LinkLabel.Width)) and ((Y >= LinkLabel.Top) and (Y < LinkLabel.Top+LinkLabel.Height)) then SetCursor(LoadCursor(0, IDC_HAND)); end;
procedure TEnhancedCtrl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); const sc_dragmove = $f012; const WM_POPUPSYSTEMMENU = $313; begin inherited;
if not FActive then exit;
if FSystemMenu then if ssRight in Shift then SendMessage(Application.Handle, WM_POPUPSYSTEMMENU, 0, MakeLong(Mouse.CursorPos.X, Mouse.CursorPos.Y));
if FMove then if ssLeft in Shift then begin ReleaseCapture; Parent.Perform(wm_syscommand,sc_dragmove, 0); end; end;
procedure TEnhancedCtrl.SetRoundCornerX(Value: Byte); var Rgn : HRGN; begin if not FActive then exit;
if FRoundCornerY <= 0 then FRoundCornerY := FRoundCornerX; FRoundCornerX := Value; if Value <= 0 then exit;
with Parent do begin Rgn := CreateRoundRectRgn(0,0,Width,Height,FRoundCornerX,FRoundCornerY); SetWindowRgn(Handle, Rgn, True); end; end;
procedure TEnhancedCtrl.SetRoundCornerY(Value: Byte); var Rgn : HRGN; begin if not FActive then exit;
if FRoundCornerX <= 0 then FRoundCornerX := FRoundCornerY; FRoundCornerY := Value; if Value <= 0 then exit;
with Parent do begin Rgn := CreateRoundRectRgn(0,0,Width,Height,FRoundCornerX,FRoundCornerY); SetWindowRgn(Handle, Rgn, True); end; end;
procedure TEnhancedCtrl.SetLeft(Value: Word); begin FLeft := Value; end;
procedure TEnhancedCtrl.SetTop(Value: Word); begin FTop := Value; end;
procedure TEnhancedCtrl.SetRight(Value: Word); begin FRight := Value; end;
procedure TEnhancedCtrl.SetBottom(Value: Word); begin FBottom := Value; end;
procedure TEnhancedCtrl.SetControl(Value: TWinControl); begin if Value = nil then Value := Parent; FControl := Value; Parent := FControl;
if not ((Owner as TForm).Menu = nil) and FTransParent then if Parent is TForm then (Owner as TForm).Menu := nil;
if Start then begin Start := False; FBackGrdColor1 := Parent.Brush.Color; FBackGrdColor2 := Parent.Brush.Color; end; end;
procedure TEnhancedCtrl.DrawGradient(Canvas: TCanvas; Color1, Color2: TColor; Rect: TRect); var Y, R, G, B: Integer; begin for Y := Rect.Top to Rect.Bottom do begin R := Round(GetRValue(Color1) + ((GetRValue(Color2) - GetRValue(Color1)) * Y / (Rect.Bottom - Rect.Top))); G := Round(GetGValue(Color1) + ((GetGValue(Color2) - GetGValue(Color1)) * Y / (Rect.Bottom - Rect.Top))); B := Round(GetBValue(Color1) + ((GetBValue(Color2) - GetBValue(Color1)) * Y / (Rect.Bottom - Rect.Top)));
Canvas.Pen.Color := RGB(R, G, B); Canvas.Pen.Width := 2; Canvas.Pen.Style := psInsideFrame;
Canvas.MoveTo(Rect.Left, Y); Canvas.LineTo(Rect.Right, Y); end; end;
procedure TEnhancedCtrl.SetBackGrdColor1(Value: TColor); begin FBackGrdColor1 := Value; if csDesigning in ComponentState then exit; DrawGradient(Canvas, FBackGrdColor1, FBackGrdColor2, ClientRect); end;
procedure TEnhancedCtrl.SetBackGrdColor2(Value: TColor); begin FBackGrdColor2 := Value; if csDesigning in ComponentState then exit; DrawGradient(Canvas, FBackGrdColor1, FBackGrdColor2, ClientRect); end;
procedure TEnhancedCtrl.MenuRight(const Value: Byte); var m: TMenuItemInfo; h: hMenu; s: String; begin with Owner as TForm do begin h := GetMenu(Handle); m.cbSize := SizeOf(m); m.cch := SizeOf(s); m.dwTypeData := PChar(@s[1]); m.fMask := MIIM_TYPE;
GetMenuItemInfo(h,Value,true,m); m.ftype := m.ftype or MFT_RIGHTJUSTIFY; SetMenuItemInfo(h,Value,true,m); Refresh; end; end;
procedure TEnhancedCtrl.CursorRect(Value: Boolean); var MouseRect: TRect; begin try with Parent as TForm do begin if Value then begin MouseRect := Rect(Left,Top,Left+Width,Top+Height); ClipCursor(@MouseRect); end else ClipCursor(nil); end; except ; end; end;
constructor TEnhancedCtrl.Create(AOwner: TComponent); begin inherited; Align := alClient; Enabled := True; FActive := True; Active := True; Start := True; end;
destructor TEnhancedCtrl.Destroy; begin inherited Destroy; end;
procedure Register; begin RegisterComponents('Samples', [TEnhancedCtrl]); end;
end. |