rvscroll.pas

richview1.7 full.source

{========================} unit RVScroll; {=============================}
{ unit RVScroll:                                                        }
{ classes:                                                              }
{   TRVScroller                                                         }
{ components:                                                           }
{   none (YOU MUST NOT INSTALL THIS FILE IN DELPHI2 AND CB1)            }
{-----------------------------------------------------------------------}
{ Copyright (C) S.Tkachenko                                             }
{=======================================================================}

interface

uses
{$I RV_Defs.inc}
  Windows, Messages, SysUtils, Classes, Controls, Graphics, Forms,
  {$IFDEF RICHVIEWDEF4}
  ImgList,
  {$ENDIF}
  CommCtrl, RVXPTheme, RVStr;
type

  TRVBiDiMode = (rvbdUnspecified, rvbdLeftToRight, rvbdRightToLeft);
{-----------------------------------------------------------------------}
  TRVOption = (rvoAllowSelection, rvoSingleClick, rvoScrollToEnd, rvoClientTextWidth,
               rvoShowCheckpoints, rvoShowPageBreaks,
               rvoTagsArePChars,
               rvoAutoCopyText, rvoAutoCopyUnicodeText,
               rvoAutoCopyRVF, rvoAutoCopyImage,
               rvoAutoCopyRTF,
               rvoFormatInvalidate,
               rvoDblClickSelectsWord, rvoRClickDeselects);
  TRVOptions = set of TRVOption;
{-----------------------------------------------------------------------}
  TRVTabNavigationType = (rvtnNone, rvtnTab, rvtnCtrlTab);
{-----------------------------------------------------------------------}
  TRVPaletteAction = (rvpaDoNothing, rvpaAssignPallette, rvpaCreateCopies,
                      rvpaCreateCopiesEx);

  TBackgroundStyle = (bsNoBitmap, bsStretched, bsTiled, bsTiledAndScrolled, bsCentered);
{-----------------------------------------------------------------------}
  TRVDisplayOption = (rvdoImages, rvdoComponents, rvdoBullets);
  TRVDisplayOptions = set of TRVDisplayOption;
{-----------------------------------------------------------------------}
  TRVSearchOption = (rvsroMatchCase, rvsroDown, rvsroWholeWord);
  TRVSearchOptions = set of TRVSearchOption;
{-----------------------------------------------------------------------}
  TCPEventKind = (cpeNone, cpeAsSectionStart, cpeWhenVisible);
  TRVScrollBarStyle = (rvssRegular, rvssFlat, rvssHotTrack);
{-----------------------------------------------------------------------}
  TRVRTFHighlight = (rtfhlIgnore, rtfhlFixedColors, rtfhlColorTable);  
{-----------------------------------------------------------------------}
  TRVScroller = class(TCustomControl)
  private
    FBorderStyle: TBorderStyle;
    FSmallStep: Integer;
    FTracking: Boolean;
    FFullRedraw: Boolean;
    FVScrollVisible, FHScrollVisible, FUpdatingScrollBars: Boolean;
    FVScrollMax, FVScrollPage: Integer;
    FHScrollMax, FHScrollPage: Integer;
    FDoInPaletteMode: TRVPaletteAction;
    FBiDiMode: TRVBiDiMode;
    FUseXPThemes: Boolean;    
    {$IFDEF RVFLATSCROLLBARS}
    FScrollBarStyle: TRVScrollBarStyle;
    FScrollBarColor: TColor;
    {$ENDIF}
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure WMQueryNewPalette(var Message: TWMQueryNewPalette); message WM_QUERYNEWPALETTE;
    procedure WMPaletteChanged(var Message: TWMPaletteChanged); message WM_PALETTECHANGED;
    procedure WMThemeChanged(var Message: TMessage); message WM_THEMECHANGED;
    procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;

    function GetVScrollMax: Integer;
    function GetHScrollMax: Integer;
    procedure SetVScrollVisible(vis: Boolean);
    procedure SetHScrollVisible(vis: Boolean);
    procedure SetBorderStyle(const Value: TBorderStyle);
    procedure SetDoInPaletteMode(Value: TRVPaletteAction);
    procedure SetVScrollPos(Value: Integer);
    function GetInplaceEditor: TWinControl;
    function GetChosenRVData: TPersistent;
    {$IFDEF RVFLATSCROLLBARS}
    procedure SetScrollBarStyle(const Value: TRVScrollBarStyle);
    procedure SetScrollBarColor(const Value: TColor);
    procedure UpdateScrollStyle(Redraw: Boolean);
    procedure UpdateScrollColor(Redraw: Boolean);
    {$ENDIF}
    procedure CreateThemeHandle; virtual;
    procedure FreeThemeHandle; virtual;
    procedure SetUseXPThemes(const Value: Boolean);
  protected
    FOnVScrolled, FOnHScrolled: TNotifyEvent;
    FVDisableNoScroll: ByteBool;
    HPos, VPos, XSize, YSize: Integer;
    KeyboardScroll: Boolean;
    FChosenItem: TPersistent;
    FChosenRVData: TPersistent;
    FTheme: HTheme;
    {$IFDEF RICHVIEWDEF4}
    FWheelStep: Integer;
    function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    {$ENDIF}
    procedure SetBiDiModeRV(const Value: TRVBiDiMode); virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure AfterCreateWnd1; dynamic;
    procedure AfterCreateWnd2; dynamic;
    procedure DestroyWnd; override;
    function GetPalette: HPALETTE; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;

    procedure SetVPos(p: Integer; Redraw: Boolean);virtual;
    procedure SetHPos(p: Integer); virtual;
    procedure ScrollChildren(dx, dy: Integer);
    procedure AfterVScroll; virtual;
    procedure AfterHScroll; virtual;
    function GetDefSmallStep: Integer; dynamic;

    function AllocLogPalette(ColorCount: Integer): PLogPalette;
    procedure FreeLogPalette(var lpLogPal: PLogPalette);
    function GenerateLogPalette: PLogPalette; dynamic;
    //function GetLogPalette(hpal: HPALETTE):PLogPalette;
    procedure UpdatePaletteInfo; dynamic;
    procedure SetVSmallStep(Value: Integer); virtual;

    property Tracking: Boolean read FTracking write FTracking default True;
    property OnVScrolled: TNotifyEvent read FOnVScrolled write FOnVScrolled;
    property OnHScrolled: TNotifyEvent read FOnHScrolled write FOnHScrolled;
    property DoInPaletteMode: TRVPaletteAction read FDoInPaletteMode write SetDoInPaletteMode;

    property VSmallStep: Integer read FSmallStep write SetVSmallStep;
    property InplaceEditor: TWinControl read GetInplaceEditor;

    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle;
    {$IFDEF RICHVIEWDEF4}
    property WheelStep: Integer read FWheelStep write FWheelStep default 2;
    {$ENDIF}
    {$IFDEF RVFLATSCROLLBARS}
    property ScrollBarColor: TColor read FScrollBarColor write SetScrollBarColor default clBtnHighlight;
    property ScrollBarStyle: TRVScrollBarStyle read FScrollBarStyle write SetScrollBarStyle default rvssRegular;
    {$ENDIF}
    property FullRedraw: Boolean read FFullRedraw write FFullRedraw;
    property VScrollVisible: Boolean read FVScrollVisible write SetVScrollVisible default True;
    property HScrollVisible: Boolean read FHScrollVisible write SetHScrollVisible default True;
    property VScrollPos: Integer read VPos write SetVScrollPos;
    property HScrollPos: Integer read HPos write SetHPos;
    property VScrollMax: Integer read GetVScrollMax;
    property HScrollMax: Integer read GetHScrollMax;
  public
    { Declarations that should be protected }
    RVPalette: HPALETTE;
    PRVLogPalette: PLogPalette;
    procedure SetFocusSilent;
    procedure UpdateScrollBars(XS, YS: Integer; UpdateH, UseDNS: Boolean);
    property AreaWidth: Integer read XSize;
    property ChosenRVData: TPersistent read GetChosenRVData;
    property ChosenItem: TPersistent read FChosenItem;
    procedure ScrollToNoRedraw(y: Integer);
    procedure AssignChosenRVData(RVData: TPersistent; Item: TPersistent);
    procedure SilentReplaceChosenRVData(RVData: TPersistent);
    procedure UnassignChosenRVData(RVData: TPersistent);
    procedure DestroyInplace;
    function FocusedEx: Boolean;
    { Public declarations }
    constructor Create(AOwner: TComponent);override;
    destructor Destroy; override;
    procedure ScrollTo(y: Integer);
    property BiDiMode: TRVBiDiMode read FBiDiMode write SetBiDiModeRV default rvbdUnspecified;
    property UseXPThemes: Boolean read FUseXPThemes write SetUseXPThemes default True;
  end;

