Ignore:
Timestamp:
Apr 9, 2021, 5:56:50 PM (3 years ago)
Author:
chronos
Message:
  • Modified: Merged changes from trunk r360 into highdpi branch.
File:
1 edited

Legend:

Unmodified
Added
Removed

  • branches/highdpi/Packages/CevoComponents/ScreenTools.pas

    r349 r361  
    1111
    1212type
    13   TTexture = record
     13
     14  { TTexture }
     15
     16  TTexture = class
     17  private
     18    FAge: Integer;
     19    function GetHeight: Integer;
     20    function GetWidth: Integer;
     21    procedure SetAge(AValue: Integer);
     22  public
    1423    Image: TDpiBitmap;
    15     clBevelLight: TColor;
    16     clBevelShade: TColor;
    17     clTextLight: TColor;
    18     clTextShade: TColor;
    19     clLitText: TColor;
    20     clMark: TColor;
    21     clPage: TColor;
    22     clCover: TColor;
    23   end;
     24    ColorBevelLight: TColor;
     25    ColorBevelShade: TColor;
     26    ColorTextLight: TColor;
     27    ColorTextShade: TColor;
     28    ColorLitText: TColor;
     29    ColorMark: TColor;
     30    ColorPage: TColor;
     31    ColorCover: TColor;
     32    constructor Create;
     33    destructor Destroy; override;
     34    procedure Assign(Source: TTexture);
     35    property Age: Integer read FAge write SetAge;
     36    property Width: Integer read GetWidth;
     37    property Height: Integer read GetHeight;
     38  end;
     39
    2440  TLoadGraphicFileOption = (gfNoError, gfNoGamma);
    2541  TLoadGraphicFileOptions = set of TLoadGraphicFileOption;
    … …  
    3551function TurnToString(Turn: integer): string;
    3652function MovementToString(Movement: integer): string;
    37 procedure BtnFrame(ca: TDpiCanvas; p: TRect; const T: TTexture);
    38 procedure EditFrame(ca: TDpiCanvas; p: TRect; const T: TTexture);
     53procedure BtnFrame(ca: TDpiCanvas; p: TRect; T: TTexture);
     54procedure EditFrame(ca: TDpiCanvas; p: TRect; T: TTexture);
    3955function HexStringToColor(S: string): integer;
    4056function LoadGraphicFile(Bmp: TDpiBitmap; FileName: string; Options: TLoadGraphicFileOptions = []): boolean;
    … …  
    7490procedure GlowFrame(Dst: TDpiBitmap; x0, y0, Width, Height: integer; cl: TColor);
    7591procedure InitOrnament;
    76 procedure InitCityMark(const T: TTexture);
     92procedure InitCityMark(T: TTexture);
    7793procedure Fill(ca: TDpiCanvas; Left, Top, Width, Height, xOffset, yOffset: integer); overload;
    7894procedure Fill(Canvas: TDpiCanvas; Rect: TRect; Offset: TPoint); overload;
    … …  
    8399  const Texture: TDpiBitmap);
    84100procedure PaintBackground(Form: TDpiForm; Left, Top, Width, Height: integer);
    85 procedure Corner(ca: TDpiCanvas; x, y, Kind: integer; const T: TTexture);
     101procedure Corner(ca: TDpiCanvas; x, y, Kind: integer; T: TTexture);
    86102procedure BiColorTextOut(ca: TDpiCanvas; clMain, clBack: TColor; x, y: integer; s: string);
    87 procedure LoweredTextOut(ca: TDpiCanvas; cl: TColor; const T: TTexture;
     103procedure LoweredTextOut(ca: TDpiCanvas; cl: TColor; T: TTexture;
    88104  x, y: integer; s: string);
    89105function BiColorTextWidth(ca: TDpiCanvas; s: string): integer;
    … …  
    95111procedure UnderlinedTitleValue(Canvas: TDpiCanvas; Title, Value: string; X, Y, Width: Integer);
    96112procedure NumberBar(dst: TDpiBitmap; x, y: integer; Cap: string; val: integer;
    97   const T: TTexture);
     113  T: TTexture);
    98114procedure CountBar(dst: TDpiBitmap; x, y, w: integer; Kind: integer;
    99   Cap: string; val: integer; const T: TTexture);
     115  Cap: string; val: integer; T: TTexture);
    100116procedure PaintProgressBar(ca: TDpiCanvas; Kind, x, y, pos, Growth, max: integer;
    101   const T: TTexture);
     117  T: TTexture);
    102118procedure PaintRelativeProgressBar(ca: TDpiCanvas;
    103119  Kind, x, y, size, pos, Growth, max: integer; IndicateComplete: boolean;
    104   const T: TTexture);
     120  T: TTexture);
    105121procedure PaintLogo(Canvas: TDpiCanvas; X, Y, LightColor, ShadeColor: integer);
    106 function SetMainTextureByAge(Age: integer): boolean;
    107122procedure LoadPhrases;
    108123procedure Texturize(Dest, Texture: TDpiBitmap; TransparentColor: Cardinal);
    … …  
    113128  TransparentColor1 = $FF00FF;
    114129  TransparentColor2 = $7F007F;
    115 
    116   wMainTexture = 640;
    117   hMainTexture = 480;
    118130
    119131  // template positions in Templates.png
    … …  
    165177  HGrSystem2: TGraphicSet;
    166178  ClickFrameColor: Integer;
    167   MainTextureAge: Integer;
    168179  MainTexture: TTexture;
    169180  Templates: TGraphicSet;
    … …  
    325336end;
    326337
    327 procedure BtnFrame(ca: TDpiCanvas; p: TRect; const T: TTexture);
    328 begin
    329   RFrame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, T.clBevelShade,
    330     T.clBevelLight);
    331 end;
    332 
    333 procedure EditFrame(ca: TDpiCanvas; p: TRect; const T: TTexture);
     338procedure BtnFrame(ca: TDpiCanvas; p: TRect; T: TTexture);
     339begin
     340  RFrame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, T.ColorBevelShade,
     341    T.ColorBevelLight);
     342end;
     343
     344procedure EditFrame(ca: TDpiCanvas; p: TRect; T: TTexture);
    334345begin
    335346  Frame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, $000000, $000000);
    336347  Frame(ca, p.Left - 2, p.Top - 2, p.Right + 1, p.Bottom + 1, $000000, $000000);
    337348  Frame(ca, p.Left - 3, p.Top - 3, p.Right + 2, p.Bottom + 1, $000000, $000000);
    338   RFrame(ca, p.Left - 4, p.Top - 4, p.Right + 3, p.Bottom + 2, T.clBevelShade,
    339     T.clBevelLight);
     349  RFrame(ca, p.Left - 4, p.Top - 4, p.Right + 3, p.Bottom + 2, T.ColorBevelShade,
     350    T.ColorBevelLight);
    340351end;
    341352
    … …  
    10391050begin
    10401051  if InitOrnamentDone then Exit;
    1041   Light := ColorToColor32(MainTexture.clBevelLight);
    1042   // and $FCFCFC shr 2*3+MainTexture.clBevelShade and $FCFCFC shr 2;
    1043   Shade := ColorToColor32(MainTexture.clBevelShade and $FCFCFC shr 2 * 3 +
    1044     MainTexture.clBevelLight and $FCFCFC shr 2);
     1052  Light := ColorToColor32(MainTexture.ColorBevelLight);
     1053  // and $FCFCFC shr 2*3+MainTexture.ColorBevelShade and $FCFCFC shr 2;
     1054  Shade := ColorToColor32(MainTexture.ColorBevelShade and $FCFCFC shr 2 * 3 +
     1055    MainTexture.ColorBevelLight and $FCFCFC shr 2);
    10451056  HGrSystem2.Data.BeginUpdate;
    10461057  PixelPtr := PixelPointer(HGrSystem2.Data, ScaleToNative(Ornament.Left), ScaleToNative(Ornament.Top));
    … …  
    10701081end;
    10711082
    1072 procedure InitCityMark(const T: TTexture);
     1083procedure InitCityMark(T: TTexture);
    10731084var
    10741085  x: Integer;
    … …  
    10831094          x, CityMark1.Top + y] and $FF;
    10841095        HGrSystem.Data.Canvas.Pixels[CityMark2.Left + x, CityMark2.Top + y] :=
    1085           T.clMark and $FF * Intensity div $FF + T.clMark shr 8 and
    1086           $FF * Intensity div $FF shl 8 + T.clMark shr 16 and
     1096          T.ColorMark and $FF * Intensity div $FF + T.ColorMark shr 8 and
     1097          $FF * Intensity div $FF shl 8 + T.ColorMark shr 16 and
    10871098          $FF * Intensity div $FF shl 16;
    10881099      end;
    … …  
    10951106procedure Fill(ca: TDpiCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer);
    10961107begin
    1097   Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= wMainTexture) and
    1098     (Top + yOffset >= 0) and (Top + yOffset + Height <= hMainTexture));
     1108  Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= MainTexture.Width) and
     1109    (Top + yOffset >= 0) and (Top + yOffset + Height <= MainTexture.Height));
    10991110  DpiBitCanvas(ca, Left, Top, Width, Height, MainTexture.Image.Canvas,
    11001111    Left + xOffset, Top + yOffset);
    … …  
    11121123    n: integer;
    11131124  begin
    1114     n := ((hMainTexture div 2) div (y1 - y0)) * 2;
    1115     while hMainTexture div 2 + (I + 1) * (y1 - y0) > hMainTexture do
     1125    n := ((MainTexture.Height div 2) div (y1 - y0)) * 2;
     1126    while MainTexture.Height div 2 + (I + 1) * (y1 - y0) > MainTexture.Height do
    11161127      Dec(I, n);
    1117     while hMainTexture div 2 + I * (y1 - y0) < 0 do
     1128    while MainTexture.Height div 2 + I * (y1 - y0) < 0 do
    11181129      Inc(I, n);
    11191130    Result := I;
    … …  
    11231134  I: Integer;
    11241135begin
    1125   for I := 0 to (x1 - xm) div wMainTexture - 1 do
    1126     DpiBitCanvas(ca, xm + I * wMainTexture, y0, wMainTexture, y1 - y0,
    1127       MainTexture.Image.Canvas, 0, hMainTexture div 2 + Band(I) *
     1136  for I := 0 to (x1 - xm) div MainTexture.Width - 1 do
     1137    DpiBitCanvas(ca, xm + I * MainTexture.Width, y0, MainTexture.Width, y1 - y0,
     1138      MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band(I) *
    11281139      (y1 - y0));
    1129   DpiBitCanvas(ca, xm + ((x1 - xm) div wMainTexture) * wMainTexture, y0,
    1130     x1 - (xm + ((x1 - xm) div wMainTexture) * wMainTexture), y1 - y0,
    1131     MainTexture.Image.Canvas, 0, hMainTexture div 2 + Band(
    1132     (x1 - xm) div wMainTexture) * (y1 - y0));
    1133   for I := 0 to (xm - x0) div wMainTexture - 1 do
    1134     DpiBitCanvas(ca, xm - (I + 1) * wMainTexture, y0, wMainTexture, y1 - y0,
    1135       MainTexture.Image.Canvas, 0, hMainTexture div 2 +
     1140  DpiBitCanvas(ca, xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width, y0,
     1141    x1 - (xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width), y1 - y0,
     1142    MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band(
     1143    (x1 - xm) div MainTexture.Width) * (y1 - y0));
     1144  for I := 0 to (xm - x0) div MainTexture.Width - 1 do
     1145    DpiBitCanvas(ca, xm - (I + 1) * MainTexture.Width, y0, MainTexture.Width, y1 - y0,
     1146      MainTexture.Image.Canvas, 0, MainTexture.Height div 2 +
    11361147      Band(-I - 1) * (y1 - y0));
    1137   DpiBitCanvas(ca, x0, y0, xm - ((xm - x0) div wMainTexture) *
    1138     wMainTexture - x0, y1 - y0, MainTexture.Image.Canvas,
    1139     ((xm - x0) div wMainTexture + 1) * wMainTexture - (xm - x0),
    1140     hMainTexture div 2 + Band(-(xm - x0) div wMainTexture - 1) * (y1 - y0));
     1148  DpiBitCanvas(ca, x0, y0, xm - ((xm - x0) div MainTexture.Width) *
     1149    MainTexture.Width - x0, y1 - y0, MainTexture.Image.Canvas,
     1150    ((xm - x0) div MainTexture.Width + 1) * MainTexture.Width - (xm - x0),
     1151    MainTexture.Height div 2 + Band(-(xm - x0) div MainTexture.Width - 1) * (y1 - y0));
    11411152end;
    11421153
    … …  
    11831194procedure PaintBackground(Form: TDpiForm; Left, Top, Width, Height: Integer);
    11841195begin
    1185   Fill(Form.Canvas, Left, Top, Width, Height, (wMainTexture - Form.ClientWidth) div
    1186     2, (hMainTexture - Form.ClientHeight) div 2);
    1187 end;
    1188 
    1189 procedure Corner(ca: TDpiCanvas; x, y, Kind: Integer; const T: TTexture);
     1196  Fill(Form.Canvas, Left, Top, Width, Height, (MainTexture.Width - Form.ClientWidth) div
     1197    2, (MainTexture.Height - Form.ClientHeight) div 2);
     1198end;
     1199
     1200procedure Corner(ca: TDpiCanvas; x, y, Kind: Integer; T: TTexture);
    11901201begin
    11911202  { DpiBitCanvas(ca,x,y,8,8,T.HGr.Mask.Canvas,
    … …  
    12821293end;
    12831294
    1284 procedure LoweredTextOut(ca: TDpiCanvas; cl: TColor; const T: TTexture;
     1295procedure LoweredTextOut(ca: TDpiCanvas; cl: TColor; T: TTexture;
    12851296  x, y: Integer; s: string);
    12861297begin
    12871298  if cl = -2 then
    1288     BiColorTextOut(ca, (T.clBevelShade and $FEFEFE) shr 1,
    1289       T.clBevelLight, x, y, s)
     1299    BiColorTextOut(ca, (T.ColorBevelShade and $FEFEFE) shr 1,
     1300      T.ColorBevelLight, x, y, s)
    12901301  else if cl < 0 then
    1291     BiColorTextOut(ca, T.clTextShade, T.clTextLight, x, y, s)
     1302    BiColorTextOut(ca, T.ColorTextShade, T.ColorTextLight, x, y, s)
    12921303  else
    1293     BiColorTextOut(ca, cl, T.clTextLight, x, y, s);
     1304    BiColorTextOut(ca, cl, T.ColorTextLight, x, y, s);
    12941305end;
    12951306
    … …  
    13661377procedure UnderlinedTitleValue(Canvas: TDpiCanvas; Title, Value: string; X, Y, Width: Integer);
    13671378begin
    1368   DLine(Canvas, X, X + Width, Y + 19, MainTexture.clBevelLight, MainTexture.clBevelShade);
     1379  DLine(Canvas, X, X + Width, Y + 19, MainTexture.ColorBevelLight, MainTexture.ColorBevelShade);
    13691380  RisedTextOut(Canvas, X, Y, Title);
    13701381  RisedTextOut(Canvas, X + Width - BiColorTextWidth(Canvas, Value), Y, Value);
    … …  
    13721383
    13731384procedure NumberBar(dst: TDpiBitmap; x, y: integer; Cap: string;
    1374   val: Integer; const T: TTexture);
     1385  val: Integer; T: TTexture);
    13751386var
    13761387  s: string;
    … …  
    13781389  if val > 0 then
    13791390  begin
    1380     DLine(dst.Canvas, x - 2, x + 170, y + 16, T.clBevelShade,
    1381       T.clBevelLight);
     1391    DLine(dst.Canvas, x - 2, x + 170, y + 16, T.ColorBevelShade,
     1392      T.ColorBevelLight);
    13821393    LoweredTextOut(dst.Canvas, -1, T, x - 2, y, Cap);
    13831394    s := IntToStr(val);
    … …  
    13881399
    13891400procedure CountBar(dst: TDpiBitmap; x, y, w: Integer; Kind: Integer;
    1390   Cap: string; val: Integer; const T: TTexture);
     1401  Cap: string; val: Integer; T: TTexture);
    13911402var
    13921403  i, sd, ld, cl, xIcon, yIcon: Integer;
    … …  
    14011412    // xIcon:=x+100;
    14021413    // yIcon:=y;
    1403     // DLine(dst.Canvas,x-2,x+170+32,y+16,T.clBevelShade,T.clBevelLight);
     1414    // DLine(dst.Canvas,x-2,x+170+32,y+16,T.ColorBevelShade,T.ColorBevelLight);
    14041415
    14051416    xIcon := x - 5;
    14061417    yIcon := y + 15;
    1407     DLine(dst.Canvas, x - 2, xIcon + w + 2, yIcon + 16, T.clBevelShade,
    1408       T.clBevelLight);
     1418    DLine(dst.Canvas, x - 2, xIcon + w + 2, yIcon + 16, T.ColorBevelShade,
     1419      T.ColorBevelLight);
    14091420
    14101421    s := IntToStr(val);
    … …  
    14841495
    14851496procedure PaintProgressBar(ca: TDpiCanvas; Kind, x, y, pos, Growth, max: Integer;
    1486   const T: TTexture);
     1497  T: TTexture);
    14871498var
    14881499  i: Integer;
    … …  
    15021513    Growth := max - pos;
    15031514  Frame(ca, x - 1, y - 1, x + max, y + 7, $000000, $000000);
    1504   RFrame(ca, x - 2, y - 2, x + max + 1, y + 8, T.clBevelShade,
    1505     T.clBevelLight);
     1515  RFrame(ca, x - 2, y - 2, x + max + 1, y + 8, T.ColorBevelShade,
     1516    T.ColorBevelLight);
    15061517  with ca do
    15071518  begin
    … …  
    15381549procedure PaintRelativeProgressBar(ca: TDpiCanvas;
    15391550  Kind, x, y, size, pos, Growth, max: Integer; IndicateComplete: Boolean;
    1540   const T: TTexture);
     1551  T: TTexture);
    15411552begin
    15421553  if Growth > 0 then
    … …  
    15571568    LightColor, ShadeColor);
    15581569  DpiBitCanvas(Canvas, X, Y, Logo.Width, Logo.Height, LogoBuffer.Canvas, 0, 0);
    1559 end;
    1560 
    1561 function SetMainTextureByAge(Age: Integer): Boolean;
    1562 begin
    1563   if Age <> MainTextureAge then
    1564     with MainTexture do begin
    1565       MainTextureAge := Age;
    1566       LoadGraphicFile(Image, GetGraphicsDir + DirectorySeparator +
    1567         'Texture' + IntToStr(Age + 1) + '.jpg');
    1568       clBevelLight := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelLight];
    1569       clBevelShade := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelShade];
    1570       clTextLight := Colors.Canvas.Pixels[clkAge0 + Age, cliTextLight];
    1571       clTextShade := Colors.Canvas.Pixels[clkAge0 + Age, cliTextShade];
    1572       clLitText := Colors.Canvas.Pixels[clkAge0 + Age, cliLitText];
    1573       clMark := Colors.Canvas.Pixels[clkAge0 + Age, cliMark];
    1574       clPage := Colors.Canvas.Pixels[clkAge0 + Age, cliPage];
    1575       clCover := Colors.Canvas.Pixels[clkAge0 + Age, cliCover];
    1576       Result := True;
    1577     end
    1578   else
    1579     Result := False;
    15801570end;
    15811571
    … …  
    17861776  BigImp := TDpiBitmap.Create;
    17871777  BigImp.PixelFormat := pf24bit;
    1788   MainTexture.Image := TDpiBitmap.Create;
    1789   MainTextureAge := -2;
     1778  MainTexture := TTexture.Create;
    17901779  ClickFrameColor := HGrSystem.Data.Canvas.Pixels[187, 175];
    17911780  InitOrnamentDone := False;
    … …  
    18101799  FreeAndNil(Paper);
    18111800  FreeAndNil(Colors);
    1812   FreeAndNil(MainTexture.Image);
     1801  FreeAndNil(MainTexture);
     1802end;
     1803
     1804{ TTexture }
     1805
     1806procedure TTexture.SetAge(AValue: Integer);
     1807begin
     1808  if FAge = AValue then Exit;
     1809  FAge := AValue;
     1810  LoadGraphicFile(Image, GetGraphicsDir + DirectorySeparator +
     1811    'Texture' + IntToStr(Age + 1) + '.jpg');
     1812  ColorBevelLight := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelLight];
     1813  ColorBevelShade := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelShade];
     1814  ColorTextLight := Colors.Canvas.Pixels[clkAge0 + Age, cliTextLight];
     1815  ColorTextShade := Colors.Canvas.Pixels[clkAge0 + Age, cliTextShade];
     1816  ColorLitText := Colors.Canvas.Pixels[clkAge0 + Age, cliLitText];
     1817  ColorMark := Colors.Canvas.Pixels[clkAge0 + Age, cliMark];
     1818  ColorPage := Colors.Canvas.Pixels[clkAge0 + Age, cliPage];
     1819  ColorCover := Colors.Canvas.Pixels[clkAge0 + Age, cliCover];
     1820end;
     1821
     1822function TTexture.GetHeight: Integer;
     1823begin
     1824  Result := Image.Height;
     1825end;
     1826
     1827function TTexture.GetWidth: Integer;
     1828begin
     1829  Result := Image.Width;
     1830end;
     1831
     1832constructor TTexture.Create;
     1833begin
     1834  Image := TDpiBitmap.Create;
     1835  FAge := -2;
     1836end;
     1837
     1838destructor TTexture.Destroy;
     1839begin
     1840  FreeAndNil(Image);
     1841  inherited;
     1842end;
     1843
     1844procedure TTexture.Assign(Source: TTexture);
     1845begin
     1846  FAge := Source.FAge;
     1847  Image.Assign(Image);
     1848  ColorBevelLight := Source.ColorBevelLight;
     1849  ColorBevelShade := Source.ColorBevelShade;
     1850  ColorTextLight := Source.ColorTextLight;
     1851  ColorTextShade := Source.ColorTextShade;
     1852  ColorLitText := Source.ColorLitText;
     1853  ColorMark := Source.ColorMark;
     1854  ColorPage := Source.ColorPage;
     1855  ColorCover := Source.ColorCover;
    18131856end;
    18141857
Note: See TracChangeset for help on using the changeset viewer.