1{%MainUnit ../stdctrls.pp} 2 3{ 4 TCustomScrollBar 5 6 ***************************************************************************** 7 This file is part of the Lazarus Component Library (LCL) 8 9 See the file COPYING.modifiedLGPL.txt, included in this distribution, 10 for details about the license. 11 ***************************************************************************** 12} 13 14 15 16{------------------------------------------------------------------------------} 17{ function TCustomScrollBar.Create } 18{------------------------------------------------------------------------------} 19constructor TCustomScrollBar.Create(AOwner: TComponent); 20begin 21 inherited Create(AOwner); 22 fCompStyle := csScrollBar; 23 with GetControlClassDefaultSize do 24 SetInitialBounds(0, 0, CX, CY); 25 TabStop := True; 26 ControlStyle := ControlStyle + [csFramed, csDoubleClicks, csOpaque] 27 - [csAcceptsControls, csDoubleClicks, 28 csCaptureMouse, csSetCaption]; 29 FKind := sbHorizontal; 30 FPosition := 0; 31 FMin := 0; 32 FMax := 100; 33 FSmallChange := 1; 34 FLargeChange := 1; 35end; 36 37procedure TCustomScrollBar.CreateParams(var Params: TCreateParams); 38const 39 Kinds: array[TScrollBarKind] of DWORD = (SBS_HORZ, SBS_VERT); 40begin 41 inherited CreateParams(Params); 42 Params.Style := Params.Style or Kinds[FKind]; 43 FRTLFactor := 1 44end; 45 46procedure TCustomScrollBar.CreateWnd; 47var 48 ScrollInfo: TScrollInfo; 49begin 50 inherited CreateWnd; 51 if not HandleAllocated then RaiseGDBException('TCustomScrollBar.CreateWnd HandleAllocated=false'); 52 ScrollInfo.cbSize := SizeOf(ScrollInfo); 53 ScrollInfo.nMin := FMin; 54 ScrollInfo.nMax := FMax; 55 ScrollInfo.nPage := FPageSize; 56 ScrollInfo.fMask := SIF_PAGE or SIF_Range; 57 SetScrollInfo(Handle, SB_CTL, ScrollInfo, False); 58 if NotRightToLeft then 59 SetScrollPos(Handle, SB_CTL, FPosition, True) 60 else 61 SetScrollPos(Handle, SB_CTL, FMax - FPosition, True); 62end; 63 64function TCustomScrollBar.NotRightToLeft: Boolean; 65begin 66 Result := True; 67end; 68 69procedure TCustomScrollBar.SetKind(Value: TScrollBarKind); 70var 71 OldWidth: Integer; 72 OldHeight: Integer; 73begin 74 if FKind = Value then Exit; 75 76 FKind := Value; 77 78 // the InterfaceConstraints need to get updated, even when loading 79 OldWidth:=Width; 80 OldHeight:=Height; 81 Constraints.UpdateInterfaceConstraints; 82 83 // switch width and height, but not when loading, because we assume that 84 // the lfm contains a consistent combination of kind and (width, height) 85 if (csLoading in ComponentState) then Exit; 86 87 if HandleAllocated then 88 TWSScrollBarClass(WidgetSetClass).SetKind(Self, FKind = sbHorizontal); 89 90 SetBounds(Left,Top,OldHeight,OldWidth); 91end; 92 93procedure TCustomScrollBar.SetParams(APosition, AMin, AMax, APageSize: Integer); 94var 95 ScrollInfo: TScrollInfo; 96begin 97 if AMax < AMin then 98 raise EInvalidOperation.Create(rsScrollBarOutOfRange); 99 if APosition < AMin then APosition := AMin; 100 if APosition > AMax then APosition := AMax; 101 if APageSize < 0 then APageSize := 0; 102 if (FMin <> AMin) or (FMax <> AMax) or (APageSize <> FPageSize) then 103 begin 104 FMin := AMin; 105 FMax := AMax; 106 FPageSize := APageSize; 107 if HandleAllocated then 108 begin 109 ScrollInfo.fMask := SIF_PAGE or SIF_Range; 110 ScrollInfo.nMin := AMin; 111 ScrollInfo.nMax := AMax; 112 ScrollInfo.nPage := APageSize; 113 SetScrollInfo(Handle, SB_CTL, ScrollInfo, FPosition = APosition); 114 end; 115 end; 116 if FPosition <> APosition then 117 begin 118 FPosition := APosition; 119 if HandleAllocated then 120 if NotRightToLeft then 121 SetScrollPos(Handle, SB_CTL, FPosition, True) 122 else 123 SetScrollPos(Handle, SB_CTL, FMax - FPosition, True); 124 Change; 125 end; 126 127 128 if HandleAllocated then 129 TWSScrollBarClass(WidgetSetClass).SetParams(Self); 130end; 131 132procedure TCustomScrollBar.SetParams(APosition, AMin, AMax: Integer); 133begin 134 SetParams(APosition, AMin, AMax, FPageSize); 135end; 136 137procedure TCustomScrollBar.CalculatePreferredSize(var PreferredWidth, 138 PreferredHeight: integer; WithThemeSpace: Boolean); 139begin 140 inherited CalculatePreferredSize(PreferredWidth, PreferredHeight, 141 WithThemeSpace); 142 if (Kind=sbHorizontal) and (PreferredHeight=0) then 143 PreferredHeight:=GetSystemMetrics(SM_CYHSCROLL); 144 if (Kind=sbVertical) and (PreferredWidth=0) then 145 PreferredWidth:=GetSystemMetrics(SM_CYVSCROLL); 146end; 147 148procedure TCustomScrollBar.SetPosition(Value: Integer); 149begin 150 SetParams(Value, FMin, FMax, FPageSize); 151end; 152 153procedure TCustomScrollBar.SetPageSize(Value: Integer); 154begin 155 SetParams(FPosition, FMin, FMax, Value); 156end; 157 158procedure TCustomScrollBar.SetMin(Value: Integer); 159begin 160 SetParams(FPosition, Value, FMax, FPageSize); 161end; 162 163procedure TCustomScrollBar.SetMax(Value: Integer); 164begin 165 SetParams(FPosition, FMin, Value, FPageSize); 166end; 167 168procedure TCustomScrollBar.Change; 169begin 170 inherited Changed; 171 if Assigned(FOnChange) then FOnChange(Self); 172end; 173 174procedure TCustomScrollBar.Scroll(ScrollCode: TScrollCode; var ScrollPos: Integer); 175begin 176 if Assigned(FOnScroll) then FOnScroll(Self, ScrollCode, ScrollPos); 177end; 178 179procedure TCustomScrollBar.DoScroll(var Message: TLMScroll); 180var 181 ScrollPos: Integer; 182 ScrollCode: TScrollCode; 183 NewPos: Longint; 184begin 185 NewPos := FPosition; 186 case Message.ScrollCode of 187 SB_LINEUP: begin 188 ScrollCode := scLineUp; 189 Dec(NewPos, FSmallChange * FRTLFactor); 190 end; 191 SB_LINEDOWN: begin 192 ScrollCode := scLineDown; 193 Inc(NewPos, FSmallChange * FRTLFactor); 194 end; 195 SB_PAGEUP: begin 196 ScrollCode := scPageUp; 197 Dec(NewPos, FLargeChange * FRTLFactor); 198 end; 199 SB_PAGEDOWN: begin 200 ScrollCode := scPageDown; 201 Inc(NewPos, FLargeChange * FRTLFactor); 202 end; 203 SB_THUMBPOSITION, SB_THUMBTRACK: begin 204 if Message.ScrollCode = SB_THUMBPOSITION 205 then ScrollCode := scPosition 206 else ScrollCode := scTrack; 207 { We need to reverse the positioning because SetPosition below calls 208 SetParams that reverses the position. This acts as a double negative. } 209 if NotRightToLeft 210 then NewPos := Message.Pos 211 else NewPos := FMax - Message.Pos; 212 end; 213 SB_TOP: begin 214 ScrollCode := scTop; 215 NewPos := FMin; 216 end; 217 SB_BOTTOM: begin 218 ScrollCode := scBottom; 219 NewPos := FMax; 220 end; 221 SB_ENDSCROLL: begin 222 ScrollCode := scEndScroll; 223 end; 224 else 225 Exit; 226 end; 227 228 {see issue #20127 +1 follows winapi bug otherwise under mswindows at max position 229 we'll have gap between slider and edge of scrollbar. Gtk2 and Qt are fine with this.} 230 if NewPos + 1 > (FMax - FPageSize) + 1 then NewPos := (FMax - FPageSize) + 1; 231 if NewPos < FMin then NewPos := FMin; 232 233 ScrollPos := NewPos; 234 Scroll(ScrollCode, ScrollPos); 235 SetPosition(ScrollPos); 236end; 237 238procedure TCustomScrollBar.CNHScroll(var Message: TLMHScroll); 239begin 240 DoScroll(Message); 241end; 242 243procedure TCustomScrollBar.CNVScroll(var Message: TLMVScroll); 244begin 245 DoScroll(Message); 246end; 247 248procedure TCustomScrollBar.CNCtlColorScrollBar(var Message: TLMessage); 249begin 250//CallWIndowProc is not yet created so no code is here 251end; 252 253procedure TCustomScrollBar.WMEraseBkgnd(var Message: TLMEraseBkgnd); 254begin 255 DefaultHandler(Message); 256end; 257 258class procedure TCustomScrollBar.WSRegisterClass; 259begin 260 inherited WSRegisterClass; 261 RegisterCustomScrollBar; 262end; 263 264class function TCustomScrollBar.GetControlClassDefaultSize: TSize; 265begin 266 Result.CX := 121; 267 Result.CY := GetSystemMetrics(SM_CYHSCROLL); 268end; 269 270// included by stdctrls.pp 271