Delphi 滾動條的自繪

原創 dbyoung 2019-07-30 20:52

一開始想讓 TListview 滾動條好看一點，進行自繪嘗試。
寫着寫着就發現，這應該是個通用的類。
想想也是應該的。WINDOWS所有控件的滾動條原理都是一樣的。
本自繪滾動條類，是通用類，可針對所有WINDOWS控件(除了IE滾動條)。
本自繪滾動條類，是替換了WINDOWS控件的原來的滾動條，用 TPanel 代替，在 TPanel 中進行自繪滾動條。
代碼如下：

unit untFMScrollBar;
{
  [email protected]
  2012-06-02
}

interface

uses Windows, Classes, Graphics, Controls, Messages, ExtCtrls, PngImage, Forms;

type
  TScrollBarPos = record
    Btn: Integer;
    ScrollArea: Integer;
    Thumb: Integer;
    ThumbPos: Integer;
    MsgID: Integer;
  end;

  TScrollBarState = (ssNormal, ssHover, ssClick);

type
  TDBScrollBar = class(TCustomPanel)
  private
    procedure WMLButtonDown(var aMsg: TMessage);    message WM_LButtonDown;
    procedure WMMouseMove(var aMsg: TMessage);      message WM_MouseMove;
    procedure WMMouseLeave(var aMsg: TMessage);     message WM_MouseLeave;
    procedure WMLButtonDBClick(var aMsg: TMessage); message WM_LBUTTONDBLCLK;
    procedure WMLButtonUp(var aMsg: TMessage);      message WM_LButtonUp;
    procedure WMERASEBKGND(var Msg: TMessage);      message WM_ERASEBKGND;
  protected
    FLen                    : Integer;
    FthumbTop, Fthumbbottom : Integer;
    FOffsetSC, Ftrackp      : tpoint;
    Ftrackthumb             : Integer;
    FLButtonDown            : Boolean;
    FsbDir                  : Integer;
    FScrollPos              : Integer;
    procedure Paint; override;
    procedure GetThumb(rc: TRect);
    function GetScrollPos(p: tpoint): Integer;
  public
    FCW       : Integer;
    FhWnd     : THandle;
    FControl  : TWincontrol;
    FsbType   : byte;
    FsbRect   : TRect;
    FsbVisible: Boolean;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Attach(aControl: TWincontrol; aType: byte);
    procedure AttachhWnd(ahWnd: THandle; aType: byte);
    procedure SetPosition(ahWnd: THandle);
    procedure ButtonUp;
    procedure HideScrollbar;
  end;

  TFMControl = class(TComponent)
  protected
    procedure Default(var Msg: TMessage);
    procedure Invalidate;
  public
    FhWnd       : hWnd;
    FOldWndProc : TWndMethod;
    FControl    : TWincontrol;
    procedure FillBG( dc:HDC; rc:TRect);
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure NewWndProc(var Message: TMessage);
    procedure AfterProc(var Message: TMessage); virtual;
    procedure PaintControl(aDC: HDC = 0); virtual;
    procedure DrawControl(aDC: HDC; rc: TRect); virtual;
  end;

  TFMScrollBar = class(TFMControl)
  protected
    procedure SetScrollbarPos(Message: TMessage);
  public
    Fhb, Fvb: TDBScrollBar;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure InitScrollbar(aControl: TWincontrol);
    procedure DrawControl(dc: HDC; rc: TRect); override;
    procedure AfterProc(var Message: TMessage); override;
  end;
{$R *.res}

implementation

const
  iResHeight    = 16;

var
  PngSB: TPngImage;

function Point(AX, AY: Integer): tpoint;
begin
  Result.X := AX;
  Result.Y := AY;
end;

function MakeRect(Left, Top, Width, Height: Integer): TRect;
begin
  Result.Left   := Left;
  Result.Top    := Top;
  Result.Right  := Left + Width;
  Result.Bottom := Top + Height;
end;

procedure DrawRect(DestDC: HDC; DestRect: TRect; SrcDC: HDC; SrcX: Integer; SrcY: Integer);
begin
  BitBlt(DestDC, DestRect.Left, DestRect.Top, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top, SrcDC, SrcX, SrcY, SRCCOPY);
end;

procedure StretchRect(DestDC: HDC; DestRect: TRect; SrcDC: HDC; SrcRect: TRect);
begin
  StretchBlt(DestDC, DestRect.Left, DestRect.Top, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top, SrcDC, SrcRect.Left, SrcRect.Top, SrcRect.Right - SrcRect.Left, SrcRect.Bottom - SrcRect.Top, SRCCOPY);
end;

const
  intOffsetX = 2;

