1 | unit Dpi.Common;
|
---|
2 |
|
---|
3 | interface
|
---|
4 |
|
---|
5 | uses
|
---|
6 | {$IFDEF WINDOWS}Windows,{$ENDIF}
|
---|
7 | Classes, SysUtils, LCLType, Types, LCLIntf, Graphics, Math, Dpi.Graphics;
|
---|
8 |
|
---|
9 | const
|
---|
10 | DpiControlsComponentPaletteName = 'DpiControls';
|
---|
11 |
|
---|
12 | function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
|
---|
13 | YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
|
---|
14 | function BitBltCanvas(Dest: TCanvas; X, Y, Width, Height: Integer; Src: TCanvas;
|
---|
15 | XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
|
---|
16 | function BitBltBitmapPrecise(Dest: TBitmap; X, Y, Width, Height: Integer; Src: TBitmap;
|
---|
17 | XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY; Precise: Boolean = False): Boolean;
|
---|
18 | function CreateRectRgn(X1, Y1, X2, Y2: Integer): HRGN;
|
---|
19 | {$IFDEF WINDOWS}
|
---|
20 | function ScrollDC(hDC: HDC; dx: longint; dy: longint; const lprcScroll: RECT;
|
---|
21 | const lprcClip:RECT;hrgnUpdate:HRGN; lprcUpdate: LPRECT): WINBOOL; overload;
|
---|
22 | {$ENDIF}
|
---|
23 | function ScrollDC(Canvas: TCanvas; dx: Longint; dy: Longint; const lprcScroll: TRect;
|
---|
24 | const lprcClip:TRect; hrgnUpdate: Handle; lprcUpdate: PRect): Boolean; overload;
|
---|
25 | function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
|
---|
26 | X, Y, cx, cy: Integer; uFlags: UINT): Boolean;
|
---|
27 | function ScaleToNative(Value: Integer): Integer; inline;
|
---|
28 | function ScaleToNativeDist(Base, Value: Integer): Integer;
|
---|
29 | function ScaleFromNative(Value: Integer): Integer;
|
---|
30 | function ScalePointToNative(Value: TPoint): TPoint;
|
---|
31 | function ScalePointFromNative(Value: TPoint): TPoint;
|
---|
32 | function ScaleSizeToNative(Value: TSize): TSize;
|
---|
33 | function ScaleSizeFromNative(Value: TSize): TSize;
|
---|
34 | function ScaleRectToNative(Value: TRect): TRect;
|
---|
35 | function ScaleRectFromNative(Value: TRect): TRect;
|
---|
36 | function ScaleFloatToNative(Value: Double): Double;
|
---|
37 | function ScaleFloatFromNative(Value: Double): Double;
|
---|
38 | procedure WriteLog(Text: string);
|
---|
39 | function GetSystemMetrics(nIndex: Integer): Integer;
|
---|
40 | function InvalidateRect(AHandle: HWND; ARect: PRect; BErase: Boolean): Boolean;
|
---|
41 |
|
---|
42 | resourcestring
|
---|
43 | SNotImplemented = 'Not implemented';
|
---|
44 | SUnsupportedPaintOperationType = 'Unsupported paint operation type';
|
---|
45 |
|
---|
46 |
|
---|
47 | implementation
|
---|
48 |
|
---|
49 | uses
|
---|
50 | NativePixelPointer;
|
---|
51 |
|
---|
52 | function BitBltCanvas(Dest: TCanvas; X, Y, Width, Height: Integer;
|
---|
53 | Src: TCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
|
---|
54 | begin
|
---|
55 | Result := BitBlt(Dest.Handle, X, Y, Width, Height, Src.Handle, XSrc, YSrc, Rop);
|
---|
56 | end;
|
---|
57 |
|
---|
58 | function BitBltBitmapPrecise(Dest: TBitmap; X, Y, Width, Height: Integer;
|
---|
59 | Src: TBitmap; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY;
|
---|
60 | Precise: Boolean = False): Boolean;
|
---|
61 | var
|
---|
62 | SrcPixel: TPixelPointer;
|
---|
63 | DstPixel: TPixelPointer;
|
---|
64 | XX, YY: Integer;
|
---|
65 | DstPixelX, DstPixelY: Integer;
|
---|
66 | DstPixelWidth, DstPixelHeight: Integer;
|
---|
67 | begin
|
---|
68 | if not Precise or (Frac(ScreenInfo.Dpi / 96) = 0) then begin
|
---|
69 | // Use faster non-fractional scaling
|
---|
70 | Result := BitBlt(Dest.Canvas.Handle, X, Y, Width, Height, Src.Canvas.Handle,
|
---|
71 | XSrc, YSrc, Rop);
|
---|
72 | Exit;
|
---|
73 | end;
|
---|
74 |
|
---|
75 | if XSrc < 0 then begin
|
---|
76 | X := X - XSrc;
|
---|
77 | Width := Width - XSrc;
|
---|
78 | XSrc := 0;
|
---|
79 | end;
|
---|
80 | if YSrc < 0 then begin
|
---|
81 | Y := Y - YSrc;
|
---|
82 | Height := Height - YSrc;
|
---|
83 | YSrc := 0;
|
---|
84 | end;
|
---|
85 |
|
---|
86 | if X < 0 then begin
|
---|
87 | Width := Width + X;
|
---|
88 | XSrc := XSrc - X;
|
---|
89 | X := 0;
|
---|
90 | end;
|
---|
91 | if Y < 0 then begin
|
---|
92 | Height := Height + Y;
|
---|
93 | YSrc := YSrc - Y;
|
---|
94 | Y := 0;
|
---|
95 | end;
|
---|
96 | if (X + Width) >= Dest.Width then begin
|
---|
97 | Width := Dest.Width - X;
|
---|
98 | end;
|
---|
99 | if (Y + Height) >= Dest.Height then begin
|
---|
100 | Height := Dest.Height - Y;
|
---|
101 | end;
|
---|
102 | if (Width < 0) or (Height < 0) then begin
|
---|
103 | Result := True;
|
---|
104 | Exit;
|
---|
105 | end;
|
---|
106 |
|
---|
107 | Dest.BeginUpdate;
|
---|
108 | SrcPixel := TPixelPointer.Create(Src.NativeBitmap);
|
---|
109 | DstPixel := TPixelPointer.Create(Dest.NativeBitmap, ScaleToNative(X), ScaleToNative(Y));
|
---|
110 | if Rop = SRCCOPY then begin
|
---|
111 | for YY := 0 to Height - 1 do begin
|
---|
112 | SrcPixel.SetXY(0, ScaleToNative(YSrc + YY));
|
---|
113 | DstPixelHeight := ScaleToNative(Y + YY + 1) - ScaleToNative(Y + YY);
|
---|
114 | for DstPixelY := 0 to DstPixelHeight - 1 do begin
|
---|
115 | for XX := 0 to Width - 1 do begin
|
---|
116 | SrcPixel.SetX(ScaleToNative(XSrc + XX));
|
---|
117 | DstPixelWidth := ScaleToNative(X + XX + 1) - ScaleToNative(X + XX);
|
---|
118 | for DstPixelX := 0 to DstPixelWidth - 1 do begin
|
---|
119 | DstPixel.PixelRGB := SrcPixel.PixelARGB;
|
---|
120 | DstPixel.NextPixel;
|
---|
121 | end;
|
---|
122 | end;
|
---|
123 | DstPixel.NextLine;
|
---|
124 | end;
|
---|
125 | end;
|
---|
126 | end else
|
---|
127 | if Rop = SRCPAINT then begin
|
---|
128 | for YY := 0 to Height - 1 do begin
|
---|
129 | SrcPixel.SetXY(0, ScaleToNative(YSrc + YY));
|
---|
130 | DstPixelHeight := ScaleToNative(Y + YY + 1) - ScaleToNative(Y + YY);
|
---|
131 | for DstPixelY := 0 to DstPixelHeight - 1 do begin
|
---|
132 | for XX := 0 to Width - 1 do begin
|
---|
133 | SrcPixel.SetX(ScaleToNative(XSrc + XX));
|
---|
134 | DstPixelWidth := ScaleToNative(X + XX + 1) - ScaleToNative(X + XX);
|
---|
135 | for DstPixelX := 0 to DstPixelWidth - 1 do begin
|
---|
136 | DstPixel.PixelRGB := DstPixel.PixelRGB or SrcPixel.PixelARGB;
|
---|
137 | DstPixel.NextPixel;
|
---|
138 | end;
|
---|
139 | end;
|
---|
140 | DstPixel.NextLine;
|
---|
141 | end;
|
---|
142 | end;
|
---|
143 | end else
|
---|
144 | if Rop = SRCAND then begin
|
---|
145 | for YY := 0 to Height - 1 do begin
|
---|
146 | SrcPixel.SetXY(0, ScaleToNative(YSrc + YY));
|
---|
147 | DstPixelHeight := ScaleToNative(Y + YY + 1) - ScaleToNative(Y + YY);
|
---|
148 | for DstPixelY := 0 to DstPixelHeight - 1 do begin
|
---|
149 | for XX := 0 to Width - 1 do begin
|
---|
150 | SrcPixel.SetX(ScaleToNative(XSrc + XX));
|
---|
151 | DstPixelWidth := ScaleToNative(X + XX + 1) - ScaleToNative(X + XX);
|
---|
152 | for DstPixelX := 0 to DstPixelWidth - 1 do begin
|
---|
153 | DstPixel.PixelRGB := DstPixel.PixelRGB and SrcPixel.PixelARGB;
|
---|
154 | DstPixel.NextPixel;
|
---|
155 | end;
|
---|
156 | end;
|
---|
157 | DstPixel.NextLine;
|
---|
158 | end;
|
---|
159 | end;
|
---|
160 | end else
|
---|
161 | if Rop = DSTINVERT then begin
|
---|
162 | for YY := 0 to Height - 1 do begin
|
---|
163 | SrcPixel.SetXY(0, ScaleToNative(YSrc + YY));
|
---|
164 | DstPixelHeight := ScaleToNative(Y + YY + 1) - ScaleToNative(Y + YY);
|
---|
165 | for DstPixelY := 0 to DstPixelHeight - 1 do begin
|
---|
166 | for XX := 0 to Width - 1 do begin
|
---|
167 | SrcPixel.SetX(ScaleToNative(XSrc + XX));
|
---|
168 | DstPixelWidth := ScaleToNative(X + XX + 1) - ScaleToNative(X + XX);
|
---|
169 | for DstPixelX := 0 to DstPixelWidth - 1 do begin
|
---|
170 | DstPixel.PixelRGB := not DstPixel.PixelRGB;
|
---|
171 | DstPixel.NextPixel;
|
---|
172 | end;
|
---|
173 | end;
|
---|
174 | DstPixel.NextLine;
|
---|
175 | end;
|
---|
176 | end;
|
---|
177 | end else raise Exception.Create(SUnsupportedPaintOperationType);
|
---|
178 | Dest.EndUpdate;
|
---|
179 | Result := True;
|
---|
180 | end;
|
---|
181 |
|
---|
182 | function CreateRectRgn(X1, Y1, X2, Y2: Integer): HRGN;
|
---|
183 | begin
|
---|
184 | Result := LCLIntf.CreateRectRgn(ScaleToNative(X1), ScaleToNative(Y1), ScaleToNative(X2),
|
---|
185 | ScaleToNative(Y2));
|
---|
186 | end;
|
---|
187 |
|
---|
188 | {$IFDEF WINDOWS}
|
---|
189 | function ScrollDC(hDC: HDC; dx: longint; dy: longint; const lprcScroll: RECT;
|
---|
190 | const lprcClip: RECT; hrgnUpdate: HRGN; lprcUpdate: LPRECT): WINBOOL;
|
---|
191 | var
|
---|
192 | R: RECT;
|
---|
193 | begin
|
---|
194 | if Assigned(lprcUpdate) then begin
|
---|
195 | R := ScaleRectToNative(lprcUpdate^);
|
---|
196 | lprcUpdate := @R;
|
---|
197 | end;
|
---|
198 | Result := Windows.ScrollDC(hDC, ScaleToNative(dx), ScaleToNative(dY),
|
---|
199 | ScaleRectToNative(lprcScroll), ScaleRectToNative(lprcClip), hrgnUpdate, lprcUpdate);
|
---|
200 | end;
|
---|
201 | {$ENDIF}
|
---|
202 |
|
---|
203 | function ScrollDC(Canvas: TCanvas; dx: Longint; dy: Longint;
|
---|
204 | const lprcScroll: TRect; const lprcClip: TRect; hrgnUpdate: Handle;
|
---|
205 | lprcUpdate: PRect): Boolean;
|
---|
206 | begin
|
---|
207 | {$IFDEF WINDOWS}
|
---|
208 | Result := Windows.ScrollDC(Canvas.Handle, ScaleToNative(dx), ScaleToNative(dy),
|
---|
209 | ScaleRectToNative(lprcScroll), ScaleRectToNative(lprcClip),
|
---|
210 | hrgnUpdate, lprcUpdate);
|
---|
211 | {$ENDIF}
|
---|
212 | {$IFDEF LINUX}
|
---|
213 | // Can't do scrolling of DC under Linux, then fallback into BitBlt.
|
---|
214 | Result := BitBltCanvas(Canvas, lprcScroll.Left + dx, lprcScroll.Top + dy, lprcScroll.Right - lprcScroll.Left, lprcScroll.Bottom - lprcScroll.Top,
|
---|
215 | Canvas, lprcScroll.Left, lprcScroll.Top);
|
---|
216 | {$ENDIF}
|
---|
217 | end;
|
---|
218 |
|
---|
219 | function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND; X, Y, cx, cy: Integer;
|
---|
220 | uFlags: UINT): Boolean;
|
---|
221 | begin
|
---|
222 | Result := LCLIntf.SetWindowPos(hWnd, hWndInsertAfter, ScaleToNative(X), ScaleToNative(Y),
|
---|
223 | ScaleToNative(cx), ScaleToNative(cy), uFlags);
|
---|
224 | end;
|
---|
225 |
|
---|
226 | function ScaleToNative(Value: Integer): Integer; inline;
|
---|
227 | begin
|
---|
228 | Result := ScreenInfo.LookupToNative[Value];
|
---|
229 | // Round and Trunc are fast. Ceil and Floor are slow.
|
---|
230 | // Without lookup table we would use:
|
---|
231 | // Result := Ceil(Value * ScreenInfo.ToNative);
|
---|
232 | end;
|
---|
233 |
|
---|
234 | function ScaleToNativeDist(Base, Value: Integer): Integer;
|
---|
235 | begin
|
---|
236 | Result := ScaleToNative(Base + Value) - ScaleToNative(Base);
|
---|
237 | end;
|
---|
238 |
|
---|
239 | function ScaleFromNative(Value: Integer): Integer;
|
---|
240 | begin
|
---|
241 | Result := ScreenInfo.LookupFromNative[Value];
|
---|
242 | // Round and Trunc are fast. Ceil and Floor are slow.
|
---|
243 | // Without lookup table we would use:
|
---|
244 | // Result := Floor(Value * ScreenInfo.FromNative);
|
---|
245 | end;
|
---|
246 |
|
---|
247 | function ScalePointToNative(Value: TPoint): TPoint;
|
---|
248 | begin
|
---|
249 | Result.X := ScaleToNative(Value.X);
|
---|
250 | Result.Y := ScaleToNative(Value.Y);
|
---|
251 | end;
|
---|
252 |
|
---|
253 | function ScalePointFromNative(Value: TPoint): TPoint;
|
---|
254 | begin
|
---|
255 | Result.X := ScaleFromNative(Value.X);
|
---|
256 | Result.Y := ScaleFromNative(Value.Y);
|
---|
257 | end;
|
---|
258 |
|
---|
259 | function ScaleSizeToNative(Value: TSize): TSize;
|
---|
260 | begin
|
---|
261 | Result.Width := ScaleToNative(Value.Width);
|
---|
262 | Result.Height := ScaleToNative(Value.Height);
|
---|
263 | end;
|
---|
264 |
|
---|
265 | function ScaleSizeFromNative(Value: TSize): TSize;
|
---|
266 | begin
|
---|
267 | Result.Width := ScaleFromNative(Value.Width);
|
---|
268 | Result.Height := ScaleFromNative(Value.Height);
|
---|
269 | end;
|
---|
270 |
|
---|
271 | function ScaleRectToNative(Value: TRect): TRect;
|
---|
272 | begin
|
---|
273 | Result.Left := ScaleToNative(Value.Left);
|
---|
274 | Result.Top := ScaleToNative(Value.Top);
|
---|
275 | Result.Right := ScaleToNative(Value.Right);
|
---|
276 | Result.Bottom := ScaleToNative(Value.Bottom);
|
---|
277 | end;
|
---|
278 |
|
---|
279 | function ScaleRectFromNative(Value: TRect): TRect;
|
---|
280 | begin
|
---|
281 | Result.Left := ScaleFromNative(Value.Left);
|
---|
282 | Result.Top := ScaleFromNative(Value.Top);
|
---|
283 | Result.Right := ScaleFromNative(Value.Right);
|
---|
284 | Result.Bottom := ScaleFromNative(Value.Bottom);
|
---|
285 | end;
|
---|
286 |
|
---|
287 | function ScaleFloatToNative(Value: Double): Double;
|
---|
288 | begin
|
---|
289 | Result := Value * ScreenInfo.ToNative;
|
---|
290 | end;
|
---|
291 |
|
---|
292 | function ScaleFloatFromNative(Value: Double): Double;
|
---|
293 | begin
|
---|
294 | Result := Value * ScreenInfo.FromNative;
|
---|
295 | end;
|
---|
296 |
|
---|
297 | procedure WriteLog(Text: string);
|
---|
298 | var
|
---|
299 | F: Text;
|
---|
300 | const
|
---|
301 | FileName = 'Log.txt';
|
---|
302 | begin
|
---|
303 | AssignFile(F, FileName);
|
---|
304 | if FileExists(FileName) then Append(F) else Rewrite(F);
|
---|
305 | WriteLn(F, Text);
|
---|
306 | CloseFile(F);
|
---|
307 | end;
|
---|
308 |
|
---|
309 | function GetSystemMetrics(nIndex: Integer): Integer;
|
---|
310 | begin
|
---|
311 | Result := ScaleFromNative(LCLIntf.GetSystemMetrics(nIndex));
|
---|
312 | end;
|
---|
313 |
|
---|
314 | function InvalidateRect(AHandle: HWND; ARect: PRect; BErase: Boolean): Boolean;
|
---|
315 | var
|
---|
316 | NativeRect: TRect;
|
---|
317 | begin
|
---|
318 | NativeRect := ScaleRectToNative(ARect^);
|
---|
319 | Result := LCLIntf.InvalidateRect(AHandle, @NativeRect, BErase);
|
---|
320 | end;
|
---|
321 |
|
---|
322 | function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
|
---|
323 | YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
|
---|
324 | var
|
---|
325 | DstWidth, DstHeight: Integer;
|
---|
326 | SrcWidth, SrcHeight: Integer;
|
---|
327 | begin
|
---|
328 | DstWidth := ScaleToNativeDist(X, Width);
|
---|
329 | DstHeight := ScaleToNativeDist(Y, Height);
|
---|
330 | SrcWidth := ScaleToNativeDist(XSrc, Width);
|
---|
331 | SrcHeight := ScaleToNativeDist(YSrc, Height);
|
---|
332 |
|
---|
333 | if (DstWidth = SrcWidth) and (DstHeight = SrcHeight) then begin
|
---|
334 | {$IFDEF WINDOWS}
|
---|
335 | // On Windows LCLIntf.BitBlt is slower than direct Windows BitBlt
|
---|
336 | Result := Windows.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
|
---|
337 | DstWidth, DstHeight, SrcDC,
|
---|
338 | ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
|
---|
339 | {$ELSE}
|
---|
340 | Result := LCLIntf.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
|
---|
341 | DstWidth, DstHeight, SrcDC,
|
---|
342 | ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
|
---|
343 | {$ENDIF}
|
---|
344 | end else begin
|
---|
345 | {$IFDEF WINDOWS}
|
---|
346 | // On Windows LCLIntf.BitBlt is slower than direct Windows BitBlt
|
---|
347 | Result := Windows.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
|
---|
348 | Min(SrcWidth, DstWidth), Min(DstHeight, SrcHeight), SrcDC,
|
---|
349 | ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
|
---|
350 |
|
---|
351 | // Instead calling StretchBlt for entire region try to draw missing part with BitBlt
|
---|
352 | if DstWidth > SrcWidth then begin
|
---|
353 | Windows.BitBlt(DestDC, ScaleToNative(X) + SrcWidth, ScaleToNative(Y),
|
---|
354 | DstWidth - SrcWidth, DstHeight, SrcDC,
|
---|
355 | ScaleToNative(XSrc) + SrcWidth - (DstWidth - SrcWidth), ScaleToNative(YSrc), Rop);
|
---|
356 | end;
|
---|
357 | if DstHeight > SrcHeight then begin
|
---|
358 | Windows.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y) + SrcHeight,
|
---|
359 | DstWidth, DstHeight - SrcHeight, SrcDC,
|
---|
360 | ScaleToNative(XSrc), ScaleToNative(YSrc) + SrcHeight - (DstHeight - SrcHeight), Rop);
|
---|
361 | end;
|
---|
362 | {$ELSE}
|
---|
363 | Result := LCLIntf.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
|
---|
364 | Min(SrcWidth, DstWidth), Min(DstHeight, SrcHeight), SrcDC,
|
---|
365 | ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
|
---|
366 |
|
---|
367 | // Instead calling StretchBlt for entire region try to draw missing part with BitBlt
|
---|
368 | if DstWidth > SrcWidth then begin
|
---|
369 | LCLIntf.BitBlt(DestDC, ScaleToNative(X) + SrcWidth, ScaleToNative(Y),
|
---|
370 | DstWidth - SrcWidth, DstHeight, SrcDC,
|
---|
371 | ScaleToNative(XSrc) + SrcWidth - (DstWidth - SrcWidth), ScaleToNative(YSrc), Rop);
|
---|
372 | end;
|
---|
373 | if DstHeight > SrcHeight then begin
|
---|
374 | LCLIntf.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y) + SrcHeight,
|
---|
375 | DstWidth, DstHeight - SrcHeight, SrcDC,
|
---|
376 | ScaleToNative(XSrc), ScaleToNative(YSrc) + SrcHeight - (DstHeight - SrcHeight), Rop);
|
---|
377 | end;
|
---|
378 | {$ENDIF}
|
---|
379 | end;
|
---|
380 | end;
|
---|
381 |
|
---|
382 | end.
|
---|
383 |
|
---|