Changeset 456 for trunk/Packages/CevoComponents/ScreenTools.pas
- Timestamp:
- May 30, 2023, 11:31:10 AM (18 months ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Packages/CevoComponents/ScreenTools.pas
r447 r456 8 8 {$ENDIF} 9 9 StringTables, LCLIntf, LCLType, SysUtils, Classes, Graphics, Controls, Math, 10 Forms, Menus, GraphType, UGraphicSet, LazFileUtils, UTexture;10 Forms, Menus, GraphType, GraphicSet, LazFileUtils, Texture; 11 11 12 12 type … … 24 24 function TurnToString(Turn: Integer): string; 25 25 function MovementToString(Movement: Integer): string; 26 procedure BtnFrame( ca: TCanvas; P: TRect; T: TTexture);27 procedure EditFrame( ca: TCanvas; P: TRect; T: TTexture);26 procedure BtnFrame(Canvas: TCanvas; P: TRect; T: TTexture); 27 procedure EditFrame(Canvas: TCanvas; P: TRect; T: TTexture); 28 28 function HexStringToColor(S: string): Integer; 29 29 function ExtractFileNameWithoutExt(const Filename: string): string; … … 54 54 function BitBltBitmap(Dest: TBitmap; DestRect: TRect; 55 55 Src: TBitmap; SrcPos: TPoint; Rop: DWORD = SRCCOPY): Boolean; overload; 56 procedure SLine( ca: TCanvas; x0, x1, Y: Integer; cl: TColor);57 procedure DLine( ca: TCanvas; x0, x1, Y: Integer; cl0, cl1: TColor);58 procedure Frame( ca: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor);59 procedure RFrame( ca: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor);60 procedure CFrame( ca: TCanvas; x0, y0, x1, y1, Corner: Integer; cl: TColor);61 procedure FrameImage( ca: TCanvas; Src: TBitmap;56 procedure SLine(Canvas: TCanvas; x0, x1, Y: Integer; cl: TColor); 57 procedure DLine(Canvas: TCanvas; x0, x1, Y: Integer; cl0, cl1: TColor); 58 procedure Frame(Canvas: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor); 59 procedure RFrame(Canvas: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor); 60 procedure CFrame(Canvas: TCanvas; x0, y0, x1, y1, Corner: Integer; cl: TColor); 61 procedure FrameImage(Canvas: TCanvas; Src: TBitmap; 62 62 X, Y, Width, Height, xSrc, ySrc: Integer; IsControl: Boolean = False); 63 63 procedure GlowFrame(Dst: TBitmap; x0, y0, Width, Height: Integer; cl: TColor); 64 64 procedure InitOrnament; 65 procedure InitCityMark(T : TTexture);66 procedure Fill( ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer); overload;65 procedure InitCityMark(Texture: TTexture); 66 procedure Fill(Canvas: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer); overload; 67 67 procedure Fill(Canvas: TCanvas; Rect: TRect; Offset: TPoint); overload; 68 procedure FillLarge( ca: TCanvas; x0, y0, x1, y1, xm: Integer);69 procedure FillSeamless( ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer;68 procedure FillLarge(Canvas: TCanvas; x0, y0, x1, y1, xm: Integer); 69 procedure FillSeamless(Canvas: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer; 70 70 const Texture: TBitmap); 71 procedure FillRectSeamless( ca: TCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer;71 procedure FillRectSeamless(Canvas: TCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer; 72 72 const Texture: TBitmap); 73 73 procedure PaintBackground(Form: TForm; Left, Top, Width, Height: Integer); 74 procedure Corner( ca: TCanvas; X, Y, Kind: Integer; T: TTexture);75 procedure BiColorTextOut( ca: TCanvas; clMain, clBack: TColor; X, Y: Integer; S: string);76 procedure LoweredTextOut( ca: TCanvas; cl: TColor; T: TTexture;74 procedure Corner(Canvas: TCanvas; X, Y, Kind: Integer; T: TTexture); 75 procedure BiColorTextOut(Canvas: TCanvas; clMain, clBack: TColor; X, Y: Integer; S: string); 76 procedure LoweredTextOut(Canvas: TCanvas; cl: TColor; T: TTexture; 77 77 X, Y: Integer; S: string); 78 function BiColorTextWidth( ca: TCanvas; S: string): Integer;79 procedure RisedTextOut( ca: TCanvas; X, Y: Integer; S: string);80 procedure LightGradient( ca: TCanvas; X, Y, Width, Color: Integer);81 procedure DarkGradient( ca: TCanvas; X, Y, Width, Kind: Integer);82 procedure VLightGradient( ca: TCanvas; X, Y, Height, Color: Integer);83 procedure VDarkGradient( ca: TCanvas; X, Y, Height, Kind: Integer);78 function BiColorTextWidth(Canvas: TCanvas; S: string): Integer; 79 procedure RisedTextOut(Canvas: TCanvas; X, Y: Integer; S: string); 80 procedure LightGradient(Canvas: TCanvas; X, Y, Width, Color: Integer); 81 procedure DarkGradient(Canvas: TCanvas; X, Y, Width, Kind: Integer); 82 procedure VLightGradient(Canvas: TCanvas; X, Y, Height, Color: Integer); 83 procedure VDarkGradient(Canvas: TCanvas; X, Y, Height, Kind: Integer); 84 84 procedure UnderlinedTitleValue(Canvas: TCanvas; Title, Value: string; X, Y, Width: Integer); 85 85 procedure NumberBar(dst: TBitmap; X, Y: Integer; Cap: string; val: Integer; … … 87 87 procedure CountBar(dst: TBitmap; X, Y, W: Integer; Kind: Integer; 88 88 Cap: string; val: Integer; T: TTexture); 89 procedure PaintProgressBar( ca: TCanvas; Kind, X, Y, Pos, Growth, Max: Integer;89 procedure PaintProgressBar(Canvas: TCanvas; Kind, X, Y, Pos, Growth, Max: Integer; 90 90 T: TTexture); 91 procedure PaintRelativeProgressBar( ca: TCanvas;91 procedure PaintRelativeProgressBar(Canvas: TCanvas; 92 92 Kind, X, Y, size, Pos, Growth, Max: Integer; IndicateComplete: Boolean; 93 93 T: TTexture); … … 199 199 200 200 uses 201 Directories, Sound, UPixelPointer;201 Directories, Sound, PixelPointer; 202 202 203 203 var … … 318 318 end; 319 319 320 procedure BtnFrame( ca: TCanvas; P: TRect; T: TTexture);321 begin 322 RFrame( ca, P.Left - 1, P.Top - 1, P.Right, P.Bottom, T.ColorBevelShade,320 procedure BtnFrame(Canvas: TCanvas; P: TRect; T: TTexture); 321 begin 322 RFrame(Canvas, P.Left - 1, P.Top - 1, P.Right, P.Bottom, T.ColorBevelShade, 323 323 T.ColorBevelLight); 324 324 end; 325 325 326 procedure EditFrame( ca: TCanvas; P: TRect; T: TTexture);327 begin 328 Frame( ca, P.Left - 1, P.Top - 1, P.Right, P.Bottom, $000000, $000000);329 Frame( ca, P.Left - 2, P.Top - 2, P.Right + 1, P.Bottom + 1, $000000, $000000);330 Frame( ca, P.Left - 3, P.Top - 3, P.Right + 2, P.Bottom + 1, $000000, $000000);331 RFrame( ca, P.Left - 4, P.Top - 4, P.Right + 3, P.Bottom + 2, T.ColorBevelShade,326 procedure EditFrame(Canvas: TCanvas; P: TRect; T: TTexture); 327 begin 328 Frame(Canvas, P.Left - 1, P.Top - 1, P.Right, P.Bottom, $000000, $000000); 329 Frame(Canvas, P.Left - 2, P.Top - 2, P.Right + 1, P.Bottom + 1, $000000, $000000); 330 Frame(Canvas, P.Left - 3, P.Top - 3, P.Right + 2, P.Bottom + 1, $000000, $000000); 331 RFrame(Canvas, P.Left - 4, P.Top - 4, P.Right + 3, P.Bottom + 2, T.ColorBevelShade, 332 332 T.ColorBevelLight); 333 333 end; … … 371 371 begin 372 372 Bitmap.BeginUpdate; 373 PixelPtr := PixelPointer(Bitmap);373 PixelPtr := TPixelPointer.Create(Bitmap); 374 374 for Y := 0 to ScaleToNative(Bitmap.Height) - 1 do begin 375 375 for X := 0 to ScaleToNative(Bitmap.Width) - 1 do begin … … 388 388 begin 389 389 //Dst.SetSize(Src.Width, Src.Height); 390 SrcPtr := PixelPointer(Src);391 DstPtr := PixelPointer(Dst);390 SrcPtr := TPixelPointer.Create(Src); 391 DstPtr := TPixelPointer.Create(Dst); 392 392 for Y := 0 to ScaleToNative(Src.Height - 1) do begin 393 393 for X := 0 to ScaleToNative(Src.Width - 1) do begin … … 520 520 Result.Data.BeginUpdate; 521 521 Result.Mask.BeginUpdate; 522 DataPixel := PixelPointer(Result.Data);523 MaskPixel := PixelPointer(Result.Mask);522 DataPixel := TPixelPointer.Create(Result.Data); 523 MaskPixel := TPixelPointer.Create(Result.Mask); 524 524 for Y := 0 to ScaleToNative(Result.Data.Height) - 1 do begin 525 525 for X := 0 to ScaleToNative(Result.Data.Width) - 1 do begin … … 564 564 begin 565 565 Dst.BeginUpdate; 566 PixelPtr := PixelPointer(Dst, ScaleToNative(X), ScaleToNative(Y));566 PixelPtr := TPixelPointer.Create(Dst, ScaleToNative(X), ScaleToNative(Y)); 567 567 for YY := 0 to ScaleToNative(Height) - 1 do begin 568 568 for XX := 0 to ScaleToNative(Width) - 1 do begin … … 583 583 begin 584 584 Dst.BeginUpdate; 585 PixelPtr := PixelPointer(Dst, ScaleToNative(X), ScaleToNative(Y));585 PixelPtr := TPixelPointer.Create(Dst, ScaleToNative(X), ScaleToNative(Y)); 586 586 for yy := 0 to ScaleToNative(Height) - 1 do begin 587 587 for xx := 0 to ScaleToNative(Width) - 1 do begin … … 603 603 begin 604 604 Dst.BeginUpdate; 605 PixelPtr := PixelPointer(Dst, ScaleToNative(X), ScaleToNative(Y));605 PixelPtr := TPixelPointer.Create(Dst, ScaleToNative(X), ScaleToNative(Y)); 606 606 for YY := 0 to ScaleToNative(Height) - 1 do begin 607 607 for XX := 0 to ScaleToNative(Width) - 1 do begin … … 654 654 dst.BeginUpdate; 655 655 Src.BeginUpdate; 656 PixelDst := PixelPointer(Dst, xDst, yDst);657 PixelSrc := PixelPointer(Src, xSrc, ySrc);656 PixelDst := TPixelPointer.Create(Dst, xDst, yDst); 657 PixelSrc := TPixelPointer.Create(Src, xSrc, ySrc); 658 658 for Y := 0 to Height - 1 do begin 659 659 for X := 0 to Width - 1 do begin … … 720 720 Src.BeginUpdate; 721 721 dst.BeginUpdate; 722 SrcPixel := PixelPointer(Src, xSrc, ySrc);723 DstPixel := PixelPointer(Dst, xDst, yDst);722 SrcPixel := TPixelPointer.Create(Src, xSrc, ySrc); 723 DstPixel := TPixelPointer.Create(Dst, xDst, yDst); 724 724 for iy := 0 to Height - 1 do begin 725 725 for ix := 0 to Width - 1 do begin … … 777 777 Src.BeginUpdate; 778 778 Dst.BeginUpdate; 779 SrcPixel := PixelPointer(Src, xSrc, ySrc);780 DstPixel := PixelPointer(Dst, xDst, yDst);779 SrcPixel := TPixelPointer.Create(Src, xSrc, ySrc); 780 DstPixel := TPixelPointer.Create(Dst, xDst, yDst); 781 781 for iy := 0 to Height - 1 do begin 782 782 for ix := 0 to Width - 1 do begin … … 823 823 Assert(bmp.PixelFormat = pf24bit); 824 824 Height := Y + Height; 825 PixelPtr := PixelPointer(Bmp, X, Y);825 PixelPtr := TPixelPointer.Create(Bmp, X, Y); 826 826 while Y < Height do begin 827 827 for I := 0 to Width - 1 do begin … … 890 890 end; 891 891 892 procedure SLine( ca: TCanvas; x0, x1, Y: Integer; cl: TColor);893 begin 894 with cado begin892 procedure SLine(Canvas: TCanvas; x0, x1, Y: Integer; cl: TColor); 893 begin 894 with Canvas do begin 895 895 Pen.Color := cl; 896 896 MoveTo(x0, Y); … … 899 899 end; 900 900 901 procedure DLine( ca: TCanvas; x0, x1, Y: Integer; cl0, cl1: TColor);902 begin 903 with cado begin901 procedure DLine(Canvas: TCanvas; x0, x1, Y: Integer; cl0, cl1: TColor); 902 begin 903 with Canvas do begin 904 904 Pen.Color := cl0; 905 905 MoveTo(x0, Y); … … 913 913 end; 914 914 915 procedure Frame( ca: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor);916 begin 917 with cado begin915 procedure Frame(Canvas: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor); 916 begin 917 with Canvas do begin 918 918 MoveTo(x0, y1); 919 919 Pen.Color := cl0; … … 926 926 end; 927 927 928 procedure RFrame( ca: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor);929 begin 930 with cado begin928 procedure RFrame(Canvas: TCanvas; x0, y0, x1, y1: Integer; cl0, cl1: TColor); 929 begin 930 with Canvas do begin 931 931 Pen.Color := cl0; 932 932 MoveTo(x0, y0 + 1); … … 942 942 end; 943 943 944 procedure CFrame( ca: TCanvas; x0, y0, x1, y1, Corner: Integer; cl: TColor);945 begin 946 with cado begin944 procedure CFrame(Canvas: TCanvas; x0, y0, x1, y1, Corner: Integer; cl: TColor); 945 begin 946 with Canvas do begin 947 947 Pen.Color := cl; 948 948 MoveTo(x0, y0 + Corner - 1); … … 961 961 end; 962 962 963 procedure FrameImage( ca: TCanvas; Src: TBitmap;963 procedure FrameImage(Canvas: TCanvas; Src: TBitmap; 964 964 X, Y, Width, Height, xSrc, ySrc: Integer; IsControl: Boolean = False); 965 965 begin 966 966 if IsControl then begin 967 Frame( ca, X - 1, Y - 1, X + Width, Y + Height, $B0B0B0, $FFFFFF);968 RFrame( ca, X - 2, Y - 2, X + Width + 1, Y + Height + 1, $FFFFFF, $B0B0B0);967 Frame(Canvas, X - 1, Y - 1, X + Width, Y + Height, $B0B0B0, $FFFFFF); 968 RFrame(Canvas, X - 2, Y - 2, X + Width + 1, Y + Height + 1, $FFFFFF, $B0B0B0); 969 969 end else 970 Frame( ca, X - 1, Y - 1, X + Width, Y + Height, $000000, $000000);971 BitBltCanvas( ca, X, Y, Width, Height, Src.Canvas, xSrc, ySrc);970 Frame(Canvas, X - 1, Y - 1, X + Width, Y + Height, $000000, $000000); 971 BitBltCanvas(Canvas, X, Y, Width, Height, Src.Canvas, xSrc, ySrc); 972 972 end; 973 973 … … 984 984 Height := ScaleToNative(Height); 985 985 Dst.BeginUpdate; 986 DstPtr := PixelPointer(Dst, x0 - DpiGlowRange + 1, y0 - DpiGlowRange + 1);986 DstPtr := TPixelPointer.Create(Dst, x0 - DpiGlowRange + 1, y0 - DpiGlowRange + 1); 987 987 for Y := -DpiGlowRange + 1 to Height - 1 + DpiGlowRange - 1 do begin 988 988 for X := -DpiGlowRange + 1 to Width - 1 + DpiGlowRange - 1 do begin … … 1036 1036 MainTexture.ColorBevelLight and $FCFCFC shr 2); 1037 1037 HGrSystem2.Data.BeginUpdate; 1038 PixelPtr := PixelPointer(HGrSystem2.Data, ScaleToNative(Ornament.Left),1038 PixelPtr := TPixelPointer.Create(HGrSystem2.Data, ScaleToNative(Ornament.Left), 1039 1039 ScaleToNative(Ornament.Top)); 1040 1040 if PixelPtr.BytesPerPixel = 3 then begin … … 1063 1063 end; 1064 1064 1065 procedure InitCityMark(T : TTexture);1065 procedure InitCityMark(Texture: TTexture); 1066 1066 var 1067 1067 X: Integer; … … 1076 1076 X, CityMark1.Top + Y] and $FF; 1077 1077 HGrSystem.Data.Canvas.Pixels[CityMark2.Left + X, CityMark2.Top + Y] := 1078 T .ColorMark and $FF * Intensity div $FF + T.ColorMark shr 8 and1079 $FF * Intensity div $FF shl 8 + T .ColorMark shr 16 and1078 Texture.ColorMark and $FF * Intensity div $FF + Texture.ColorMark shr 8 and 1079 $FF * Intensity div $FF shl 8 + Texture.ColorMark shr 16 and 1080 1080 $FF * Intensity div $FF shl 16; 1081 1081 end; … … 1086 1086 end; 1087 1087 1088 procedure Fill( ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer);1089 begin 1090 Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= MainTexture.Width) and1091 (Top + yOffset >= 0) and (Top + yOffset + Height <= MainTexture.Height));1092 BitBltCanvas( ca, Left, Top, Width, Height, MainTexture.Image.Canvas,1088 procedure Fill(Canvas: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer); 1089 begin 1090 //Assert((Left + xOffset >= 0) and (Left + xOffset + Width <= MainTexture.Width) and 1091 // (Top + yOffset >= 0) and (Top + yOffset + Height <= MainTexture.Height)); 1092 BitBltCanvas(Canvas, Left, Top, Width, Height, MainTexture.Image.Canvas, 1093 1093 Left + xOffset, Top + yOffset); 1094 1094 end; … … 1099 1099 end; 1100 1100 1101 procedure FillLarge( ca: TCanvas; x0, y0, x1, y1, xm: Integer);1101 procedure FillLarge(Canvas: TCanvas; x0, y0, x1, y1, xm: Integer); 1102 1102 1103 1103 function Band(I: Integer): Integer; … … 1117 1117 begin 1118 1118 for I := 0 to (x1 - xm) div MainTexture.Width - 1 do 1119 BitBltCanvas( ca, xm + I * MainTexture.Width, y0, MainTexture.Width, y1 - y0,1119 BitBltCanvas(Canvas, xm + I * MainTexture.Width, y0, MainTexture.Width, y1 - y0, 1120 1120 MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band(I) * 1121 1121 (y1 - y0)); 1122 BitBltCanvas( ca, xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width, y0,1122 BitBltCanvas(Canvas, xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width, y0, 1123 1123 x1 - (xm + ((x1 - xm) div MainTexture.Width) * MainTexture.Width), y1 - y0, 1124 1124 MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + Band( 1125 1125 (x1 - xm) div MainTexture.Width) * (y1 - y0)); 1126 1126 for I := 0 to (xm - x0) div MainTexture.Width - 1 do 1127 BitBltCanvas( ca, xm - (I + 1) * MainTexture.Width, y0, MainTexture.Width, y1 - y0,1127 BitBltCanvas(Canvas, xm - (I + 1) * MainTexture.Width, y0, MainTexture.Width, y1 - y0, 1128 1128 MainTexture.Image.Canvas, 0, MainTexture.Height div 2 + 1129 1129 Band(-I - 1) * (y1 - y0)); 1130 BitBltCanvas( ca, x0, y0, xm - ((xm - x0) div MainTexture.Width) *1130 BitBltCanvas(Canvas, x0, y0, xm - ((xm - x0) div MainTexture.Width) * 1131 1131 MainTexture.Width - x0, y1 - y0, MainTexture.Image.Canvas, 1132 1132 ((xm - x0) div MainTexture.Width + 1) * MainTexture.Width - (xm - x0), … … 1134 1134 end; 1135 1135 1136 procedure FillSeamless( ca: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer;1136 procedure FillSeamless(Canvas: TCanvas; Left, Top, Width, Height, xOffset, yOffset: Integer; 1137 1137 const Texture: TBitmap); 1138 1138 var … … 1161 1161 if x1cut < 0 then 1162 1162 x1cut := 0; 1163 BitBltCanvas( ca, X * Texture.Width + x0cut - xOffset,1163 BitBltCanvas(Canvas, X * Texture.Width + x0cut - xOffset, 1164 1164 Y * Texture.Height + y0cut - yOffset, Texture.Width - x0cut - x1cut, 1165 1165 Texture.Height - y0cut - y1cut, Texture.Canvas, x0cut, y0cut); … … 1168 1168 end; 1169 1169 1170 procedure FillRectSeamless( ca: TCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer;1170 procedure FillRectSeamless(Canvas: TCanvas; x0, y0, x1, y1, xOffset, yOffset: Integer; 1171 1171 const Texture: TBitmap); 1172 1172 begin 1173 FillSeamless( ca, x0, y0, x1 - x0, y1 - y0, xOffset, yOffset, Texture);1173 FillSeamless(Canvas, x0, y0, x1 - x0, y1 - y0, xOffset, yOffset, Texture); 1174 1174 end; 1175 1175 … … 1180 1180 end; 1181 1181 1182 procedure Corner( ca: TCanvas; X, Y, Kind: Integer; T: TTexture);1183 begin 1184 { BitBltCanvas( ca,x,y,8,8,T.HGr.Mask.Canvas,1182 procedure Corner(Canvas: TCanvas; X, Y, Kind: Integer; T: TTexture); 1183 begin 1184 { BitBltCanvas(Canvas,x,y,8,8,T.HGr.Mask.Canvas, 1185 1185 T.xGr+29+Kind*9,T.yGr+89,SRCAND); 1186 BitBltCanvas( ca,X,Y,8,8,T.HGr.Data.Canvas,1186 BitBltCanvas(Canvas,X,Y,8,8,T.HGr.Data.Canvas, 1187 1187 T.xGr+29+Kind*9,T.yGr+89,SRCPAINT); } 1188 1188 end; 1189 1189 1190 procedure BiColorTextOut( ca: TCanvas; clMain, clBack: TColor; X, Y: Integer; S: string);1190 procedure BiColorTextOut(Canvas: TCanvas; clMain, clBack: TColor; X, Y: Integer; S: string); 1191 1191 1192 1192 procedure PaintIcon(X, Y, Kind: Integer); 1193 1193 begin 1194 BitBltCanvas( ca, X, Y + 6, 10, 10, HGrSystem.Mask.Canvas,1194 BitBltCanvas(Canvas, X, Y + 6, 10, 10, HGrSystem.Mask.Canvas, 1195 1195 66 + Kind mod 11 * 11, 115 + Kind div 11 * 11, SRCAND); 1196 BitBltCanvas( ca, X, Y + 6, 10, 10, HGrSystem.Data.Canvas,1196 BitBltCanvas(Canvas, X, Y + 6, 10, 10, HGrSystem.Data.Canvas, 1197 1197 66 + Kind mod 11 * 11, 115 + Kind div 11 * 11, SRCPAINT); 1198 1198 end; … … 1207 1207 Inc(Y); 1208 1208 for shadow := True downto False do 1209 with cado1209 with Canvas do 1210 1210 if not shadow or (clBack <> $7F007F) then 1211 1211 begin … … 1221 1221 (sp[P + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) then 1222 1222 begin 1223 ca.Textout(xp, Y, sp);1223 Canvas.Textout(xp, Y, sp); 1224 1224 Break; 1225 1225 end … … 1228 1228 Text := Copy(sp, 1, P - 1); 1229 1229 Textout(xp, Y, Text); 1230 Inc(xp, ca.TextWidth(Text));1230 Inc(xp, Canvas.TextWidth(Text)); 1231 1231 if not shadow then 1232 1232 case sp[P + 1] of … … 1251 1251 end; 1252 1252 1253 function BiColorTextWidth( ca: TCanvas; S: string): Integer;1253 function BiColorTextWidth(Canvas: TCanvas; S: string): Integer; 1254 1254 var 1255 1255 P: Integer; … … 1260 1260 if (P = 0) or (P = Length(S)) then 1261 1261 begin 1262 Inc(Result, ca.TextWidth(S));1262 Inc(Result, Canvas.TextWidth(S)); 1263 1263 Break; 1264 1264 end … … 1267 1267 if not (S[P + 1] in ['c', 'f', 'l', 'm', 'n', 'o', 'p', 'r', 't', 'w']) 1268 1268 then 1269 Inc(Result, ca.TextWidth(Copy(S, 1, P + 1)))1269 Inc(Result, Canvas.TextWidth(Copy(S, 1, P + 1))) 1270 1270 else 1271 Inc(Result, ca.TextWidth(Copy(S, 1, P - 1)) + 10);1271 Inc(Result, Canvas.TextWidth(Copy(S, 1, P - 1)) + 10); 1272 1272 Delete(S, 1, P + 1); 1273 1273 end; … … 1275 1275 end; 1276 1276 1277 procedure LoweredTextOut( ca: TCanvas; cl: TColor; T: TTexture;1277 procedure LoweredTextOut(Canvas: TCanvas; cl: TColor; T: TTexture; 1278 1278 X, Y: Integer; S: string); 1279 1279 begin 1280 1280 if cl = -2 then 1281 BiColorTextOut( ca, (T.ColorBevelShade and $FEFEFE) shr 1,1281 BiColorTextOut(Canvas, (T.ColorBevelShade and $FEFEFE) shr 1, 1282 1282 T.ColorBevelLight, X, Y, S) 1283 1283 else if cl < 0 then 1284 BiColorTextOut( ca, T.ColorTextShade, T.ColorTextLight, X, Y, S)1284 BiColorTextOut(Canvas, T.ColorTextShade, T.ColorTextLight, X, Y, S) 1285 1285 else 1286 BiColorTextOut( ca, cl, T.ColorTextLight, X, Y, S);1287 end; 1288 1289 procedure RisedTextOut( ca: TCanvas; X, Y: Integer; S: string);1290 begin 1291 BiColorTextOut( ca, $FFFFFF, $000000, X, Y, S);1292 end; 1293 1294 procedure Gradient( ca: TCanvas; X, Y, dx, dy, Width, Height, Color: Integer;1286 BiColorTextOut(Canvas, cl, T.ColorTextLight, X, Y, S); 1287 end; 1288 1289 procedure RisedTextOut(Canvas: TCanvas; X, Y: Integer; S: string); 1290 begin 1291 BiColorTextOut(Canvas, $FFFFFF, $000000, X, Y, S); 1292 end; 1293 1294 procedure Gradient(Canvas: TCanvas; X, Y, dx, dy, Width, Height, Color: Integer; 1295 1295 Brightness: array of Integer); 1296 1296 var … … 1313 1313 else if B >= 256 then 1314 1314 B := 255; 1315 ca.Pen.Color := R + G shl 8 + B shl 16;1316 ca.MoveTo(X + dx * I, Y + dy * I);1317 ca.LineTo(X + dx * I + Width, Y + dy * I + Height);1318 end; 1319 ca.Pen.Color := $000000;1320 ca.MoveTo(X + 1, Y + 16 * dy + Height);1321 ca.LineTo(X + 16 * dx + Width, Y + 16 * dy + Height);1322 ca.LineTo(X + 16 * dx + Width, Y);1323 end; 1324 1325 procedure LightGradient( ca: TCanvas; X, Y, Width, Color: Integer);1315 Canvas.Pen.Color := R + G shl 8 + B shl 16; 1316 Canvas.MoveTo(X + dx * I, Y + dy * I); 1317 Canvas.LineTo(X + dx * I + Width, Y + dy * I + Height); 1318 end; 1319 Canvas.Pen.Color := $000000; 1320 Canvas.MoveTo(X + 1, Y + 16 * dy + Height); 1321 Canvas.LineTo(X + 16 * dx + Width, Y + 16 * dy + Height); 1322 Canvas.LineTo(X + 16 * dx + Width, Y); 1323 end; 1324 1325 procedure LightGradient(Canvas: TCanvas; X, Y, Width, Color: Integer); 1326 1326 const 1327 1327 Brightness: array [0 .. 15] of Integer = 1328 1328 (16, 12, 8, 4, 0, -4, -8, -12, -16, -20, -24, -28, -32, -36, -40, -44); 1329 1329 begin 1330 Gradient( ca, X, Y, 0, 1, Width, 0, Color, Brightness);1331 end; 1332 1333 procedure DarkGradient( ca: TCanvas; X, Y, Width, Kind: Integer);1330 Gradient(Canvas, X, Y, 0, 1, Width, 0, Color, Brightness); 1331 end; 1332 1333 procedure DarkGradient(Canvas: TCanvas; X, Y, Width, Kind: Integer); 1334 1334 const 1335 1335 Brightness: array [0 .. 15] of Integer = 1336 1336 (16, 12, 8, 4, 0, -4, -8, -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44); 1337 1337 begin 1338 Gradient( ca, X, Y, 0, 1, Width, 0, HGrSystem.Data.Canvas.Pixels1338 Gradient(Canvas, X, Y, 0, 1, Width, 0, HGrSystem.Data.Canvas.Pixels 1339 1339 [187, 137 + Kind], Brightness); 1340 1340 end; 1341 1341 1342 procedure VLightGradient( ca: TCanvas; X, Y, Height, Color: Integer);1342 procedure VLightGradient(Canvas: TCanvas; X, Y, Height, Color: Integer); 1343 1343 const 1344 1344 Brightness: array [0 .. 15] of Integer = 1345 1345 (16, 12, 8, 4, 0, -4, -8, -12, -16, -20, -24, -28, -32, -36, -40, -44); 1346 1346 begin 1347 Gradient( ca, X, Y, 1, 0, 0, Height, Color, Brightness);1348 end; 1349 1350 procedure VDarkGradient( ca: TCanvas; X, Y, Height, Kind: Integer);1347 Gradient(Canvas, X, Y, 1, 0, 0, Height, Color, Brightness); 1348 end; 1349 1350 procedure VDarkGradient(Canvas: TCanvas; X, Y, Height, Kind: Integer); 1351 1351 const 1352 1352 Brightness: array [0 .. 15] of Integer = 1353 1353 (16, 12, 8, 4, 0, -4, -8, -12 - 24, -16 + 16, -20, -24, -28, -32, -36, -40, -44); 1354 1354 begin 1355 Gradient( ca, X, Y, 1, 0, 0, Height,1355 Gradient(Canvas, X, Y, 1, 0, 0, Height, 1356 1356 HGrSystem.Data.Canvas.Pixels[187, 137 + Kind], Brightness); 1357 1357 end; … … 1476 1476 end; 1477 1477 1478 procedure PaintProgressBar( ca: TCanvas; Kind, X, Y, Pos, Growth, Max: Integer;1478 procedure PaintProgressBar(Canvas: TCanvas; Kind, X, Y, Pos, Growth, Max: Integer; 1479 1479 T: TTexture); 1480 1480 var … … 1494 1494 else if Pos + Growth > Max then 1495 1495 Growth := Max - Pos; 1496 Frame( ca, X - 1, Y - 1, X + Max, Y + 7, $000000, $000000);1497 RFrame( ca, X - 2, Y - 2, X + Max + 1, Y + 8, T.ColorBevelShade,1496 Frame(Canvas, X - 1, Y - 1, X + Max, Y + 7, $000000, $000000); 1497 RFrame(Canvas, X - 2, Y - 2, X + Max + 1, Y + 8, T.ColorBevelShade, 1498 1498 T.ColorBevelLight); 1499 with cado1499 with Canvas do 1500 1500 begin 1501 1501 for I := 0 to Pos div 8 - 1 do 1502 BitBltCanvas( ca, X + I * 8, Y, 8, 7,1502 BitBltCanvas(Canvas, X + I * 8, Y, 8, 7, 1503 1503 HGrSystem.Data.Canvas, 104, 9 + 8 * Kind); 1504 BitBltCanvas( ca, X + 8 * (Pos div 8), Y, Pos - 8 * (Pos div 8), 7,1504 BitBltCanvas(Canvas, X + 8 * (Pos div 8), Y, Pos - 8 * (Pos div 8), 7, 1505 1505 HGrSystem.Data.Canvas, 104, 9 + 8 * Kind); 1506 1506 if Growth > 0 then 1507 1507 begin 1508 1508 for I := 0 to Growth div 8 - 1 do 1509 BitBltCanvas( ca, X + Pos + I * 8, Y, 8, 7,1509 BitBltCanvas(Canvas, X + Pos + I * 8, Y, 8, 7, 1510 1510 HGrSystem.Data.Canvas, 112, 9 + 8 * Kind); 1511 BitBltCanvas( ca, X + Pos + 8 * (Growth div 8), Y,1511 BitBltCanvas(Canvas, X + Pos + 8 * (Growth div 8), Y, 1512 1512 Growth - 8 * (Growth div 8), 7, HGrSystem.Data.Canvas, 1513 1513 112, 9 + 8 * Kind); … … 1516 1516 begin 1517 1517 for I := 0 to -Growth div 8 - 1 do 1518 BitBltCanvas( ca, X + Pos + I * 8, Y, 8, 7,1518 BitBltCanvas(Canvas, X + Pos + I * 8, Y, 8, 7, 1519 1519 HGrSystem.Data.Canvas, 104, 1); 1520 BitBltCanvas( ca, X + Pos + 8 * (-Growth div 8), Y, -Growth -1520 BitBltCanvas(Canvas, X + Pos + 8 * (-Growth div 8), Y, -Growth - 1521 1521 8 * (-Growth div 8), 7, 1522 1522 HGrSystem.Data.Canvas, 104, 1); … … 1529 1529 1530 1530 // pos and growth are relative to max, set size independent 1531 procedure PaintRelativeProgressBar( ca: TCanvas;1531 procedure PaintRelativeProgressBar(Canvas: TCanvas; 1532 1532 Kind, X, Y, size, Pos, Growth, Max: Integer; IndicateComplete: Boolean; 1533 1533 T: TTexture); 1534 1534 begin 1535 1535 if Growth > 0 then 1536 PaintProgressBar( ca, Kind, X, Y, Pos * size div Max,1536 PaintProgressBar(Canvas, Kind, X, Y, Pos * size div Max, 1537 1537 (Growth * size + Max div 2) div Max, size, T) 1538 1538 else 1539 PaintProgressBar( ca, Kind, X, Y, Pos * size div Max,1539 PaintProgressBar(Canvas, Kind, X, Y, Pos * size div Max, 1540 1540 (Growth * size - Max div 2) div Max, size, T); 1541 1541 if IndicateComplete and (Pos + Growth >= Max) then 1542 Sprite( ca, HGrSystem, X + size - 10, Y - 7, 23, 16, 1, 129);1542 Sprite(Canvas, HGrSystem, X + size - 10, Y - 7, 23, 16, 1, 129); 1543 1543 end; 1544 1544 … … 1591 1591 TexWidth := Texture.Width; 1592 1592 TexHeight := Texture.Height; 1593 DstPixel := PixelPointer(Dest);1594 SrcPixel := PixelPointer(Texture);1593 DstPixel := TPixelPointer.Create(Dest); 1594 SrcPixel := TPixelPointer.Create(Texture); 1595 1595 for Y := 0 to ScaleToNative(Dest.Height) - 1 do begin 1596 1596 for X := 0 to ScaleToNative(Dest.Width) - 1 do begin … … 1614 1614 begin 1615 1615 Bitmap.BeginUpdate; 1616 PicturePixel := PixelPointer(Bitmap);1616 PicturePixel := TPixelPointer.Create(Bitmap); 1617 1617 for Y := 0 to ScaleToNative(Bitmap.Height) - 1 do begin 1618 1618 for X := 0 to ScaleToNative(Bitmap.Width) - 1 do begin
Note:
See TracChangeset
for help on using the changeset viewer.