Changeset 23
- Timestamp:
- May 8, 2013, 1:52:33 PM (12 years ago)
- Location:
- branches/Xvcl
- Files:
-
- 10 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/Xvcl/Applications
-
Property svn:ignore
set to
__history
-
Property svn:ignore
set to
-
branches/Xvcl/Applications/TestApplication.pas
r19 r23 8 8 type 9 9 TTestApplication = class(TApplication) 10 Form: TForm; 10 Form1: TForm; 11 Form2: TForm; 11 12 Button: TButton; 12 13 Label1: TLabel; … … 31 32 procedure TTestApplication.Run; 32 33 begin 33 Form := TForm.Create; 34 Form.Bounds := TRectangle.Create(50, 50, 100, 100); 35 Form.Name := 'Form1'; 36 Form.Caption := 'Test application'; 37 Form.Screen := Screen; 34 Form1 := TForm.Create; 35 Form1.Bounds := TRectangle.Create(50, 50, 100, 100); 36 Form1.Name := 'Form1'; 37 Form1.Caption := 'Test application'; 38 Form1.Screen := Screen; 39 Form2 := TForm.Create; 40 Form2.Bounds := TRectangle.Create(250, 150, 200, 150); 41 Form2.Name := 'Form1'; 42 Form2.Caption := 'Test application'; 43 Form2.Screen := Screen; 38 44 Button := TButton.Create; 39 Button.Parent := Form ;45 Button.Parent := Form1; 40 46 Button.Bounds := TRectangle.Create(50, 50, 60, 24); 41 47 Button.Visible := True; 42 48 Button.Caption := 'Start'; 43 49 Button.OnClick := ButtonClick; 44 Form .Controls.Add(Button);50 Form1.Controls.Add(Button); 45 51 Label1 := TLabel.Create; 46 Label1.Parent := Form ;52 Label1.Parent := Form1; 47 53 Label1.Bounds := TRectangle.Create(50, 70, 60, 24); 48 54 Label1.Visible := True; 49 55 Label1.Caption := '0'; 50 Form.Controls.Add(Label1); 51 TScreen(Screen).Forms.Add(Form); 56 Form1.Controls.Add(Label1); 57 Form2.Controls.Add(Label1); 58 TScreen(Screen).Forms.Add(Form1); 52 59 TScreen(Screen).Paint; 53 60 end; -
branches/Xvcl/Drivers/Driver.MouseVCL.pas
r20 r23 13 13 procedure DoMouseUp(Sender: TObject; Button: TMouseButton; 14 14 Shift: TShiftState; X, Y: Integer); 15 procedure DoMouseMove(Sender: TObject; Shift: TShiftState; 16 X, Y: Integer); 15 17 public 16 18 Form: Vcl.Forms.TForm; … … 25 27 begin 26 28 Kernel.Mouse.HandleDown(TPoint.Create(X, Y)); 29 end; 30 31 procedure TDriverMouseVCL.DoMouseMove(Sender: TObject; Shift: TShiftState; X, 32 Y: Integer); 33 begin 34 Kernel.Mouse.HandleMouseMove(TPoint.Create(X, Y)); 27 35 end; 28 36 … … 45 53 TForm1(Form).Image1.OnMouseDown := DoMouseDown; 46 54 TForm1(Form).Image1.OnMouseUp := DoMouseUp; 55 TForm1(Form).Image1.OnMouseMove := DoMouseMove; 47 56 end; 48 57 -
branches/Xvcl/Drivers/Driver.VideoVCL.pas
r22 r23 56 56 begin 57 57 case Color of 58 clBlack: Result := Vcl.Graphics.clBlack; 59 clWhite: Result := Vcl.Graphics.clWhite; 60 clBlue: Result := Vcl.Graphics.clBlue; 61 clGreen: Result := Vcl.Graphics.clGreen; 62 clRed: Result := Vcl.Graphics.clRed; 63 clSilver: Result := Vcl.Graphics.clSilver; 64 clGray: Result := Vcl.Graphics.clGray; 65 else Result := Vcl.Graphics.clBlack; 58 clBlack: Result := $000000; 59 clWhite: Result := $ffffff; 60 clBlue: Result := $ff0000; 61 clGreen: Result := $00ff00; 62 clRed: Result := $0000ff; 63 clSilver: Result := $c0c0c0; 64 clGray: Result := $808080; 65 clLightBlue: Result := $ff8080; 66 clLightRed: Result := $80ff80; 67 clLightGreen: Result := $8080ff; 68 clBrown: Result := $a52a2a; 69 clMagenta: Result := $ff00ff; 70 clCyan: Result := $00ffff; 71 clYellow: Result := $ffff00; 72 else Result := $000000; 66 73 end; 67 74 end; -
branches/Xvcl/Xvcl.Classes.pas
r20 r23 11 11 function Substract(Point: TPoint): TPoint; 12 12 function IsZero: Boolean; 13 class operator Add(A, B: TPoint): TPoint; 14 class operator Subtract(A, B: TPoint): TPoint; 13 15 end; 14 16 … … 57 59 TNotifyEvent = procedure (Sender: TObject) of object; 58 60 61 TUpdateLock = class 62 private 63 FOnUpdate: TNotifyEvent; 64 published 65 Counter: Integer; 66 procedure Start; 67 procedure Stop; 68 procedure Update; 69 property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate; 70 end; 71 59 72 60 73 implementation … … 157 170 end; 158 171 172 class operator TPoint.Add(A, B: TPoint): TPoint; 173 begin 174 Result.X := A.X + B.X; 175 Result.Y := A.Y + B.Y; 176 end; 177 159 178 constructor TPoint.Create(X, Y: Integer); 160 179 begin … … 169 188 end; 170 189 190 class operator TPoint.Subtract(A, B: TPoint): TPoint; 191 begin 192 Result.X := A.X - B.X; 193 Result.Y := A.Y - B.Y; 194 end; 195 171 196 function TPoint.Substract(Point: TPoint): TPoint; 172 197 begin … … 174 199 end; 175 200 201 { TUpdateLock } 202 203 procedure TUpdateLock.Start; 204 begin 205 Inc(Counter); 206 end; 207 208 procedure TUpdateLock.Stop; 209 begin 210 if Counter > 0 then begin 211 Dec(Counter); 212 Update; 213 end; 214 end; 215 216 procedure TUpdateLock.Update; 217 begin 218 if (Counter = 0) and Assigned(FOnUpdate) then 219 FOnUpdate(Self); 220 end; 221 176 222 end. -
branches/Xvcl/Xvcl.Controls.pas
r21 r23 23 23 TMessageMouseDown = class(TMessageMouse); 24 24 TMessageMouseUp = class(TMessageMouse); 25 TMessageMouseMove = class(TMessageMouse); 25 26 26 27 TKeyState = (ksShift, ksAlt, ksOS); … … 37 38 Control: TControl; 38 39 function AdjustPos(Position: TPoint): TPoint; override; 40 end; 41 42 TControlMove = class 43 Control: TControl; 44 StartControlPos: TPoint; 45 StartMousePos: TPoint; 46 Active: Boolean; 39 47 end; 40 48 … … 54 62 protected 55 63 function GetVideoDevice: TVideoDevice; virtual; 56 public57 Controls: TList<TControl>;58 64 function HandleMessage(Message: TMessage): Boolean; virtual; 65 public 66 Move: TControlMove; 59 67 function ClientToScreen(Position: TPoint): TPoint; virtual; 60 68 function ScreenToClient(Position: TPoint): TPoint; virtual; … … 75 83 TWinControl = class(TControl) 76 84 protected 85 function HandleMessage(Message: TMessage): Boolean; override; 77 86 public 78 87 Controls: TList<TControl>; 79 function HandleMessage(Message: TMessage): Boolean; override;88 procedure Paint; override; 80 89 constructor Create; override; 81 90 destructor Destroy; override; … … 115 124 begin 116 125 inherited; 117 Controls := TList<TControl>.Create;126 Move := TControlMove.Create; 118 127 end; 119 128 120 129 destructor TControl.Destroy; 121 130 begin 122 Controls.Destroy;131 Move.Destroy; 123 132 if Assigned(FCanvas) then FCanvas.Destroy; 124 133 inherited; … … 159 168 160 169 procedure TControl.Paint; 161 var 162 C: TControl; 163 begin 164 for C in Controls do C.Paint; 170 begin 165 171 end; 166 172 … … 267 273 end; 268 274 275 procedure TWinControl.Paint; 276 var 277 C: TControl; 278 begin 279 inherited; 280 for C in Controls do C.Paint; 281 end; 282 269 283 { TLabel } 270 284 -
branches/Xvcl/Xvcl.Forms.pas
r22 r23 8 8 type 9 9 TForm = class(TWinControl) 10 private 11 FFocused: Boolean; 12 procedure SetFocused(const Value: Boolean); 10 13 protected 11 14 function GetVideoDevice: TVideoDevice; override; 12 15 public 16 const 17 TitleBarHeight = 24; 18 var 13 19 Screen: TObject; // TScreen; 14 20 Caption: string; 21 function HandleMessage(Message: TMessage): Boolean; override; 15 22 procedure Paint; override; 23 property Focused: Boolean read FFocused write SetFocused; 16 24 end; 17 25 … … 50 58 end; 51 59 60 function TForm.HandleMessage(Message: TMessage): Boolean; 61 var 62 TitleBarBounds: TRectangle; 63 begin 64 Result := False; 65 if Message is TMessageMouseDown then 66 with TMessageMouseDown(Message) do begin 67 TitleBarBounds := TRectangle.Create(0, 0, Bounds.Width, TitleBarHeight); 68 if TitleBarBounds.Contains(ScreenToClient(Position)) then begin 69 Focused := True; 70 Result := True; 71 Move.StartControlPos := Bounds.TopLeft; 72 Move.StartMousePos := Position; 73 Move.Active := True; 74 end; 75 end else 76 if Message is TMessageMouseUp then 77 with TMessageMouseUp(Message) do begin 78 Move.Active := False; 79 end else 80 if Message is TMessageMouseMove then 81 with TMessageMouseUp(Message) do begin 82 if Move.Active then begin 83 Bounds.TopLeft := Move.StartControlPos + (Position - Move.StartMousePos); 84 TScreen(Screen).Paint; 85 end; 86 end; 87 if not Result then inherited; 88 end; 89 52 90 procedure TForm.Paint; 53 const54 TitleBarHeight = 24;55 91 begin 56 inherited;57 92 with Canvas do begin 93 Canvas.Brush.Color := clWhite; 94 Canvas.FillRect(TRectangle.Create(0, TitleBarHeight, Size.X, Size.Y)); 95 if Focused then Brush.Color := clLightBlue else 96 Brush.Color := clSilver; 97 FillRect(TRectangle.Create(0, 0, Bounds.Width - 1, TitleBarHeight)); 58 98 MoveTo(TPoint.Create(0, 0)); 59 99 LineTo(TPoint.Create(Bounds.Width - 1, 0)); … … 66 106 (TitleBarHeight - GetTextSize(Caption).Y) div 2), Caption); 67 107 end; 108 inherited; 109 end; 110 111 procedure TForm.SetFocused(const Value: Boolean); 112 begin 113 FFocused := Value; 114 Paint; 68 115 end; 69 116 -
branches/Xvcl/Xvcl.Generics.pas
r22 r23 4 4 5 5 type 6 TList<T> = class;7 8 9 10 6 TList<T> = class 11 7 private … … 35 31 implementation 36 32 37 { TList Enumerator<T>}33 { TList<T>.TEnumerator } 38 34 39 35 function TList<T>.TEnumerator.GetCurrent: T; -
branches/Xvcl/Xvcl.Graphics.pas
r20 r23 8 8 type 9 9 10 TColor = (clNone, clBlack, clWhite, clGray, clSilver, clBlue, clGreen, clRed); 10 TColor = (clNone, clBlack, clWhite, clGray, clSilver, clBlue, clGreen, clRed, 11 clLightBlue, clLightRed, clLightGreen, clBrown, clYellow, clMagenta, clCyan); 11 12 12 13 TPen = class … … 115 116 function TCanvas.GetVideoDevice: TVideoDevice; 116 117 begin 117 Result := nil;118 Result := FVideoDevice; 118 119 end; 119 120 … … 138 139 begin 139 140 if Assigned(VideoDevice) then VideoDevice.SetPixel(Position, Color); 141 end; 142 143 procedure TCanvas.SetVideoDevice(const Value: TVideoDevice); 144 begin 145 FVideoDevice := Value; 140 146 end; 141 147 -
branches/Xvcl/Xvcl.Kernel.pas
r21 r23 8 8 type 9 9 TKernel = class; 10 TScreen = class; 10 11 11 12 TProcessState = (psReady, psRunning, psWaiting, psFinished); … … 24 25 procedure Initialize; virtual; 25 26 procedure Finalize; virtual; 27 end; 28 29 TScreenCanvas = class(TCanvas) 30 Screen: TScreen; 31 function GetVideoDevice: TVideoDevice; override; 26 32 end; 27 33 … … 45 51 TMouse = class 46 52 Kernel: TKernel; 53 procedure HandleMove(Position: TPoint); 47 54 procedure HandleDown(Position: TPoint); 48 55 procedure HandleUp(Position: TPoint); … … 144 151 inherited; 145 152 Forms := TList<TForm>.Create; 146 Canvas := T Canvas.Create;153 Canvas := TScreenCanvas.Create; 147 154 end; 148 155 … … 158 165 Form: TForm; 159 166 begin 167 Canvas.Brush.Color := clWhite; 168 Canvas.FillRect(TRectangle.Create(0, 0, Size.X, Size.Y)); 160 169 for Form in Forms do Form.Paint; 161 170 end; … … 203 212 var 204 213 Form: TForm; 205 NewMessage: TMessageMouse ;214 NewMessage: TMessageMouseDown; 206 215 begin 207 216 NewMessage := TMessageMouseDown.Create; 208 217 NewMessage.Position := Position; 209 218 try 210 for Form in Kernel.Screen.Forms do begin 219 for Form in Kernel.Screen.Forms do 220 if Form.Bounds.Contains(Position) then begin 211 221 if Form.HandleMessage(NewMessage) then begin 212 222 Break; … … 218 228 end; 219 229 220 procedure TMouse.Handle Up(Position: TPoint);221 var 222 Form: TForm; 223 NewMessage: TMessageMouse ;224 begin 225 NewMessage := TMessageMouse Up.Create;230 procedure TMouse.HandleMove(Position: TPoint); 231 var 232 Form: TForm; 233 NewMessage: TMessageMouseMove; 234 begin 235 NewMessage := TMessageMouseMove.Create; 226 236 NewMessage.Position := Position; 227 237 try 228 for Form in Kernel.Screen.Forms do begin 238 for Form in Kernel.Screen.Forms do 239 if Form.Bounds.Contains(Position) then begin 229 240 if Form.HandleMessage(NewMessage) then begin 230 241 Break; … … 236 247 end; 237 248 249 procedure TMouse.HandleUp(Position: TPoint); 250 var 251 Form: TForm; 252 NewMessage: TMessageMouseUp; 253 begin 254 NewMessage := TMessageMouseUp.Create; 255 NewMessage.Position := Position; 256 try 257 for Form in Kernel.Screen.Forms do 258 if Form.Bounds.Contains(Position) then begin 259 if Form.HandleMessage(NewMessage) then begin 260 Break; 261 end; 262 end; 263 finally 264 NewMessage.Destroy; 265 end; 266 end; 267 268 { TScrenCanvas } 269 270 function TScreenCanvas.GetVideoDevice: TVideoDevice; 271 begin 272 if Assigned(Screen) then Result := Screen.VideoDevice 273 else Result := nil; 274 end; 275 238 276 end.
Note:
See TracChangeset
for help on using the changeset viewer.