const   rvdoALL = [rvdoImages, rvdoComponents, rvdoBullets];
procedure RV_Tag2Y(AControl: TControl);
function RV_GetYByTag(AControl: TControl): Integer;

implementation
uses CRVData, CRVFData, RVItem;

var
  RV_SetScrollProp: function(p1: HWND; index: Integer; newValue: Integer;
    p4: Bool): Bool; stdcall;
  RV_InitializeFlatSB: function(hWnd: HWND): Bool; stdcall;
  RV_UninitializeFlatSB: procedure (hWnd: HWND); stdcall;
  RV_ShowScrollBar: function(hWnd: HWND; wBar: Integer; bShow: BOOL): BOOL; stdcall;
  RV_GetScrollInfo: function(hWnd: HWND; BarFlag: Integer;
    var ScrollInfo: TScrollInfo): BOOL; stdcall;
  RV_GetScrollPos: function(hWnd: HWND; nBar: Integer): Integer; stdcall;
  RV_SetScrollPos: function(hWnd: HWND; nBar, nPos: Integer;
    bRedraw: BOOL): Integer; stdcall;
  RV_SetScrollInfo: function(hWnd: HWND; BarFlag: Integer;
    const ScrollInfo: TScrollInfo; Redraw: BOOL): Integer; stdcall;
  RV_EnableScrollBar: function(hWnd: HWND; wSBflags, wArrows: UINT): BOOL; stdcall;    