{ 上箭頭 }
procedure DrawArrowUp(Canvas: TCanvas; sRect: TRect; sbState: TScrollBarState);
begin
  case sbState of
    ssNormal:
      Canvas.CopyRect(Rect(intOffsetX, 0, iResHeight + intOffsetX, iResHeight), PngSB.Canvas, Rect(0, 0, iResHeight, iResHeight));
    ssHover:
      Canvas.CopyRect(Rect(intOffsetX, 0, iResHeight + intOffsetX, iResHeight), PngSB.Canvas, Rect(iResHeight * 4, 0, iResHeight + iResHeight * 4, iResHeight));
    ssClick:
      Canvas.CopyRect(Rect(intOffsetX, 0, iResHeight + intOffsetX, iResHeight), PngSB.Canvas, Rect(iResHeight * 8, 0, iResHeight + iResHeight * 8, iResHeight));
  end;
end;

{ 下箭頭 }
procedure DrawArrowDown(Canvas: TCanvas; sRect: TRect; sbState: TScrollBarState);
begin
  case sbState of
    ssNormal:
      Canvas.CopyRect(Rect(intOffsetX, sRect.Bottom - iResHeight, iResHeight + intOffsetX, sRect.Bottom), PngSB.Canvas, Rect(16, 0, iResHeight + 16, iResHeight));
    ssHover:
      Canvas.CopyRect(Rect(intOffsetX, sRect.Bottom - iResHeight, iResHeight + intOffsetX, sRect.Bottom), PngSB.Canvas, Rect(iResHeight * 5, 0, iResHeight + iResHeight * 5, iResHeight));
    ssClick:
      Canvas.CopyRect(Rect(intOffsetX, sRect.Bottom - iResHeight, iResHeight + intOffsetX, sRect.Bottom), PngSB.Canvas, Rect(iResHeight * 9, 0, iResHeight + iResHeight * 9, iResHeight));
  end;
end;

{ 左箭頭 }
procedure DrawArrowLeft(Canvas : TCanvas; sRect : TRect; sbState : TScrollBarState);
begin
  case sbState of
    ssNormal:
      Canvas.CopyRect(Rect(intOffsetX + 2, intOffsetX, intOffsetX + 2 + iResHeight, intOffsetX + iResHeight), PngSB.Canvas, Rect(iResHeight * 13, 0, iResHeight + iResHeight * 13, iResHeight));
    ssHover:
      Canvas.CopyRect(Rect(intOffsetX + 2, intOffsetX, intOffsetX + 2 + iResHeight, intOffsetX + iResHeight), PngSB.Canvas, Rect(iResHeight * 15, 0, iResHeight + iResHeight * 15, iResHeight));
    ssClick:
      Canvas.CopyRect(Rect(intOffsetX + 2, intOffsetX, intOffsetX + 2 + iResHeight, intOffsetX + iResHeight), PngSB.Canvas, Rect(iResHeight * 17, 0, iResHeight + iResHeight * 17, iResHeight));
  end;
end;

{ 右箭頭 }
procedure DrawArrowRight(Canvas : TCanvas; sRect : TRect; sbState : TScrollBarState);
begin
  case sbState of
    ssNormal:
      Canvas.CopyRect(Rect(sRect.Right - iResHeight, intOffsetX, sRect.Right, intOffsetX + iResHeight), PngSB.Canvas, Rect(iResHeight * 12, 0, iResHeight + iResHeight * 12, iResHeight));
    ssHover:
      Canvas.CopyRect(Rect(sRect.Right - iResHeight, intOffsetX, sRect.Right, intOffsetX + iResHeight), PngSB.Canvas, Rect(iResHeight * 14, 0, iResHeight + iResHeight * 14, iResHeight));
    ssClick:
      Canvas.CopyRect(Rect(sRect.Right - iResHeight, intOffsetX, sRect.Right, intOffsetX + iResHeight), PngSB.Canvas, Rect(iResHeight * 16, 0, iResHeight + iResHeight * 16, iResHeight));
  end;
end;

{ 垂直滾動條 }
procedure DrawThumbVB(Canvas: TCanvas; sRect: TRect; sbState: TScrollBarState);
begin
  case sbState of
    ssNormal:
      begin
        Canvas.Pen.Color   := RGB(169, 169, 169);
        Canvas.Brush.Color := RGB(169, 169, 169);
        Canvas.Brush.Style := bsSolid;
        Canvas.RoundRect(sRect.Left + 6, sRect.Top, sRect.Right - 4, sRect.Bottom, 4, 4);
      end;
    ssHover:
      begin
        Canvas.Pen.Color   := RGB(139, 139, 139);
        Canvas.Brush.Color := RGB(139, 139, 139);
        Canvas.Brush.Style := bsSolid;
        Canvas.RoundRect(sRect.Left + 6, sRect.Top, sRect.Right - 4, sRect.Bottom, 4, 4);
      end;
    ssClick:
      begin
        Canvas.Pen.Color   := RGB(107, 109, 108);
        Canvas.Brush.Color := RGB(107, 109, 108);
        Canvas.Brush.Style := bsSolid;
        Canvas.RoundRect(sRect.Left + 6, sRect.Top, sRect.Right - 4, sRect.Bottom, 4, 4);
      end;
  end;
end;

