Extract the Cookie Direcory

uses
Registry;

function GetDirectory: string;
var
reg : TRegistry;
begin
reg := TRegistry.Create;
try
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings\Cache\Special Paths\Cookies',
False);
Result := reg.ReadString('Directory');
finally
reg.Free;
end;
end;


procedure TForm1.Button1Click(Sender : TObject);
var
s : string;
begin
S := GetDirectory;
ShowMessage(GetDirectory);
end;

Change the font for all controls at run-time

procedure ModifyFontsFor(ctrl: TWinControl);
procedure ModifyFont(ctrl: TControl);
var
f: TFont;
begin
if IsPublishedProp(ctrl, 'Parentfont')
and (GetOrdProp(ctrl, 'Parentfont') = Ord(false))
and IsPublishedProp(ctrl, 'font')
then begin
f := TFont(GetObjectProp(ctrl, 'font', TFont));
f.Name := 'Symbol';
end;
end;
var
i: Integer;
begin
ModifyFont(ctrl);
for i := 0 to ctrl.controlcount - 1 do
if ctrl.controls[i] is Twincontrol then
ModifyFontsfor(TWincontrol(ctrl.controls[i]))
else
Modifyfont(ctrl.controls[i]);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Modifyfontsfor(self);
end;

Convert HTML to RTF

procedure HTMLtoRTF(html: string; var rtf: TRichedit);
var
i, dummy, row: Integer;
cfont: TFont; { Standard sschrift }
Tag, tagparams: string;
params: TStringList;

function GetTag(s: string; var i: Integer; var Tag, tagparams: string): Boolean;
var
a_tag: Boolean;
begin
GetTag := False;
Tag := '';
tagparams := '';
a_tag := False;

while i <= Length(s) do
begin
Inc(i);
// es wird nochein tag geöffnet --> das erste war kein tag;
if s[i] = '<' then
begin
GetTag := False;
Exit;
end;

if s[i] = '>' then
begin
GetTag := True;
Exit;
end;

if not a_tag then
begin
if s[i] = ' ' then
begin
if Tag <> '' then a_tag := True;
end
else
Tag := Tag + s[i];
end
else
tagparams := tagparams + s[i];
end;
end;

procedure GetTagParams(tagparams: string; var params: TStringList);
var
i: Integer;
s: string;
gleich: Boolean;

