Ignore:
Timestamp:
Apr 6, 2021, 10:16:55 PM (4 years ago)
Author:
chronos
Message:
  • Modified: TTexture changed from record to class.
  • Modified: Code cleanup.
File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/Packages/CevoComponents/ScreenTools.pas

    r347 r352  
    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: TBitmap;
    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: TCanvas; p: TRect; const T: TTexture);
    38 procedure EditFrame(ca: TCanvas; p: TRect; const T: TTexture);
     53procedure BtnFrame(ca: TCanvas; p: TRect; T: TTexture);
     54procedure EditFrame(ca: TCanvas; p: TRect; T: TTexture);
    3955function HexStringToColor(S: string): integer;
    4056function LoadGraphicFile(Bmp: TBitmap; FileName: string; Options: TLoadGraphicFileOptions = []): boolean;
    … …  
    7490procedure GlowFrame(Dst: TBitmap; x0, y0, Width, Height: integer; cl: TColor);
    7591procedure InitOrnament;
    76 procedure InitCityMark(const T: TTexture);
     92procedure InitCityMark(T: TTexture);
    7793procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: integer); overload;
    7894procedure Fill(Canvas: TCanvas; Rect: TRect; Offset: TPoint); overload;
    … …  
    8399  const Texture: TBitmap);
    84100procedure PaintBackground(Form: TForm; Left, Top, Width, Height: integer);
    85 procedure Corner(ca: TCanvas; x, y, Kind: integer; const T: TTexture);
     101procedure Corner(ca: TCanvas; x, y, Kind: integer; T: TTexture);
    86102procedure BiColorTextOut(ca: TCanvas; clMain, clBack: TColor; x, y: integer; s: string);
    87 procedure LoweredTextOut(ca: TCanvas; cl: TColor; const T: TTexture;
     103procedure LoweredTextOut(ca: TCanvas; cl: TColor; T: TTexture;
    88104  x, y: integer; s: string);
    89105function BiColorTextWidth(ca: TCanvas; s: string): integer;
    … …  
    95111procedure UnderlinedTitleValue(Canvas: TCanvas; Title, Value: string; X, Y, Width: Integer);
    96112procedure NumberBar(dst: TBitmap; x, y: integer; Cap: string; val: integer;
    97   const T: TTexture);
     113  T: TTexture);
    98114procedure CountBar(dst: TBitmap; x, y, w: integer; Kind: integer;
    99   Cap: string; val: integer; const T: TTexture);
     115  Cap: string; val: integer; T: TTexture);
    100116procedure PaintProgressBar(ca: TCanvas; Kind, x, y, pos, Growth, max: integer;
    101   const T: TTexture);
     117  T: TTexture);
    102118procedure PaintRelativeProgressBar(ca: TCanvas;
    103119  Kind, x, y, size, pos, Growth, max: integer; IndicateComplete: boolean;
    104   const T: TTexture);
     120  T: TTexture);
    105121procedure PaintLogo(Canvas: TCanvas; X, Y, LightColor, ShadeColor: integer);
    106 function SetMainTextureByAge(Age: integer): boolean;
    107122procedure LoadPhrases;
    108123procedure Texturize(Dest, Texture: TBitmap; TransparentColor: Cardinal);
    … …  
    115130  TransparentColor1 = $FF00FF;
    116131  TransparentColor2 = $7F007F;
    117 
    118   wMainTexture = 640;
    119   hMainTexture = 480;
    120132
    121133  // template positions in Templates.png
    … …  
    167179  HGrSystem2: TGraphicSet;
    168180  ClickFrameColor: Integer;
    169   MainTextureAge: Integer;
    170181  MainTexture: TTexture;
    171182  Templates: TGraphicSet;
    … …  
    327338end;
    328339
    329 procedure BtnFrame(ca: TCanvas; p: TRect; const T: TTexture);
    330 begin
    331   RFrame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, T.clBevelShade,
    332     T.clBevelLight);
    333 end;
    334 
    335 procedure EditFrame(ca: TCanvas; p: TRect; const T: TTexture);
     340procedure BtnFrame(ca: TCanvas; p: TRect; T: TTexture);
     341begin
     342  RFrame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, T.ColorBevelShade,
     343    T.ColorBevelLight);
     344end;
     345
     346procedure EditFrame(ca: TCanvas; p: TRect; T: TTexture);
    336347begin
    337348  Frame(ca, p.Left - 1, p.Top - 1, p.Right, p.Bottom, $000000, $000000);
    338349  Frame(ca, p.Left - 2, p.Top - 2, p.Right + 1, p.Bottom + 1, $000000, $000000);
    339350  Frame(ca, p.Left - 3, p.Top - 3, p.Right + 2, p.Bottom + 1, $000000, $000000);
    340   RFrame(ca, p.Left - 4, p.Top - 4, p.Right + 3, p.Bottom + 2, T.clBevelShade,
    341     T.clBevelLight);
     351  RFrame(ca, p.Left - 4, p.Top - 4, p.Right + 3, p.Bottom + 2, T.ColorBevelShade,
     352    T.ColorBevelLight);
    342353end;
    343354
    … …  
    10411052begin
    10421053  if InitOrnamentDone then Exit;
    1043   Light := ColorToColor32(MainTexture.clBevelLight);
    1044   // and $FCFCFC shr 2*3+MainTexture.clBevelShade and $FCFCFC shr 2;
    1045   Shade := ColorToColor32(MainTexture.clBevelShade and $FCFCFC shr 2 * 3 +
    1046     MainTexture.clBevelLight and $FCFCFC shr 2);
     1054  Light := ColorToColor32(MainTexture.ColorBevelLight);
     1055  // and $FCFCFC shr 2*3+MainTexture.ColorBevelShade and $FCFCFC shr 2;
     1056  Shade := ColorToColor32(MainTexture.ColorBevelShade and $FCFCFC shr 2 * 3 +
     1057    MainTexture.ColorBevelLight and $FCFCFC shr 2);
    10471058  HGrSystem2.Data.BeginUpdate;
    10481059  PixelPtr := PixelPointer(HGrSystem2.Data, ScaleToNative(Ornament.Left), ScaleToNative(Ornament.Top));
    … …  
    10721083end;
    10731084
    1074 procedure InitCityMark(const T: TTexture);
     1085procedure InitCityMark(T: TTexture);
    10751086var
    10761087  x: Integer;
    … …  
    10851096          x, CityMark1.Top + y] and $FF;
    10861097        HGrSystem.Data.Canvas.Pixels[CityMark2.Left + x, CityMark2.Top + y] :=
    1087           T.clMark and $FF * Intensity div $FF + T.clMark shr 8 and
    1088           $FF * Intensity div $FF shl 8 + T.clMark shr 16 and
     1098          T.ColorMark and $FF * Intensity div $FF + T.ColorMark shr 8 and
     1099          $FF * Intensity div $FF shl 8 + T.ColorMark shr 16 and
    10891100          $FF * Intensity div $FF shl 16;
    10901101      end;
    … …  
    10971108procedure Fill(ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer);
    10981109begin
    1099   Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= wMainTexture) and
    1100     (Top + yOffset >= 0) and (Top + yOffset + Height <= hMainTexture));
     1110  Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= MainTexture.Width) and
     1111    (Top + yOffset >= 0) and (Top + yOffset + Height <= MainTexture.Height));
    11011112  BitBltCanvas(ca, Left, Top, Width, Height, MainTexture.Image.Canvas,
    11021113    Left + xOffset, Top + yOffset);
    … …  
    11141125    n: integer;
    11151126  begin
    1116     n := ((hMainTexture div 2) div (y1 - y0)) * 2;
    1117     while hMainTexture div 2 + (I + 1) * (y1 - y0) > hMainTexture do
     1127    n := ((MainTexture.Height div 2) div (y1 - y0)) * 2;
     1128    while MainTexture.Height div 2 + (I + 1) * (y1 - y0) > MainTexture.Height do
    11181129      Dec(I, n);
    1119     while hMainTexture div 2 + I * (y1 - y0) < 0 do
     1130    while MainTexture.Height div 2 + I * (y1 - y0) < 0 do
    11201131      Inc(I, n);
    11211132    Result := I;
    … …  
    11251136  I: Integer;
    11261137begin
    1127   for I := 0 to (x1 - xm) div wMainTexture - 1 do
    1128     BitBltCanvas(ca, xm + I * wMainTexture, y0, wMainTexture, y1 - y0,
    1129       MainTexture.Image.Canvas, 0, hMainTexture div 2 + Band(I) *
     1138  for I := 0 to (x1 - xm) div MainTexture.Width - 1 do
     1139    BitBltCanvas(ca, xm + I * MainTexture.Width, y0, MainTexture.Width, y1 - y0,
     1140      MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band(I) *
    11301141      (y1 - y0));
    1131   BitBltCanvas(ca, xm + ((x1 - xm) div wMainTexture) * wMainTexture, y0,
    1132     x1 - (xm + ((x1 - xm) div wMainTexture) * wMainTexture), y1 - y0,
    1133     MainTexture.Image.Canvas, 0, hMainTexture div 2 + Band(
    1134     (x1 - xm) div wMainTexture) * (y1 - y0));
    1135   for I := 0 to (xm - x0) div wMainTexture - 1 do
    1136     BitBltCanvas(ca, xm - (I + 1) * wMainTexture, y0, wMainTexture, y1 - y0,
    1137       MainTexture.Image.Canvas, 0, hMainTexture div 2 +
     1142  BitBltCanvas(ca, xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width, y0,
     1143    x1 - (xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width), y1 - y0,
     1144    MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band(
     1145    (x1 - xm) div MainTexture.Width) * (y1 - y0));
     1146  for I := 0 to (xm - x0) div MainTexture.Width - 1 do
     1147    BitBltCanvas(ca, xm - (I + 1) * MainTexture.Width, y0, MainTexture.Width, y1 - y0,
     1148      MainTexture.Image.Canvas, 0, MainTexture.Height div 2 +
    11381149      Band(-I - 1) * (y1 - y0));
    1139   BitBltCanvas(ca, x0, y0, xm - ((xm - x0) div wMainTexture) *
    1140     wMainTexture - x0, y1 - y0, MainTexture.Image.Canvas,
    1141     ((xm - x0) div wMainTexture + 1) * wMainTexture - (xm - x0),
    1142     hMainTexture div 2 + Band(-(xm - x0) div wMainTexture - 1) * (y1 - y0));
     1150  BitBltCanvas(ca, x0, y0, xm - ((xm - x0) div MainTexture.Width) *
     1151    MainTexture.Width - x0, y1 - y0, MainTexture.Image.Canvas,
     1152    ((xm - x0) div MainTexture.Width + 1) * MainTexture.Width - (xm - x0),
     1153    MainTexture.Height div 2 + Band(-(xm - x0) div MainTexture.Width - 1) * (y1 - y0));
    11431154end;
    11441155
    … …  
    11851196procedure PaintBackground(Form: TForm; Left, Top, Width, Height: Integer);
    11861197begin
    1187   Fill(Form.Canvas, Left, Top, Width, Height, (wMainTexture - Form.ClientWidth) div
    1188     2, (hMainTexture - Form.ClientHeight) div 2);
    1189 end;
    1190 
    1191 procedure Corner(ca: TCanvas; x, y, Kind: Integer; const T: TTexture);
     1198  Fill(Form.Canvas, Left, Top, Width, Height, (MainTexture.Width - Form.ClientWidth) div
     1199    2, (MainTexture.Height - Form.ClientHeight) div 2);
     1200end;
     1201
     1202procedure Corner(ca: TCanvas; x, y, Kind: Integer; T: TTexture);
    11921203begin
    11931204  { BitBltCanvas(ca,x,y,8,8,T.HGr.Mask.Canvas,
    … …  
    12841295end;
    12851296
    1286 procedure LoweredTextOut(ca: TCanvas; cl: TColor; const T: TTexture;
     1297procedure LoweredTextOut(ca: TCanvas; cl: TColor; T: TTexture;
    12871298  x, y: Integer; s: string);
    12881299begin
    12891300  if cl = -2 then
    1290     BiColorTextOut(ca, (T.clBevelShade and $FEFEFE) shr 1,
    1291       T.clBevelLight, x, y, s)
     1301    BiColorTextOut(ca, (T.ColorBevelShade and $FEFEFE) shr 1,
     1302      T.ColorBevelLight, x, y, s)
    12921303  else if cl < 0 then
    1293     BiColorTextOut(ca, T.clTextShade, T.clTextLight, x, y, s)
     1304    BiColorTextOut(ca, T.ColorTextShade, T.ColorTextLight, x, y, s)
    12941305  else
    1295     BiColorTextOut(ca, cl, T.clTextLight, x, y, s);
     1306    BiColorTextOut(ca, cl, T.ColorTextLight, x, y, s);
    12961307end;
    12971308
    … …  
    13681379procedure UnderlinedTitleValue(Canvas: TCanvas; Title, Value: string; X, Y, Width: Integer);
    13691380begin
    1370   DLine(Canvas, X, X + Width, Y + 19, MainTexture.clBevelLight, MainTexture.clBevelShade);
     1381  DLine(Canvas, X, X + Width, Y + 19, MainTexture.ColorBevelLight, MainTexture.ColorBevelShade);
    13711382  RisedTextOut(Canvas, X, Y, Title);
    13721383  RisedTextOut(Canvas, X + Width - BiColorTextWidth(Canvas, Value), Y, Value);
    … …  
    13741385
    13751386procedure NumberBar(dst: TBitmap; x, y: integer; Cap: string;
    1376   val: Integer; const T: TTexture);
     1387  val: Integer; T: TTexture);
    13771388var
    13781389  s: string;
    … …  
    13801391  if val > 0 then
    13811392  begin
    1382     DLine(dst.Canvas, x - 2, x + 170, y + 16, T.clBevelShade,
    1383       T.clBevelLight);
     1393    DLine(dst.Canvas, x - 2, x + 170, y + 16, T.ColorBevelShade,
     1394      T.ColorBevelLight);
    13841395    LoweredTextOut(dst.Canvas, -1, T, x - 2, y, Cap);
    13851396    s := IntToStr(val);
    … …  
    13901401
    13911402procedure CountBar(dst: TBitmap; x, y, w: Integer; Kind: Integer;
    1392   Cap: string; val: Integer; const T: TTexture);
     1403  Cap: string; val: Integer; T: TTexture);
    13931404var
    13941405  i, sd, ld, cl, xIcon, yIcon: Integer;
    … …  
    14031414    // xIcon:=x+100;
    14041415    // yIcon:=y;
    1405     // DLine(dst.Canvas,x-2,x+170+32,y+16,T.clBevelShade,T.clBevelLight);
     1416    // DLine(dst.Canvas,x-2,x+170+32,y+16,T.ColorBevelShade,T.ColorBevelLight);
    14061417
    14071418    xIcon := x - 5;
    14081419    yIcon := y + 15;
    1409     DLine(dst.Canvas, x - 2, xIcon + w + 2, yIcon + 16, T.clBevelShade,
    1410       T.clBevelLight);
     1420    DLine(dst.Canvas, x - 2, xIcon + w + 2, yIcon + 16, T.ColorBevelShade,
     1421      T.ColorBevelLight);
    14111422
    14121423    s := IntToStr(val);
    … …  
    14861497
    14871498procedure PaintProgressBar(ca: TCanvas; Kind, x, y, pos, Growth, max: Integer;
    1488   const T: TTexture);
     1499  T: TTexture);
    14891500var
    14901501  i: Integer;
    … …  
    15041515    Growth := max - pos;
    15051516  Frame(ca, x - 1, y - 1, x + max, y + 7, $000000, $000000);
    1506   RFrame(ca, x - 2, y - 2, x + max + 1, y + 8, T.clBevelShade,
    1507     T.clBevelLight);
     1517  RFrame(ca, x - 2, y - 2, x + max + 1, y + 8, T.ColorBevelShade,
     1518    T.ColorBevelLight);
    15081519  with ca do
    15091520  begin
    … …  
    15401551procedure PaintRelativeProgressBar(ca: TCanvas;
    15411552  Kind, x, y, size, pos, Growth, max: Integer; IndicateComplete: Boolean;
    1542   const T: TTexture);
     1553  T: TTexture);
    15431554begin
    15441555  if Growth > 0 then
    … …  
    15591570    LightColor, ShadeColor);
    15601571  BitBltCanvas(Canvas, X, Y, Logo.Width, Logo.Height, LogoBuffer.Canvas, 0, 0);
    1561 end;
    1562 
    1563 function SetMainTextureByAge(Age: Integer): Boolean;
    1564 begin
    1565   if Age <> MainTextureAge then
    1566     with MainTexture do begin
    1567       MainTextureAge := Age;
    1568       LoadGraphicFile(Image, GetGraphicsDir + DirectorySeparator +
    1569         'Texture' + IntToStr(Age + 1) + '.jpg');
    1570       clBevelLight := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelLight];
    1571       clBevelShade := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelShade];
    1572       clTextLight := Colors.Canvas.Pixels[clkAge0 + Age, cliTextLight];
    1573       clTextShade := Colors.Canvas.Pixels[clkAge0 + Age, cliTextShade];
    1574       clLitText := Colors.Canvas.Pixels[clkAge0 + Age, cliLitText];
    1575       clMark := Colors.Canvas.Pixels[clkAge0 + Age, cliMark];
    1576       clPage := Colors.Canvas.Pixels[clkAge0 + Age, cliPage];
    1577       clCover := Colors.Canvas.Pixels[clkAge0 + Age, cliCover];
    1578       Result := True;
    1579     end
    1580   else
    1581     Result := False;
    15821572end;
    15831573
    … …  
    17951785  BigImp := TBitmap.Create;
    17961786  BigImp.PixelFormat := pf24bit;
    1797   MainTexture.Image := TBitmap.Create;
    1798   MainTextureAge := -2;
     1787  MainTexture := TTexture.Create;
    17991788  ClickFrameColor := HGrSystem.Data.Canvas.Pixels[187, 175];
    18001789  InitOrnamentDone := False;
    … …  
    18191808  FreeAndNil(Paper);
    18201809  FreeAndNil(Colors);
    1821   FreeAndNil(MainTexture.Image);
     1810  FreeAndNil(MainTexture);
     1811end;
     1812
     1813{ TTexture }
     1814
     1815procedure TTexture.SetAge(AValue: Integer);
     1816begin
     1817  if FAge = AValue then Exit;
     1818  FAge := AValue;
     1819  LoadGraphicFile(Image, GetGraphicsDir + DirectorySeparator +
     1820    'Texture' + IntToStr(Age + 1) + '.jpg');
     1821  ColorBevelLight := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelLight];
     1822  ColorBevelShade := Colors.Canvas.Pixels[clkAge0 + Age, cliBevelShade];
     1823  ColorTextLight := Colors.Canvas.Pixels[clkAge0 + Age, cliTextLight];
     1824  ColorTextShade := Colors.Canvas.Pixels[clkAge0 + Age, cliTextShade];
     1825  ColorLitText := Colors.Canvas.Pixels[clkAge0 + Age, cliLitText];
     1826  ColorMark := Colors.Canvas.Pixels[clkAge0 + Age, cliMark];
     1827  ColorPage := Colors.Canvas.Pixels[clkAge0 + Age, cliPage];
     1828  ColorCover := Colors.Canvas.Pixels[clkAge0 + Age, cliCover];
     1829end;
     1830
     1831function TTexture.GetHeight: Integer;
     1832begin
     1833  Result := Image.Height;
     1834end;
     1835
     1836function TTexture.GetWidth: Integer;
     1837begin
     1838  Result := Image.Width;
     1839end;
     1840
     1841constructor TTexture.Create;
     1842begin
     1843  Image := TBitmap.Create;
     1844  FAge := -2;
     1845end;
     1846
     1847destructor TTexture.Destroy;
     1848begin
     1849  FreeAndNil(Image);
     1850  inherited;
     1851end;
     1852
     1853procedure TTexture.Assign(Source: TTexture);
     1854begin
     1855  FAge := Source.FAge;
     1856  Image.Assign(Image);
     1857  ColorBevelLight := Source.ColorBevelLight;
     1858  ColorBevelShade := Source.ColorBevelShade;
     1859  ColorTextLight := Source.ColorTextLight;
     1860  ColorTextShade := Source.ColorTextShade;
     1861  ColorLitText := Source.ColorLitText;
     1862  ColorMark := Source.ColorMark;
     1863  ColorPage := Source.ColorPage;
     1864  ColorCover := Source.ColorCover;
    18221865end;
    18231866
Note: See TracChangeset for help on using the changeset viewer.