{ 水平滾動條 }
procedure DrawThumbHB(Canvas: TCanvas; sRect: TRect; sbState: TScrollBarState);
begin
  case sbState of
    ssNormal:
      begin
        Canvas.Pen.Color   := RGB(169, 169, 169);
        Canvas.Brush.Color := RGB(169, 169, 169);
        Canvas.Brush.Style := bsSolid;
        Canvas.RoundRect(sRect.Left + 4, sRect.Top + 6, sRect.Right - 4, sRect.Bottom - 4, 4, 4);
      end;
    ssHover:
      begin
        Canvas.Pen.Color   := RGB(139, 139, 139);
        Canvas.Brush.Color := RGB(139, 139, 139);
        Canvas.Brush.Style := bsSolid;
        Canvas.RoundRect(sRect.Left + 4, sRect.Top + 6, sRect.Right - 4, sRect.Bottom - 4, 4, 4);
      end;
    ssClick:
      begin
        Canvas.Pen.Color   := RGB(107, 109, 108);
        Canvas.Brush.Color := RGB(107, 109, 108);
        Canvas.Brush.Style := bsSolid;
        Canvas.RoundRect(sRect.Left + 4, sRect.Top + 6, sRect.Right - 4, sRect.Bottom - 4, 4, 4);
      end;
  end;
end;

{ 滾動條垂直背景 }
procedure DrawTrackVB(Canvas: TCanvas; sRect: TRect);
begin
  Canvas.Pen.Color   := RGB(216, 215, 213);
  Canvas.Brush.Color := RGB(216, 215, 213);
  Canvas.Brush.Style := bsSolid;
  Canvas.RoundRect(6, iResHeight, 6 + 7, sRect.Bottom, 4, 4);
end;

{ 滾動條水平背景 }
procedure DrawTrackHB(Canvas: TCanvas; sRect: TRect);
begin
  Canvas.Pen.Color   := RGB(216, 215, 213);
  Canvas.Brush.Color := RGB(216, 215, 213);
  Canvas.Brush.Style := bsSolid;
  Canvas.RoundRect(sRect.Left + 6, sRect.Top + 6, sRect.Right - 4, sRect.Bottom - 4, 4, 4);
end;

{ TFMControl }

procedure TFMControl.AfterProc(var Message: TMessage);
begin
  case message.Msg of
    WM_Paint:                       PaintControl(message.WParam);
    WM_KILLFOCUS, WM_SETFOCUS:      Invalidate;
    WM_SETTEXT:                     Invalidate;
    WM_ENABLE, CM_ENABLEDCHANGED:   Invalidate;
  end;
end;

constructor TFMControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FhWnd := 0;
  FControl := nil;
end;

procedure TFMControl.Default(var Msg: TMessage);
begin
  if Assigned(FOldWndProc) then
    FOldWndProc(Msg);
end;

destructor TFMControl.Destroy;
begin
  if Assigned(FOldWndProc) then
  begin
    if FControl <> nil then
      FControl.WindowProc := FOldWndProc;

    FOldWndProc := nil;
  end;

  inherited Destroy;
end;

procedure TFMControl.DrawControl(aDC: HDC; rc: TRect);
begin

end;

procedure TFMControl.FillBG(dc: HDC; rc: TRect);
var
  Brush: HBrush;
begin
  Brush := CreateSolidBrush(RGB(236,233,216));
  try
    fillrect(dc,rc,brush);
  finally
    DeleteObject(Brush);
  end;
end;

procedure TFMControl.Invalidate;
begin
  if (FhWnd > 0) then
  begin
    InvalidateRect(FhWnd, nil, True);
    UpdateWindow(FhWnd);
  end;
end;

procedure TFMControl.NewWndProc(var Message: TMessage);
begin
  Default(Message);
  AfterProc(message);
end;

procedure TFMControl.PaintControl(aDC: HDC = 0);
var
  dc: HDC;
  Rect: TRect;
begin
  if GetWindowRect(FhWnd, Rect) then
  begin
    try
      OffsetRect(Rect, -Rect.Left, -Rect.Top);
      if (aDC = 0) then
      begin
        dc := GetWindowDC(FhWnd);
        try
          DrawControl(dc, Rect);
        finally
          ReleaseDC(FhWnd, dc);
        end;
      end
      else
        DrawControl(aDC, Rect);
    except
    end;
  end;
end;

{ TDBScrollBar }

procedure TDBScrollBar.Attach(aControl: TWincontrol; aType: byte);
begin
  FhWnd         := aControl.Handle;
  FControl      := aControl;
  FsbType       := aType;
  FsbDir        := FsbType;
  ParentWindow  := GetParent(FhWnd);
  SetPosition(FhWnd);
end;

procedure TDBScrollBar.AttachhWnd(ahWnd: THandle; aType: byte);
begin
  FhWnd     := ahWnd;
  FControl  := nil;
  FsbType   := aType;
  FsbDir    := FsbType;

  ParentWindow := GetParent(FhWnd);
  SetPosition(FhWnd);
end;

procedure TDBScrollBar.ButtonUp;
begin
  FLButtonDown := False;
  ReleaseCapture;
  if FsbType = SB_CTL then
    Invalidate;
end;

