rvscroll.pas

richview1.7 full.source

      end
    else begin
      ScrollInfo.fMask := SIF_ALL;
      RV_GetScrollInfo(Handle, SB_VERT, 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_VERT, ScrollInfo, True);
        end;
    end;
  finally
    FUpdatingScrollBars := False;
  end;
end;
{------------------------------------------------------}
procedure TRVScroller.ScrollChildren(dx, dy: Integer);
var i: Integer;
begin
  if (dx=0) and (dy=0) then exit;
  for i:=0 to ControlCount-1 do begin
   if dy<>0 then begin
    Controls[i].Tag := Controls[i].Tag+dy;
    RV_Tag2Y(Controls[i]);
   end;
   if dx<>0 then Controls[i].Left := Controls[i].Left + dx;
  end
end;
{------------------------------------------------------}
procedure TRVScroller.WMHScroll(var Message: TWMHScroll);
begin
  with Message do
    case ScrollCode of
      SB_LINEUP: SetHPos(HPos - FSmallStep);
      SB_LINEDOWN: SetHPos(HPos + FSmallStep);
      SB_PAGEUP: SetHPos(HPos-ClientWidth);
      SB_PAGEDOWN: SetHPos(HPos+ClientWidth);
      SB_THUMBPOSITION: SetHPos(Pos);
      SB_THUMBTRACK: if FTracking then SetHPos(Pos);
      SB_TOP: SetHPos(0);
      SB_BOTTOM: SetHPos(XSize);
    end;

end;
{------------------------------------------------------}
procedure TRVScroller.WMVScroll(var Message: TWMVScroll);
begin
  with Message do
    case ScrollCode of
      SB_LINEUP: SetVScrollPos(VPos - 1);
      SB_LINEDOWN: SetVScrollPos(VPos + 1);
      SB_PAGEUP: SetVScrollPos(VPos-(ClientHeight div FSmallStep));
      SB_PAGEDOWN: SetVScrollPos(VPos+(ClientHeight div FSmallStep));
      SB_THUMBPOSITION: SetVScrollPos(Pos);
      SB_THUMBTRACK: if FTracking then SetVScrollPos(Pos);
      SB_TOP: SetVScrollPos(0);
      SB_BOTTOM: SetVScrollPos(YSize);
    end;
end;
{------------------------------------------------------}
procedure TRVScroller.KeyDown(var Key: Word; Shift: TShiftState);
var vScrollNotify, hScrollNotify: Integer;
begin
  inherited KeyDown(Key, Shift);
  if not KeyboardScroll then exit;
  vScrollNotify := -1;
  hScrollNotify := -1;
    case Key of
        VK_UP:
            vScrollNotify := SB_LINEUP;
        VK_PRIOR:
            vScrollNotify := SB_PAGEUP;
        VK_NEXT:
            vScrollNotify := SB_PAGEDOWN;
        VK_DOWN:
            vScrollNotify := SB_LINEDOWN;
        VK_HOME:
            vScrollNotify := SB_TOP;
        VK_END:
            vScrollNotify := SB_BOTTOM;
        VK_LEFT:
            hScrollNotify := SB_LINELEFT;
        VK_RIGHT:
            hScrollNotify := SB_LINERIGHT;
    end;
  if (vScrollNotify <> -1) then
        Perform(WM_VSCROLL, vScrollNotify, 0);
  if (hScrollNotify <> -1) then
        Perform(WM_HSCROLL, hScrollNotify, 0);
end;
{------------------------------------------------------------------------------}
procedure TRVScroller.SetVScrollPos(Value: Integer);
begin
  SetVPos(Value,True);
end;
{------------------------------------------------------------------------------}
procedure TRVScroller.SetVPos(p: Integer; Redraw: Boolean);
var   ScrollInfo: TScrollInfo;
      oldPos: Integer;
      r: TRect;
