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

jvcllaz: Add JvGIF unit (read and write GIF images).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8070 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2021-08-14 09:23:48 +00:00
parent 9ac2000e57
commit 329c200276
7 changed files with 3232 additions and 162 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
components/jvcllaz/packages/jvcorelazd.lpk
View File

@ -36,6 +36,7 @@
<UnitName Value="JvDsgnEditors"/> <UnitName Value="JvDsgnEditors"/>
</Item4> </Item4>
</Files> </Files>
<CompatibilityMode Value="True"/>
<RequiredPkgs Count="2"> <RequiredPkgs Count="2">
<Item1> <Item1>
<PackageName Value="IDEIntf"/> <PackageName Value="IDEIntf"/>

1
components/jvcllaz/packages/jvcorelazr.lpk
View File

@ -65,6 +65,7 @@
<UnitName Value="JvExtComponent"/> <UnitName Value="JvExtComponent"/>
</Item10> </Item10>
</Files> </Files>
<CompatibilityMode Value="True"/>
<RequiredPkgs Count="2"> <RequiredPkgs Count="2">
<Item1> <Item1>
<PackageName Value="FCL"/> <PackageName Value="FCL"/>

1
components/jvcllaz/packages/jvmmlazd.lpk
View File

@ -44,6 +44,7 @@ bmp animator, id3v1 and id3v2 tags, full color components and dialogs, gradient
<UnitName Value="JvFullColorListForm"/> <UnitName Value="JvFullColorListForm"/>
</Item6> </Item6>
</Files> </Files>
<CompatibilityMode Value="True"/>
<RequiredPkgs Count="3"> <RequiredPkgs Count="3">
<Item1> <Item1>
<PackageName Value="JvCoreLazD"/> <PackageName Value="JvCoreLazD"/>

7
components/jvcllaz/packages/jvmmlazr.lpk
View File

@ -16,7 +16,7 @@
<Description Value="JVCL Multimedia and image components (Run-time package): bmp animator, id3v1 and id3v2 tags, full color components and dialogs, gradient, gradient header, special progress bar, animated image"/> <Description Value="JVCL Multimedia and image components (Run-time package): bmp animator, id3v1 and id3v2 tags, full color components and dialogs, gradient, gradient header, special progress bar, animated image"/>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/> <License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="7"/> <Version Major="1" Release="7"/>
<Files Count="19"> <Files Count="20">
<Item1> <Item1>
<Filename Value="..\run\JvMM\jvspecialprogress.pas"/> <Filename Value="..\run\JvMM\jvspecialprogress.pas"/>
<UnitName Value="JvSpecialProgress"/> <UnitName Value="JvSpecialProgress"/>
@ -93,7 +93,12 @@
<Filename Value="..\run\JvMM\jvimagetransform.pas"/> <Filename Value="..\run\JvMM\jvimagetransform.pas"/>
<UnitName Value="JvImageTransform"/> <UnitName Value="JvImageTransform"/>
</Item19> </Item19>
<Item20>
<Filename Value="..\run\JvMM\jvgif.pas"/>
<UnitName Value="JvGIF"/>
</Item20>
</Files> </Files>
<CompatibilityMode Value="True"/>
<RequiredPkgs Count="2"> <RequiredPkgs Count="2">
<Item1> <Item1>
<PackageName Value="JvCoreLazR"/> <PackageName Value="JvCoreLazR"/>

7
components/jvcllaz/run/JvCore/jvjclutils.pas
View File

