pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

lazbarcode: Add sample project QRCodeGenerator.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8688 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2023-01-16 22:57:28 +00:00
parent 75b3b0004b
commit fca20c8bec
7 changed files with 1294 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

846
components/lazbarcodes/examples/qrcodegenerator/fpwritegif.pas Normal file
View File

@ -0,0 +1,846 @@
{
Copyright (c) 2007-2023, Udo Schmal <udo.schmal@t-online.de>
Permission to use, copy, modify, and/or distribute the software for any purpose
with or without fee is hereby granted, provided that the above copyright notice
and this permission notice appear in all copies.
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
PERFORMANCE OF THIS SOFTWARE.
https://www.gocher.me/FPWriteGIF
}
unit FPWriteGIF;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FPImage, FPReadGif;
type TColor = -$7FFFFFFF - 1..$7FFFFFFF;
const
// GIF record separators
kGifImageSeparator: byte = $2c;
kGifExtensionSeparator: byte = $21;
kGifTerminator: byte = $3b;
kGifLabelGraphic: byte = $f9;
kGifBlockTerminator: byte = $00;
// LZW encode table sizes
kGifCodeTableSize = 4096;
// Raw rgb value
clNone = TColor($1FFFFFFF);
AlphaOpaque = $FF;
AlphaTransparent = 0;
MaxArr = (MaxLongint div Sizeof(integer)) - 1;
type
APixel8 = array[0..MaxArr] of Byte;
PAPixel8 = ^APixel8;
TRGBQuadArray256 = array[0..256] of TFPCompactImgRGBA8BitValue;
TOpenColorTableArray = array of TColor;
TColorTableArray = array[0..$FF] of TColor;
TOctreeNode = class; // Forward definition so TReducibleNodes can be declared
TReducibleNodes = array[0..7] of TOctreeNode;
TOctreeNode = class(TObject)
IsLeaf: Boolean;
PixelCount: Integer;
RedSum, GreenSum, BlueSum: Integer;
Next: TOctreeNode;
Child: TReducibleNodes;
constructor Create(const Level: Integer; var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
destructor Destroy; override;
end;
TFPWriterGIF = class(TFPCustomImageWriter)
private
fHeader: TGifHeader;
fDescriptor: TGifImageDescriptor; // only one image supported
fGraphicsCtrlExt: TGifGraphicsControlExtension;
fTransparent: Boolean;
fBackground: TColor;
fPixels: PAPixel8;
fPixelList: PChar; // decoded pixel indices
fPixelCount: longint; // number of pixels
fColorTable: TColorTableArray;
fColorTableSize: integer;
procedure SaveToStream(Destination: TStream);
protected
procedure InternalWrite(Stream: TStream; Img: TFPCustomImage); override;
public
constructor Create; override;
destructor Destroy; override;
end;
implementation
{$REGION ' - TOctreeNode - '}
constructor TOctreeNode.Create(const Level: Integer; var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
var i: Integer;
begin
PixelCount := 0;
RedSum := 0;
GreenSum := 0;
BlueSum := 0;
for i := Low(Child) to High(Child) do
Child[i] := nil;
IsLeaf := (Level = 8);
if IsLeaf then
begin
Next := nil;
Inc(LeafCount);
end
else
begin
Next := ReducibleNodes[Level];
ReducibleNodes[Level] := Self;
end
end;
destructor TOctreeNode.Destroy;
var i: Integer;
begin
for i := Low(Child) to High(Child) do
Child[i].Free
end;
{$ENDREGION}
{$REGION ' - TFPWriterGIF. - '}
constructor TFPWriterGIF.Create;
begin
inherited Create;
end;
destructor TFPWriterGIF.Destroy;
begin
inherited Destroy;
end;
// save the current GIF definition to a stream object
// at first, just write it to our memory stream fSOURCE
procedure TFPWriterGIF.SaveToStream(Destination: TStream);
var
LZWStream: TMemoryStream; // temp storage for LZW
LZWSize: integer; // LZW minimum code size
// these LZW encode routines sqrunch a bitmap into a memory stream
procedure LZWEncode();
var
rPrefix: array[0..kGifCodeTableSize-1] of integer; // string prefixes
rSuffix: array[0..kGifCodeTableSize-1] of integer; // string suffixes
rCodeStack: array[0..kGifCodeTableSize-1] of byte; // encoded pixels
rSP: integer; // pointer into CodeStack
rClearCode: integer; // reset decode params
rEndCode: integer; // last code in input stream
rCurSize: integer; // current code size
rBitString: integer; // steady stream of bits to be decoded
rBits: integer; // number of valid bits in BitString
rMaxVal: boolean; // max code value found?
rCurX: integer; // position of next pixel
rCurY: integer; // position of next pixel
rCurPass: integer; // pixel line pass 1..4
rFirstSlot: integer; // for encoding an image
rNextSlot: integer; // for encoding
rCount: integer; // number of bytes read/written
rLast: integer; // last byte read in
rUnget: boolean; // read a new byte, or use zLast?
procedure LZWReset;
var i: integer;
begin
for i := 0 to (kGifCodeTableSize - 1) do
begin
rPrefix[i] := 0;
rSuffix[i] := 0;
end;
rCurSize := LZWSize + 1;
rClearCode := (1 shl LZWSize);
rEndCode := rClearCode + 1;
rFirstSlot := (1 shl (rCurSize - 1)) + 2;
rNextSlot := rFirstSlot;
rMaxVal := false;
end;
// save a code value on the code stack
procedure LZWSaveCode(Code: integer);
begin
rCodeStack[rSP] := Code;
inc(rSP);
end;
// save the code in the output data stream
procedure LZWPutCode(code: integer);
var
n: integer;
b: byte;
begin
// write out finished bytes
// a literal "8" for 8 bits per byte
while (rBits >= 8) do
begin
b := (rBitString and $ff);
rBitString := (rBitString shr 8);
rBits := rBits - 8;
LZWStream.Write(b, 1);
end;
// make sure no junk bits left above the first byte
rBitString := (rBitString and $ff);
// and save out-going code
n := (code shl rBits);
rBitString := (rBitString or n);
rBits := rBits + rCurSize;
end;
// get the next pixel from the bitmap, and return it as an index into the colormap
function LZWReadBitmap: integer;
var
n: integer;
j: longint;
p: PChar;
begin
if (rUnget) then
begin
n := rLast;
rUnget := false;
end
else
begin
inc(rCount);
j := (rCurY * fDescriptor.Width) + rCurX;
if ((0 <= j) and (j < fPixelCount)) then
begin
p := fPixelList + j;
n := ord(p^);
end
else
n := 0;
// if first pass, make sure CurPass was initialized
if (rCurPass = 0) then rCurPass := 1;
inc(rCurX); // inc X position
if (rCurX >= fDescriptor.Width) then // bumping Y ?
begin
rCurX := 0;
inc(rCurY);
end;
end;
rLast := n;
result := n;
end;
var
i,n,
cc: integer; // current code to translate
oc: integer; // last code encoded
found: boolean; // decoded string in prefix table?
pixel: byte; // lowest code to search for
ldx: integer; // last index found
fdx: integer; // current index found
b: byte;
begin
// init data block
fillchar(rCodeStack, sizeof(rCodeStack), 0);
rBitString := 0;
rBits := 0;
rCurX := 0;
rCurY := 0;
rCurPass := 0;
rLast := 0;
rUnget:= false;
LZWReset;
// all within the data record
// always save the clear code first ...
LZWPutCode(rClearCode);
// and first pixel
oc := LZWReadBitmap;
LZWPutCode(oc);
// nothing found yet (but then, we haven't searched)
ldx := 0;
fdx := 0;
// and the rest of the pixels
rCount := 1;
while (rCount <= fPixelCount) do
begin
rSP := 0; // empty the stack of old data
n := LZWReadBitmap; // next pixel from the bitmap
LZWSaveCode(n);
cc := rCodeStack[0]; // beginning of the string
// add new encode table entry
rPrefix[rNextSlot] := oc;
rSuffix[rNextSlot] := cc;
inc(rNextSlot);
if (rNextSlot >= kGifCodeTableSize) then
rMaxVal := true
else if (rNextSlot > (1 shl rCurSize)) then
inc(rCurSize);
// find the running string of matching codes
ldx := cc;
found := true;
while (found and (rCount <= fPixelCount)) do
begin
n := LZWReadBitmap;
LZWSaveCode(n);
cc := rCodeStack[0];
if (ldx < rFirstSlot) then
i := rFirstSlot
else
i := ldx + 1;
pixel := rCodeStack[rSP - 1];
found := false;
while ((not found) and (i < rNextSlot)) do
begin
found := ((rPrefix[i] = ldx) and (rSuffix[i] = pixel));
inc(i);
end;
if (found) then
begin
ldx := i - 1;
fdx := i - 1;
end;
end;
// if not found, save this index, and get the same code again
if (not found) then
begin
rUnget := true;
rLast := rCodeStack[rSP-1];
dec(rSP);
cc := ldx;
end
else
cc := fdx;
// whatever we got, write it out as current table entry
LZWPutCode(cc);
if ((rMaxVal) and (rCount <= fPixelCount)) then
begin
LZWPutCode(rClearCode);
LZWReset;
cc := LZWReadBitmap;
LZWPutCode(cc);
end;
oc := cc;
end;
LZWPutCode(rEndCode);
// write out the rest of the bit string
while (rBits > 0) do
begin
b := (rBitString and $ff);
rBitString := (rBitString shr 8);
rBits := rBits - 8;
LZWStream.Write(b, 1);
end;
end;
var i: integer;
begin
Destination.Position := 0;
with fHeader do
begin
// write the GIF signature
// if only one image, and no image extensions, then GIF is GIF87a,
// else use the updated version GIF98a
// we just added an extension block; the signature must be version 89a
Destination.Write(Signature, 3);
Destination.Write(Version, 3);
// write the overall GIF screen description to the source stream
Destination.Write(ScreenWidth, 2); // logical screen width
Destination.Write(ScreenHeight, 2); // logical screen height
Destination.Write(Packedbit, 1); // packed bit fields (Global Color valid, Global Color size, Sorted, Color Resolution)
Destination.Write(BackgroundColor, 1); // background color
Destination.Write(AspectRatio, 1); // pixel aspect ratio
if (Packedbit and $80)>0 then //Global Color valid
// write out color gobal table with RGB values
for i := 0 to fColorTableSize-1 do
Destination.Write(fColorTable[i], 3);
end;
// write out graphic extension for this image
Destination.Write(kGifExtensionSeparator, 1); // write the extension separator
Destination.Write(kGifLabelGraphic, 1); // write the extension label
Destination.Write(fGraphicsCtrlExt.BlockSize, 1); // block size (always 4)
Destination.Write(fGraphicsCtrlExt.Packedbit, 1); // packed bit field
Destination.Write(fGraphicsCtrlExt.DelayTime, 2); // delay time
Destination.Write(fGraphicsCtrlExt.ColorIndex, 1); // transparent color
Destination.Write(fGraphicsCtrlExt.Terminator, 1); // block terminator
// write actual image data
Destination.Write(kGifImageSeparator, 1);
// write the next image descriptor shortcut to the record fields
with fDescriptor do
begin
// write the basic descriptor record
Destination.Write(Left, 2); // left position
Destination.Write(Top, 2); // top position
Destination.Write(Width, 2); // size of image
Destination.Write(Height, 2); // size of image
Destination.Write(Packedbit, 1); // packed bit field
// there is no local color table defined we use global
LZWSize := 8; // the LZW minimum code size
Destination.Write(LZWSize, 1);
LZWStream := TMemoryStream.Create; // init the storage for compressed data
try
LZWEncode(); // encode the image and save it in LZWStream
// write out the data stream as a series of data blocks
LZWStream.Position := 0;
while (LZWStream.Position < LZWStream.Size) do
begin
i := LZWStream.Size - LZWStream.Position;
if (i > 255) then i := 255;
Destination.Write(i, 1);
Destination.CopyFrom(LZWStream, i);
end;
finally
FreeAndNil(LZWStream);
end;
Destination.Write(kGifBlockTerminator, 1); // block terminator
end;
Destination.Write(kGifTerminator, 1); // done with writing
end;
procedure TFPWriterGIF.InternalWrite(Stream: TStream; Img: TFPCustomImage);
var
CT: TOpenColorTableArray;
Palette: TList;
PaletteHasAllColours: Boolean;
Mappings: array[BYTE, BYTE] of TList;
Tree: TOctreeNode;
LeafCount: Integer;
ReducibleNodes: TReducibleNodes;
LastColor: TColor;
LastColorIndex: Byte;
// convert TFPCustomImage TFPColor to TColor
function FPColorToTColor(const FPColor: TFPColor): TColor;
begin
result := TColor(((FPColor.Red shr 8) and $ff) or (FPColor.Green and $ff00) or ((FPColor.Blue shl 8) and $ff0000));
end;
// try to make color table of all colors
function MakeColorTableOfAllColors(): Boolean;
var
Flags: array[Byte, Byte] of TBits;
x, y, ci: Cardinal;
Red, Green, Blue: Byte;
Cnt: word;
begin
result := false;
// init Flags
for y := 0 to $FF do
for x := 0 to $FF do
Flags[x, y] := nil;
try
for ci := 0 to $ff do
CT[ci] := 0;
Cnt := 0;
for y := 0 to Img.Height - 1 do
for x := 0 to Img.Width - 1 do
begin
Red := Byte(Img.Colors[x, y].red shr 8);
Green := Byte(Img.Colors[x, y].green shr 8);
Blue := Byte(Img.Colors[x, y].blue shr 8);
if (Flags[Red, Green]) = nil then
begin
Flags[Red, Green] := Classes.TBits.Create;
Flags[Red, Green].Size := 256;
end;
if not Flags[Red, Green].Bits[Blue] then
begin
CT[Cnt] := FPColorToTColor(Img.Colors[x, y]);
if Cnt = $ff then exit;
inc(Cnt);
Flags[Red, Green].Bits[Blue] := true;
end;
end;
result := true;
PaletteHasAllColours := true;
finally // free Flags
for y := 0 to $FF do
for x := 0 to $FF do
if Flags[x, y] <> nil then
FreeAndNil(Flags[x, y]);
end;
fColorTableSize := High(CT) + 1;
for x := 0 to fColorTableSize - 1 do
fColorTable[x] := CT[x];
LastColor := clNone;
end;
procedure MakeColorTableofReducedColors();
procedure AddColor(var Node: TOctreeNode; const r, g, b: Byte; const Level: Integer; var ReducibleNodes: TReducibleNodes);
const mask: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
var Index, Shift: Integer;
begin
if Node = nil then
Node := TOctreeNode.Create(Level, LeafCount, ReducibleNodes);
if Node.IsLeaf then
begin
Inc(Node.PixelCount);
Inc(Node.RedSum, r);
Inc(Node.GreenSum, g);
Inc(Node.BlueSum, b)
end
else
begin
Shift := 7 - Level;
Index := (((r and mask[Level]) shr Shift) shl 2) or (((g and mask[Level]) shr Shift) shl 1) or
((b and mask[Level]) shr Shift);
AddColor(Node.Child[Index], r, g, b, Level + 1, ReducibleNodes)
end
end;
procedure ReduceTree(var LeafCount: Integer; var ReducibleNodes: TReducibleNodes);
var
RedSum, BlueSum, GreenSum, Children, i: Integer;
Node: TOctreeNode;
begin
i := 7;
while (i > 0) and (ReducibleNodes[i] = nil) do
dec(i);
Node := ReducibleNodes[i];
ReducibleNodes[i] := Node.Next;
RedSum := 0;
GreenSum := 0;
BlueSum := 0;
Children := 0;
for i := Low(ReducibleNodes) to High(ReducibleNodes) do
if Node.Child[i] <> nil then
begin
Inc(RedSum, Node.Child[i].RedSum);
Inc(GreenSum, Node.Child[i].GreenSum);
Inc(BlueSum, Node.Child[i].BlueSum);
Inc(Node.PixelCount, Node.Child[i].PixelCount);
Node.Child[i].Free;
Node.Child[i] := nil;
inc(Children)
end;
Node.IsLeaf := true;
Node.RedSum := RedSum;
Node.GreenSum := GreenSum;
Node.BlueSum := BlueSum;
Dec(LeafCount, Children - 1)
end;
procedure GetPaletteColors(const Node: TOctreeNode; var RGBQuadArray: TRGBQuadArray256; var Index: integer);
var i: integer;
begin
if Node.IsLeaf then
begin
with RGBQuadArray[Index] do
begin
try
r := Byte(Node.RedSum div Node.PixelCount);
g := Byte(Node.GreenSum div Node.PixelCount);
b := Byte(Node.BlueSum div Node.PixelCount);
a := 0;
except
r := 0;
g := 0;
b := 0;
a := 0;
end;
a := 0
end;
inc(Index);
end
else
for i := Low(Node.Child) to High(Node.Child) do
if Node.Child[i] <> nil then
GetPaletteColors(Node.Child[i], RGBQuadArray, Index)
end;
procedure SetPalette(Pal: array of TColor; Size: integer);
var
PalSize, i: integer;
Col: PFPCompactImgRGB8BitValue;
x, y: Cardinal;
Red, Green, Blue: Byte;
Pcol: PInteger;
DistanceSquared, SmallestDistanceSquared: integer;
R1, G1, B1: Byte;
begin
if Size <> -1 then PalSize := Size else PalSize := High(Pal) + 1;
for i := 0 to PalSize - 1 do
begin
GetMem(Col, SizeOf(TFPCompactImgRGB8BitValue));
Col^.r := Byte(Pal[i]);
Col^.g := Byte(Pal[i] shr 8);
Col^.b := Byte(Pal[i] shr 16);
Palette.Add(Col);
end;
for y := 0 to $ff do
for x := 0 to $ff do
Mappings[y,x] := nil;
for y := 0 to Img.Height - 1 do
for x := 0 to Img.Width - 1 do
begin
Red := Byte(Img.Colors[x, y].red shr 8);
Green := Byte(Img.Colors[x, y].green shr 8);
Blue := Byte(Img.Colors[x, y].blue shr 8);
//Small reduction of color space
dec(Red, Red mod 3);
dec(Green, Green mod 3);
dec(Blue, Blue mod 3);
if (Mappings[Red, Green]) = nil then
begin
Mappings[Red, Green] := TList.Create;
Mappings[Red, Green].Count := 256;
end;
if (Mappings[Red, Green].Items[Blue] = nil) then
begin
GetMem(Pcol, SizeOf(integer));
PCol^ := 0;
SmallestDistanceSquared := $1000000;
for i := 0 to Palette.Count - 1 do
begin
R1 := PFPCompactImgRGB8BitValue(Palette[i])^.r;
G1 := PFPCompactImgRGB8BitValue(Palette[i])^.g;
B1 := PFPCompactImgRGB8BitValue(Palette[i])^.b;
DistanceSquared := (Red - R1) * (Red - R1) + (Green - G1) * (Green - G1) + (Blue - B1) * (Blue - B1);
if DistanceSquared < SmallestDistanceSquared then
begin
PCol^ := i;
if (Red = R1) and (Green = G1) and (Blue = B1) then break;
SmallestDistanceSquared := DistanceSquared;
end
end;
Mappings[Red, Green].Items[Blue] := PCol;
end;
end;
end;
procedure DeleteTree(var Node: TOctreeNode);
var i: integer;
begin
for i := Low(TReducibleNodes) to High(TReducibleNodes) do
if Node.Child[i] <> nil then
DeleteTree(Node.Child[i]);
FreeAndNil(Node);
end;
var
i, j, Index: integer;
QArr: TRGBQuadArray256;
begin
PaletteHasAllColours := false;
Tree := nil;
LeafCount := 0;
for i := Low(ReducibleNodes) to High(ReducibleNodes) do
ReducibleNodes[i] := nil;
if (Img.Height > 0) and (Img.Width > 0) then
for j := 0 to Img.Height - 1 do
for i := 0 to Img.Width - 1 do
begin
AddColor(Tree, Byte(Img.Colors[i,j].red shr 8), Byte(Img.Colors[i,j].green shr 8), Byte(Img.Colors[i,j].blue shr 8), 0, ReducibleNodes);
while LeafCount > 256 do
ReduceTree(LeafCount, ReducibleNodes)
end;
Index := 0;
GetPaletteColors(Tree, QArr, Index);
for i := 0 to LeafCount - 1 do
CT[i] := (QArr[i].b shl 16) + (QArr[i].g shl 8) + QArr[i].r;
fColorTableSize := LeafCount;
for i := 0 to fColorTableSize - 1 do
fColorTable[i] := CT[i];
LastColor := clNone;
SetPalette(fColorTable, LeafCount);
if Tree <> nil then DeleteTree(Tree);
end;
procedure ClearMappings;
var i, j, k: integer;
begin
{ wp: Avoids crash at FreeMem - may result in a memory leak !!!!
for j := 0 to $FF do
for i := 0 to $FF do
begin
if Assigned(Mappings[i, j]) then
begin
for k := 0 to $FF do
FreeMem(Mappings[i, j].Items[k], SizeOf(TColor));
Mappings[i, j].Free;
end;
Mappings[i, j] := nil;
end;
}
end;
procedure SetPixel(X, Y: Integer; Value: TColor);
var
Val: integer;
PCol: PInteger;
R, G, B: byte;
begin
if not ((Img.Width >= X) and (Img.Height >= Y) and (X > -1) and (Y > -1)) then exit;
Val := -1;
if LastColor = Value then
Val := LastColorIndex
else
begin
if PaletteHasAllColours then
begin
TFPCompactImgRGBA8BitValue(Value).a := 0;
for Val := 0 to fColorTableSize - 1 do
if fColorTable[Val] = Value then break;
end
else
begin
B := Byte(Value shr 16);
B := B - (B mod 3);
G := Byte(Value shr 8);
G := G - (G mod 3);
R := Byte(Value);
R := R - (R mod 3);
Val := -1;
if Mappings[R, G] <> nil then
begin
PCol := Mappings[R, G].Items[B];
if PCol <> nil then Val := PCol^;
end;
end;
LastColor := Value;
LastColorIndex := Val;
end;
fPixels^[Y * Img.Width + X] := Val;
end;
// find the color within the color table; returns 0..255, -1 if color not found
function FindColorIndex(c: TColor): integer;
var i: integer;
begin
i := 0;
result := -1;
while (i<fColorTableSize) and (result < 0) do
begin
if (fColorTable[i] = c) then result := i;
inc(i);
end;
end;
function lsb(w: word): byte;
begin
result := 0;
while ((w shr result) and 1) = 0 do inc(result);
end;
var
x, y: cardinal;
i, n, ci: integer;
b: byte;
pptr: PChar;
begin
if not ((Img.Width < 1) or (Img.Height < 1)) then
try
fTransparent := false;
// translate 64bit image to 8bit colortable image
Palette := TList.Create;
fColorTableSize := 0;
SetLength(CT, 256);
//try to make optimized palette on original Data.
if not MakeColorTableOfAllColors() then
MakeColorTableofReducedColors(); // to mutch colors, reduce colors
GetMem(fPixels, Img.Height * Img.Width);
for y := 0 to Img.Height - 1 do
for x := 0 to Img.Width - 1 do
begin
SetPixel(x, y, FPColorToTColor(Img.Colors[x, y]));
if not fTransparent then
if Img.Colors[x, y].alpha = AlphaTransparent then
begin
fBackground := FPColorToTColor(Img.Colors[x, y]);
fTransparent := true;
end;
end;
// color count must be a power of 2
if (fColorTableSize <= 2) then fColorTableSize := 2
else if (fColorTableSize <= 4) then fColorTableSize := 4
else if (fColorTableSize <= 8) then fColorTableSize := 8
else if (fColorTableSize <= 16) then fColorTableSize := 16
else if (fColorTableSize <= 32) then fColorTableSize := 32
else if (fColorTableSize <= 64) then fColorTableSize := 64
else if (fColorTableSize <= 128) then fColorTableSize := 128
else fColorTableSize := 256;
finally
for i := 0 to Palette.Count - 1 do
FreeMem(Palette[i], SizeOf(TFPCompactImgRGB8BitValue));
Palette.Clear;
ClearMappings;
Palette.Free;
end;
// create a new gif image record from the given 8bit colortable image
with fHeader do
begin
Signature := 'GIF';
Version := '89a';
ScreenWidth := Img.Width;
ScreenHeight := Img.Height;
b := lsb(fColorTableSize)-1;
Packedbit := (Packedbit and $8F) or (b shl 4); // Color Resolution
Packedbit := (Packedbit and $F7); // not sorted
Packedbit := (Packedbit and $F8) or b;
BackgroundColor := 0;
Packedbit := Packedbit or $80; // Global Color valid
end;
// make a descriptor record, color map for this image, and space for a pixel list
with fDescriptor do
begin
Left := 0;
Top := 0;
Width := Img.Width;
Height := Img.Height;
Packedbit := 0; // or $80 = but non local Color Table; or $40 = but not interlaced; or $20 but not sorted
end;
fPixelList := nil; // make empty pixel list
fPixelCount := Img.Width * Img.Height;
fPixelList := allocmem(fPixelCount);
if (fPixelList = nil) then OutOfMemoryError;
// and the color table
// the first call attempts to use all colors in the bitmap
// if too many colors, the 2nd call uses only most significat 8 bits of color
for ci:=0 to fPixelCount-1 do
begin
pptr := fPixelList + ci;
pptr^ := Chr(fPixels^[ci]);
end;
// set transparency for this image
with fGraphicsCtrlExt do
begin
BlockSize := 4;
Packedbit := $00;
ColorIndex := 0;
if (fTransparent) then
begin
n := FindColorIndex(fBackground);
if (n < 0) then n := FindColorIndex(fBackground and $00E0E0E0);
if (n < 0) then n := FindColorIndex(fBackground and $00C0E0E0);
if (n > -1) then
begin
Packedbit := Packedbit or $01; // transparent color given (Packedbit or $01)
ColorIndex := n; //transparent color index
end;
end;
DelayTime := 0;
Terminator := 0; // allways 0
end;
SaveToStream(Stream);
if (fPixelList <> nil) then FreeMem(fPixelList);
FreeMem(fPixels);
fPixels := nil;
end;
{$ENDREGION}
initialization
ImageHandlers.RegisterImageWriter ('GIF Graphics', 'gif', TFPWriterGif);
end.

166
components/lazbarcodes/examples/qrcodegenerator/main.lfm Normal file
View File

@ -0,0 +1,166 @@
object MainForm: TMainForm
Left = 403
Height = 326
Top = 256
Width = 380
Caption = 'QRCode Generator'
ClientHeight = 326
ClientWidth = 380
Constraints.MinWidth = 300
OnActivate = FormActivate
OnDestroy = FormDestroy
LCLVersion = '2.3.0.0'
object btnCreateQR: TButton
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = edText
AnchorSideTop.Side = asrBottom
Left = 8
Height = 25
Top = 64
Width = 108
AutoSize = True
BorderSpacing.Left = 8
BorderSpacing.Top = 16
Caption = 'Create QR code'
OnClick = btnCreateQRClick
TabOrder = 0
end
object edText: TEdit
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Label1
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = Owner
AnchorSideRight.Side = asrBottom
Left = 8
Height = 23
Top = 25
Width = 364
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Left = 8
BorderSpacing.Top = 2
BorderSpacing.Right = 8
OnChange = edTextChange
TabOrder = 1
Text = 'https://www.lazarus-ide.org/'
end
object btnSaveAsGIF: TButton
AnchorSideLeft.Control = btnCreateQR
AnchorSideTop.Control = btnCreateQR
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = btnCreateQR
AnchorSideRight.Side = asrBottom
Left = 8
Height = 25
Top = 97
Width = 108
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Top = 8
Caption = 'Save as GIF'
OnClick = btnSaveAsGIFClick
TabOrder = 2
Visible = False
end
object btnSaveAsBMP: TButton
AnchorSideLeft.Control = btnCreateQR
AnchorSideTop.Control = btnSaveAsGIF
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = btnCreateQR
AnchorSideRight.Side = asrBottom
Left = 8
Height = 25
Top = 130
Width = 108
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Top = 8
Caption = 'Save as BMP'
OnClick = btnSaveAsBMPClick
TabOrder = 3
Visible = False
end
object StatusBar: TStatusBar
Left = 0
Height = 23
Top = 303
Width = 380
Panels = <>
end
object btnSaveAsPNG: TButton
AnchorSideLeft.Control = btnCreateQR
AnchorSideTop.Control = btnSaveAsBMP
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = btnCreateQR
AnchorSideRight.Side = asrBottom
Left = 8
Height = 25
Top = 163
Width = 108
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Top = 8
Caption = 'Save as PNG'
OnClick = btnSaveAsPNGClick
TabOrder = 5
Visible = False
end
object btnSaveAsJPEG: TButton
AnchorSideLeft.Control = btnCreateQR
AnchorSideTop.Control = btnSaveAsPNG
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = btnCreateQR
AnchorSideRight.Side = asrBottom
Left = 8
Height = 25
Top = 196
Width = 108
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Top = 8
Caption = 'Save as JPEG'
OnClick = btnSaveAsPNGClick
TabOrder = 6
Visible = False
end
object Label1: TLabel
AnchorSideLeft.Control = Owner
AnchorSideTop.Control = Owner
Left = 8
Height = 15
Top = 8
Width = 100
BorderSpacing.Left = 8
BorderSpacing.Top = 8
Caption = 'Text to be encoded'
end
object btnSaveAsSVG: TButton
AnchorSideLeft.Control = btnCreateQR
AnchorSideTop.Control = btnSaveAsJPEG
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = btnCreateQR
AnchorSideRight.Side = asrBottom
Left = 8
Height = 25
Top = 229
Width = 108
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Top = 8
Caption = 'Save as SVG'
OnClick = btnSaveAsSVGClick
TabOrder = 7
Visible = False
end
object btnSaveAsEPS: TButton
AnchorSideLeft.Control = btnCreateQR
AnchorSideTop.Control = btnSaveAsSVG
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = btnCreateQR
AnchorSideRight.Side = asrBottom
Left = 8
Height = 25
Top = 262
Width = 108
Anchors = [akTop, akLeft, akRight]
BorderSpacing.Top = 8
Caption = 'Save as EPS'
OnClick = btnSaveAsEPSClick
TabOrder = 8
Visible = False
end
end

170
components/lazbarcodes/examples/qrcodegenerator/main.pas Normal file
View File

@ -0,0 +1,170 @@
unit main;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
ComCtrls, LCLIntf,
fpimage, fpWriteGIF,
ubarcodes;
type
TMyGifImage = class(TGifImage)
protected
class function GetWriterClass: TFPCustomImageWriterClass; override;
end;
{ TMainForm }
TMainForm = class(TForm)
btnCreateQR: TButton;
btnSaveAsGIF: TButton;
btnSaveAsBMP: TButton;
btnSaveAsSVG: TButton;
btnSaveAsPNG: TButton;
btnSaveAsJPEG: TButton;
btnSaveAsEPS: TButton;
edText: TEdit;
Label1: TLabel;
StatusBar: TStatusBar;
procedure btnCreateQRClick(Sender: TObject);
procedure btnSaveAsEPSClick(Sender: TObject);
procedure btnSaveAsGIFClick(Sender: TObject);
procedure btnSaveAsBMPClick(Sender: TObject);
procedure btnSaveAsPNGClick(Sender: TObject);
procedure btnSaveAsSVGClick(Sender: TObject);
procedure edTextChange(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
QRCode: TBarcodeQR;
procedure EnableButtons(Enable: Boolean);
procedure SaveQRCodeToImage(AFileName: String; AImageClass: TFPImageBitmapClass);
public
end;
var
MainForm: TMainForm;
implementation
{$R *.lfm}
class function TMyGifImage.GetWriterClass: TFPCustomImageWriterClass;
begin
Result := TFPWriterGIF;
end;
{ TMainForm }
procedure TMainForm.btnCreateQRClick(Sender: TObject);
begin
QRCode.Free;
QRCode := TBarcodeQR.Create(self);
QRCode.Text := edText.Text;
QRCode.Top := btnCreateQR.Top;
QRCode.Left := btnCreateQR.Left + btnCreateQR.Width + 10;
QRCode.Width := 168;
QRCode.Height := 168;
QRCode.Generate;
QRCode.Parent := self;
EnableButtons(true);
StatusBar.simpleText := 'QRCode generated.';
end;
procedure TMainForm.btnSaveAsEPSClick(Sender: TObject);
var
fn: String;
begin
if QRCode = nil then
exit;
fn := 'qrcode.eps';
QRCode.SaveToEpsFile(fn);
StatusBar.SimpleText := 'QRCode saved to "' + fn + '".';
end;
procedure TMainForm.btnSaveAsGIFClick(Sender: TObject);
begin
SaveQRCodeToImage('qrcode', TMyGifImage);
end;
procedure TMainForm.btnSaveAsBMPClick(Sender: TObject);
begin
SaveQRCodeToImage('qrcode', TBitmap);
end;
procedure TMainForm.btnSaveAsPNGClick(Sender: TObject);
begin
SaveQRCodeToImage('qrcode', TPortableNetworkGraphic);
end;
procedure TMainForm.btnSaveAsSVGClick(Sender: TObject);
var
fn: String;
begin
if QRCode = nil then
exit;
fn := 'qrcode.svg';
QRCode.SaveToSvgFile(fn);
StatusBar.SimpleText := 'QRCode saved to "' + fn + '".';
end;
procedure TMainForm.edTextChange(Sender: TObject);
begin
EnableButtons(false);
end;
procedure TMainForm.FormActivate(Sender: TObject);
begin
ClientHeight := btnSaveAsEPS.Top + btnSaveAsEPS.Height + StatusBar.Height + 16;
end;
procedure TMainForm.EnableButtons(Enable: Boolean);
begin
btnSaveAsGIF.Visible := Enable;
btnSaveAsBMP.Visible := Enable;
btnSaveAsPNG.Visible := Enable;
btnSaveAsJPEG.Visible := Enable;
btnSaveAsSVG.Visible := Enable;
btnSaveAsEPS.Visible := Enable;
if not Enable then StatusBar.SimpleText := '';
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
QRCode.Free;
end;
procedure TMainForm.SaveQRCodeToImage(AFileName: String; AImageClass: TFPImageBitmapClass);
var
ext: String;
begin
if QRCode = nil then
exit;
if AImageClass = TBitmap then
ext := '.bmp'
else if AImageClass = TMyGifImage then
ext := '.gif'
else if AImageClass = TPortableNetworkGraphic then
ext := '.png'
else if AImageClass = TJpegImage then
ext := '.jpg'
else
raise Exception.Create('Image format not supported.');
AFileName := ChangeFileExt(AFileName, ext);
QRCode.SaveToFile(AFileName, AImageClass);
StatusBar.SimpleText := 'QRCode saved to "' + AFileName + '".';
end;
initialization
TPicture.RegisterFileFormat('.gif', 'gif', TMyGifImage);
end.

BIN
components/lazbarcodes/examples/qrcodegenerator/qrcodegen.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 64 KiB

87
components/lazbarcodes/examples/qrcodegenerator/qrcodegen.lpi Normal file
View File

@ -0,0 +1,87 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<Flags>
<CompatibilityMode Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="qrcodegen"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="lazbarcodes"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="qrcodegen.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="QRCodeGen"/>
</Unit0>
<Unit1>
<Filename Value="main.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="MainForm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="qrcodegen"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf3"/>
</Debugging>
<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>

25
components/lazbarcodes/examples/qrcodegenerator/qrcodegen.lpr Normal file
View File

@ -0,0 +1,25 @@
program QRCodeGen;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}
cthreads,
{$ENDIF}
{$IFDEF HASAMIGA}
athreads,
{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, main
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Scaled:=True;
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.

BIN
components/lazbarcodes/examples/qrcodegenerator/qrcodegen.res Normal file
View File

Binary file not shown.