babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Стартовый пул

Browse Source
This commit is contained in:
Александр Бабаев
2024-04-02 08:46:59 +03:00
parent fd57fffd3a
commit 3bb34d000b
5591 changed files with 3291734 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
bgrabitmap/test/createbitmap/createbitmap.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 3.6 KiB

79
bgrabitmap/test/createbitmap/createbitmap.lpi Normal file
View File

@@ -0,0 +1,79 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="createbitmap"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="createbitmap.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="umain.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="FMain"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="createbitmap"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
bgrabitmap/test/createbitmap/createbitmap.lpr Normal file
View File

@@ -0,0 +1,21 @@
program createbitmap;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, umain
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Initialize;
Application.CreateForm(TFMain, FMain);
Application.Run;
end.

BIN
bgrabitmap/test/createbitmap/test_createbitmap.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 6.0 KiB

9
bgrabitmap/test/createbitmap/umain.lfm Normal file
View File

@@ -0,0 +1,9 @@
object FMain: TFMain
Left = 454
Height = 289
Top = 226
Width = 430
Caption = 'Test CreateBitmap'
OnPaint = FormPaint
LCLVersion = '1.6.0.4'
end

110
bgrabitmap/test/createbitmap/umain.pas Normal file
View File

@@ -0,0 +1,110 @@
unit umain;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, LCLType;
type
{ TFMain }
TFMain = class(TForm)
procedure FormPaint(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
FMain: TFMain;
implementation
uses GraphType, LCLIntf;
{$R *.lfm}
{ TFMain }
procedure TFMain.FormPaint(Sender: TObject);
procedure DrawTestBitmap(Left,Top,Right,Bottom: integer; AName: string);
var
bmp: TBitmap;
imgWidth,imgHeight, ty: integer;
RawImage: TRawImage;
BitmapHandle, MaskHandle: HBitmap;
p: pbyte;
cx,cy,x,y: integer;
RedOfs,GreenOfs,BlueOfs,AlphaOfs: integer;
begin
ty := (Bottom-Top) div 8;
Canvas.Font.Height := ty*7 div 10;
Canvas.Brush.Style := bsClear;
Canvas.TextOut(Left,Top,AName);
RedOfs := pos('R',AName)-1;
GreenOfs := pos('G',AName)-1;
BlueOfs := pos('B',AName)-1;
AlphaOfs := pos('A',AName)-1;
imgWidth := Right-Left;
imgHeight := Bottom-(Top+ty);
bmp := TBitmap.Create;
RawImage.Init;
RawImage.Description.Init_BPP32_B8G8R8A8_BIO_TTB(imgWidth, imgHeight);
RawImage.Description.RedShift := RedOfs*8;
RawImage.Description.GreenShift := GreenOfs*8;
RawImage.Description.BlueShift := BlueOfs*8;
if AlphaOfs >= 0 then
RawImage.Description.AlphaShift := AlphaOfs*8
else
begin
RawImage.Description.Depth := 24;
RawImage.Description.AlphaShift := 0;
RawImage.Description.AlphaPrec := 0;
end;
RawImage.CreateData(true);
for y := 0 to imgHeight-1 do
begin
cy := y*9 div imgHeight;
p := RawImage.GetLineStart(y);
for x := 0 to imgWidth-1 do
begin
cx := x*9 div imgWidth;
(p+RedOfs)^ := (cx mod 3)*255 div 2;
(p+GreenOfs)^ := (cx div 3)*255 div 2;
(p+BlueOfs)^ := (cy mod 3)*255 div 2;
if AlphaOfs >= 0 then (p+AlphaOfs)^ := (cy div 3)*255 div 2;
inc(p,4);
end;
end;
if RawImage_CreateBitmaps(RawImage, BitmapHandle, MaskHandle, False) then
begin
bmp := TBitmap.Create;
bmp.Handle := BitmapHandle;
bmp.MaskHandle := MaskHandle;
Canvas.Draw(Left,Top+ty,bmp);
bmp.Free;
end else
Canvas.TextOut(Left,Top+ty,'Unable to create');
RawImage.FreeData;
end;
begin
DrawTestBitmap(0,0,ClientWidth div 4,ClientHeight div 2,'RGBA');
DrawTestBitmap(ClientWidth div 4,0,ClientWidth div 2,ClientHeight div 2,'BGRA');
DrawTestBitmap(0,ClientHeight div 2,ClientWidth div 4,ClientHeight,'ARGB');
DrawTestBitmap(ClientWidth div 4,ClientHeight div 2,ClientWidth div 2,ClientHeight,'ABGR');
DrawTestBitmap(ClientWidth div 2,0,3*ClientWidth div 4,ClientHeight div 2,'RGB.');
DrawTestBitmap(3*ClientWidth div 4,0,ClientWidth,ClientHeight div 2,'BGR.');
DrawTestBitmap(ClientWidth div 2,ClientHeight div 2,3*ClientWidth div 4,ClientHeight,'.RGB');
DrawTestBitmap(3*ClientWidth div 4,ClientHeight div 2,ClientWidth,ClientHeight,'.BGR');
end;
end.