constructor TDBScrollBar.Create(AOwner: TComponent);
begin
  FControl := nil;
  FCW      := GetSystemMetrics(SM_CXHSCROLL);
  FhWnd    := 0;
  inherited Create(AOwner);
  FScrollPos := -1;
end;

destructor TDBScrollBar.Destroy;
begin
  inherited Destroy;
end;

{ 獲取滾動條狀態 }
function TDBScrollBar.GetScrollPos(p: tpoint): Integer;
var
  X: Integer;
begin
  if FsbDir = SB_Horz then
    X := p.X
  else
    X := p.Y;

  if X < FCW then
    Result := SB_LINEUP
  else if X < FthumbTop then
    Result := SB_PAGEUP
  else if X < Fthumbbottom then
    Result := SB_THUMBTRACK
  else if X < FLen - FCW then
    Result := SB_PAGEDOWN
  else
    Result := SB_LINEDOWN;
end;

{ 獲取滾動條滾動的位置 }
procedure TDBScrollBar.GetThumb(rc: TRect);
var
  p   : tpoint;
  size: Integer;
begin
  GetCursorPos(p);
  size := Fthumbbottom - FthumbTop;
  FthumbTop := Ftrackthumb;
  if (FsbDir = sb_Vert) then
    inc(FthumbTop, p.Y - Ftrackp.Y)
  else
    inc(FthumbTop, p.X - Ftrackp.X);

  if FthumbTop < FCW then
    FthumbTop := FCW;
  if FthumbTop > FLen - FCW - size then
    FthumbTop := FLen - FCW - size;
  Fthumbbottom := FthumbTop + size;
end;

{ 隱藏滾動條 }
procedure TDBScrollBar.HideScrollbar;
begin
  ShowWindow(Handle, SW_HIDE);
  FsbVisible := False;
  visible    := False;
end;

{ 重繪 }
procedure TDBScrollBar.Paint;
var
  rc, rc1, rc2: TRect;
  BarInfo     : tagScrollBarInfo;
  sbEnable    : Boolean;
  Temp        : TBitmap;
  bw, sWidth  : Integer;
  b           : Boolean;
