BitMap := TBitMap.Create;
try
BitMap.LoadFromFile(FileName);
BitMap.PixelFormat:=pf16bit;
BitMap.SaveToFile(FileName);
finally
BitMap.Free;
end;
Wenn der obige Code für 8 Bit angewendet wird, bekommt man ein Fake Bild, deren Farbblöcke nur halbiert oder geviertelt wurden. In den Header Informationen ist zwar 8 Bit eingetragen, doch das Bild ist nicht wirklich 8 Bit.
Tatsächlich ist es ein Problem ein echtes 8 Bit Bitmap herzustellen, dazu müssen nun mal alle Pixel des Bitmaps neu berechnet werden.
...und so lösen wir das Problem.
Erstellt ein neues Projekt und legt diese Komponenten auf die Form.
4 x Button
3 x TrackBar
3 x Paint Box
1 x ProgressBar
1 x CheckBox
1 x SaveDialog
1 x OpenPictureDialog
6 x Panel
Dann bindet ihr diese Unit in das Projekt mit ein.
Nun müsste euer Code ein echtes 8 Bit Bitmap berechnen können.
unit hackbard;
interface
uses
SysUtils,Classes,Dialogs,Windows,Contnrs,ComCtrls,Graphics,Commctrl;
type
TComponents=class;
TTreeHistogram=class
public
FCount,FValue:Cardinal;
FParent:TTreeHistogram;
FBounds:array of Cardinal;
FChilds:TObjectList;
FLeaf:Boolean;
constructor SubCreate(AParent:TTreeHistogram;AValues:array of Cardinal);
function GetSubHistogram(Index: Integer): TTreeHistogram;
property SubHistogram[Index:Integer]:TTreeHistogram read GetSubHistogram;
function CalculateWeight:Double;
function CalculateMean:Double;
function CalculateMin:Cardinal;
function CalculateMax:Cardinal;
public
constructor Create(ABounds:array of Cardinal);
procedure Add(Values:array of Cardinal);overload;
procedure Add(AHistogram:TTreeHistogram);overload;
destructor Destroy;override;
end;
TComponents=class
public
FWeight,FMean,FHistoCount:Double;
FSubComponents:TObjectList;
FHistogram:TTreeHistogram;
FMin,FMax:Cardinal;
FUnused:Boolean;
procedure Split;
procedure MultiSplit(ACount:Integer);
function GetComponents(Index: Cardinal): TComponents;
procedure InsertComponents(o:TCOmponents);
function Interpolate(t:array of Cardinal):TComponents;
public
constructor Create(AHistogram:TTreeHistogram;AMin,AMax:Cardinal);
constructor CreateRoot(AHistogram:TTreeHistogram);
function GetComponentIndex(Value:Cardinal):Integer;
function GetValueWeight(Value:Cardinal):Cardinal;
property Components[Index:Cardinal]:TComponents read GetComponents;
destructor Destroy;override;
end;
TColorFunc=function(Values,Bounds:array of Cardinal):TColor;
TInterpolator=class
private
FComponents:TComponents;
FEntryCount,FNDims:Integer;
FLeafComponents:TObjectList;
FEntries:array of Cardinal;
FColorFunc:TColorFunc;
procedure TreeViewAdvancedCustomDrawItem(Sender:TCustomTreeView;Node:TTreeNode;State:TCustomDrawState;Stage:TCustomDrawStage;var PaintImages,DefaultDraw:Boolean);
public
constructor Create(AHistogram:TTreeHistogram;ASplitCount:Integer);
procedure AssignToTreeView(t:TTreeView;AColorFunc:TColorFunc);
procedure GetEntry(Index:Integer;Values:array of PCardinal);
property EntryCount:Integer read FEntryCount;
procedure Interpolate(AEntryCount:Integer);
function GetEntryIndex(Values:array of Cardinal;UseMethod1:Boolean):Integer;
destructor Destroy;override;
end;
implementation
{ TTreeHistogram }
procedure TTreeHistogram.Add(Values: array of Cardinal);
var
a,b:Integer;
t:array of Cardinal;
begin
Assert(Values[0]<=FBounds[0],'Value out of range');
a:=0;
while (a<FChilds.Count) and (Values[0]>SubHistogram[a].FValue) do
Inc(a);
if (a<FChilds.Count) and (Values[0]=SubHistogram[a].FValue) then begin
Inc(SubHistogram[a].FCount);
if High(Values)>0 then begin
SetLength(t,High(Values));
for b:=1 to High(Values) do
t[b-1]:=Values[b];
SubHistogram[a].Add(t);
SetLength(t,0);
end;
end else
FChilds.Insert(a,TTreeHistogram.SubCreate(Self,Values));
end;
procedure TTreeHistogram.Add(AHistogram: TTreeHistogram);
var
a,b:Integer;
t:array of Cardinal;
begin
a:=0;
while (a<FChilds.Count) and (AHistogram.FValue>SubHistogram[a].FValue) do
Inc(a);
if (a=FChilds.Count) or (AHistogram.FValue<>SubHistogram[a].FValue) then begin
SetLength(t,High(FBounds));
for b:=1 to High(FBounds) do
t[b-1]:=FBounds[b];
FChilds.Insert(a,TTreeHistogram.Create(t));
SetLength(t,0);
SubHistogram[a].FValue:=AHistogram.FValue;
end;
Inc(SubHistogram[a].FCount,AHistogram.FCount);
for b:=0 to AHistogram.FChilds.Count-1 do
SubHistogram[a].Add(AHistogram.SubHistogram[b]);
end;
function TTreeHistogram.CalculateMax: Cardinal;
begin
Result:=SubHistogram[FChilds.Count-1].FValue;
end;
function TTreeHistogram.CalculateMean: Double;
var
a:Integer;
begin
Result:=0;
for a:=0 to FChilds.Count-1 do
with SubHistogram[a] do
Result:=Result+FCount*FValue;
Result:=Result/CalculateWeight;
end;
function TTreeHistogram.CalculateMin: Cardinal;
begin
Result:=SubHistogram[0].FValue;
end;
function TTreeHistogram.CalculateWeight: Double;
var
a:Integer;
begin
Result:=0;
for a:=0 to FChilds.Count-1 do
with SubHistogram[a] do
Result:=Result+FCount;
end;
constructor TTreeHistogram.Create(ABounds: array of Cardinal);
var
a:Integer;
begin
SetLength(FBounds,High(ABounds)+1);
for a:=0 to High(ABounds) do
FBounds[a]:=ABounds[a];
FChilds:=TObjectList.Create(True);
FLeaf:=High(ABounds)=0;
FCount:=0;
end;
destructor TTreeHistogram.Destroy;
begin
FChilds.Destroy;
SetLength(FBounds,0);
inherited;
end;
function TTreeHistogram.GetSubHistogram(Index: Integer): TTreeHistogram;
begin
Result:=FChilds[Index] as TTreeHistogram;
end;
constructor TTreeHistogram.SubCreate(AParent: TTreeHistogram; AValues: array of Cardinal);
var
a:Integer;
t:array of Cardinal;
begin
SetLength(t,High(AParent.FBounds));
for a:=1 to High(AParent.FBounds) do
t[a-1]:=AParent.FBounds[a];
Create(t);
FParent:=AParent;
FValue:=AValues[0];
FCount:=1;
for a:=1 to High(AValues) do
t[a-1]:=AValues[a];
if High(AValues)>0 then
FChilds.Add(TTreeHistogram.SubCreate(Self,t));
SetLength(t,0);
end;
{ TComponent }
constructor TComponents.Create(AHistogram: TTreeHistogram; AMin, AMax: Cardinal);
var
a,b:Integer;
c:TComponents;
h:TTreeHistogram;
begin
FMin:=AMin;
FMax:=AMax;
FSubComponents:=TObjectList.Create(True);
FHistogram:=AHistogram;
if not FHistogram.FLeaf then begin
h:=TTreeHistogram.Create(AHistogram.SubHistogram[0].FBounds);
for a:=0 to FHistogram.FChilds.Count-1 do
with FHistogram.SubHistogram[a] do
for b:=0 to FChilds.Count-1 do
h.Add(SubHistogram[b]);
c:=TComponents.Create(h,0,FHistogram.FBounds[0]);
FSubComponents.Add(c);
end;
FMean:=FHistogram.CalculateMean;
FHistoCount:=FHistogram.CalculateWeight;
FWeight:=FHistoCount*(Integer(FMax)-Integer(FMin)+1);
end;
constructor TComponents.CreateRoot(AHistogram: TTreeHistogram);
var
h:TTreeHistogram;
a:Integer;
begin
FHistogram:=AHistogram;
FSubComponents:=TObjectList.Create(True);
h:=TTreeHistogram.Create(AHistogram.FBounds);
for a:=0 to AHistogram.FChilds.Count-1 do
h.Add(AHistogram.SubHistogram[a]);
FSubComponents.Add(TComponents.Create(h,0,AHistogram.FBounds[0]));
FMean:=FHistogram.CalculateMean;
FHistoCount:=FHistogram.CalculateWeight;
FWeight:=FHistoCount*(FMax-FMin+1);
end;
destructor TComponents.Destroy;
begin
FHistogram.Destroy;
FSubComponents.Destroy;
inherited;
end;
function TComponents.GetComponentIndex(Value: Cardinal): Integer;
var
a:Integer;
begin
Result:=-1;
for a:=0 to FSubComponents.Count-1 do
with Components[a] do
if (Value>=FMin) and (Value<=FMax) then
Result:=a;
Assert(Result>-1);
end;
function TComponents.GetComponents(Index: Cardinal): TComponents;
begin
Result:=FSubComponents[Index] as TComponents;
end;
function TComponents.GetValueWeight(Value: Cardinal): Cardinal;
var
a:Integer;
begin
Result:=0;
for a:=0 to FHistogram.FChilds.Count-1 do
if FHistogram.SubHistogram[a].FValue=Value then
Result:=FHistogram.SubHistogram[a].FCount;
end;
procedure TComponents.InsertComponents(o: TCOmponents);
var
a:Integer;
begin
a:=0;
while (a<FSubComponents.Count) and ((FSubComponents[a] as TComponents).FWeight>o.FWeight) do
Inc(a);
FSubComponents.Insert(a,o);
end;
function TComponents.Interpolate(t: array of Cardinal):TComponents;
var
a,b:Integer;
u:array of Cardinal;
r:Double;
begin
Assert(not FUnused);
r:=1E10;
b:=-1;
for a:=0 to FSubComponents.Count-1 do
with Components[a] do
if (not FUnused) and (Abs(t[0]-FMean)<r) then begin
r:=Abs(t[0]-FMean);
b:=a;
end;
SetLength(u,High(t));
for a:=1 to High(t) do
u[a-1]:=t[a];
if High(t)>0 then
Result:=Components[b].Interpolate(u)
else
Result:=Components[b];
SetLength(u,0);
end;
procedure TComponents.MultiSplit(ACount: Integer);
var
a:Integer;
begin
for a:=0 to ACount-1 do
Split;
for a:=0 to FSubComponents.Count-1 do
COmponents[a].MultiSplit(ACount);
end;
procedure TComponents.Split;
var
a,c1,c2,c3:Integer;
s,m1,m2,m3:Double;
h1,h2:TTreeHistogram;
o1,o2:TComponents;
begin
if (FSubComponents.Count=0) or (Components[0].FHistogram.FChilds.Count<=1) then Exit;
m1:=0;
c1:=0;
with Components[0].FHistogram do begin
for a:=0 to FChilds.Count-1 do
if SubHistogram[a].FCount>=m1 then begin
m1:=SubHistogram[a].FCount;
c1:=a;
end;
end;
m2:=0;
c2:=Components[0].FHistogram.FChilds.Count-1;
with Components[0].FHistogram do begin
for a:=0 to FChilds.Count-1 do begin
s:=SubHistogram[a].FCount*(1-Exp(-0.1*Abs(Integer(SubHistogram[a].FValue)-Integer(SubHistogram[c1].FValue))/(FMax-FMin+1)));
if s>=m2 then begin
m2:=s;
c2:=a;
end;
end;
end;
if c1>c2 then begin
a:=c2;
c2:=c1;
c1:=a;
end;
m3:=1E10;
c3:=(c1+c2) div 2;
with Components[0].FHistogram do begin
for a:=c1 to c2 do begin
s:=SubHistogram[a].FCount+0.3*(m1+m2)*
(1-Exp(-5*(Abs(Integer(SubHistogram[a].FValue)-Integer(SubHistogram[c1].FValue))+
Abs(Integer(SubHistogram[a].FValue)-Integer(SubHistogram[c2].FValue)))/(FMax-FMin+1)));
if s <= m3 then begin
m3:=s;
c3:=a;
end;
end;
end;
if c3=0 then
c3:=1;
h1:=TTreeHistogram.Create(Components[0].FHistogram.FBounds);
with Components[0].FHistogram do
for a:=0 to c3-1 do
h1.Add(SubHistogram[a]);
h2:=TTreeHistogram.Create(Components[0].FHistogram.FBounds);
with Components[0].FHistogram do
for a:=c3 to FChilds.Count-1 do
h2.Add(SubHistogram[a]);
c1:=Components[0].FMin;
c2:=Components[0].FMax;
c3:=(Components[0].FHistogram.SubHistogram[c3-1].FValue+Components[0].FHistogram.SubHistogram[c3].FValue) div 2;
FSubComponents.Delete(0);
o1:=TComponents.Create(h1,c1,c3);
o2:=TComponents.Create(h2,c3,c2);
InsertComponents(o1);
InsertComponents(o2);
end;
{ TInterpolator }
procedure TInterpolator.AssignToTreeView(t: TTreeView;
AColorFunc: TColorFunc);
procedure RecAssign(n:TTreeNode;o:TComponents);
var
a:Integer;
m:TTreeNode;
begin
if o.FSubComponents.Count=0 then
Exit;
m:=t.Items.AddChild(n,'');
m.Data:=o;
for a:=0 to o.FSubComponents.Count-1 do
if not o.Components[a].FUnused then
RecAssign(m,o.Components[a]);
end;
begin
FColorFunc:=AColorFunc;
t.Items.Clear;
SendMessage(t.Handle,TVM_SETITEMHEIGHT,80,0);
t.OnAdvancedCustomDrawItem:=TreeViewAdvancedCustomDrawItem;
RecAssign(nil,FComponents);
end;
constructor TInterpolator.Create(AHistogram: TTreeHistogram;
ASplitCount: Integer);
procedure Insert(o:TComponents);
var
a:Integer;
begin
a:=0;
while (a<FLeafCOmponents.Count) and ((FLeafCOmponents[a] as TComponents).FHistoCount>o.FHistoCount) do
Inc(a);
FLeafCOmponents.Insert(a,o);
end;
procedure RecList(o:TComponents);
var
a:Integer;
begin
if o.FSubComponents.Count=0 then
Insert(o)
else
for a:=0 to o.FSubComponents.Count-1 do
RecList(o.Components[a]);
end;
begin
FNDims:=High(AHistogram.FBounds)+1;
FComponents:=TComponents.CreateRoot(AHistogram);
FComponents.MultiSplit(ASplitCount);
FLeafComponents:=TObjectList.Create(False);
RecList(FComponents);
end;
destructor TInterpolator.Destroy;
begin
FComponents.Destroy;
FLeafComponents.Destroy;
SetLength(FEntries,0);
inherited;
end;
procedure TInterpolator.GetEntry(Index: Integer;
Values: array of PCardinal);
var
a:Integer;
begin
for a:=0 to FNDims-1 do
Values[a]^:=FEntries[Index*FNDims+a];
end;
function TInterpolator.GetEntryIndex(Values: array of Cardinal; UseMethod1: Boolean): Integer;
var
a,b:Integer;
r,s:Double;
begin
if UseMethod1 then begin
Result:=-1;
r:=1E10;
for a:=0 to FEntryCount-1 do begin
s:=0;
for b:=0 to FNDims-1 do
s:=s+Abs(Integer(FEntries[a*FNDims+b])-Integer(Values[b]));
if s<r then begin
Result := a;
r:= s;
end;
end;
end else begin
Result := FLeafComponents.IndexOf(FComponents.Interpolate(Values));
Assert((Result>-1) and (Result<FEntryCount),IntToStr(Result));
end;
end;
procedure TInterpolator.Interpolate(AEntryCount: Integer);
var
a,b:Integer;
p:TComponents;
function RecFillEntry(o:TComponents):TComponents;
var
c:Integer;
q:TComponents;
begin
Assert(Assigned(p));
Result := nil;
if o.FSubComponents.IndexOf(p)>-1 then begin
Result:=o;
FEntries[a*FNDims+b]:=Round(p.FMean);
end;
for c:=0 to o.FSubComponents.Count-1 do begin
q:=RecFillEntry(o.Components[c]);
if Assigned(q) then
Result:=q;
end;
end;
procedure RecUsage(o:TComponents);
var
a:Integer;
begin
if o.FSubComponents.Count=0 then
Exit;
o.FUnused:=True;
for a:=0 to o.FSubComponents.Count-1 do begin
RecUsage(o.Components[a]);
o.FUnused:=o.FUnused and o.Components[a].FUnused;
end;
end;
begin
FEntryCount:=AEntryCount;
if FEntryCount>FLeafComponents.Count then
FEntryCount:=FLeafComponents.Count;
SetLength(FEntries,FEntryCount*FNDims);
for a:=0 to FLeafComponents.Count-1 do
(FLeafComponents[a] as TComponents).FUnused:=a>=AEntryCount;
RecUsage(FComponents);
for a:=0 to FEntryCount-1 do begin
p:=FLeafComponents[a] as TComponents;
for b:=FNDims-1 downto 0 do
p:=RecFillEntry(FComponents);
end;
end;
procedure TInterpolator.TreeViewAdvancedCustomDrawItem(
Sender: TCustomTreeView; Node: TTreeNode; State: TCustomDrawState;
Stage: TCustomDrawStage; var PaintImages, DefaultDraw: Boolean);
var
r:TRect;
t:array of Cardinal;
a,b,c,d,x,y,w,h,n:Integer;
o:TComponents;
s:Double;
nn:TTreeNode;
begin
if Stage=cdPostPaint then begin
Sender.Canvas.Lock;
r:=Node.DisplayRect(True);
r.Right:=Sender.ClientWidth;
// if cdsSelected in State then
// Sender.Canvas.Pen.Color:=clRed
// else
Sender.Canvas.Pen.Color:=0;
// Sender.Canvas.Brush.Color:=clWhite;
Sender.Canvas.Rectangle(r);
x:=r.Left+1;
y:=r.Top+1;
w:=r.Right-r.Left-2;
h:=r.Bottom-r.Top-12;
o:=TComponents(Node.Data);
n:=o.FHistogram.FBounds[0];
Sender.Canvas.Pen.Color:=0;
SetLength(t,Node.Level+1);
nn:=Node;
for a:=Node.Level-1 downto 0 do begin
t[a]:=Round(TComponents(nn.Data).FMean);
nn:=nn.Parent;
end;
for a:=0 to n do begin
if Node.Parent=nil then
s:=o.GetValueWeight(a)
else begin
s:=0;
for b:=0 to o.FSubComponents.Count-1 do
s:=s+o.Components[b].GetValueWeight(a);
end;
b:=Round(h*s/o.FHistoCount);
t[High(t)]:=a;
Sender.Canvas.Brush.Color:=FColorFunc(t,FComponents.FHistogram.FBounds);
c:=x+Round(a*w/(n+1));
d:=x+Round((a+1)*w/(n+1));
Sender.Canvas.FillRect(Classes.Rect(c,y+h+10,d,y+h-b));
Sender.Canvas.MoveTo(c,y+h);
Sender.Canvas.LineTo(c,y+h-b);
Sender.Canvas.LineTo(d,y+h-b);
Sender.Canvas.LineTo(d,y+h);
end;
Sender.Canvas.Pen.Style:=psDashDotDot;
for a:=0 to o.FSubComponents.Count-1 do
with o.Components[a] do
if not FUnused then begin
c:=x+Round(Integer(FMin)*w/(n+1));
Sender.Canvas.MoveTo(c,y);
Sender.Canvas.LineTo(c,y+h);
Sender.Canvas.TextOut(c+2,y,IntToStr(a));
c:=x+Round(Integer(FMax)*w/(n+1));
Sender.Canvas.MoveTo(c,y);
Sender.Canvas.LineTo(c,y+h);
end;
Sender.Canvas.Pen.Style:=psSolid;
SetLength(t,0);
DefaultDraw:=False;
Sender.Canvas.MoveTo(x,y+h+1);
Sender.Canvas.LineTo(x+w,y+h+1);
Sender.Canvas.UnLock;
end else
DefaultDraw:=True;
end;
end.
type
TRGB=packed record
B,G,R:Byte;
end;
TRGBArray=array[0..65535] of TRGB;
PRGBArray=^TRGBArray;
THSV=packed record
H,S,V:Single;
end;
//
public
SourceBitmap, DestBitmap, SaveBitmap:TBitmap;
FHistogram:TTreeHistogram;
FInterpolator:TInterpolator;
procedure MakeHistogram;
procedure MakeInterpolator;
procedure TrackChange(Panel:TPanel;TrackBar:TTrackBar;Button:TButton);
end;
function MinValue(t:array of single):single;
var
a:integer;
begin
Result:=t[0];
for a:=1 to high(t) do
if t[a]<Result then
Result:=t[a];
end;
function MaxValue(t:array of single):single;
var
a:integer;
begin
Result:=t[0];
for a:=1 to high(t) do
if t[a]>Result then
Result:=t[a];
end;
procedure RGB2HSV(const RGB:TRGB;var HSV:THSV);
var
Delta,Min:single;
begin
with RGB,HSV do begin
Min:=MinValue([r,g,b]);
v:=MaxValue([r,g,b]);
Delta:=v-Min;
if v=0 then
s:=0
else
s:=Delta/v;
if s=0 then begin
h:=0;
v:=r;
end else begin
if r=v then
h:=60*(g-b)/Delta;
if g=v then
h:=120+60*(b-r)/Delta;
if b=v then
h:=240+60*(r-g)/Delta;
if h<0 then
h:=h+360;
end;
end;
end;
procedure HSV2RGB(const HSV:THSV;var RGB:TRGB);
var
f:Single;
i:integer;
p,q,t,vv:Byte;
begin
with RGB,HSV do begin
if s=0 then begin
r:=Round(v);
g:=r;
b:=r;
end else begin
i:=Trunc(h/60) mod 6;
f:=Frac(h/60);
p:=Round(v*(1-s));
q:=Round(v*(1-s*f));
t:=Round(v*(1-s*(1-f)));
vv:=Round(v);
case i of
0:begin r:=vv;g:=t;b:=p end;
1:begin r:=q;g:=vv;b:=p end;
2:begin r:=p;g:=vv;b:=t end;
3:begin r:=p;g:=q;b:=vv end;
4:begin r:=t;g:=p;b:=vv end;
5:begin r:=vv;g:=p;b:=q end;
end;
end;
end;
end;
procedure TForm1.MakeHistogram;
var
a,b,N:Integer;
p:PRGBArray;
h:THSV;
begin
if Assigned(FInterpolator) then
FInterpolator.Destroy;
N:=TrackBar2.Position;
FHistogram:=TTreeHistogram.Create([N,N,N]);
ProgressBar1.Max:=SourceBitmap.Height-1;
for b:=0 to SourceBitmap.Height-1 do begin
ProgressBar1.Position:=b;
ProgressBar1.Repaint;
p:=PRGBArray(SourceBitmap.ScanLine[b]);
for a:=0 to SourceBitmap.Width-1 do begin
RGB2HSV(p[a],h);
with h do
FHistogram.Add([Round(H*N/360),Round(S*N),Round(V*N/255)]);
end;
end;
FInterpolator:=TInterpolator.Create(FHistogram,TrackBar1.Position);
GroupBox4.Enabled:=True;
MakeInterpolator;
Button1.Enabled:=False;
end;
function ColorFunc(Values,Bounds:array of Cardinal):TColor;
var
RGB:TRGB;
HSV:THSV;
begin
case High(Values) of
0:with HSV do begin
H:=360*Values[0]/Bounds[0];
S:=1;
V:=255;
end;
1:with HSV do begin
H:=360*Values[0]/Bounds[0];
S:=Values[1]/Bounds[1];
V:=255;
end;
2:with HSV do begin
H:=360*Values[0]/Bounds[0];
S:=Values[1]/Bounds[1];
V:=255*Values[2]/Bounds[2];
end;
end;
HSV2RGB(HSV,RGB);
with RGB do
Result:=Windows.RGB(R,G,B);
end;
procedure TForm1.MakeInterpolator;
var
Pal:PLogPalette;
cc:TColor;
t:array[0..2] of Cardinal;
a,b,c,N:Integer;
p,q:PRGBArray;
h:THSV;
hh,ss,vv:Cardinal;
type
TByteArray=array[0..65535] of Byte;
PByteArray=^TByteArray;
begin
FInterpolator.Interpolate(TrackBar3.Position);
FInterpolator.AssignToTreeView(TreeView1,ColorFunc);
if Assigned(SaveBitmap) then begin
GetMem(Pal,SizeOf(TLogPalette)+256*SizeOf(TPaletteEntry));
Pal.palVersion:=$300;
Pal.palNumEntries:=256;
for a:=0 to 255 do begin
FInterpolator.GetEntry(a,[@t[0],@t[1],@t[2]]);
cc:=ColorFunc(t,[TrackBar2.Position,TrackBar2.Position,TrackBar2.Position]);
{$R-}
with Pal.palPalEntry[a] do begin
peRed:=GetRValue(cc);
peGreen:=GetGValue(cc);
peBlue:=GetBValue(cc);
peFlags:=0;
end;
{$R+}
end;
SaveBitmap.Palette:=CreatePalette(Pal^);
FreeMem(Pal);
end;
N:=TrackBar2.Position;
DestBitmap.Assign(SourceBitmap);
ProgressBar1.Max:=SourceBitmap.Height-1;
for b:=0 to SourceBitmap.Height-1 do begin
ProgressBar1.Position:=b;
Progressbar1.Repaint;
p:=PRGBArray(SourceBitmap.ScanLine[b]);
q:=PRGBArray(DestBitmap.ScanLine[b]);
for a:=0 to SourceBitmap.Width-1 do begin
RGB2HSV(p[a],h);
with h do begin
hh:=Round(H*N/360);
ss:=Round(S*N);
vv:=Round(V*N/255);
end;
c:=FInterpolator.GetEntryIndex([hh,ss,vv],CheckBox1.Checked);
if Assigned(SaveBitmap) then
PByteArray(SaveBitmap.ScanLine[b])[a]:=c;
FInterpolator.GetEntry(c,[@hh,@ss,@vv]);
with h do begin
H:=hh*360/N;
S:=ss/N;
V:=vv*255/N;
end;
HSV2RGB(h,q[a]);
end;
end;
PaintBox2.Repaint;
PaintBox3.Repaint;
Button2.Enabled:=False;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
p:TPicture;
begin
if OpenPictureDialog1.Execute then begin
p:=TPicture.Create;
p.LoadFromFile(OpenPictureDialog1.FileName);
SourceBitmap.Assign(p.Graphic);
p.Destroy;
PaintBox1.Repaint;
PaintBox2.Repaint;
MakeHistogram;
Button4.Enabled:=True;
GroupBox3.Enabled:=True;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SourceBitmap:=TBitmap.Create;
SourceBitmap.PixelFormat:=pf24bit;
DestBitmap:=TBitmap.Create;
SourceBitmap.PixelFormat:=pf24bit;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
PaintBox1.Canvas.StretchDraw(Rect(0,0,PaintBox1.Width,PaintBox1.Height),SourceBitmap);
end;
procedure TForm1.PaintBox2Paint(Sender: TObject);
begin
PaintBox2.Canvas.StretchDraw(Rect(0,0,PaintBox2.Width,PaintBox2.Height),DestBitmap);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
MakeInterpolator;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
MakeHistogram;
end;
procedure TForm1.PaintBox3Paint(Sender: TObject);
var
a,n:Integer;
t:array[0..2] of Cardinal;
begin
if Assigned(FInterpolator) then begin
n:=FInterpolator.EntryCount;
for a:=0 to n-1 do begin
FInterpolator.GetEntry(a,[@t[0],@t[1],@t[2]]);
PaintBox3.Canvas.Brush.Color:=ColorFunc(t,[TrackBar2.Position,TrackBar2.Position,TrackBar2.Position]);
PaintBox3.Canvas.FillRect(Rect(Round(a*PaintBox3.Width/n),0,Round((a+1)*PaintBox3.Width/n),PaintBox3.Height));
end;
end;
end;
procedure TForm1.TrackChange(Panel: TPanel; TrackBar: TTrackBar;
Button: TButton);
begin
Panel.Caption:=Panel.Hint+' ('+IntToStr(TrackBar.Position)+')';
Button.Enabled:=True;
end;
procedure TForm1.TrackBar2Change(Sender: TObject);
begin
TrackChange(Panel5,TrackBar2,Button1);
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
TrackChange(Panel4,TrackBar1,Button1);
end;
procedure TForm1.TrackBar3Change(Sender: TObject);
begin
TrackChange(Panel6,TrackBar3,Button2);
end;
procedure TForm1.TreeView1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if (htOnRight in TreeView1.GetHitTestInfoAt(X,Y)) and (TreeView1.GetNodeAt(X,Y)<>nil) then
TreeView1.Selected:=TreeView1.GetNodeAt(X,Y);
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
Button2.Enabled:=True;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
if SaveDialog1.Execute then begin
TrackBar3.Position:=256;
SaveBitmap:=TBitmap.Create;
SaveBitmap.PixelFormat:=pf8bit;
SaveBitmap.Width:=SourceBitmap.Width;
SaveBitmap.Height:=SourceBitmap.Height;
MakeInterpolator;
SaveBitmap.SaveToFile(SaveDialog1.FileName);
SaveBitmap.Destroy;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(FInterpolator) then
FInterpolator.Destroy;
SourceBitmap.Destroy;
DestBitmap.Destroy;
end;
Ein fertiges Projekt kann hier heruntergeladen werden.
Keine Kommentare:
Kommentar veröffentlichen