Ja, das ist ja der Sinn der Sache, das man vorhandene Codes verwenden kann.pluto hat geschrieben:aber musst du die "Encoder und Decoder" funktionen nicht auch selbst schreiben ?
oder greifst du dann auf vorhande codes zurück ?
Mein Code läuft zwar schon, ist aber noch nicht zu Weitergabe bereit.schnullerbacke hat geschrieben:Na erstmal die gängigen Grafikformate, das sind einige schon vorhanden, da muß theo mal erzählen welche noch fehlen. Dann müssen die gängigen animierten gemacht werden, eben GIF, MNG, ANI, AVI.
Dann gibt es da noch ne Menge Raum, SVG und SWF sind da nur 2. Video wird schon etwas happig, da gibt es verschiedene Formate ohne Ende. Die sind auch schwer umzusetzen. Hinzukommt, das bei den Videoformaten häufig Lizensrechtliche Dinge beachtet werden müssen.
Code: Alles auswählen
unit ucanvasextras;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,Graphics,types,lcltype,lclintf;
implementation
type
unschaerfe = 0..20;
ausschlag = -20..20;
shp = (Diagonal=0, Dreieck=1, Diamant=2, Linse=3);
rgbarray = array[0..2] of byte;
argbarray = array of rgbarray;
procedure farbverlauf
(bmp:TBitmap;dc: HDC; x, y, breit, hoch: integer; oben, unten: array of TColor);
var
b1, b2: rgbarray;
o, u, w, h, j, c, z, fo: integer;
ao: argbarray;
au: argbarray;
p: PBytearray;
procedure rgbermitteln(at: array of TColor; ar: argbarray; k: integer);
var i: integer;
begin
for i := 0 to k do begin
at[i] := colortorgb(at[i]);
ar[i][2] := getrvalue(at[i]);
ar[i][1] := getgvalue(at[i]);
ar[i][0] := getbvalue(at[i]);
end;
end;
function rechnen(ar: argbarray): byte;
begin
result := trunc(ar[j][z] + (ar[j + 1][z] - ar[j][z]) * (w / fo));
end;
begin
bmp.pixelformat := pf24bit;
o := high(oben);
u := high(unten);
if o = u then begin
if o > 0 then begin
bmp.width := breit;
bmp.height := hoch;
setlength(ao, o + 1);
setlength(au, u + 1);
rgbermitteln(oben, ao, o);
rgbermitteln(unten, au, u);
fo := trunc(breit / o + 1) * 3;
for h := 0 to hoch - 1 do begin
p := bmp.scanline[h];
for j := 0 to o do begin
w := 0;
while w <= fo - 1 do begin
c := j * fo + w;
if c <= breit * 3 - 1 then begin
for z := 0 to 2 do begin
b1[z] := rechnen(ao);
b2[z] := rechnen(au);
p[c + z] := trunc(b1[z] + (b2[z] - b1[z]) * (h / hoch));
end;
end;
inc(w, 3);
end;
end;
end;
bitblt(dc, x, y, breit, hoch, bmp.canvas.handle, 0, 0, srccopy);
end else showmessage('Es müssen mindestens zwei Farben angegeben werden!');
end else
showmessage('Die Anzahl der Farben muss oben und unten gleich sein!');
end;
procedure farbverlauf1
(dc: HDC; x, y, breit, hoch: integer; ar: array of TColor; Winkel: Single);
var
bmp: TBitmap;
o, w, h, j, c, z, v, br, fo: integer;
ao: array of array[0..2] of byte;
p: PBytearray;
procedure rgbermitteln;
var
i: integer;
begin
for i := 0 to o do begin
ar[i] := colortorgb(ar[i]);
ao[i][2] := getrvalue(ar[i]);
ao[i][1] := getgvalue(ar[i]);
ao[i][0] := getbvalue(ar[i]);
end;
for i := 0 to 2 do
ao[o + 1][i] := ao[0][i];
end;
function rechnen: byte;
begin
result := trunc(ao[j][z] + (ao[j + 1][z] - ao[j][z]) * (w / fo));
end;
begin
if (breit > 1) and (hoch > 1) then begin
if (Winkel >= -45) and (Winkel <= 45) then begin
o := high(ar);
if (o > 0) and (o < 8) then begin
bmp := TBitmap.create;
bmp.pixelformat := pf24bit;
Winkel := -Winkel / 45;
fo := round(breit / o + 1.3333) * 3;
bmp.width := breit;
bmp.height := hoch;
br := breit * 3;
setlength(ao, o + 2);
rgbermitteln;
for h := 0 to hoch - 1 do begin
p := bmp.scanline[h];
for j := 0 to o do begin
w := 0;
while w < fo do begin
c := j * fo + w + round(h * Winkel) * 3;
v := br + fo + o * 3;
while c < 0 do inc(c, v);
while c >= v do dec(c, v);
if c < br then
for z := 0 to 2 do
p[c + z] := rechnen;
inc(w, 3);
end;
end;
end;
bitblt(dc, x, y, breit, hoch, bmp.canvas.handle, 0, 0, srccopy);
bmp.free;
end else showmessage('Anzahl der Farben ungültig!');
end else showmessage('Der Winkel muss zwischen -45.0 und +45.0 liegen!');
end else showmessage('Abmaße zu gering!');
end;
procedure verlauf(bm: TBitmap; farbe1, farbe2: TColor; art: shp);
var
x, y, h, w, w3: integer;
p: pBytearray;
ri, gi, bi: byte;
ra, ga, ba: word;
rd, gd, bd, a, d: single;
begin
bm.pixelformat := pf24bit;
if art = Diamant then
h := bm.height shr 1
else h := bm.height - 1;
if art <> Diagonal then
w := bm.width shr 1 else
w := bm.width;
w3 := w * 3;
farbe1 := colortorgb(farbe1);
farbe2 := colortorgb(farbe2);
ra := getrvalue(farbe1);
ga := getgvalue(farbe1);
ba := getbvalue(farbe1);
ri := getrvalue(farbe2);
gi := getgvalue(farbe2);
bi := getbvalue(farbe2);
rd := ri - ra;
gd := gi - ga;
bd := bi - ba;
inc(ra, ra);
inc(ga, ga);
inc(ba, ba);
for y := 0 to h do begin
p := bm.scanline[y];
a := y / h;
if art = Linse then a := sin(pi * a);
x := 0;
while x < w3 do begin
d := a + x / w3;
p[x] := trunc((ba + bd * d) / 2);
p[x + 1] := trunc((ga + gd * d) / 2);
p[x + 2] := trunc((ra + rd * d) / 2);
inc(x, 3);
end;
end;
if art <> Diagonal then
stretchblt(bm.canvas.handle, w, 0, w + 1, h + 1,
bm.canvas.handle, w - 1, 0, -w, h, SRCCOPY);
if art = Diamant then
stretchblt(bm.canvas.handle, 0, h + 1, bm.width, h,
bm.canvas.handle, 0, h, bm.width, -h, SRCCOPY);
end;
procedure MosaikVerlauf(bm: TBitmap; F1, F2: TColor;
stufewaag, stufesenk: byte);
var
r1, g1, b1: byte;
vh, vw, uh, uw, fh, fw, i, j: integer;
rj, gj, bj, ri, bi, gi, drh, dgh, dbh, drw, dgw, dbw: single;
begin
if (bm.height > 1) and (bm.width > 1) then begin
if (stufesenk > bm.height) or (stufesenk < 2) then stufesenk := bm.height;
if (stufewaag > bm.width) or (stufewaag < 2) then stufewaag := bm.width;
vh := pred(stufesenk);
vw := pred(stufewaag);
fh := round(bm.height / stufesenk);
fw := round(bm.width / stufewaag);
F1 := ColorToRGB(F1);
F2 := ColorToRGB(F2);
r1 := getrvalue(F1);
g1 := getgvalue(F1);
b1 := getbvalue(F1);
drh := (getrvalue(F2) - r1) / vh;
dgh := (getgvalue(F2) - g1) / vh;
dbh := (getbvalue(F2) - b1) / vh;
drw := (getrvalue(F2) - r1) / vw;
dgw := (getgvalue(F2) - g1) / vw;
dbw := (getbvalue(F2) - b1) / vw;
for i := 0 to vw do begin
ri := r1 + i * drw;
gi := g1 + i * dgw;
bi := b1 + i * dbw;
if i = vw then uw := bm.width else
uw := succ(i) * fw;
for j := 0 to vh do begin
with bm.canvas do begin
rj := r1 + j * drh;
gj := g1 + j * dgh;
bj := b1 + j * dbh;
brush.color := RGB(round((rj + ri) / 2), round((gj + gi) / 2),
round((bj + bi) / 2));
if j = vh then uh := bm.height else
uh := succ(j) * fh;
fillrect(rect(i * fw, j * fh, uw, uh));
end;
end;
end;
end;
end;
procedure RotateFont(cnv: TCanvas; Winkel: integer);
var
Logfont: TLogFont;
begin
GetObject(cnv.Font.Handle, sizeof(Logfont), @Logfont);
Logfont.lfEscapement := winkel * 10;
Logfont.lfOrientation := Logfont.lfEscapement;
cnv.Font.Handle := CreateFontIndirect(Logfont);
end;
procedure WaveTextOut(cnv: TCanvas; x, y: integer;
amplitude: ausschlag; txt: string);
var
a, i, j, z, lg: integer;
s: TSize;
begin
lg := length(txt);
if lg = 0 then exit;
a := abs(amplitude);
with cnv do begin
s := TextExtent(txt);
fillrect(rect(x - 2, y - a, x + s.cx + 2, y + s.cy + a));
z := y;
j := 2;
moveto(x, y);
for i := 0 to lg - 1 do begin
if txt[i + 1] <> #32 then
z := trunc(y + sin(i - j) * amplitude) else inc(j);
textout(penpos.x, z, txt[i + 1]);
end;
end;
end;
function SchattenSchrift
(cnv: TCanvas; txt, fontname: string; fontsize: integer;
fontstyle: TFontstyles; x, y, xversatz, yversatz: integer;
fontfarbe: array of TColor; schattenfarbe: TColor;
unscharf: unschaerfe; var rct: TRect;pbrush:Tbrush): boolean;
var
sz: TSize;
bm: TBitmap;
p: array[0..2] of PBytearray;
xv, yv, i, j, k, w, z, li, lg, ob, vd2, txtl, txto: integer;
tempColor,a:Array of TColor;
begin
result := false;
lg := length(fontfarbe);
if lg = 0 then begin
lg:=length(txt)-1;
SetLength(tempColor,2);
for i:=0 to lg do
tempColor[i]:=rgb(random(255),random(255),random(255));
a:=tempColor;
end
else begin
SetLength(a,high(fontfarbe)+1);
for i:=0 to high(fontfarbe) do
a[i]:=fontfarbe[i];
end;
if (lg = 0) or (txt = '') then exit;
vd2 := unscharf shr 1;
xv := abs(xversatz);
yv := abs(yversatz);
li := ord(xversatz > 0) * xversatz + vd2 + 1;
ob := ord(yversatz > 0) * yversatz;
txtl := 1 + vd2 + ord(xversatz < 0) * xv;
txto := vd2 + ord(yversatz < 0) * yv;
dec(x, txtl);
dec(y, txto);
bm := TBitmap.create;
bm.pixelformat := pf24bit;
with bm.canvas do begin
font.name := fontname;
font.color := schattenfarbe;
font.size := fontsize;
font.style := fontstyle;
sz := Textextent(txt);
bm.width := 1 + unscharf + sz.cx + xv;
bm.height := 1 + unscharf + sz.cy + yv;
brush:=pbrush;
rct := rect(x, y, x + bm.width, y + bm.height);
bm.canvas.copyrect(rect(0, 0, bm.width, bm.height), cnv, rct);
textout(li, ob + vd2, txt);
for k := 1 to unscharf do
for j := ob + 1 to ob + sz.cy + vd2 do begin
for w := 0 to 2 do
p[w] := bm.scanline[j - 1 + w];
for i := li to li + sz.cx - 1 do begin
z := i * 3;
for w := 0 to 2 do
p[1][z + w] := round((p[0][z + w] + p[2][z + w] +
p[1][(i - 1) * 3 + w] + p[1][(i + 1) * 3 + w]) / 4);
end;
end;
font.color := a[0];
textout(txtl, txto, txt[1]);
for i := 1 to length(txt) - 1 do begin
if lg > i then font.color := a[i];
textout(penpos.x, txto, txt[i + 1]);
end;
end;
cnv.draw(x, y, bm);
bm.free;
result := true;
end;
procedure DrawGradient(ACanvas: TCanvas; Rect: TRect;
Horicontal: Boolean; Colors: array of TColor);
type
RGBArray = array[0..2] of Byte;
var
x, y, z, stelle, mx, bis, faColorsh, mass: Integer;
Faktor: double;
A: RGBArray;
B: array of RGBArray;
merkw: integer;
merks: TPenStyle;
merkp: TColor;
begin
mx := High(Colors);
if mx > 0 then
begin
if Horicontal then
mass := Rect.Right - Rect.Left
else
mass := Rect.Bottom - Rect.Top;
SetLength(b, mx + 1);
for x := 0 to mx do
begin
Colors[x] := ColorToRGB(Colors[x]);
b[x][0] := GetRValue(Colors[x]);
b[x][1] := GetGValue(Colors[x]);
b[x][2] := GetBValue(Colors[x]);
end;
merkw := ACanvas.Pen.Width;
merks := ACanvas.Pen.Style;
merkp := ACanvas.Pen.Color;
ACanvas.Pen.Width := 1;
ACanvas.Pen.Style := psSolid;
faColorsh := Round(mass / mx);
for y := 0 to mx - 1 do
begin
if y = mx - 1 then
bis := mass - y * faColorsh - 1
else
bis := faColorsh;
for x := 0 to bis do
begin
Stelle := x + y * faColorsh;
faktor := x / bis;
for z := 0 to 3 do
a[z] := Trunc(b[y][z] + ((b[y + 1][z] - b[y][z]) * Faktor));
ACanvas.Pen.Color := RGB(a[0], a[1], a[2]);
if Horicontal then
begin
ACanvas.MoveTo(Rect.Left + Stelle, Rect.Top);
ACanvas.LineTo(Rect.Left + Stelle, Rect.Bottom);
end
else
begin
ACanvas.MoveTo(Rect.Left, Rect.Top + Stelle);
ACanvas.LineTo(Rect.Right, Rect.Top + Stelle);
end;
end;
end;
b := nil;
ACanvas.Pen.Width := merkw;
ACanvas.Pen.Style := merks;
ACanvas.Pen.Color := merkp;
end
else
// Please specify at least two colors
raise EMathError.Create('Es müssen mindestens zwei Farben angegeben werden.');
end;
end.Code: Alles auswählen
var
b1, b2: rgbarray;
o, u, w, h, j, c, z, fo: integer;
ao: argbarray;
au: argbarray;
p: PByteArray;
begin
.....
if c <= breit * 3 - 1 then begin
for z := 0 to 2 do begin
b1[z] := rechnen(ao);
b2[z] := rechnen(au);
// hier kommt die fehlermeldung:
// lazarus/Units/ucanvasextras.pas(74,29) Error: Incompatible types: got "Byte" expected "TByteArray"
p[c + z] := trunc(b1[z] + (b2[z] - b1[z]) * (h / hoch));
end;
end;
.....Weiss nicht, ich kapier die Frage nicht ganz.pluto hat geschrieben:@theo
könntes du mir evlt. weiter helfen beim "scanline"
Nicht unbedingt. Du kannst ja über TLazIntfImage gehen wie im Beispiel auf:pluto hat geschrieben:achso d.h. scanline wird nur unter windows unterzützt das heißt also mein vorhaben kann ich vergessen schade !
Code: Alles auswählen
Row:= ThisCanvas.CopyRect(..);Ich versteh dich jetzt nicht ganzschnullerbacke hat geschrieben:@theo
ScanLine sollte sich aber eigentlich auch emulieren lassen. Das macht ja eigentlich nix weiter als von dem Canvas eine Zeile mit der Höhe = 1 einzulesen, also etwa:
Code: Alles auswählen
Row:= ThisCanvas.CopyRect(..);
Verein
Links
Suche