@ -519,8 +519,9 @@ procedure GetIconSize(Icon: HICON; var W, H: Integer);
function CreateRealSizeIcon(Icon: TIcon): HICON; function CreateRealSizeIcon(Icon: TIcon): HICON;
procedure DrawRealSizeIcon(Canvas: TCanvas; Icon: TIcon; X, Y: Integer); procedure DrawRealSizeIcon(Canvas: TCanvas; Icon: TIcon; X, Y: Integer);
{end JvIconClipboardUtils } {end JvIconClipboardUtils }
*)
function CreateScreenCompatibleDC: HDC; function CreateScreenCompatibleDC: HDC;
(*
{$ENDIF !CLR} {$ENDIF !CLR}
{ begin JvRLE } { begin JvRLE }
@ -4903,14 +4904,14 @@ begin
DestroyIcon(Ico); DestroyIcon(Ico);
end; end;
end; end;
*)
function CreateScreenCompatibleDC: HDC; function CreateScreenCompatibleDC: HDC;
const const
HDC_DESKTOP = HDC(0); HDC_DESKTOP = HDC(0);
begin begin
Result := CreateCompatibleDC(HDC_DESKTOP); Result := CreateCompatibleDC(HDC_DESKTOP);
end; end;
(*
{$ENDIF !CLR} {$ENDIF !CLR}

285
components/jvcllaz/run/JvCore/jvjvclutils.pas
View File

@ -38,7 +38,7 @@ uses
Windows, // before Types! Windows, // before Types!
{$ENDIF} {$ENDIF}
Classes, Graphics, Controls, ImgList, Classes, Graphics, Controls, ImgList,
LCLType, LCLProc, LCLVersion, LMessages, Types, LCLType, LCLProc, LCLVersion, LMessages, Types, Forms,
JvTypes; JvTypes;
(******************** NOT CONVERTED (******************** NOT CONVERTED
@ -128,6 +128,7 @@ function ChangeBitmapColor(Bitmap: TBitmap; Color, NewColor: TColor): TBitmap;
procedure ImageListDrawDisabled(Images: TCustomImageList; Canvas: TCanvas; procedure ImageListDrawDisabled(Images: TCustomImageList; Canvas: TCanvas;
X, Y, Index: Integer; HighLightColor, GrayColor: TColor; X, Y, Index: Integer; HighLightColor, GrayColor: TColor;
DrawHighlight: Boolean); DrawHighlight: Boolean);
(******************** NOT CONVERTED (******************** NOT CONVERTED
{$IFNDEF CLR} {$IFNDEF CLR}
@ -183,6 +184,7 @@ function PointInPolyRgn(const P: TPoint; const Points: array of TPoint): Boolean
******************** NOT CONVERTED *) ******************** NOT CONVERTED *)
function PaletteColor(Color: TColor): Longint; function PaletteColor(Color: TColor): Longint;
function GetNearestColor(hdc: THandle; AColor: TColor): TColor;
(******************** NOT CONVERTED (******************** NOT CONVERTED
procedure PaintInverseRect(const RectOrg, RectEnd: TPoint); procedure PaintInverseRect(const RectOrg, RectEnd: TPoint);
@ -238,7 +240,9 @@ procedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
(******************** NOT CONVERTED (******************** NOT CONVERTED
procedure DrawTransparentBitmap(DC: HDC; Bitmap: HBITMAP; procedure DrawTransparentBitmap(DC: HDC; Bitmap: HBITMAP;
DstX, DstY: Integer; TransparentColor: TColorRef); DstX, DstY: Integer; TransparentColor: TColorRef);
*)
function PaletteEntries(Palette: HPALETTE): Integer; function PaletteEntries(Palette: HPALETTE): Integer;
(******************** NOT CONVERTED
procedure ShadeRect(DC: HDC; const Rect: TRect); procedure ShadeRect(DC: HDC; const Rect: TRect);
function ScreenWorkArea: TRect; function ScreenWorkArea: TRect;
@ -468,17 +472,19 @@ procedure InternalSaveMDIChildren(MainForm: TForm; const AppStorage: TJvCustomAp
procedure InternalRestoreMDIChildren(MainForm: TForm; const AppStorage: TJvCustomAppStorage; const StorePath: string); procedure InternalRestoreMDIChildren(MainForm: TForm; const AppStorage: TJvCustomAppStorage; const StorePath: string);
{ end JvAppUtils } { end JvAppUtils }
************)
{ begin JvGraph } { begin JvGraph }
type type
TMappingMethod = (mmHistogram, mmQuantize, mmTrunc784, mmTrunc666, TMappingMethod = (mmHistogram, mmQuantize, mmTrunc784, mmTrunc666,
mmTripel, mmGrayscale); mmTripel, mmGrayscale);
function GetBitmapPixelFormat(Bitmap: TBitmap): TPixelFormat; function GetBitmapPixelFormat(Bitmap: TBitmap): TPixelFormat;
(*
function GetPaletteBitmapFormat(Bitmap: TBitmap): TPixelFormat; function GetPaletteBitmapFormat(Bitmap: TBitmap): TPixelFormat;
{$IFNDEF CLR}
procedure SetBitmapPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat; procedure SetBitmapPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat;
Method: TMappingMethod); Method: TMappingMethod);
*)
function BitmapToMemoryStream(Bitmap: TBitmap; PixelFormat: TPixelFormat; function BitmapToMemoryStream(Bitmap: TBitmap; PixelFormat: TPixelFormat;
Method: TMappingMethod): TMemoryStream; Method: TMappingMethod): TMemoryStream;
procedure GrayscaleBitmap(Bitmap: TBitmap); procedure GrayscaleBitmap(Bitmap: TBitmap);
@ -486,14 +492,14 @@ procedure GrayscaleBitmap(Bitmap: TBitmap);
function BitmapToMemory(Bitmap: TBitmap; Colors: Integer): TStream; function BitmapToMemory(Bitmap: TBitmap; Colors: Integer): TStream;
procedure SaveBitmapToFile(const FileName: string; Bitmap: TBitmap; procedure SaveBitmapToFile(const FileName: string; Bitmap: TBitmap;
Colors: Integer); Colors: Integer);
{$ENDIF !CLR} (*
function ScreenPixelFormat: TPixelFormat; function ScreenPixelFormat: TPixelFormat;
function ScreenColorCount: Integer; function ScreenColorCount: Integer;
*)
var var
DefaultMappingMethod: TMappingMethod = mmHistogram; DefaultMappingMethod: TMappingMethod = mmHistogram;
(******************
function GetWorkareaRect(Monitor: TMonitor): TRect; function GetWorkareaRect(Monitor: TMonitor): TRect;
function FindMonitor(Handle: HMONITOR): TMonitor; function FindMonitor(Handle: HMONITOR): TMonitor;
@ -864,11 +870,12 @@ function Scale96ToForm(ASize: Integer): Integer;
implementation implementation
uses uses
sysutils, LCLIntf, GraphType, Math, Forms, sysutils, LCLIntf, GraphType, Math,
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
CommCtrl, CommCtrl,
{$ENDIF} {$ENDIF}
JvConsts, JvJCLUtils; JvConsts, JvJCLUtils,
JvResources;
(******************** (********************
SysConst, SysConst,
Consts, Consts,
@ -889,7 +896,12 @@ const
RC_TileWallpaper = 'TileWallpaper'; RC_TileWallpaper = 'TileWallpaper';
RC_RunCpl = 'rundll32.exe shell32,Control_RunDLL '; RC_RunCpl = 'rundll32.exe shell32,Control_RunDLL ';
{$ENDIF MSWINDOWS} {$ENDIF MSWINDOWS}
*)
const
SInvalidBitmap = 'Invalid bitmap';
(*
function GetAppHandle: THandle; function GetAppHandle: THandle;
begin begin
Result := Application.Handle; Result := Application.Handle;
@ -2284,6 +2296,16 @@ begin
Result := ColorToRGB(Color) or PaletteMask; Result := ColorToRGB(Color) or PaletteMask;
end; end;
// Added for LCL. Note: NOT CORRECT ON NON-WINDOWS }
function GetNearestColor(hdc: THandle; AColor: TColor): TColor;
begin
{$IFDEF MSWINDOWS}
Result := Windows.GetNearestColor(hdc, AColor);
{$ELSE}
Result := AColor;
{$ENDIF}
end;
(******************** NOT CONVERTED (******************** NOT CONVERTED
function CreateRotatedFont(Font: TFont; Angle: Integer): HFONT; function CreateRotatedFont(Font: TFont; Angle: Integer): HFONT;
@ -2332,17 +2354,13 @@ begin
end; end;
Result := CreateFontIndirect(LogFont); Result := CreateFontIndirect(LogFont);
end; end;
*)
function PaletteEntries(Palette: HPALETTE): Integer; function PaletteEntries(Palette: HPALETTE): Integer;
begin begin
{$IFDEF CLR}
GetObject(Palette, 4, Result);
{$ELSE}
GetObject(Palette, SizeOf(Integer), @Result); GetObject(Palette, SizeOf(Integer), @Result);
{$ENDIF CLR}
end; end;
(******************
procedure Delay(MSecs: Int64); procedure Delay(MSecs: Int64);
var var
FirstTickCount, Now: Int64; FirstTickCount, Now: Int64;
@ -4453,9 +4471,10 @@ begin
SwitchToWindow(Application.Handle, False); SwitchToWindow(Application.Handle, False);
end; end;
{ end JvAppUtils } { end JvAppUtils }
*)
{ begin JvGraph } { begin JvGraph }
// (rom) moved here to make JvMaxMin obsolete // (rom) moved here to make JvMaxMin obsolete
@ -4471,11 +4490,7 @@ end;
procedure InvalidBitmap; procedure InvalidBitmap;
begin begin
{$IFDEF CLR}
raise EInvalidGraphic.Create(SInvalidBitmap); raise EInvalidGraphic.Create(SInvalidBitmap);
{$ELSE}
raise EInvalidGraphic.CreateRes(@SInvalidBitmap);
{$ENDIF CLR}
end; end;
function WidthBytes(I: Longint): Longint; function WidthBytes(I: Longint): Longint;
@ -4498,6 +4513,7 @@ begin
end; end;
(*****************
function ScreenPixelFormat: TPixelFormat; function ScreenPixelFormat: TPixelFormat;
var var
@ -4556,6 +4572,9 @@ begin
end; end;
end; end;
{$IFNDEF CLR}
*)
{ Quantizing } { Quantizing }
{ Quantizing procedures based on free C source code written by { Quantizing procedures based on free C source code written by
Joe C. Oliphant, CompuServe 71742, 1451, joe_oliphant att csufresno dott edu } Joe C. Oliphant, CompuServe 71742, 1451, joe_oliphant att csufresno dott edu }
@ -4566,34 +4585,6 @@ const
type type
TTriple = array [0..2] of Byte; TTriple = array [0..2] of Byte;
{$IFDEF CLR}
TQColor = class;
PQColor = TQColor;
TQColor = class
RGB: TTriple;
NewColorIndex: Byte;
Count: Longint;
PNext: PQColor;
end;
PQColorArray = array of TQColor;
TQColorArray = array [0..MAX_COLORS - 1] of TQColor;
PQColorList = array of PQColor;
TQColorList = array [0..MaxListSize - 1] of PQColor;
TNewColor = record
RGBMin: TTriple;
RGBWidth: TTriple;
NumEntries: Longint;
Count: Longint;
QuantizedColors: PQColor;
end;
PNewColor = TNewColor;
PNewColorArray = array of TNewColor;
TNewColorArray = array [Byte] of TNewColor;
{$ELSE}
PQColor = ^TQColor; PQColor = ^TQColor;
TQColor = record TQColor = record
RGB: TTriple; RGB: TTriple;
@ -4606,7 +4597,7 @@ type
TQColorArray = array [0..MAX_COLORS - 1] of TQColor; TQColorArray = array [0..MAX_COLORS - 1] of TQColor;
PQColorList = ^TQColorList; PQColorList = ^TQColorList;
TQColorList = array [0..MaxListSize - 1] of PQColor; TQColorList = array [0..{$IFDEF RTL230_UP}MaxInt div 16{$ELSE}MaxListSize{$ENDIF RTL230_UP} - 1] of PQColor;
PNewColor = ^TNewColor; PNewColor = ^TNewColor;
TNewColor = record TNewColor = record
@ -4619,9 +4610,8 @@ type
PNewColorArray = ^TNewColorArray; PNewColorArray = ^TNewColorArray;
TNewColorArray = array [Byte] of TNewColor; TNewColorArray = array [Byte] of TNewColor;
{$ENDIF CLR}
procedure PInsert(ColorList: PQColorList; {$IFDEF CLR}Offset: Integer;{$ENDIF} procedure PInsert(ColorList: PQColorList;
Number: Integer; SortRGBAxis: Integer); Number: Integer; SortRGBAxis: Integer);
var var
Q1, Q2: PQColor; Q1, Q2: PQColor;
@ -4630,22 +4620,22 @@ var
begin begin
for I := 1 to Number - 1 do for I := 1 to Number - 1 do
begin begin
Temp := ColorList[{$IFDEF CLR}Offset +{$ENDIF}I]; Temp := ColorList[I];
J := I - 1; J := I - 1;
while J >= 0 do while J >= 0 do
begin begin
Q1 := Temp; Q1 := Temp;
Q2 := ColorList[{$IFDEF CLR}Offset +{$ENDIF}J]; Q2 := ColorList[J];
if Q1.RGB[SortRGBAxis] - Q2.RGB[SortRGBAxis] > 0 then if Q1.RGB[SortRGBAxis] - Q2.RGB[SortRGBAxis] > 0 then
Break; Break;
ColorList[{$IFDEF CLR}Offset +{$ENDIF}J + 1] := ColorList[{$IFDEF CLR}Offset +{$ENDIF}J]; ColorList[J + 1] := ColorList[J];
Dec(J); Dec(J);
end; end;
ColorList[{$IFDEF CLR}Offset +{$ENDIF}J + 1] := Temp; ColorList[J + 1] := Temp;
end; end;
end; end;
procedure PSort(ColorList: PQColorList; {$IFDEF CLR}Offset: Integer;{$ENDIF} procedure PSort(ColorList: PQColorList;
Number: Integer; SortRGBAxis: Integer); Number: Integer; SortRGBAxis: Integer);
var var
Q1, Q2: PQColor; Q1, Q2: PQColor;
@ -4654,61 +4644,46 @@ var
begin begin
if Number < 8 then if Number < 8 then
begin begin
PInsert(ColorList, {$IFDEF CLR}Offset, {$ENDIF} Number, SortRGBAxis); PInsert(ColorList, Number, SortRGBAxis);
Exit; Exit;
end; end;
Part := ColorList[{$IFDEF CLR}Offset +{$ENDIF} Number div 2]; Part := ColorList[Number div 2];
I := -1; I := -1;
J := Number; J := Number;
repeat repeat
repeat repeat
Inc(I); Inc(I);
Q1 := ColorList[{$IFDEF CLR}Offset +{$ENDIF} I]; Q1 := ColorList[I];
Q2 := Part; Q2 := Part;
N := Q1.RGB[SortRGBAxis] - Q2.RGB[SortRGBAxis]; N := Q1.RGB[SortRGBAxis] - Q2.RGB[SortRGBAxis];
until N >= 0; until N >= 0;
repeat repeat
Dec(J); Dec(J);
Q1 := ColorList[{$IFDEF CLR}Offset +{$ENDIF} J]; Q1 := ColorList[J];
Q2 := Part; Q2 := Part;
N := Q1.RGB[SortRGBAxis] - Q2.RGB[SortRGBAxis]; N := Q1.RGB[SortRGBAxis] - Q2.RGB[SortRGBAxis];
until N <= 0; until N <= 0;
if I >= J then if I >= J then
Break; Break;
Temp := ColorList[{$IFDEF CLR}Offset +{$ENDIF} I]; Temp := ColorList[I];
ColorList[{$IFDEF CLR}Offset +{$ENDIF} I] := ColorList[{$IFDEF CLR}Offset +{$ENDIF} J]; ColorList[I] := ColorList[J];
ColorList[{$IFDEF CLR}Offset +{$ENDIF} J] := Temp; ColorList[J] := Temp;
until False; until False;
Nr := Number - I; Nr := Number - I;
if I < Number div 2 then if I < Number div 2 then
begin begin
{$IFDEF CLR}
PSort(ColorList, Offset, I, SortRGBAxis);
PSort(ColorList, Offset + I, Nr, SortRGBAxis);
{$ELSE}
PSort(ColorList, I, SortRGBAxis); PSort(ColorList, I, SortRGBAxis);
PSort(PQColorList(@ColorList[I]), Nr, SortRGBAxis); PSort(PQColorList(@ColorList[I]), Nr, SortRGBAxis);
{$ENDIF CLR}
end end
else else
begin begin
{$IFDEF CLR}
PSort(ColorList, Offset + I, Nr, SortRGBAxis);
PSort(ColorList, Offset, I, SortRGBAxis);
{$ELSE}
PSort(PQColorList(@ColorList[I]), Nr, SortRGBAxis); PSort(PQColorList(@ColorList[I]), Nr, SortRGBAxis);
PSort(ColorList, I, SortRGBAxis); PSort(ColorList, I, SortRGBAxis);
{$ENDIF CLR}
end; end;
end; end;
{$IFDEF CLR}
function DivideMap(var NewColorSubdiv: PNewColorArray; ColorMapSize: Integer;
var NewColormapSize: Integer; var LPSTR: PQColorArray; Offset: Integer): Integer;
{$ELSE}
function DivideMap(NewColorSubdiv: PNewColorArray; ColorMapSize: Integer; function DivideMap(NewColorSubdiv: PNewColorArray; ColorMapSize: Integer;
var NewColormapSize: Integer; LPSTR: Pointer): Integer; var NewColormapSize: Integer; LPSTR: Pointer): Integer;
{$ENDIF CLR}
var var
I, J: Integer; I, J: Integer;
MaxSize, Index: Integer; MaxSize, Index: Integer;
@ -4747,16 +4722,16 @@ begin
while (J < NewColorSubdiv[Index].NumEntries) and while (J < NewColorSubdiv[Index].NumEntries) and
(QuantizedColor <> nil) do (QuantizedColor <> nil) do
begin begin
SortArray[{$IFDEF CLR}Offset +{$ENDIF} J] := QuantizedColor; SortArray[J] := QuantizedColor;
Inc(J); Inc(J);
QuantizedColor := QuantizedColor.PNext; QuantizedColor := QuantizedColor.PNext;
end; end;
PSort(SortArray, {$IFDEF CLR}Offset,{$ENDIF} NewColorSubdiv[Index].NumEntries, SortRGBAxis); PSort(SortArray, NewColorSubdiv[Index].NumEntries, SortRGBAxis);
for J := 0 to NewColorSubdiv[Index].NumEntries - 2 do for J := 0 to NewColorSubdiv[Index].NumEntries - 2 do
SortArray[{$IFDEF CLR}Offset +{$ENDIF} J].PNext := SortArray[{$IFDEF CLR}Offset +{$ENDIF} J + 1]; SortArray[J].PNext := SortArray[J + 1];
SortArray[{$IFDEF CLR}Offset +{$ENDIF} NewColorSubdiv[Index].NumEntries - 1].PNext := nil; SortArray[NewColorSubdiv[Index].NumEntries - 1].PNext := nil;
NewColorSubdiv[Index].QuantizedColors := SortArray[{$IFDEF CLR}Offset +{$ENDIF} 0]; NewColorSubdiv[Index].QuantizedColors := SortArray[0];
QuantizedColor := SortArray[{$IFDEF CLR}Offset +{$ENDIF} 0]; QuantizedColor := SortArray[0];
Sum := NewColorSubdiv[Index].Count div 2 - QuantizedColor.Count; Sum := NewColorSubdiv[Index].Count div 2 - QuantizedColor.Count;
NumEntries := 1; NumEntries := 1;
Count := QuantizedColor.Count; Count := QuantizedColor.Count;
@ -4795,14 +4770,13 @@ begin
Result := 1; Result := 1;
end; end;
{$IFNDEF CLR}
function Quantize(const Bmp: TBitmapInfoHeader; gptr, Data8: Pointer; function Quantize(const Bmp: TBitmapInfoHeader; gptr, Data8: Pointer;
var ColorCount: Integer; var OutputColormap: TRGBPalette): Integer; var ColorCount: Integer; var OutputColormap: TRGBPalette): Integer;
type type
PWord = ^Word; PWord = ^Word;
var var
P: PByteArray; P: PByteArray;
LineBuffer, Data: Pointer; LineBuffer, Data: PAnsiChar;
LineWidth: Longint; LineWidth: Longint;
TmpLineWidth, NewLineWidth: Longint; TmpLineWidth, NewLineWidth: Longint;
I, J: Longint; I, J: Longint;
@ -4810,7 +4784,7 @@ var
NewColormapSize, NumOfEntries: Integer; NewColormapSize, NumOfEntries: Integer;
Mems: Longint; Mems: Longint;
cRed, cGreen, cBlue: Longint; cRed, cGreen, cBlue: Longint;
LPSTR, Temp, Tmp: Pointer; LPSTR, Temp, Tmp: PAnsiChar;
NewColorSubdiv: PNewColorArray; NewColorSubdiv: PNewColorArray;
ColorArrayEntries: PQColorArray; ColorArrayEntries: PQColorArray;
QuantizedColor: PQColor; QuantizedColor: PQColor;
@ -4819,17 +4793,15 @@ begin
Mems := (Longint(SizeOf(TQColor)) * (MAX_COLORS)) + Mems := (Longint(SizeOf(TQColor)) * (MAX_COLORS)) +
(Longint(SizeOf(TNewColor)) * 256) + LineWidth + (Longint(SizeOf(TNewColor)) * 256) + LineWidth +
(Longint(SizeOf(PQColor)) * (MAX_COLORS)); (Longint(SizeOf(PQColor)) * (MAX_COLORS));
LPSTR := AllocMemo(Mems); LPSTR := AllocMem(Mems);
try try
Temp := AllocMemo(Longint(Bmp.biWidth) * Longint(Bmp.biHeight) * Temp := AllocMem(Longint(Bmp.biWidth) * Longint(Bmp.biHeight) * SizeOf(Word));
SizeOf(Word));
try try
ColorArrayEntries := PQColorArray(LPSTR); ColorArrayEntries := PQColorArray(LPSTR);
NewColorSubdiv := PNewColorArray(HugeOffset(LPSTR, NewColorSubdiv := PNewColorArray(LPSTR + Longint(SizeOf(TQColor)) * (MAX_COLORS));
Longint(SizeOf(TQColor)) * (MAX_COLORS))); LineBuffer := LPSTR + (Longint(SizeOf(TQColor)) * (MAX_COLORS))
LineBuffer := HugeOffset(LPSTR, (Longint(SizeOf(TQColor)) * (MAX_COLORS))
+ +
(Longint(SizeOf(TNewColor)) * 256)); (Longint(SizeOf(TNewColor)) * 256);
for I := 0 to MAX_COLORS - 1 do for I := 0 to MAX_COLORS - 1 do
begin begin
ColorArrayEntries^[I].RGB[0] := I shr 8; ColorArrayEntries^[I].RGB[0] := I shr 8;
@ -4840,17 +4812,16 @@ begin
Tmp := Temp; Tmp := Temp;
for I := 0 to Bmp.biHeight - 1 do for I := 0 to Bmp.biHeight - 1 do
begin begin
HMemCpy(LineBuffer, HugeOffset(gptr, (Bmp.biHeight - 1 - I) * Move(Pointer(PAnsiChar(gptr) + (Bmp.biHeight - 1 - I) * LineWidth)^, LineBuffer^, LineWidth);
LineWidth), LineWidth); P := PByteArray(LineBuffer);
P := LineBuffer;
for J := 0 to Bmp.biWidth - 1 do for J := 0 to Bmp.biWidth - 1 do
begin begin
Index := (Longint(P^[2] and $F0) shl 4) + Index := (Longint(P^[2] and $F0) shl 4) +
Longint(P^[1] and $F0) + (Longint(P^[0] and $F0) shr 4); Longint(P^[1] and $F0) + (Longint(P^[0] and $F0) shr 4);
Inc(ColorArrayEntries^[Index].Count); Inc(ColorArrayEntries^[Index].Count);
P := HugeOffset(P, 3); Inc(PByte(P), 3);
PWord(Tmp)^ := Index; PWord(Tmp)^ := Index;
Tmp := HugeOffset(Tmp, 2); Inc(Tmp, 2);
end; end;
end; end;
for I := 0 to 255 do for I := 0 to 255 do
@ -4890,8 +4861,7 @@ begin
NewColorSubdiv^[0].Count := Longint(Bmp.biWidth) * Longint(Bmp.biHeight); NewColorSubdiv^[0].Count := Longint(Bmp.biWidth) * Longint(Bmp.biHeight);
NewColormapSize := 1; NewColormapSize := 1;
DivideMap(NewColorSubdiv, ColorCount, NewColormapSize, DivideMap(NewColorSubdiv, ColorCount, NewColormapSize,
HugeOffset(LPSTR, Longint(SizeOf(TQColor)) * (MAX_COLORS) + LPSTR + Longint(SizeOf(TQColor)) * (MAX_COLORS) + Longint(SizeOf(TNewColor)) * 256 + LineWidth);
Longint(SizeOf(TNewColor)) * 256 + LineWidth));
if NewColormapSize < ColorCount then if NewColormapSize < ColorCount then
begin begin
for I := NewColormapSize to ColorCount - 1 do for I := NewColormapSize to ColorCount - 1 do
@ -4930,31 +4900,32 @@ begin
FillChar(Data8^, NewLineWidth * Bmp.biHeight, #0); FillChar(Data8^, NewLineWidth * Bmp.biHeight, #0);
for I := 0 to Bmp.biHeight - 1 do for I := 0 to Bmp.biHeight - 1 do
begin begin
LineBuffer := HugeOffset(Temp, (Bmp.biHeight - 1 - I) * TmpLineWidth); LineBuffer := Temp + (Bmp.biHeight - 1 - I) * TmpLineWidth;
Data := HugeOffset(Data8, I * NewLineWidth); Data := PAnsiChar(Data8) + I * NewLineWidth;
for J := 0 to Bmp.biWidth - 1 do for J := 0 to Bmp.biWidth - 1 do
begin begin
PByte(Data)^ := ColorArrayEntries^[PWord(LineBuffer)^].NewColorIndex; PByte(Data)^ := ColorArrayEntries^[PWord(LineBuffer)^].NewColorIndex;
LineBuffer := HugeOffset(LineBuffer, 2); Inc(LineBuffer, 2);
Data := HugeOffset(Data, 1); Inc(Data);
end; end;
end; end;
finally finally
FreeMemo(Temp); FreeMem(Temp);
end; end;
finally finally
FreeMemo(LPSTR); FreeMem(LPSTR);
end; end;
ColorCount := NewColormapSize; ColorCount := NewColormapSize;
Result := 0; Result := 0;
end; end;
{
{ ------------------------------------------------------------------------------
Procedures to truncate to lower bits-per-pixel, grayscale, tripel and Procedures to truncate to lower bits-per-pixel, grayscale, tripel and
histogram conversion based on freeware C source code of GBM package by histogram conversion based on freeware C source code of GBM package by
Andy Key (nyangau att interalpha dott co dott uk). The home page of GBM Andy Key (nyangau att interalpha dott co dott uk). The home page of GBM
author is at http://www.interalpha.net/customer/nyangau/. author is at http://www.interalpha.net/customer/nyangau/.
} -------------------------------------------------------------------------------}
{ Truncate to lower bits per pixel } { Truncate to lower bits per pixel }
@ -5033,8 +5004,7 @@ begin
SrcScanline := (Header.biWidth * 3 + 3) and not 3; SrcScanline := (Header.biWidth * 3 + 3) and not 3;
DstScanline := ((Header.biWidth * DstBitsPerPixel + 31) div 32) * 4; DstScanline := ((Header.biWidth * DstBitsPerPixel + 31) div 32) * 4;
for Y := 0 to Header.biHeight - 1 do for Y := 0 to Header.biHeight - 1 do
TruncLineProc(HugeOffset(Src, Y * SrcScanline), TruncLineProc(PAnsiChar(Src) + Y * SrcScanline, PAnsiChar(Dest) + Y * DstScanline, Header.biWidth);
HugeOffset(Dest, Y * DstScanline), Header.biWidth);
end; end;
{ return 6Rx6Gx6B palette { return 6Rx6Gx6B palette
@ -5071,13 +5041,13 @@ begin
for X := 0 to CX - 1 do for X := 0 to CX - 1 do
begin begin
B := TruncIndex06[Byte(Src^)]; B := TruncIndex06[Byte(Src^)];
Src := HugeOffset(Src, 1); Inc(PByte(Src));
G := TruncIndex06[Byte(Src^)]; G := TruncIndex06[Byte(Src^)];
Src := HugeOffset(Src, 1); Inc(PByte(Src));
R := TruncIndex06[Byte(Src^)]; R := TruncIndex06[Byte(Src^)];
Src := HugeOffset(Src, 1); Inc(PByte(Src), 1);
PByte(Dest)^ := 6 * (6 * R + G) + B; PByte(Dest)^ := 6 * (6 * R + G) + B;
Dest := HugeOffset(Dest, 1); Inc(PByte(Dest));
end; end;
end; end;
@ -5124,13 +5094,13 @@ begin
for X := 0 to CX - 1 do for X := 0 to CX - 1 do
begin begin
B := TruncIndex04[Byte(Src^)]; B := TruncIndex04[Byte(Src^)];
Src := HugeOffset(Src, 1); Inc(PByte(Src));
G := TruncIndex08[Byte(Src^)]; G := TruncIndex08[Byte(Src^)];
Src := HugeOffset(Src, 1); Inc(PByte(Src));
R := TruncIndex07[Byte(Src^)]; R := TruncIndex07[Byte(Src^)];
Src := HugeOffset(Src, 1); Inc(PByte(Src));
PByte(Dest)^ := 4 * (8 * R + G) + B; PByte(Dest)^ := 4 * (8 * R + G) + B;
Dest := HugeOffset(Dest, 1); Inc(PByte(Dest));
end; end;
end; end;
@ -5169,19 +5139,20 @@ begin
for X := 0 to Header.biWidth - 1 do for X := 0 to Header.biWidth - 1 do
begin begin
B := Src^; B := Src^;
Src := HugeOffset(Src, 1); Inc(Src);
G := Src^; G := Src^;
Src := HugeOffset(Src, 1); Inc(Src);
R := Src^; R := Src^;
Src := HugeOffset(Src, 1); Inc(Src);
Dest^ := Byte(Longint(Word(R) * 77 + Word(G) * 150 + Word(B) * 29) shr 8); Dest^ := Byte(Longint(Word(R) * 77 + Word(G) * 150 + Word(B) * 29) shr 8);
Dest := HugeOffset(Dest, 1); Inc(Dest);
end; end;
Data24 := HugeOffset(Data24, SrcScanline); Data24 := PAnsiChar(Data24) + SrcScanline;
Data8 := HugeOffset(Data8, DstScanline); Data8 := PAnsiChar(Data8) + DstScanline;
end; end;
end; end;
{ Tripel conversion } { Tripel conversion }
procedure TripelPal(var Colors: TRGBPalette); procedure TripelPal(var Colors: TRGBPalette);
@ -5213,23 +5184,24 @@ begin
for X := 0 to Header.biWidth - 1 do for X := 0 to Header.biWidth - 1 do
begin begin
B := Src^; B := Src^;
Src := HugeOffset(Src, 1); Inc(Src);
G := Src^; G := Src^;
Src := HugeOffset(Src, 1); Inc(Src);
R := Src^; R := Src^;
Src := HugeOffset(Src, 1); Inc(Src);
case ((X + Y) mod 3) of case ((X + Y) mod 3) of
0: Dest^ := Byte(R shr 2); 0: Dest^ := Byte(R shr 2);
1: Dest^ := Byte($40 + (G shr 2)); 1: Dest^ := Byte($40 + (G shr 2));
2: Dest^ := Byte($80 + (B shr 2)); 2: Dest^ := Byte($80 + (B shr 2));
end; end;
Dest := HugeOffset(Dest, 1); Inc(Dest);
end; end;
Data24 := HugeOffset(Data24, SrcScanline); Data24 := PAnsiChar(Data24) + SrcScanline;
Data8 := HugeOffset(Data8, DstScanline); Data8 := PAnsiChar(Data8) + DstScanline;
end; end;
end; end;
{ Histogram/Frequency-of-use method of color reduction } { Histogram/Frequency-of-use method of color reduction }
const const
@ -5312,11 +5284,11 @@ begin
for X := 0 to Header.biWidth - 1 do for X := 0 to Header.biWidth - 1 do
begin begin
B := Byte(Data24^) and BM; B := Byte(Data24^) and BM;
Data24 := HugeOffset(Data24, 1); Inc(PByte(Data24));
G := Byte(Data24^) and Gm; G := Byte(Data24^) and Gm;
Data24 := HugeOffset(Data24, 1); Inc(PByte(Data24));
R := Byte(Data24^) and Rm; R := Byte(Data24^) and Rm;
Data24 := HugeOffset(Data24, 1); Inc(PByte(Data24));
HashColor := Hash(R, G, B); HashColor := Hash(R, G, B);
repeat repeat
Index := Hist.HashTable[HashColor]; Index := Hist.HashTable[HashColor];
@ -5350,7 +5322,7 @@ begin
Inc(Hist.Freqs[Index].Frequency); Inc(Hist.Freqs[Index].Frequency);
end; end;
end; end;
Data24 := HugeOffset(Data24, Step24); Inc(PByte(Data24), Step24);
end; end;
Hist.ColCount := ColCount; Hist.ColCount := ColCount;
Result := True; Result := True;
@ -5440,11 +5412,11 @@ begin
for X := 0 to Header.biWidth - 1 do for X := 0 to Header.biWidth - 1 do
begin begin
B := Byte(Data24^) and BM; B := Byte(Data24^) and BM;
Data24 := HugeOffset(Data24, 1); Inc(PByte(Data24));
G := Byte(Data24^) and Gm; G := Byte(Data24^) and Gm;
Data24 := HugeOffset(Data24, 1); Inc(PByte(Data24));
R := Byte(Data24^) and Rm; R := Byte(Data24^) and Rm;
Data24 := HugeOffset(Data24, 1); Inc(PByte(Data24));
HashColor := Hash(R, G, B); HashColor := Hash(R, G, B);
repeat repeat
Index := Hist.HashTable[HashColor]; Index := Hist.HashTable[HashColor];
@ -5456,10 +5428,10 @@ begin
HashColor := 0; HashColor := 0;
until False; until False;
PByte(Data8)^ := Hist.Freqs[Index].Nearest; PByte(Data8)^ := Hist.Freqs[Index].Nearest;
Data8 := HugeOffset(Data8, 1); Inc(PByte(Data8));
end; end;
Data24 := HugeOffset(Data24, Step24); Inc(PByte(Data24), Step24);
Data8 := HugeOffset(Data8, Step8); Inc(PByte(Data8), Step8);
end; end;
end; end;
@ -5495,6 +5467,7 @@ begin
end; end;
end; end;
(*
{ expand to 24 bits-per-pixel } { expand to 24 bits-per-pixel }
(-* (-*
@ -5612,7 +5585,7 @@ begin
end; end;
end; end;
end; end;
************)
function GetBitmapPixelFormat(Bitmap: TBitmap): TPixelFormat; function GetBitmapPixelFormat(Bitmap: TBitmap): TPixelFormat;
begin begin
@ -5627,9 +5600,6 @@ begin
Result := Result div 8; Result := Result div 8;
end; end;
{$IFNDEF CLR}
procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader; procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
PixelFormat: TPixelFormat); PixelFormat: TPixelFormat);
var var
@ -5743,7 +5713,7 @@ begin
InvalidBitmap; InvalidBitmap;
InternalGetDIBSizes(Src, HeaderSize, ImageSize, PixelFormat); InternalGetDIBSizes(Src, HeaderSize, ImageSize, PixelFormat);
Length := SizeOf(TBitmapFileHeader) + HeaderSize + ImageSize; Length := SizeOf(TBitmapFileHeader) + HeaderSize + ImageSize;
Result := AllocMemo(Length); Result := AllocMem(Length);
try try
FillChar(Result^, Length, 0); FillChar(Result^, Length, 0);
FileHeader := Result; FileHeader := Result;
@ -5757,7 +5727,7 @@ begin
Bits := Pointer(Longint(BI) + HeaderSize); Bits := Pointer(Longint(BI) + HeaderSize);
InternalGetDIB(Src, Pal, BI^, Bits^, PixelFormat); InternalGetDIB(Src, Pal, BI^, Bits^, PixelFormat);
except except
FreeMemo(Result); FreeMem(Result);
raise; raise;
end; end;
end; end;
@ -5808,7 +5778,7 @@ begin
raise; raise;
end; end;
finally finally
FreeMemo(P); FreeMem(P);
end; end;
end; end;
pf8bit: pf8bit:
@ -5816,20 +5786,20 @@ begin
{ pf8bit - expand to 24bit first } { pf8bit - expand to 24bit first }
InitData := DIBFromBit(Bitmap.Handle, Bitmap.Palette, pf24bit, Len); InitData := DIBFromBit(Bitmap.Handle, Bitmap.Palette, pf24bit, Len);
try try
BI := PBitmapInfoHeader(Longint(InitData) + SizeOf(TBitmapFileHeader)); BI := PBitmapInfoHeader(PtrInt(InitData) + SizeOf(TBitmapFileHeader));
if BI^.biBitCount <> 24 then if BI^.biBitCount <> 24 then
raise EJVCLException.CreateRes(@RsEBitCountNotImplemented); raise EJVCLException.CreateRes(@RsEBitCountNotImplemented);
Bits := Pointer(Longint(BI) + SizeOf(TBitmapInfoHeader)); Bits := Pointer(PtrInt(BI) + SizeOf(TBitmapInfoHeader));
InternalGetDIBSizes(Bitmap.Handle, NewHeaderSize, ImageSize, PixelFormat); InternalGetDIBSizes(Bitmap.Handle, NewHeaderSize, ImageSize, PixelFormat);
Length := SizeOf(TBitmapFileHeader) + NewHeaderSize; Length := SizeOf(TBitmapFileHeader) + NewHeaderSize;
P := AllocMemo(Length); P := AllocMem(Length);
try try
FillChar(P^, Length, #0); FillChar(P^, Length, #0);
NewBI := PBitmapInfoHeader(Longint(P) + SizeOf(TBitmapFileHeader)); NewBI := PBitmapInfoHeader(PtrInt(P) + SizeOf(TBitmapFileHeader));
if NewHeaderSize <= SizeOf(TBitmapInfoHeader) then if NewHeaderSize <= SizeOf(TBitmapInfoHeader) then
NewPalette := nil NewPalette := nil
else else
NewPalette := PRGBPalette(Longint(NewBI) + SizeOf(TBitmapInfoHeader)); NewPalette := PRGBPalette(PtrInt(NewBI) + SizeOf(TBitmapInfoHeader));
FileHeader := PBitmapFileHeader(P); FileHeader := PBitmapFileHeader(P);
InitializeBitmapInfoHeader(Bitmap.Handle, NewBI^, PixelFormat); InitializeBitmapInfoHeader(Bitmap.Handle, NewBI^, PixelFormat);
if Assigned(NewPalette) then if Assigned(NewPalette) then
@ -5884,10 +5854,10 @@ begin
raise; raise;
end; end;
finally finally
FreeMemo(P); FreeMem(P);
end; end;
finally finally
FreeMemo(InitData); FreeMem(InitData);
end; end;
end end
else else
@ -5947,9 +5917,6 @@ begin
SetBitmapPixelFormat(Bitmap, pf8bit, mmGrayscale); SetBitmapPixelFormat(Bitmap, pf8bit, mmGrayscale);
end; end;
{$ENDIF CLR}
function ZoomImage(ImageW, ImageH, MaxW, MaxH: Integer; Stretch: Boolean): function ZoomImage(ImageW, ImageH, MaxW, MaxH: Integer; Stretch: Boolean):
TPoint; TPoint;
var var
@ -6000,6 +5967,8 @@ begin
end; end;
end; end;
(***************
//=== { TJvGradientOptions } ================================================= //=== { TJvGradientOptions } =================================================
constructor TJvGradientOptions.Create; constructor TJvGradientOptions.Create;

3092
components/jvcllaz/run/JvMM/jvgif.pas Normal file
View File

File diff suppressed because it is too large Load Diff