{------------------------------------------------------}
function RV_GetYByTag(AControl: TControl): Integer;
begin
  if AControl.Tag>10000 then
    Result := 10000
  else if AControl.Tag<-10000 then
    Result := -10000
  else
    Result := AControl.Tag;
end;
{------------------------------------------------------}
procedure RV_Tag2Y(AControl: TControl);
begin
  AControl.Top := RV_GetYByTag(AControl);
end;
{------------------------------------------------------------------------------}
constructor TRVScroller.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FUseXPThemes    := True;
 FSmallStep      := 1;
 KeyboardScroll  := True;
 TabStop         := True;
 FTracking       := True;
 FFullRedraw     := False;
 FVScrollVisible := True;
 FHScrollVisible := True;
 FBorderStyle    := bsNone;
 {$IFDEF RICHVIEWDEF4}
 WheelStep       := 2;
 BorderWidth     := 0;
 {$ENDIF}
 {$IFDEF RICHVIEWCBDEF3}
 FDoInPaletteMode := rvpaCreateCopies;
 {$ELSE}
 FDoInPaletteMode := rvpaDoNothing;
 {$ENDIF}
 ControlStyle    := ControlStyle+[csReplicatable]{+[csFramed]};
 {$IFDEF RVFLATSCROLLBARS}
 FScrollBarStyle := rvssRegular;
 FScrollBarColor := clBtnHighlight;
 {$ENDIF}
end;
{------------------------------------------------------------------------------}
destructor TRVScroller.Destroy;
begin
  if RVPalette<>0 then
    DeleteObject(RVPalette);
  FreeLogPalette(PRVLogPalette);
  inherited Destroy;
end;
{------------------------------------------------------------------------------}
procedure TRVScroller.CreateParams(var Params: TCreateParams);
const
  BorderStyles: array[TBorderStyle] of DWORD = (0, WS_BORDER);