// kontrolliert ob nach dem zeichen bis zum nächsten zeichen ausser
// leerzeichen ein Ist-Gleich-Zeichen kommt
function notGleich(s: string; i: Integer): Boolean;
begin
notGleich := True;
while i <= Length(s) do
begin
Inc(i);
if s[i] = '=' then
begin
notGleich := False;
Exit;
end
else if s[i] <> ' ' then Exit;
end;
end;
begin
Params.Clear;
s := '';
for i := 1 to Length(tagparams) do
begin
if (tagparams[i] <> ' ') then
begin
if tagparams[i] <> '=' then gleich := False;
if (tagparams[i] <> '''') and (tagparams[i] <> '"') then s := s + tagparams[i]
end
else
begin
if (notGleich(tagparams, i)) and (not Gleich) then
begin
params.Add(s);
s := '';
end
else
Gleich := True;
end;
end;
params.Add(s);
end;

function HtmlToColor(Color: string): TColor;
begin
Result := StringToColor('$' + Copy(Color, 6, 2) + Copy(Color, 4,
2) + Copy(Color, 2, 2));
end;

procedure TransformSpecialChars(var s: string; i: Integer);
var
c: string;
z, z2: Byte;
i2: Integer;
const
nchars = 9;
chars: array[1..nchars, 1..2] of string =
(('Ö', 'Ö'), ('ö', 'ö'), ('Ä', 'Ä'), ('ä', 'ä'),
('Ü', 'Ü'), ('ü', 'ü'), ('ß', 'ß'), ('<', '<'),
('>', '>'));
begin
// Maximal die nächsten 7 zeichen auf sonderzeichen überprüfen
c := '';
i2 := i;
for z := 1 to 7 do
begin
c := c + s[i2];
for z2 := 1 to nchars do
begin
if chars[z2, 1] = c then
begin
Delete(s, i, Length(c));
Insert(chars[z2, 2], s, i);
Exit;
end;
end;
Inc(i2);
end;
end;

// HtmlTag Schriftgröße in pdf größe umwandeln
function CalculateRTFSize(pt: Integer): Integer;
begin
case pt of
1: Result := 6;
2: Result := 9;
3: Result := 12;
4: Result := 15;
5: Result := 18;
6: Result := 22;
else
Result := 30;
end;
end;


// Die Font-Stack Funktionen
type
fontstack = record
Font: array[1..100] of tfont;
Pos: Byte;
end;

procedure CreateFontStack(var s: fontstack);
begin
s.Pos := 0;
end;

procedure PushFontStack(var s: Fontstack; fnt: TFont);
begin
Inc(s.Pos);
s.Font[s.Pos] := TFont.Create;
s.Font[s.Pos].Assign(fnt);
end;

procedure PopFontStack(var s: Fontstack; var fnt: TFont);
begin
if (s.Font[s.Pos] <> nil) and (s.Pos > 0) then
begin
fnt.Assign(s.Font[s.Pos]);
// vom stack nehmen
s.Font[s.Pos].Free;
Dec(s.Pos);
end;
end;

procedure FreeFontStack(var s: Fontstack);
begin
while s.Pos > 0 do
begin
s.Font[s.Pos].Free;
Dec(s.Pos);
end;
end;
var
fo_cnt: array[1..1000] of tfont;
fo_liste: array[1..1000] of Boolean;
fo_pos: TStringList;
fo_stk: FontStack;
wordwrap, liste: Boolean;
begin
CreateFontStack(fo_Stk);

fo_Pos := TStringList.Create;

rtf.Lines.BeginUpdate;
rtf.Lines.Clear;
// Das wordwrap vom richedit merken
wordwrap := rtf.wordwrap;
rtf.WordWrap := False;


// erste Zeile hinzufügen
rtf.Lines.Add('');
Params := TStringList.Create;



cfont := TFont.Create;
cfont.Assign(rtf.Font);


i := 1;
row := 0;
Liste := False;
// Den eigentlichen Text holen und die Formatiorung merken
rtf.selstart := 0;
if Length(html) = 0 then Exit;
repeat;


if html[i] = '<' then
begin
dummy := i;
GetTag(html, i, Tag, tagparams);
GetTagParams(tagparams, params);

// Das Font-Tag
if Uppercase(Tag) = 'FONT' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
if params.Values['size'] <> '' then
cfont.Size := CalculateRTFSize(StrToInt(params.Values['size']));

if params.Values['color'] <> '' then cfont.Color :=
htmltocolor(params.Values['color']);
end
else if Uppercase(Tag) = '/FONT' then popFontstack(fo_stk, cfont)
else // Die H-Tags-Überschriften
if Uppercase(Tag) = 'H1' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 6;
end
else if Uppercase(Tag) = '/H1' then popFontstack(fo_stk, cfont)
else // Die H-Tags-Überschriften
if Uppercase(Tag) = 'H2' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 9;
end
else if Uppercase(Tag) = '/H2' then popFontstack(fo_stk, cfont)
else // Die H-Tags-Überschriften
if Uppercase(Tag) = 'H3' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 12;
end
else if Uppercase(Tag) = '/H3' then popFontstack(fo_stk, cfont)
else // Die H-Tags-Überschriften
if Uppercase(Tag) = 'H4' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 15;
end
else if Uppercase(Tag) = '/H4' then popFontstack(fo_stk, cfont)
else // Die H-Tags-Überschriften
if Uppercase(Tag) = 'H5' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 18;
end
else if Uppercase(Tag) = '/H5' then popFontstack(fo_stk, cfont)
else // Die H-Tags-Überschriften
if Uppercase(Tag) = 'H6' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 22;
end
else if Uppercase(Tag) = '/H6' then popFontstack(fo_stk, cfont)
else // Die H-Tags-Überschriften
if Uppercase(Tag) = 'H7' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 27;
end
else if Uppercase(Tag) = '/H7' then popFontstack(fo_stk, cfont)
else // Bold-Tag

if Uppercase(Tag) = 'B' then cfont.Style := cfont.Style + [fsbold]
else if Uppercase(Tag) = '/B' then cfont.Style := cfont.Style - [fsbold]
else // Italic-Tag

if Uppercase(Tag) = 'I' then cfont.Style := cfont.Style + [fsitalic]
else if Uppercase(Tag) = '/I' then cfont.Style := cfont.Style - [fsitalic]
else // underline-Tag

if Uppercase(Tag) = 'U' then cfont.Style := cfont.Style + [fsunderline]
else if Uppercase(Tag) = '/U' then cfont.Style := cfont.Style - [fsunderline]
else // underline-Tag

if Uppercase(Tag) = 'UL' then liste := True
else if Uppercase(Tag) = '/UL' then
begin
liste := False;
rtf.Lines.Add('');
Inc(row);
rtf.Lines.Add('');
Inc(row);
end
else // BR - Breakrow tag

if (Uppercase(Tag) = 'BR') or (Uppercase(Tag) = 'LI') then
begin
rtf.Lines.Add('');
Inc(row);
end;

// unbekanntes tag als text ausgeben
// else rtf.Lines[row]:=RTF.lines[row]+'<'+tag+' '+tagparams+'>';

fo_pos.Add(IntToStr(rtf.selstart));
fo_cnt[fo_pos.Count] := TFont.Create;
fo_cnt[fo_pos.Count].Assign(cfont);
fo_liste[fo_pos.Count] := liste;
end
else
begin
// Spezialzeichen übersetzen
if html[i] = '&' then Transformspecialchars(html, i);

if (Ord(html[i]) <> 13) and (Ord(html[i]) <> 10) then
rtf.Lines[row] := RTF.Lines[row] + html[i];
end;

Inc(i);

until i >= Length(html);
// dummy eintragen
fo_pos.Add('999999');

// Den fertigen Text formatieren
for i := 0 to fo_pos.Count - 2 do
begin
rtf.SelStart := StrToInt(fo_pos[i]);
rtf.SelLength := StrToInt(fo_pos[i + 1]) - rtf.SelStart;
rtf.SelAttributes.Style := fo_cnt[i + 1].Style;
rtf.SelAttributes.Size := fo_cnt[i + 1].Size;
rtf.SelAttributes.Color := fo_cnt[i + 1].Color;

// die font wieder freigeben;
fo_cnt[i + 1].Free;
end;

// die Paragraphen also Listen setzen
i := 0;
while i <= fo_pos.Count - 2 do
begin
if fo_liste[i + 1] then
begin
rtf.SelStart := StrToInt(fo_pos[i + 1]);
while fo_liste[i + 1] do Inc(i);
rtf.SelLength := StrToInt(fo_pos[i - 1]) - rtf.SelStart;
rtf.Paragraph.Numbering := nsBullet;
end;
Inc(i);
end;
rtf.Lines.EndUpdate;
Params.Free;
cfont.Free;
rtf.WordWrap := wordwrap;
FreeFontStack(fo_stk);
end;

draw an arrow

{ .... }

var
BeginPoint: TPoint;

{ .... }

uses Math;

{ .... }

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
BeginPoint.X := X;
BeginPoint.Y := Y;
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
B, deltaX, deltaY: Extended;
begin
Image1.Canvas.PenPos := BeginPoint;
// Beginpoint is the point from where the use drew the line
Image1.Canvas.LineTo(X, Y);

if BeginPoint.X <> X then // checks for division by zero
begin
if (BeginPoint.X > X) then
B := DegToRad(135) - ArcTan((BeginPoint.Y - Y) / (BeginPoint.X - X))
else
B := DegToRad(45) - ArcTan((BeginPoint.Y - Y) / (BeginPoint.X - X));
// the arrow will have a 45 deg corner

deltaX := 15 * Cos(B); // 15 is the length of the arrow
deltaY := 15 * Sin(B);

if (BeginPoint.X > X) then
begin
Image1.Canvas.PenPos := Point(X, Y);
Image1.Canvas.LineTo(X - Trunc(deltaX), Y + Trunc(deltaY));
Image1.Canvas.PenPos := Point(X, Y);
Image1.Canvas.LineTo(X + Trunc(deltaY), Y + Trunc(deltaX));
end
else
begin
Image1.Canvas.PenPos := Point(X, Y);
Image1.Canvas.LineTo(X - Trunc(deltaX), Y + Trunc(deltaY));
Image1.Canvas.PenPos := Point(X, Y);
Image1.Canvas.LineTo(X - Trunc(deltaY), Y - Trunc(deltaX));
end;
end
else
begin
if BeginPoint.Y > Y then
begin
Image1.Canvas.PenPos := Point(X, Y);
Image1.Canvas.LineTo(X + 10, Y + 10);
Image1.Canvas.PenPos := Point(X, Y);
Image1.Canvas.LineTo(X - 10, Y + 10);
end
else
begin
Image1.Canvas.PenPos := Point(X, Y);
Image1.Canvas.LineTo(X + 10, Y - 10);
Image1.Canvas.PenPos := Point(X, Y);
Image1.Canvas.LineTo(X - 10, Y - 10);
end;
end;
end;

draw a gradient with alpha channel

{ .... }

interface

{ .... }

type
TTriVertex = packed record
x: Longint;
y: Longint;
Red: Word;
Green: Word;
Blue: Word;
Alpha: Word;
end;
TGradientFillProc = function(DC: HDC; Verteces: Pointer; NumVerteces: DWORD;
Meshes: Pointer; NumMeshes: DWORD; Mode: DWORD): DWORD; stdcall;

{ .... }

var
MSImg32Lib: THandle;
GradientFillProc: TGradientFillProc;

{ .... }

// Example:
// Beispiel:

procedure TForm1.Button1Click(Sender: TObject);
var
cr: Cardinal;
Verteces: array[0..1] of TTriVertex;
GradientRect: TGradientRect;
begin
Verteces[0].x := 0;
Verteces[0].y := 0;
cr := GetSysColor(COLOR_ACTIVECAPTION);
Verteces[0].Red := ((cr and $0F0F) or 8);
Verteces[0].Green := (cr and $0ff00);
Verteces[0].Blue := ((cr and $0ff0000) or 8);
Verteces[0].Alpha := 0;
Verteces[1].x := Width;
Verteces[1].y := Height;
cr := GetSysColor(COLOR_GRADIENTACTIVECAPTION);
Verteces[1].Red := ((cr and $0FF) or 8);
Verteces[1].Green := (cr and $0ff00);
Verteces[1].Blue := ((cr and $0ff0000) or 8);
Verteces[1].Alpha := 0;
GradientRect.UpperLeft := 0;
GradientRect.LowerRight := 1;
GradientFillProc(Canvas.Handle, @Verteces[0], 2, @GradientRect, 1, GRADIENT_FILL_RECT_H);
end;

{ .... }

initialization
GradientFillProc := nil;
MSImg32Lib := LoadLibrary('msimg32.dll');
if MSImg32Lib <> 0 then
begin
GradientFillProc := GetProcAddress(MSImg32Lib, 'GradientFill');
if @GradientFillProc = nil then
begin
FreeLibrary(MSImg32Lib);
MSImg32Lib := 0;
end;
end
else
ShowMessage('Could not load DLL');

finalization
if @GradientFillProc <> nil then
GradientFillProc := nil;
if MSImg32Lib <> 0 then
begin
FreeLibrary(MSImg32Lib);
MSImg32Lib := 0;
end;
end.