1{%MainUnit ../extctrls.pp} 2 3{ TCustomImage 4 5 ***************************************************************************** 6 This file is part of the Lazarus Component Library (LCL) 7 8 See the file COPYING.modifiedLGPL.txt, included in this distribution, 9 for details about the license. 10 ***************************************************************************** 11} 12 13constructor TCustomImage.Create(AOwner: TComponent); 14begin 15 inherited Create(AOwner); 16 ControlStyle:= [csCaptureMouse, csClickEvents, csDoubleClicks]; 17 AutoSize := False; 18 FCenter := False; 19 FKeepOriginXWhenClipped := False; 20 FKeepOriginYWhenClipped := False; 21 FProportional := False; 22 FStretch := False; 23 FStretchOutEnabled := True; 24 FStretchInEnabled := True; 25 FTransparent := False; 26 FPicture := TPicture.Create; 27 FPicture.OnChange := @PictureChanged; 28 FUseAncestorCanvas := False; 29 with GetControlClassDefaultSize do 30 SetInitialBounds(0, 0, CX, CY); 31end; 32 33destructor TCustomImage.Destroy; 34begin 35 FPicture.OnChange := nil; 36 FPicture.Graphic := nil; 37 FPicture.Free; 38 inherited Destroy; 39end; 40 41function TCustomImage.GetCanvas: TCanvas; 42var 43 TempBitmap: TBitmap; 44begin 45 //debugln('TCustomImage.GetCanvas A ',DbgSName(Self),' ',DbgSName(FPicture.Graphic)); 46 if not FUseAncestorCanvas and (FPicture.Graphic = nil) then 47 begin 48 // make a new bitmap to draw on 49 TempBitmap := TBitmap.Create; 50 try 51 TempBitmap.Width := Width; 52 TempBitmap.Height := Height; 53 FPicture.Graphic := TempBitmap; 54 finally 55 TempBitmap.Free; 56 end; 57 end; 58 //debugln(['TCustomImage.GetCanvas B ',DbgSName(Self),' ',DbgSName(FPicture.Graphic),' FUseParentCanvas=',FUseAncestorCanvas]); 59 // try draw on the bitmap, not on the form's canvas 60 if not FUseAncestorCanvas and (FPicture.Graphic is TBitmap) then 61 Result := TBitmap(FPicture.Graphic).Canvas 62 else 63 Result := inherited Canvas; 64end; 65 66procedure TCustomImage.SetAntialiasingMode(AValue: TAntialiasingMode); 67begin 68 if FAntialiasingMode = AValue then Exit; 69 FAntialiasingMode := AValue; 70 PictureChanged(Self); 71end; 72 73procedure TCustomImage.SetKeepOriginX(AValue: Boolean); 74begin 75 if FKeepOriginXWhenClipped=AValue then Exit; 76 FKeepOriginXWhenClipped:=AValue; 77 PictureChanged(Self); 78end; 79 80procedure TCustomImage.SetKeepOriginY(AValue: Boolean); 81begin 82 if FKeepOriginYWhenClipped=AValue then Exit; 83 FKeepOriginYWhenClipped:=AValue; 84 PictureChanged(Self); 85end; 86 87procedure TCustomImage.SetPicture(const AValue: TPicture); 88begin 89 if FPicture=AValue then exit; 90 //the OnChange of the picture gets called and 91 // notifies this TCustomImage that something changed. 92 FPicture.Assign(AValue); 93end; 94 95procedure TCustomImage.SetStretch(const AValue : Boolean); 96begin 97 if FStretch = AValue then exit; 98 FStretch := AValue; 99 PictureChanged(Self); 100end; 101 102procedure TCustomImage.SetStretchInEnabled(AValue: Boolean); 103begin 104 if FStretchInEnabled = AValue then Exit; 105 FStretchInEnabled := AValue; 106 PictureChanged(Self); 107end; 108 109procedure TCustomImage.SetStretchOutEnabled(AValue: Boolean); 110begin 111 if FStretchOutEnabled = AValue then Exit; 112 FStretchOutEnabled := AValue; 113 PictureChanged(Self); 114end; 115 116procedure TCustomImage.SetTransparent(const AValue : Boolean); 117begin 118 if FTransparent = AValue then exit; 119 FTransparent := AValue; 120 if (FPicture.Graphic <> nil) and (FPicture.Graphic.Transparent <> FTransparent) 121 then FPicture.Graphic.Transparent := FTransparent 122 else PictureChanged(Self); 123end; 124 125class procedure TCustomImage.WSRegisterClass; 126begin 127 inherited WSRegisterClass; 128 RegisterCustomImage; 129end; 130 131procedure TCustomImage.SetCenter(const AValue : Boolean); 132begin 133 if FCenter = AValue then exit; 134 FCenter := AValue; 135 PictureChanged(Self); 136end; 137 138procedure TCustomImage.SetProportional(const AValue: Boolean); 139begin 140 if FProportional = AValue then exit; 141 FProportional := AValue; 142 PictureChanged(Self); 143end; 144 145procedure TCustomImage.PictureChanged(Sender : TObject); 146begin 147 if Picture.Graphic <> nil 148 then begin 149 if AutoSize 150 then begin 151 InvalidatePreferredSize; 152 AdjustSize; 153 end; 154 Picture.Graphic.Transparent := FTransparent; 155 end; 156 invalidate; 157 if Assigned(OnPictureChanged) then 158 OnPictureChanged(Self); 159end; 160 161function TCustomImage.DestRect: TRect; 162var 163 PicWidth: Integer; 164 PicHeight: Integer; 165 ImgWidth: Integer; 166 ImgHeight: Integer; 167 w: Integer; 168 h: Integer; 169 ChangeX, ChangeY: Integer; 170 PicInside, PicOutside, PicOutsidePartial: boolean; 171begin 172 PicWidth := Picture.Width; 173 PicHeight := Picture.Height; 174 ImgWidth := ClientWidth; 175 ImgHeight := ClientHeight; 176 if (PicWidth=0) or (PicHeight=0) then Exit(Rect(0, 0, 0, 0)); 177 178 PicInside := (PicWidth<ImgWidth) and (PicHeight<ImgHeight); 179 PicOutside := (PicWidth>ImgWidth) and (PicHeight>ImgHeight); 180 PicOutsidePartial := (PicWidth>ImgWidth) or (PicHeight>ImgHeight); 181 182 if Stretch or (Proportional and PicOutsidePartial) then 183 if (FStretchOutEnabled or PicOutsidePartial) and 184 (FStretchInEnabled or PicInside) then 185 if Proportional then begin 186 w:=ImgWidth; 187 h:=(PicHeight*w) div PicWidth; 188 if h>ImgHeight then begin 189 h:=ImgHeight; 190 w:=(PicWidth*h) div PicHeight; 191 end; 192 PicWidth:=w; 193 PicHeight:=h; 194 end 195 else begin 196 PicWidth := ImgWidth; 197 PicHeight := ImgHeight; 198 end; 199 200 Result := Rect(0, 0, PicWidth, PicHeight); 201 202 if Center then 203 begin 204 ChangeX := (ImgWidth-PicWidth) div 2; 205 ChangeY := (ImgHeight-PicHeight) div 2; 206 if FKeepOriginXWhenClipped and (ChangeX<0) then ChangeX := 0; 207 if FKeepOriginYWhenClipped and (ChangeY<0) then ChangeY := 0; 208 OffsetRect(Result, ChangeX, ChangeY); 209 end; 210end; 211 212procedure TCustomImage.Invalidate; 213begin 214 if FPainting then exit; 215 inherited Invalidate; 216end; 217 218procedure TCustomImage.CalculatePreferredSize(var PreferredWidth, 219 PreferredHeight: integer; WithThemeSpace: Boolean); 220begin 221 PreferredWidth := Picture.Width; 222 PreferredHeight := Picture.Height; 223end; 224 225class function TCustomImage.GetControlClassDefaultSize: TSize; 226begin 227 Result.CX := 90; 228 Result.CY := 90; 229end; 230 231procedure TCustomImage.Paint; 232 233 procedure DrawFrame; 234 begin 235 with inherited Canvas do 236 begin 237 Pen.Color := clBlack; 238 Pen.Style := psDash; 239 MoveTo(0, 0); 240 LineTo(Self.Width-1, 0); 241 LineTo(Self.Width-1, Self.Height-1); 242 LineTo(0, Self.Height-1); 243 LineTo(0, 0); 244 end; 245 end; 246 247var 248 R: TRect; 249 C: TCanvas; 250begin 251 // detect loop 252 if FUseAncestorCanvas then exit; 253 254 if csDesigning in ComponentState 255 then DrawFrame; 256 257 if Picture.Graphic = nil 258 then Exit; 259 260 C := inherited Canvas; 261 R := DestRect; 262 C.AntialiasingMode := FAntialiasingMode; 263 FPainting:=true; 264 try 265 if Assigned(FOnPaintBackground) then 266 FOnPaintBackground(Self, C, R); 267 C.StretchDraw(R, Picture.Graphic); 268 finally 269 FPainting:=false; 270 end; 271 272 FUseAncestorCanvas := True; 273 try 274 inherited Paint; 275 finally 276 FUseAncestorCanvas := False; 277 end; 278end; 279 280// included by extctrls.pp 281