begin
  sWidth := 0;

  { 獲取滾動條信息 }
  b := False;
  FillChar(BarInfo, sizeof(BarInfo), #0);
  BarInfo.cbSize := sizeof(BarInfo);
  if FsbType = SB_VERT then
    b := GetScrollBarInfo(FhWnd, Integer(OBJID_VSCROLL), BarInfo)
  else if FsbType = SB_HORZ then
    b := GetScrollBarInfo(FhWnd, Integer(OBJID_HSCROLL), BarInfo);
  if not b then
    Exit;

  { 滾動條是否可見 }
  if (BarInfo.rgstate[0] and STATE_SYSTEM_INVISIBLE) > 0 then
    Exit;

  rc := BarInfo.rcScrollBar;
  OffsetRect(rc, -rc.Left, -rc.Top);
  if (rc.Bottom < 0) or (rc.Right < 0) then
    Exit;

  if (rc.Bottom > Height) or (rc.Right > Width) then
    Exit;

  if FsbType = sb_Vert then
    FLen := rc.Bottom
  else
    FLen := rc.Right;

  if abs(sWidth - FCW) > 2 then
    sWidth := FCW;

  Temp        := TBitmap.Create;
  Temp.Width  := rc.Right;
  Temp.Height := rc.Bottom;

  SetStretchBltMode(Temp.Canvas.Handle, STRETCH_DELETESCANS);
  Temp.Canvas.Brush.Color := clWhite;
  Temp.Canvas.Fillrect(rc);

  if FsbType <> SB_CTL then
  begin
    if FsbDir = SB_Horz then
      rc.Bottom := sWidth
    else
      rc.Right  := sWidth;
  end;

  rc1 := rc;
  bw  := FCW;
  if FsbDir = SB_Horz then
  begin
    rc1.Left := rc1.Left + bw;
    rc1.Right := rc1.Right - bw;
    DrawTrackHB(Temp.Canvas, rc1);
  end
  else
  begin
    rc1.Top    := rc1.Top + bw;
    rc1.Bottom := rc1.Bottom - bw;
    DrawTrackVB(Temp.Canvas, rc1);
  end;

  rc1 := rc;
  rc2 := rc;

  if rc.Bottom < 2 * bw then
    bw := rc.Bottom div 2;
  rc1.Bottom := rc1.Top + bw;
  rc2.Top    := rc2.Bottom - bw;

  if (FScrollPos = SB_LINEUP) then
  begin
    if FLButtonDown then
    begin
      if FsbType = SB_VERT then
        DrawArrowUp(Temp.Canvas, rc1, ssClick)
      else
        DrawArrowLeft(Temp.Canvas, rc1, ssClick);
    end
    else
    begin
      if FsbType = SB_VERT then
        DrawArrowUp(Temp.Canvas, rc1, ssHover)
      else
        DrawArrowLeft(Temp.Canvas, rc1, ssHover);
    end;
  end
  else
  begin
    if FsbType = SB_VERT then
      DrawArrowUp(Temp.Canvas, rc1, ssNormal)
    else
      DrawArrowLeft(Temp.Canvas, rc1, ssNormal);
  end;

  if (FScrollPos = SB_LINEDOWN) then
  begin
    if FLButtonDown then
    begin
      if FsbType = SB_VERT then
        DrawArrowDown(Temp.Canvas, rc2, ssClick)
      else
        DrawArrowRight(Temp.Canvas, rc2, ssClick);
    end
    else
    begin
      if FsbType = SB_VERT then
        DrawArrowDown(Temp.Canvas, rc2, ssHover)
      else
        DrawArrowRight(Temp.Canvas, rc2, ssHover);
    end;
  end
  else
  begin
    if FsbType = SB_VERT then
      DrawArrowDown(Temp.Canvas, rc2, ssNormal)
    else
      DrawArrowRight(Temp.Canvas, rc2, ssNormal);
  end;

  FthumbTop := BarInfo.xyThumbTop;
  Fthumbbottom := BarInfo.xyThumbBottom;
  sbEnable := (BarInfo.rgstate[0] and STATE_SYSTEM_UNAVAILABLE) = 0;
  if sbEnable then
  begin
    if (FsbDir = sb_Vert) then
    begin
      rc1 := Rect(0, FthumbTop, sWidth, Fthumbbottom);
      if (FthumbTop < Height) and (Fthumbbottom < Height) then
      begin
        if (FScrollPos = SB_THUMBTRACK) then
        begin
          if FLButtonDown then
            DrawThumbVB(Temp.Canvas, rc1, ssClick)
          else
          begin
            if (rc1.Top = FCW - 1) and (rc1.Bottom = Height - FCW - 1) then
            begin

            end
            else
            begin
              DrawThumbVB(Temp.Canvas, rc1, ssHover);
            end;
          end;
        end
        else
        begin
          if (rc1.Top = FCW - 1) and (rc1.Bottom = Height - FCW - 1) then
          begin

          end
          else
          begin
            if (rc1.Bottom <> 2 * FCW - 1) then
              DrawThumbVB(Temp.Canvas, rc1, ssNormal);
          end;
        end;
      end;
    end;

    if FsbType = SB_HORZ then
    begin
      rc1:=Rect(FthumbTop, 0, Fthumbbottom, swidth);
      if (Fthumbtop < Width) and (Fthumbbottom < Width) then
      begin
        if (FScrollPos = SB_THUMBTRACK) then
        begin
          if FLButtonDown then
            DrawThumbHB(Temp.Canvas, rc1, ssClick)
          else
          begin
            if (rc1.Left = FCW - 1) and (rc1.Right = Width - FCW - 1) then
            begin

            end
            else
            begin
              DrawThumbHB(Temp.Canvas, rc1, ssHover);
            end;
          end;
        end
        else
        begin
          if (rc1.Left = FCW - 1) and (rc1.Right = Width - FCW - 1) then
          begin

          end
          else
          begin
            if (rc1.Bottom <> 2 * FCW - 1) then
              DrawThumbHB(Temp.Canvas, rc1, ssNormal);
          end;
        end;
      end;
    end;
  end;

  rc := ClientRect;
  StretchBlt(Canvas.Handle, 0, 0, Temp.Width, Temp.Height, Temp.Canvas.Handle, 0, 0, Temp.Width, Temp.Height, SRCCOPY);
  Temp.Free;
end;

procedure TDBScrollBar.SetPosition(ahWnd: THandle);
var
  parenthWnd, prehWnd : THandle;
  r1                  : TRect;
  p                   : tpoint;
  BarInfo             : tagScrollBarInfo;
  b                   : Boolean;
  dw                  : dword;
begin
  FhWnd           := ahWnd;
  parenthWnd      := GetParent(FhWnd);
  FillChar(BarInfo, sizeof(BarInfo), #0);
  BarInfo.cbSize  := sizeof(BarInfo);
  FsbVisible      := True;
  b               := False;

  if FsbType = sb_Vert then
    b := GetScrollBarInfo(FhWnd, Integer(OBJID_VSCROLL), BarInfo)
  else if FsbType = SB_HORZ then
    b := GetScrollBarInfo(FhWnd, Integer(OBJID_HSCROLL), BarInfo);

  FsbVisible := b;

  if not b then
    Exit;

  dw := GetWindowLong(FhWnd, GWL_STYLE);
  if (dw and ws_visible) = 0 then
  begin
    FsbVisible := False;
    ShowWindow(Handle, SW_HIDE);
    Exit;
  end;

  if ((BarInfo.rgstate[0] and STATE_SYSTEM_INVISIBLE) > 0) then
  begin
    if FsbDir = sb_Vert then
      ShowWindow(Handle, SW_HIDE)
    else
      ShowWindow(Handle, SW_HIDE);

    FsbVisible := False;
  end
  else
  begin
    r1  := BarInfo.rcScrollBar;
    p   := r1.TopLeft;
    Windows.screentoclient(FhWnd, p);
    FsbRect.TopLeft := p;
    p := r1.BottomRight;
    Windows.screentoclient(FhWnd, p);
    FsbRect.BottomRight := p;

    OffsetRect(r1, -r1.Left, -r1.Top);
    if FsbDir = sb_Vert then
      FLen := r1.Bottom
    else
      FLen := r1.Right;

    p := Point(BarInfo.rcScrollBar.Left, BarInfo.rcScrollBar.Top);
    FOffsetSC := p;
    Windows.screentoclient(parenthWnd, p);

    prehWnd := GetNextWindow(FhWnd, GW_hWndPREV);
    if prehWnd = 0 then
      prehWnd := hWnd_TOP;
    ShowWindow(Handle, SW_Show);
    FsbVisible := True;

    SetWindowPos(Handle, prehWnd, p.X, p.Y, r1.Right, r1.Bottom, 0); // SWP_NOREDRAW);
    MoveWindow(Handle, p.X, p.Y, r1.Right, r1.Bottom, True);
  end;
end;

procedure TDBScrollBar.WMERASEBKGND(var Msg: TMessage);
begin
  Msg.Result := 1;
end;

procedure TDBScrollBar.WMLButtonDBClick(var aMsg: TMessage);
begin
  WMLButtonDown(aMsg);
end;

procedure TDBScrollBar.WMLButtonDown(var aMsg: TMessage);
var
  pt      : tpoint;
  BarInfo : tagScrollBarInfo;
begin
  inherited;
  pt := Point(aMsg.LParamLo, aMsg.LParamhi);
  GetCursorPos(Ftrackp);
  FillChar(BarInfo, sizeof(BarInfo), #0);
  BarInfo.cbSize := sizeof(BarInfo);

  if FsbType = SB_HORZ then
  begin
    if GetScrollBarInfo(FhWnd, Integer(OBJID_HSCROLL), BarInfo) then
      Ftrackthumb := BarInfo.xyThumbTop;
  end
  else if FsbType = SB_VERT then
  begin
    if GetScrollBarInfo(FhWnd, Integer(OBJID_VSCROLL), BarInfo) then
      Ftrackthumb := BarInfo.xyThumbTop;
  end;

  FScrollPos := GetScrollPos(pt);

  FOffsetSC     := Point(BarInfo.rcScrollBar.Left, BarInfo.rcScrollBar.Top);
  aMsg.LParamLo := aMsg.LParamLo + FOffsetSC.X; // inc(amsg.LParamLo,offsetSc.x);
  aMsg.LParamhi := aMsg.LParamhi + FOffsetSC.Y; // inc(amsg.LParamHi,offsetSc.y);

  FLButtonDown := True;
  Invalidate;
  FScrollPos := GetScrollPos(pt);
  ReleaseCapture;

  if FsbType = sb_Vert then
    PostMessage(FhWnd, WM_NCLBUTTONDOWN, HTVSCROLL, aMsg.lparam)
  else if FsbType = SB_HORZ then
    PostMessage(FhWnd, WM_NCLBUTTONDOWN, HTHSCROLL, aMsg.lparam);

  FLButtonDown := False;
  ReleaseCapture;
end;

procedure TDBScrollBar.WMLButtonUp(var aMsg: TMessage);
begin
  inherited;

  FLButtonDown := False;
  ReleaseCapture;

  if FsbType = SB_VERT  then
    PostMessage(FhWnd, WM_NCLBUTTONUP, HTVSCROLL, aMsg.lparam)
  else
    PostMessage(FhWnd, WM_NCLBUTTONUP, HTHSCROLL, aMsg.lparam);
end;

procedure TDBScrollBar.WMMouseLeave(var aMsg: TMessage);
begin
  if not FLButtonDown then
  begin
    FScrollPos := -1;
    Invalidate;
  end;
end;

procedure TDBScrollBar.WMMouseMove(var aMsg: TMessage);
var
  ptMouse: tpoint;
  iPos: Integer;
begin
  inherited;
  PostMessage(FhWnd, WM_NCMOUSEMOVE, HTVSCROLL, aMsg.lparam);
  ptMouse := Point(aMsg.LParamLo, aMsg.LParamhi);
  iPos := GetScrollPos(ptMouse);
  if iPos <> FScrollPos then
  begin
    FScrollPos := iPos;
    Invalidate;
  end;
end;

{ TFMScrollBar }

procedure TFMScrollBar.AfterProc(var Message: TMessage);
begin
  case message.Msg of
    CM_VISIBLECHANGED:
      begin
        if message.WParam = 0 then
        begin
          Fvb.HideScrollbar;
          Fhb.HideScrollbar;
        end
        else
          SetScrollbarPos(message);
      end;
    CM_ENABLEDCHANGED:
      begin
        Fvb.Enabled := FControl.Enabled;
        Fhb.Enabled := FControl.Enabled;
      end;
    CM_RECREATEWND:
      begin
      end;
    WM_Size, WM_WINDOWPOSCHANGED:
      begin
        SetScrollbarPos(message);
      end;
    WM_VSCROLL:
      begin
        Fvb.FScrollPos := message.WParamLo;
        Fvb.Invalidate;
      end;
    WM_HSCROLL:
      begin
        Fhb.FScrollPos := message.WParamLo;
        Fhb.Invalidate;
      end;
    WM_MOUSEWHEEL:
      begin
        if (Fvb <> nil) and Fvb.FsbVisible then Fvb.Invalidate;
        if (Fhb <> nil) and Fhb.FsbVisible then Fhb.Invalidate;
      end;
  else
    inherited AfterProc(message);
  end;
end;

constructor TFMScrollBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  Fvb := nil;
  Fhb := nil;
end;

destructor TFMScrollBar.Destroy;
begin
  if Fvb <> nil then Fvb.Free;
  Fvb := nil;

  if Fhb <> nil then Fhb.free;
  Fhb:=nil;

  inherited;
end;

procedure TFMScrollBar.DrawControl(dc: HDC; rc: TRect);
var
  Style: DWORD;
  r    : TRect;
begin
  Style := GetWindowLong(FhWnd, GWL_STYLE);
  if Fvb <> nil then
  begin
    if Fvb.FsbVisible then
      Fvb.Invalidate
    else if (Style and WS_VSCROLL) > 0 then
      Fvb.SetPosition(FhWnd);
  end;

  if (Fhb<>nil) then
  begin
    if Fhb.visible then
      Fhb.Invalidate
    else if (Style and WS_HSCROLL) > 0 then
      Fhb.SetPosition(FhWnd);
  end;

  if (Fvb <> nil) and (Fhb <> nil) and Fvb.Fsbvisible and Fhb.Fsbvisible then
  begin
    r := rect(Fvb.FsbRect.left + 2, Fhb.FsbRect.top + 2, Fvb.FsbRect.right + 2, Fhb.FsbRect.bottom + 2);
    FillBG(dc,r);
  end;

end;

procedure TFMScrollBar.InitScrollbar(aControl: TWincontrol);
begin
  FControl := aControl;
  FhWnd := FControl.Handle;

  Fvb := TDBScrollBar.Create(Self);
  Fvb.Attach(FControl, sb_Vert);
  Fvb.Enabled := FControl.Enabled;

  Fhb := TDBScrollBar.Create(Self);
  Fhb.Attach(FControl, SB_HORZ);
  Fhb.Enabled := FControl.Enabled;

  if not FControl.visible then
    Fvb.HideScrollbar;

  FOldWndProc         := FControl.WindowProc;
  FControl.WindowProc := NewWndProc;
end;

procedure TFMScrollBar.SetScrollbarPos(Message: TMessage);
begin
  if Fvb <> nil then Fvb.SetPosition(FhWnd);
  if Fhb <> nil then Fhb.SetPosition(FhWnd);
end;

initialization
  PngSB := TPngImage.Create;
  PngSB.LoadFromResourceName(HInstance, 'RES_SCROLLBAR');

finalization
  PngSB.Free;

end.

自繪滾動條要使用到的圖標放在 untFMScrollBar.res 文件中。名爲 RES_SCROLLBAR 的 PNG 文件，298×16大小。形如：


調用這個類，比較簡單：
首先定義滾動條類，比如：
    FSBTreeView   : TSkinScrollBar;
    FSBListBox      : TSkinScrollBar;
    FSBMemoText : TSkinScrollBar;

在 FormCreate 中，初始化要修改控件的滾動條：

  FSBTreeView := TSkinScrollBar.Create(nil);
  FSBTreeView.InitScrollbar(tv1);
  
  FSBListBox := TSkinScrollBar.Create(nil);
  FSBListBox.InitScrollbar(lst1);
  
  FSBMemoText := TSkinScrollBar.Create(nil);
  FSBMemoText.InitScrollbar(mmo1);

在 FormDestroy 中銷燬創建的滾動條類就OK了：
 

  FSBTreeView.Free;
  FSBListBox.Free;
  FSBMemoText.Free;

效果圖：

滾動條的式樣，包含在資源文件之中，想做成什麼樣，讓美工做圖標就可以了。
此滾動條類可以適用D7至D10.3的所有版本。

發表評論
所有評論
還沒有人評論，想成為第一個評論的人麼? 請在上方評論欄輸入並且點擊發布.
相關文章

U盤安裝ubuntu kylin【雙系統】

在講解之前還是先上幾張ubuntu kylin 16.04 高清無碼截圖吧 好了，看到了這些系統截圖，是不是感覺很漂亮啊。Windows永久了，再堅強的審美也會疲勞。那接下來就來和我學習安裝這個系統吧！ 圖文教程在這兒：h

小枫vip 2020-07-08 04:48:59

U盤安裝win7系統教程【超簡單】

經常上網聊天打lol，萬一哪天自己的系統壞了怎麼辦呢？不要怕，今天我爲大家帶來了一篇關於如何安裝win7系統【傻瓜式教程】。 輕鬆快速學會如何安裝win7操作系統，get/新技能。瞬間提升你的B格、 圖文教程在這兒：http://www

小枫vip 2020-07-08 04:48:59

Ubuntu U盤啓動製作

 1：如果要裝雙系統，先空閒出一定的空間。可以下載    分區助手  這個軟件來騰出一定的空餘空間。        如果要裝服務器，全部格式化    2：準備1G左右的U盤，備份裏面的文件，後面要格式化U盤     3：下載Ubuntu

wangqiang624731186 2020-07-08 02:53:25

共享文件夾無法訪問

系統：win10 問題描述：共享文件夾無法訪問，顯示“請覈對路徑是否正確” 解決方法： 1、關閉系統防火牆，打開網絡文件共享： 結果：無法打開共享。 2.cmd--輸入文件路徑：\\Wxp-20160307jm\項目歸檔 3.安裝sm

ldm0703 2020-07-08 01:52:07

高清模擬轉數字信號；高清數字轉模擬信號；視頻解決方案

芯片：MS1820 功能：高清 模擬信號 與 數字信號 互轉 應用：會議系統，光端機，數字矩陣，所有系統集成電路中做橋接（Scaler） 輸入：8/16/24 位數字信號，VGA，YPbPr 輸出：16/24 位數字信號，VGA，

MS18963773746 2020-07-07 13:27:33

Windows BitLocker解鎖PE工具

常用筆記本的朋友肯定又遇到忘記的密碼的場景， 今天遇到指紋無法解鎖導致需要PIN解鎖，用PE嘗試修改密碼。發現硬盤有BitLocker加密，無法進行修改   嘗試各種方法，發現一款帶BitLocker解鎖工具純淨PE（只有解鎖BitLoc

瘦瘦的胖子 2020-07-07 13:16:41

CentOS7 交換文件(swap file)設置

問題來源 想在買的VPS上搭點博客服務，偏愛於動態博客之類的，選用了nodejs，範圍一下就減小了，一開始看中了N-blog。需要安裝bower，如果在安裝的時候，一直提示npm版本問題： npm WARN deprecated

无名大盗 2020-07-07 07:33:17

讀源碼學MYSQL系列（二）decimal存儲轉化函數decimal2bin

問題來源   高精度計算是計算機工程實踐中非常重要的內容，在涉及到精確計算的項目中，思考過數據庫的設計。因而比較好奇MYSQL中是如何實現對decimal的支持的。本文通過源碼閱讀，分析理解decimal的存儲及各種運算轉化。參考

无名大盗 2020-07-07 07:33:05

AWS EC2 ubuntu新增用戶（密鑰登錄）

  AWS上的EC2主機默認採用了更爲安全的密鑰連接，在保留密鑰連接的情形下，如何新增用戶呢？ 步驟 1.創建一對新的密鑰   進入AWS的EC2控制檯，查看左邊的菜單列表。選擇《網絡與安全》—《密鑰對》—《創建密鑰對》，然後選擇

无名大盗 2020-07-07 07:33:05

使用windows訪問和管理linux服務器--putty

相信大家在使用linux服務器時，厭煩了每次在windows下時，想要操縱linux服務器時，只能在瀏覽器的小黑框中進行操控，並且沒辦法直接在windows下上傳和下載linux服務器上的文件，管理Linux服務器等等。 在這裏叫大家一

程序猿式Chinoiserie 2020-07-07 06:55:44

項目上傳至服務器；使用linux系統將本地項目上傳到服務器上

很多人不明白本地的項目該如何上傳到自己的服務器上，今天這裏給大家詳細說一下． （1）linux下使用ssh命令鏈接到另一臺linux主機相信大家都聽說過，帶大家回憶一下． ssh [email protected] 其中　ro

程序猿式Chinoiserie 2020-07-07 06:55:44

Windows10+Ubuntu18.04+雙硬盤(SSD+HDD)安裝雙系統

操作步驟 主要參考以下兩篇文章，很不錯 windows10+ubuntu 16.04+雙硬盤（SSD+HDD）分區（圖文） win10+1080Ti+雙硬盤（SSD+HDD）下安裝Ubuntu16.04雙系統 情況說明 採用

松林羊 2020-07-07 04:52:08

CentOS7虛擬機設置靜態IP

在VMware中，虛擬機->設置，選擇NAT模式 在VMware中，編輯->虛擬網絡編輯器 在CentOS系統中，切換到/etc/sysconfig/network-scripts路徑下，會看看到ifcfg-***的文件 用

KerwinChou_CN 2020-07-06 23:17:27

redis/分佈式文件存儲系統/數據庫 存儲session，解決負載均衡集羣中session不一致問題

redis/分佈式文件存儲系統/數據庫 存儲session，解決負載均衡集羣中session不一致問題參考文章： （1）redis/分佈式文件存儲系統/數據庫 存儲session，解決負載均衡集羣中session不一致問題 （2）http

dearbaba_8520 2020-07-06 21:28:10

linux 安裝中文包

1.yum 安裝   yum install fonts-chinese fonts-ISO8859-2-75dpi 2.rpm包安裝   #rpm -ivh fonts-chinese-3.02-9.6.el5.noarch.rpm

fengzhongfei123 2020-07-06 13:11:58