begin
  if not HandleAllocated then exit;
  OldPos := VPos;
  VPos := p;
  if VScrollVisible then begin
    ScrollInfo.cbSize := SizeOf(ScrollInfo);
    ScrollInfo.nPos := VPos;
    ScrollInfo.fMask := SIF_POS;
    RV_SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);
    RV_GetScrollInfo(Handle, SB_VERT, ScrollInfo);
    VPos := ScrollInfo.nPos;
    end
  else begin
    if VPos > FVScrollMax - (FVScrollPage-1) then
      VPos := FVScrollMax - (FVScrollPage-1);
    if VPos<0 then VPos := 0;
  end;
  r := ClientRect;
  if OldPos-VPos <> 0 then begin
   if not Redraw then begin
     ScrollChildren(0, (OldPos-VPos)*FSmallStep);
     AfterVScroll;
     exit;
   end;
   if FFullRedraw then begin
         ScrollChildren(0, (OldPos-VPos)*FSmallStep);
         Refresh;
       end
   else begin
         ScrollWindowEx(Handle, 0, (OldPos-VPos)*FSmallStep, nil, @r, 0, nil, SW_INVALIDATE {or
                   SW_SCROLLCHILDREN});
         ScrollChildren(0, (OldPos-VPos)*FSmallStep);
         Update;
       end;
   AfterVScroll;
  end;
end;
{------------------------------------------------------}
procedure TRVScroller.SetHPos(p: Integer);
var   ScrollInfo: TScrollInfo;
      oldPos: Integer;
      r: TRect;
begin
  if not HandleAllocated then exit;
  OldPos := HPos;
  HPos := p;
  if HScrollVisible then begin
    ScrollInfo.cbSize := SizeOf(ScrollInfo);
    ScrollInfo.nPos := HPos;
    ScrollInfo.fMask := SIF_POS;
    RV_SetScrollInfo(Handle, SB_HORZ, ScrollInfo, True);
    RV_GetScrollInfo(Handle, SB_HORZ, ScrollInfo);
    HPos := ScrollInfo.nPos;
    end
  else begin
    if HPos > FHScrollMax - (FHScrollPage-1) then
      HPos := FHScrollMax - (FHScrollPage-1);
    if HPos<0 then HPos := 0;
  end;
  r := ClientRect;
  if OldPos-HPos <> 0 then begin
   if FFullRedraw then begin
         ScrollChildren((OldPos-HPos), 0);
         Refresh;
       end
   else begin
         ScrollWindowEx(Handle, (OldPos-HPos), 0,  nil, @r, 0, nil, SW_INVALIDATE{or
                   SW_SCROLLCHILDREN});
         ScrollChildren((OldPos-HPos), 0);
         Update;
       end;
   AfterHScroll;
  end;
end;
{------------------------------------------------------}
procedure TRVScroller.ScrollToNoRedraw(y: Integer);
begin
    SetVPos(y div FSmallStep, False);
end;
{------------------------------------------------------}
procedure TRVScroller.ScrollTo(y: Integer);
begin
    SetVPos(y div FSmallStep, True);
end;
{-------------------------------------------------------}
function TRVScroller.GetVScrollMax: Integer;
var ScrollInfo: TScrollInfo;
begin
  if VScrollVisible then begin
    ScrollInfo.cbSize := SizeOf(ScrollInfo);
    ScrollInfo.nPos := VPos;
    ScrollInfo.fMask := SIF_RANGE or SIF_PAGE;
    RV_GetScrollInfo(Handle, SB_VERT, ScrollInfo);
    Result := ScrollInfo.nMax - Integer(ScrollInfo.nPage)+1;
    end
  else
    Result := FVScrollMax - (FVScrollPage-1);
end;
{-------------------------------------------------------}
function TRVScroller.GetHScrollMax: Integer;
var ScrollInfo: TScrollInfo;
begin
  if HScrollVisible then begin
    ScrollInfo.cbSize := SizeOf(ScrollInfo);
    ScrollInfo.nPos := HPos;
    ScrollInfo.fMask := SIF_RANGE or SIF_PAGE;
    RV_GetScrollInfo(Handle, SB_HORZ, ScrollInfo);
    Result := ScrollInfo.nMax - Integer(ScrollInfo.nPage)+1;
    end
  else
    Result := FHScrollMax - (FHScrollPage-1);
end;
{-------------------------------------------------------}
procedure TRVScroller.SetVScrollVisible(vis: Boolean);
var Changed: Boolean;
begin
  Changed := FVScrollVisible<>vis;
  FVScrollVisible := vis;
  if not HandleAllocated then exit;
  if not (csLoading in ComponentState) then begin
    UpdateScrollBars(XSize, YSize, True, False);
    if FVScrollVisible and Changed and FVDisableNoScroll then begin
      UpdateScrollBars(XSize, YSize, True, True);
      RV_ShowScrollBar(Handle, SB_VERT, True);
    end;
    end
  else
    UpdateScrollBars(XSize, YSize, True, True);