begin
  inherited   CreateParams(Params);   //CreateWindow
  with Params do
  begin
    Style := Style or BorderStyles[FBorderStyle];
    if NewStyleControls and Ctl3D and (FBorderStyle = bsSingle) then
    begin
      Style := Style and not WS_BORDER;
      ExStyle := ExStyle or WS_EX_CLIENTEDGE;
    end;
    if BiDiMode=rvbdRightToLeft then
      ExStyle := ExStyle or WS_EX_LEFTSCROLLBAR;
    //WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  end;
  Params.Style := Params.Style or WS_CLIPCHILDREN or WS_HSCROLL or WS_VSCROLL;
  FVDisableNoScroll := False;
end;
{------------------------------------------------------}
procedure  TRVScroller.CreateWnd;
begin
  inherited CreateWnd;
  FSmallStep := GetDefSmallStep;
  AfterCreateWnd1;
  if {$IFDEF RICHVIEWDEF4} not SysLocale.MiddleEast and {$ENDIF}
     Assigned(RV_InitializeFlatSB) then
    RV_InitializeFlatSB(Handle);
  {$IFDEF RVFLATSCROLLBARS}
  UpdateScrollStyle(False);
  UpdateScrollColor(False);
  {$ENDIF}
  CreateThemeHandle;
  AfterCreateWnd2;
end;
{------------------------------------------------------}
procedure TRVScroller.DestroyWnd;
begin
  inherited DestroyWnd;
  FreeThemeHandle;
end;
{------------------------------------------------------}
procedure TRVScroller.UpdateScrollBars(XS, YS: Integer; UpdateH, UseDNS: Boolean);
var
  ScrollInfo: TScrollInfo;
begin
  if FUpdatingScrollBars or not HandleAllocated then
    exit;
  FUpdatingScrollBars := True;
  try
    ScrollInfo.cbSize := SizeOf(ScrollInfo);
    if UpdateH then begin
      XSize := XS;
      FHScrollPage := ClientWidth;
      FHScrollMax := XSize-1;
      if HScrollVisible then begin
        ScrollInfo.fMask := SIF_ALL;
        ScrollInfo.nMin := 0;
        ScrollInfo.nMax := FHScrollMax;
        ScrollInfo.nPage := ClientWidth;
        if HPos > ScrollInfo.nMax - (Integer(ScrollInfo.nPage)-1) then
          HPos := ScrollInfo.nMax - (Integer(ScrollInfo.nPage)-1);
        if HPos<0 then HPos := 0;
        ScrollInfo.nPos := HPos;
        ScrollInfo.nTrackPos := 0;
        RV_SetScrollInfo(Handle, SB_HORZ, ScrollInfo, True);
        end
      else begin
        ScrollInfo.fMask := SIF_ALL;
        RV_GetScrollInfo(Handle, SB_HORZ, ScrollInfo);
        with ScrollInfo do
          if (nMin<>0) or (nMax<>1) or (nPage<>0) or (nPos<>0) then begin
            fMask := SIF_ALL;
            nMin := 0;
            nMax := 1;
            nPage := 2;
            nPos := 0;
            RV_SetScrollInfo(Handle, SB_HORZ, ScrollInfo, True);
          end;
      end;
    end;
    YSize := YS;
    FVScrollPage := ClientHeight div FSmallStep;
//    if ClientHeight mod FSmallStep >0 then
//      inc(FVScrollPage);
    FVScrollMax := YSize-1;
    if VPos > FVScrollMax - (FVScrollPage-1) then
      VPos := FVScrollMax - (FVScrollPage-1);
    if VPos<0 then VPos := 0;
    if VScrollVisible then begin
      ScrollInfo.cbSize := SizeOf(ScrollInfo);
      ScrollInfo.fMask := SIF_ALL;

      if UseDNS and FVDisableNoScroll then
        ScrollInfo.fMask := ScrollInfo.fMask or SIF_DISABLENOSCROLL;

      ScrollInfo.nMin := 0;
      ScrollInfo.nPage := FVScrollPage;
      ScrollInfo.nMax := FVScrollMax;
      ScrollInfo.nPos := VPos;
      ScrollInfo.nTrackPos := 0;
      RV_SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);