source: trunk/Packages/DpiControls/Dpi.Common.pas

Last change on this file was 568, checked in by chronos, 3 days ago
  • Fixed: Custom draw ListBox items to keep consistent style on Linux.
  • Fixed: Last game name index error if no saved games.
File size: 12.4 KB
Line 
1unit Dpi.Common;
2
3interface
4
5uses
6 {$IFDEF WINDOWS}Windows,{$ENDIF}
7 Classes, SysUtils, LCLType, Types, LCLIntf, Graphics, Math, Dpi.Graphics;
8
9const
10 DpiControlsComponentPaletteName = 'DpiControls';
11
12function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
13 YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
14function BitBltCanvas(Dest: TCanvas; X, Y, Width, Height: Integer; Src: TCanvas;
15 XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
16function BitBltBitmap(Dest: TBitmap; X, Y, Width, Height: Integer; Src: TBitmap;
17 XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY; Precise: Boolean = False): Boolean;
18function CreateRectRgn(X1, Y1, X2, Y2: Integer): HRGN;
19{$IFDEF WINDOWS}
20function ScrollDC(hDC: HDC; dx: longint; dy: longint; const lprcScroll: RECT;
21 const lprcClip:RECT;hrgnUpdate:HRGN; lprcUpdate: LPRECT): WINBOOL; overload;
22{$ENDIF}
23function ScrollDC(Canvas: TCanvas; dx: Longint; dy: Longint; const lprcScroll: TRect;
24 const lprcClip:TRect; hrgnUpdate: Handle; lprcUpdate: PRect): Boolean; overload;
25function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND;
26 X, Y, cx, cy: Integer; uFlags: UINT): Boolean;
27function ScaleToNative(Value: Integer): Integer; inline;
28function ScaleToNativeDist(Base, Value: Integer): Integer;
29function ScaleFromNative(Value: Integer): Integer;
30function ScalePointToNative(Value: TPoint): TPoint;
31function ScalePointFromNative(Value: TPoint): TPoint;
32function ScaleSizeToNative(Value: TSize): TSize;
33function ScaleSizeFromNative(Value: TSize): TSize;
34function ScaleRectToNative(Value: TRect): TRect;
35function ScaleRectFromNative(Value: TRect): TRect;
36function ScaleFloatToNative(Value: Double): Double;
37function ScaleFloatFromNative(Value: Double): Double;
38procedure WriteLog(Text: string);
39function GetSystemMetrics(nIndex: Integer): Integer;
40
41resourcestring
42 SNotImplemented = 'Not implemented';
43 SUnsupportedPaintOperationType = 'Unsupported paint operation type';
44
45
46implementation
47
48uses
49 NativePixelPointer;
50
51function BitBltCanvas(Dest: TCanvas; X, Y, Width, Height: Integer;
52 Src: TCanvas; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
53begin
54 Result := BitBlt(Dest.Handle, X, Y, Width, Height, Src.Handle, XSrc, YSrc, Rop);
55end;
56
57function BitBltBitmap(Dest: TBitmap; X, Y, Width, Height: Integer;
58 Src: TBitmap; XSrc, YSrc: Integer; Rop: DWORD = SRCCOPY;
59 Precise: Boolean = False): Boolean;
60var
61 SrcPixel: TPixelPointer;
62 DstPixel: TPixelPointer;
63 XX, YY: Integer;
64 DstPixelX, DstPixelY: Integer;
65 DstPixelWidth, DstPixelHeight: Integer;
66 NewY: Integer;
67begin
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;
180end;
181
182function CreateRectRgn(X1, Y1, X2, Y2: Integer): HRGN;
183begin
184 Result := LCLIntf.CreateRectRgn(ScaleToNative(X1), ScaleToNative(Y1), ScaleToNative(X2),
185 ScaleToNative(Y2));
186end;
187
188{$IFDEF WINDOWS}
189function ScrollDC(hDC: HDC; dx: longint; dy: longint; const lprcScroll: RECT;
190 const lprcClip: RECT; hrgnUpdate: HRGN; lprcUpdate: LPRECT): WINBOOL;
191var
192 R: RECT;
193begin
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);
200end;
201{$ENDIF}
202
203function ScrollDC(Canvas: TCanvas; dx: Longint; dy: Longint;
204 const lprcScroll: TRect; const lprcClip: TRect; hrgnUpdate: Handle;
205 lprcUpdate: PRect): Boolean;
206begin
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}
217end;
218
219function SetWindowPos(hWnd: HWND; hWndInsertAfter: HWND; X, Y, cx, cy: Integer;
220 uFlags: UINT): Boolean;
221begin
222 Result := LCLIntf.SetWindowPos(hWnd, hWndInsertAfter, ScaleToNative(X), ScaleToNative(Y),
223 ScaleToNative(cx), ScaleToNative(cy), uFlags);
224end;
225
226function ScaleToNative(Value: Integer): Integer; inline;
227begin
228 Result := ScreenInfo.Lookup[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);
232end;
233
234function ScaleToNativeDist(Base, Value: Integer): Integer;
235begin
236 Result := ScaleToNative(Base + Value) - ScaleToNative(Base);
237end;
238
239function ScaleFromNative(Value: Integer): Integer;
240begin
241 Result := Trunc(Value * ScreenInfo.FromNative);
242end;
243
244function ScalePointToNative(Value: TPoint): TPoint;
245begin
246 Result.X := ScaleToNative(Value.X);
247 Result.Y := ScaleToNative(Value.Y);
248end;
249
250function ScalePointFromNative(Value: TPoint): TPoint;
251begin
252 Result.X := ScaleFromNative(Value.X);
253 Result.Y := ScaleFromNative(Value.Y);
254end;
255
256function ScaleSizeToNative(Value: TSize): TSize;
257begin
258 Result.Width := ScaleToNative(Value.Width);
259 Result.Height := ScaleToNative(Value.Height);
260end;
261
262function ScaleSizeFromNative(Value: TSize): TSize;
263begin
264 Result.Width := ScaleFromNative(Value.Width);
265 Result.Height := ScaleFromNative(Value.Height);
266end;
267
268function ScaleRectToNative(Value: TRect): TRect;
269begin
270 Result.Left := ScaleToNative(Value.Left);
271 Result.Top := ScaleToNative(Value.Top);
272 Result.Right := ScaleToNative(Value.Right);
273 Result.Bottom := ScaleToNative(Value.Bottom);
274end;
275
276function ScaleRectFromNative(Value: TRect): TRect;
277begin
278 Result.Left := ScaleFromNative(Value.Left);
279 Result.Top := ScaleFromNative(Value.Top);
280 Result.Right := ScaleFromNative(Value.Right);
281 Result.Bottom := ScaleFromNative(Value.Bottom);
282end;
283
284function ScaleFloatToNative(Value: Double): Double;
285begin
286 Result := Value * ScreenInfo.ToNative;
287end;
288
289function ScaleFloatFromNative(Value: Double): Double;
290begin
291 Result := Value * ScreenInfo.FromNative;
292end;
293
294procedure WriteLog(Text: string);
295var
296 F: Text;
297const
298 FileName = 'Log.txt';
299begin
300 AssignFile(F, FileName);
301 if FileExists(FileName) then Append(F) else Rewrite(F);
302 WriteLn(F, Text);
303 CloseFile(F);
304end;
305
306function GetSystemMetrics(nIndex: Integer): Integer;
307begin
308 Result := ScaleFromNative(LCLIntf.GetSystemMetrics(nIndex));
309end;
310
311function BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc,
312 YSrc: Integer; Rop: DWORD = SRCCOPY): Boolean;
313var
314 DstWidth, DstHeight: Integer;
315 SrcWidth, SrcHeight: Integer;
316begin
317 DstWidth := ScaleToNativeDist(X, Width);
318 DstHeight := ScaleToNativeDist(Y, Height);
319 SrcWidth := ScaleToNativeDist(XSrc, Width);
320 SrcHeight := ScaleToNativeDist(YSrc, Height);
321
322 if (DstWidth = SrcWidth) and (DstHeight = SrcHeight) then begin
323 {$IFDEF WINDOWS}
324 // On Windows LCLIntf.BitBlt is slower than direct Windows BitBlt
325 Result := Windows.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
326 DstWidth, DstHeight, SrcDC,
327 ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
328 {$ELSE}
329 Result := LCLIntf.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
330 DstWidth, DstHeight, SrcDC,
331 ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
332 {$ENDIF}
333 end else 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 Min(SrcWidth, DstWidth), Min(DstHeight, SrcHeight), SrcDC,
338 ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
339
340 // Instead calling StretchBlt for entire region try to draw missing part with BitBlt
341 if DstWidth > SrcWidth then begin
342 Windows.BitBlt(DestDC, ScaleToNative(X) + SrcWidth, ScaleToNative(Y),
343 DstWidth - SrcWidth, DstHeight, SrcDC,
344 ScaleToNative(XSrc) + SrcWidth - (DstWidth - SrcWidth), ScaleToNative(YSrc), Rop);
345 end;
346 if DstHeight > SrcHeight then begin
347 Windows.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y) + SrcHeight,
348 DstWidth, DstHeight - SrcHeight, SrcDC,
349 ScaleToNative(XSrc), ScaleToNative(YSrc) + SrcHeight - (DstHeight - SrcHeight), Rop);
350 end;
351 {$ELSE}
352 Result := LCLIntf.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y),
353 Min(SrcWidth, DstWidth), Min(DstHeight, SrcHeight), SrcDC,
354 ScaleToNative(XSrc), ScaleToNative(YSrc), Rop);
355
356 // Instead calling StretchBlt for entire region try to draw missing part with BitBlt
357 if DstWidth > SrcWidth then begin
358 LCLIntf.BitBlt(DestDC, ScaleToNative(X) + SrcWidth, ScaleToNative(Y),
359 DstWidth - SrcWidth, DstHeight, SrcDC,
360 ScaleToNative(XSrc) + SrcWidth - (DstWidth - SrcWidth), ScaleToNative(YSrc), Rop);
361 end;
362 if DstHeight > SrcHeight then begin
363 LCLIntf.BitBlt(DestDC, ScaleToNative(X), ScaleToNative(Y) + SrcHeight,
364 DstWidth, DstHeight - SrcHeight, SrcDC,
365 ScaleToNative(XSrc), ScaleToNative(YSrc) + SrcHeight - (DstHeight - SrcHeight), Rop);
366 end;
367 {$ENDIF}
368 end;
369end;
370
371end.
372
Note: See TracBrowser for help on using the repository browser.