end;
{-------------------------------------------------------}
procedure TRVScroller.SetHScrollVisible(vis: Boolean);
begin
  FHScrollVisible := vis;
  UpdateScrollBars(XSize, YSize, True, True);
end;
{-------------------------------------------------------}
procedure TRVScroller.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  Message.Result := DLGC_WANTARROWS;
end;
{-------------------------------------------------------}
procedure TRVScroller.AfterVScroll;
begin
  if Assigned(FOnVScrolled) then FOnVScrolled(Self);
end;
{-------------------------------------------------------}
procedure TRVScroller.AfterHScroll;
begin
  if Assigned(FOnHScrolled) then FOnHScrolled(Self);
end;
{-------------------------------------------------------}
procedure TRVScroller.SetBorderStyle(const Value: TBorderStyle);
begin
  if FBorderStyle <> Value then begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;
{-------------------------------------------------------}
procedure TRVScroller.CMCtl3DChanged(var Message: TMessage);
begin
  if NewStyleControls and (FBorderStyle = bsSingle) then
    RecreateWnd;
  inherited;
end;
{-------------------------------------------------------}
function TRVScroller.GetDefSmallStep: Integer;
begin
  Result := 10;
end;
{$R-}
function TRVScroller.AllocLogPalette(ColorCount: Integer): PLogPalette;
begin
  Result := PLogPalette(
                GlobalAlloc(GPTR, SizeOf(TLogPalette) + (ColorCount-1) * SizeOf(TPaletteEntry))
                );
  Result^.palVersion := $0300;
  Result^.palNumEntries := ColorCount;
end;
{------------------------------------------------------------------------------}
procedure TRVScroller.FreeLogPalette(var lpLogPal: PLogPalette);
begin
  if lpLogPal<>nil then
    GlobalFree(Cardinal(lpLogPal));
  lpLogPal := nil;
end;
{------------------------------------------------------------------------------}
function TRVScroller.GenerateLogPalette: PLogPalette;
var red, green, blue, i: Integer;
    var ColorCount: Integer;
begin
  ColorCount := 6*6*6;
  Result := AllocLogPalette(ColorCount);
  i := 0;
  for blue := 0 to 5 do
    for green := 0 to 5 do
      for red := 0 to 5 do
        with Result^.palPalEntry[i] do begin
          peRed := red*51;
          peGreen := green*51;
          peBlue := blue*51;
          peFlags := 0;
          inc(i);
        end;
end;
{------------------------------------------------------------------------------}
{
function TRVScroller.GetLogPalette(hpal: HPALETTE):PLogPalette;
var ColorCount: Integer;
begin
  Result := nil;
  ColorCount := 0;
  if hpal=0 then
    exit;
  if (GetObject(hpal, 2, @ColorCount)=0) or
     (ColorCount=0) then exit;
  Result := AllocLogPalette(ColorCount);
  GetPaletteEntries(hpal, 0, ColorCount, Result^.palPalEntry);
end;
}
{------------------------------------------------------------------------------}
function IsPaletteMode: Boolean;
var ScreenDC: HDC;
begin
  ScreenDC := CreateCompatibleDC(0);
  Result := (GetDeviceCaps(ScreenDC,RASTERCAPS) and RC_PALETTE)<>0;
  DeleteDC(ScreenDC);
end;
{------------------------------------------------------------------------------}
procedure TRVScroller.SetDoInPaletteMode(Value: TRVPaletteAction);
begin
  if Value<>FDoInPaletteMode then begin
    FDoInPaletteMode := Value;
    UpdatePaletteInfo;
  end;
end;
{------------------------------------------------------------------------------}
procedure TRVScroller.UpdatePaletteInfo;
begin
  if not (csDesigning in ComponentState) and
    (DoInPaletteMode<>rvpaDoNothing) and
    IsPaletteMode then begin
    if RVPalette=0 then begin
      PRVLogPalette := GenerateLogPalette;
      RVPalette := CreatePalette(PRVLogPalette^);
    end;
    end
  else begin
    if RVPalette<>0 then
      DeleteObject(RVPalette);
    RVPalette := 0;
    FreeLogPalette(PRVLogPalette);