DelphiTips: 2007

Monday, March 19, 2007

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;

determine if a printer is a Dot-Matrix or Laser

{$APPTYPE CONSOLE}
uses Windows, Printers, WinSpool, Variants;
{
Using only API calls, determinate which type is the active printer:
Dot-Matrix or Laser (or InkJet)

This example is distributed "AS IS", WITHOUT WARRANTY OF ANY KIND,
either express or implied. You use it at your own risk!
}

function IsPrinterMatrix: Boolean;
var
DeviceMode: THandle;
Device, Driver, Port: array [0..79] of Char;
pDevice, pDriver, pPort: PChar;
begin

// Determinate that active printer is a Dot-Marix
Result:= False;
pDevice := @Device;
pDriver := @Driver;
pPort := @Port;

Device := #0;
Driver := #0;
Port := #0;

Printer.GetPrinter(pDevice, pDriver, pPort, DeviceMode);

// Printer can be dot-matrix when number of colors is maximum 16
// and when printer is capable to print only for TRUETYPE
// fonts as graphics (dot-matrix and PCL printers are capable for that).

if (GetDeviceCaps(Printer.Handle,NUMCOLORS)<=16) and
(DeviceCapabilities(pDevice, pPort,DC_TRUETYPE,nil,nil) = DCTT_BITMAP)
then
Result := True;
end;

begin
writeln ('Active printer is ', Printer.Printers[Printer.PrinterIndex]);

if IsPrinterMatrix then
writeln('This is a Dot-Matrix printer')
else
writeln('This is a LaserJet or InkJet printer');
end.

retrieve the Port of a given Printer (W2K, XP)

uses
Registry;

//...

function Get_Printerport(Printername: string): string;
var
Reg: TRegistry;
p: Integer;
begin
Reg := TRegistry.Create;
with Reg do
begin
RootKey := HKEY_CURRENT_USER;
if OpenKey('\Software\Microsoft\Windows NT\CurrentVersion\Devices\', True) then
begin
if ValueExists(Printername) then
begin
// Im reg Key steht so etwas wie "winspool,LPT1:"
// The reg Key value may look like "winspool,LPT1:"
Result := ReadString(Printername);
p := Pos(',', Result);
Result := Copy(Result, p + 1,Length(Result) - p);
end;
end;
CloseKey;
end;
end;

save a file to a TBlobStream and read it back

// To save a file to BLOB:
procedure TForm1.Button1Click(Sender: TObject);
var
blob: TBlobStream;
begin
blob := yourDataset.CreateBlobStream(yourDataset.FieldByName('YOUR_BLOB'), bmWrite);
try
blob.Seek(0, soFromBeginning);
fs := TFileStream.Create('c:\your_name.doc', fmOpenRead or
fmShareDenyWrite);
try
blob.CopyFrom(fs, fs.Size)
finally
fs.Free
end;
finally
blob.Free
end;
end;
// To load from BLOB:

procedure TForm1.Button1Click(Sender: TObject);
var
blob: TBlobStream;
begin
blob := yourDataset.CreateBlobStream(yourDataset.FieldByName('YOUR_BLOB'), bmRead);
try
blob.Seek(0, soFromBeginning);

with TFileStream.Create('c:\your_name.doc', fmCreate) do
try
CopyFrom(blob, blob.Size)
finally
Free
end;
finally
blob.Free
end;
end;

{
Using this code you can work with any database engine (BDE/ADO/DAO/ODBC/etc)
and any file format (document of MS Word, spreadsheet of MS Excel, bitmap or
jpeg pictures, wav-files etc)
}

Compact and Repair an Access Database

uses
ComObj;

function CompactAndRepair(DB: string): Boolean; {DB = Path to Access Database}
var
v: OLEvariant;
begin
Result := True;
try
v := CreateOLEObject('JRO.JetEngine');
try
V.CompactDatabase('Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB,
'Provider=Microsoft.Jet.OLEDB.4.0;Data Source='+DB+'x;Jet OLEDB:Engine Type=5');
DeleteFile(DB);
RenameFile(DB+'x',DB);
finally
V := Unassigned;
end;
except
Result := False;
end;
end;

add a Row Number in your DBGrid

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1. create new blank field in dbgrid
2. rename the title with 'No'
3. put this code in OnDrawColumncell
4. Now your Grid has a row number
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if DataSource1.DataSet.RecNo > 0 then
begin
if Column.Title.Caption = 'No' then
DBGrid1.Canvas.TextOut(Rect.Left + 2, Rect.Top, IntToStr(DataSource1.DataSet.RecNo));
end;
end;

create an Access Database

uses
ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
AccessApp: Variant;
begin
AccessApp := CreateOleObject('Access.Application');
AccessApp.NewCurrentDatabase('c:\111.mdb');
AccessApp := Unassigned;
end;

color a specific (conditional) cell in a DBGrid

procedure TFRM_Main.DBG_MainGetCellParams(Sender: TObject; Field: TField;
AFont: TFont; var Background: TColor; Highlight: Boolean);
begin

if (Field.AsString = '0') and (Field.FullName = 'LoadingAttn') then
begin
Background := $00E69B00;
AFont.Color := clBlack;
AFont.Style := AFont.Style + [fsBold];
end
else
begin
if (Field.AsString = '0') and (Field.FullName = 'DeliveryAttn') then
begin
Background := $0082FFFF;
AFont.Color := clBlack;
AFont.Style := AFont.Style + [fsBold];
end
else
begin
if (Field.AsString = 'H') and (Field.FullName = 'EctaCode1') then
begin
Background := $008080FF;
AFont.Color := clBlack;
AFont.Style := AFont.Style + [fsBold];
end
else
begin
AFont.Color := clBlack;
AFont.Style := AFont.Style - [fsBold];
Background := clWhite;
end;
end;
end;

end;

Saturday, March 17, 2007

send a message to ICQ

{
You need 3 TEdits, 1 TMemo und 1 TClientSocket.
Set the TClientsocket's Port to 80 and the Host to wwp.mirabilis.com.
}

{
Für diesen Tip braucht man 3 TEdits, 1 TMemo und 1 TClientSocket.
Setze den Port des TClientsockets auf 80 un den Host auf wwp.mirabilis.com.
}

var
Form1: TForm1;
csend: string;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
cSend := 'POST http://wwp.icq.com/scripts/WWPMsg.dll HTTP/2.0' + chr(13) + chr(10);
cSend := cSend + 'Referer: http://wwp.mirabilis.com' + chr(13) + chr(10);
cSend := cSend + 'User-Agent: Mozilla/4.06 (Win95; I)' + chr(13) + chr(10);
cSend := cSend + 'Connection: Keep-Alive' + chr(13) + chr(10);
cSend := cSend + 'Host: wwp.mirabilis.com:80' + chr(13) + chr(10);
cSend := cSend + 'Content-type: application/x-www-form-urlencoded' + chr(13) + chr(10);
cSend := cSend + 'Content-length:8000' + chr(13) + chr(10);
cSend := cSend + 'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*' +
chr(13) + chr(10) + chr(13) + chr(10);
cSend := cSend + 'from=' + edit1.Text + ' &fromemail=' + edit2.Text +
' &fromicq:110206786' + ' &body=' + memo1.Text + ' &to=' + edit3.Text + '&Send=';
clientsocket1.Active := True;
end;

procedure TForm1.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
begin
clientsocket1.Socket.SendText(csend);
clientsocket1.Active := False;
end;

display the 'Choose Computer' dialog

type
TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer; cchBufSize: DWORD): bool;
stdcall;

function ShowServerDialog(AHandle: THandle): string;
var
ServerBrowseDialogA0: TServerBrowseDialogA0;
LANMAN_DLL: DWORD;
buffer: array[0..1024] of char;
bLoadLib: Boolean;
begin
LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');
if LANMAN_DLL = 0 then
begin
LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');
bLoadLib := True;
end;
if LANMAN_DLL <> 0 then
begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');
DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);
ServerBrowseDialogA0(AHandle, @buffer, 1024);
if buffer[0] = '\' then
begin
Result := buffer;
end;
if bLoadLib then
FreeLibrary(LANMAN_DLL);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := ShowServerDialog(Form1.Handle);
end;

delete the 'Temporary Internet Files'

uses
WinInet;

procedure DeleteIECache;
var
lpEntryInfo: PInternetCacheEntryInfo;
hCacheDir: LongWord;
dwEntrySize: LongWord;
begin
dwEntrySize := 0;
FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
if hCacheDir <> 0 then
begin
repeat
DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
FreeMem(lpEntryInfo, dwEntrySize);
dwEntrySize := 0;
FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);
end;
FreeMem(lpEntryInfo, dwEntrySize);
FindCloseUrlCache(hCacheDir);
end;

// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
DeleteIECache;
end;

Friday, March 16, 2007

determine which track the current CD is on

uses
MMSystem;

procedure TForm1.Timer1Timer(Sender: TObject);
var
Trk, Min, Sec: Word;
begin
with MediaPlayer1 do
begin
Trk := MCI_TMSF_TRACK(Position);
Min := MCI_TMSF_MINUTE(Position);
Sec := MCI_TMSF_SECOND(Position);
label1.Caption := Format('%.2d', [Trk]);
Label2.Caption := Format('%.2d:%.2d', [Min, Sec]);
end;
end;

get the names of all MIDI out devices

procedure GetMIDIOutDevices(Devices: TStrings);
var
i, DNum: Integer;
Caps: TMIDIOUTCAPSA;
begin
DNum := MIDIOutGetNumDevs; // Number of Devices
for i := 0 to DNum - 1 do // Query Devicenames
begin
MIDIOutGetDevCaps(i, @Caps, SizeOf(TMIDIOutCapsA));
Devices.Add(string(Caps.szPname));
end;
end;

// Usage:

var
MIDIDevices: TStringList;

begin
MIDIDevices := TStringList.Create;
try
GetMIDIOutDevices(MIDIDevices);
// Do anything with the device name list
finally
MIDIDevices.Free;
end;
end;

Thursday, March 15, 2007

refresh the desktop

uses
ShlObj;

procedure RefreshDesktop1;
begin
SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
end;

{2.}

procedure RefreshDesktop2;
var
hDesktop: HWND;
begin
hDesktop := FindWindowEx(FindWindowEx(FindWindow('Progman', 'Program Manager'), 0,
'SHELLDLL_DefView', ''), 0, 'SysListView32', '');
PostMessage(hDesktop, WM_KEYDOWN, VK_F5, 0);
PostMessage(hDesktop, WM_KEYUP, VK_F5, 1 shl 31);
end;

detect if the user is using XP style or classic style

function _IsThemeActive: Boolean;
// Returns True if the user uses XP style
const
themelib = 'uxtheme.dll';
type
TIsThemeActive = function: BOOL; stdcall;
var
IsThemeActive: TIsThemeActive;
huxtheme: HINST;
begin
Result := False;
// Check if XP or later Version
if (Win32Platform = VER_PLATFORM_WIN32_NT) and
(((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) or
(Win32MajorVersion > 5)) then
begin
huxtheme := LoadLibrary(themelib);
if huxtheme <> 0 then
begin
try
IsThemeActive := GetProcAddress(huxtheme, 'IsThemeActive');
Result := IsThemeActive;
finally
if huxtheme > 0 then
FreeLibrary(huxtheme);
end;
end;
end;
end;

// Example Call:

procedure TForm1.Button1Click(Sender: TObject);
begin
if _IsThemeActive then
ShowMessage('Windows Themes are active.');
end;

check if an audio-cd is in the cd drive

function IsAudioCD(Drive: Char): Boolean;
var
DrivePath: string;
MaximumComponentLength: DWORD;
FileSystemFlags: DWORD;
VolumeName: string;
OldErrorMode: UINT;
DriveType: UINT;
begin
Result := False;
DrivePath := Drive + ':\';
OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
DriveType := GetDriveType(PChar(DrivePath));
finally
SetErrorMode(OldErrorMode);
end;
if DriveType <> DRIVE_CDROM then
Exit;
SetLength(VolumeName, 64);
GetVolumeInformation(PChar(DrivePath),
PChar(VolumeName),
Length(VolumeName),
nil,
MaximumComponentLength,
FileSystemFlags,
nil,
0);
if lStrCmp(PChar(VolumeName), 'Audio-CD') = 0 then Result := True;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if IsAudioCD('D') then
ShowMessage('Audio-CD found in drive D.')
else
ShowMessage('No Audio-CD found in drive D.');
end;

set the volume for the microphone/ mute it

function SetMicrophoneVolume(bValue: Word): Boolean;
var {0..65535}
hMix: HMIXER;
mxlc: MIXERLINECONTROLS;
mxcd: TMIXERCONTROLDETAILS;
vol: TMIXERCONTROLDETAILS_UNSIGNED;
mxc: MIXERCONTROL;
mxl: TMixerLine;
intRet: Integer;
nMixerDevs: Integer;
begin
// Check if Mixer is available
// Überprüfen, ob ein Mixer vorhanden
nMixerDevs := mixerGetNumDevs();
if (nMixerDevs <>then
begin
Exit;
end;

// open the mixer
intRet := mixerOpen(@hMix, 0, 0, 0, 0);
if intRet = MMSYSERR_NOERROR then
begin
mxl.dwComponentType := MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE;
mxl.cbStruct := SizeOf(mxl);

{*} // this option will tell the compiler which line destination to take:
{*} // 0 - PLAYBACK destination
{*} // 1 - RECORD destination
{*} // this time the compiler will take control of recording microphone line
{*} mxl.dwDestination := 1;

// get line info
intRet := mixerGetLineInfo(hMix, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);

//...
end;
end;

Wednesday, March 14, 2007

get and set mouse position

procedure TForm1.Button1Click(Sender: TObject);
var
MausPos: TPoint;
begin
GetCursorPos(MausPos);
label1.Caption := IntToStr(MausPos.x);
label2.Caption := IntToStr(MausPos.y);
end;

// Set mouse position to (x,y)

procedure TForm1.Button2Click(Sender: TObject);
begin
SetCursorPos(600, 600);
end;

capture the screen

uses
Graphics;

// Capture the entire screen
// Screenshot des gesamten Bildschirms
procedure ScreenShot(Bild: TBitMap);
var
c: TCanvas;
r: TRect;
begin
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
try
r := Rect(0, 0, Screen.Width, Screen.Height);
Bild.Width := Screen.Width;
Bild.Height := Screen.Height;
Bild.Canvas.CopyRect(r, c, r);
finally
ReleaseDC(0, c.Handle);
c.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Visible := False;
Sleep(750); // some delay, ein wenig Zeit geben
ScreenShot(Image1.Picture.BitMap);
Form1.Visible := True;
end;

// Only active window
// Screenshot des aktiven Fensters
procedure ScreenShotActiveWindow(Bild: TBitMap);
var
c: TCanvas;
r, t: TRect;
h: THandle;
begin
c := TCanvas.Create;
c.Handle := GetWindowDC(GetDesktopWindow);
h := GetForeGroundWindow;
if h <> 0 then
GetWindowRect(h, t);
try
r := Rect(0, 0, t.Right - t.Left, t.Bottom - t.Top);
Bild.Width := t.Right - t.Left;
Bild.Height := t.Bottom - t.Top;
Bild.Canvas.CopyRect(r, c, t);
finally
ReleaseDC(0, c.Handle);
c.Free;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Form1.Visible := False;
Sleep(750); //some delay,ein wenig Zeit geben
ScreenShotActiveWindow(Image1.Picture.BitMap);
Form1.Visible := True;
end;

{**********************************************}
// Another print screen function by Xavier P:
// Capture the entire screen
procedure ScreenShot(x: Integer;
y: Integer; //(x, y) = Left-top coordinate
Width: Integer;
Height: Integer; //(Width-Height) = Bottom-Right coordinate
bm: TBitMap); //Destination
var
dc: HDC;
lpPal: PLOGPALETTE;
begin
{test width and height}
if ((Width = 0) or
(Height = 0)) then
Exit;
bm.Width := Width;
bm.Height := Height;
{get the screen dc}
dc := GetDc(0);
if (dc = 0) then
Exit;
{do we have a palette device?}
if (GetDeviceCaps(dc, RASTERCAPS) and
RC_PALETTE = RC_PALETTE) then
begin
{allocate memory for a logical palette}
GetMem(lpPal,
SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
{zero it out to be neat}
FillChar(lpPal^,
SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)),
#0);
{fill in the palette version}
lpPal^.palVersion := $300;
{grab the system palette entries}
lpPal^.palNumEntries :=
GetSystemPaletteEntries(dc,
0,
256,
lpPal^.palPalEntry);
if (lpPal^.PalNumEntries <> 0) then
{create the palette}
bm.Palette := CreatePalette(lpPal^);
FreeMem(lpPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
end;
{copy from the screen to the bitmap}
BitBlt(bm.Canvas.Handle,
0,
0,
Width,
Height,
Dc,
x,
y,
SRCCOPY);
{release the screen dc}
ReleaseDc(0, dc);
end;

// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
ScreenShot(0,0,Screen.Width, Screen.Height, Image1.Picture.Bitmap);
end;

{**********************************************}
// Capture a window
procedure ScreenShot(hWindow: HWND; bm: TBitmap);
var
Left, Top, Width, Height: Word;
R: TRect;
dc: HDC;
lpPal: PLOGPALETTE;
begin
{Check if valid window handle}
if not IsWindow(hWindow) then Exit;
{Retrieves the rectangular coordinates of the specified window}
GetWindowRect(hWindow, R);
Left := R.Left;
Top := R.Top;
Width := R.Right - R.Left;
Height := R.Bottom - R.Top;
bm.Width := Width;
bm.Height := Height;
{get the screen dc}
dc := GetDc(0);
if (dc = 0) then
begin
Exit;
end;
{do we have a palette device?}
if (GetDeviceCaps(dc, RASTERCAPS) and
RC_PALETTE = RC_PALETTE) then
begin
{allocate memory for a logical palette}
GetMem(lpPal,
SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
{zero it out to be neat}
FillChar(lpPal^,
SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)),
#0);
{fill in the palette version}
lpPal^.palVersion := $300;
{grab the system palette entries}
lpPal^.palNumEntries :=
GetSystemPaletteEntries(dc,
0,
256,
lpPal^.palPalEntry);
if (lpPal^.PalNumEntries <> 0) then
begin
{create the palette}
bm.Palette := CreatePalette(lpPal^);
end;
FreeMem(lpPal, SizeOf(TLOGPALETTE) +
(255 * SizeOf(TPALETTEENTRY)));
end;
{copy from the screen to the bitmap}
BitBlt(bm.Canvas.Handle,
0,
0,
Width,
Height,
Dc,
Left,
Top,
SRCCOPY);
{release the screen dc}
ReleaseDc(0, dc);
end;
// Example: Capture the foreground window:
procedure TForm1.Button1Click(Sender: TObject);
begin
ScreenShot(GetForeGroundWindow, Image1.Picture.Bitmap);
end;

{**********************************************}
// by Daniel Wischnewski
Sometimes you want to take a screen shot,
however often Windows has trouble with big data amounts and becomes very slow.
The simple solution is to make many small screen shots and paste the result together.
It's not light speed, however often faster than taking the whole screen at once.
const
cTileSize = 50;
function TForm1.GetSCREENSHOT: TBitmap;
var
Locked: Boolean;
X, Y, XS, YS: Integer;
Canvas: TCanvas;
R: TRect;
begin
Result := TBitmap.Create;
Result.Width := Screen.Width;
Result.Height := Screen.Height;
Canvas := TCanvas.Create;
Canvas.Handle := GetDC(0);
Locked := Canvas.TryLock;
try
XS := Pred(Screen.Width div cTileSize);
if Screen.Width mod cTileSize > 0 then
Inc(XS);
YS := Pred(Screen.Height div cTileSize);
if Screen.Height mod cTileSize > 0 then
Inc(YS);
for X := 0 to XS do
for Y := 0 to YS do
begin
R := Rect(
X * cTileSize, Y * cTileSize, Succ(X) * cTileSize,
Succ(Y) * cTileSize);
Result.Canvas.CopyRect(R, Canvas, R);
end;
finally
if Locked then
Canvas.Unlock;
ReleaseDC(0, Canvas.Handle);
Canvas.Free;
end;
end;

make a form transparent

procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Form1.Handle, GWL_EXSTYLE,
(GetWindowLong(Form1.Handle, GWL_EXSTYLE) or WS_WX_TRANSPARENT));
end;

prevent Windows from minimizing a Form?

implementation

procedure TForm1.WMShowWindow(var Msg: TWMShowWindow);
begin
if not Msg.Show then
Msg.Result := 0
else
inherited;
end;

shape a form to a bitmap

unit Unit1;

interface

uses
Windows, Classes, SysUtils, Graphics, Forms;

type
TRGBArray = array[0..32767] of TRGBTriple;
PRGBArray = ^TRGBArray;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FRegion: THandle;
function CreateRegion(Bmp: TBitmap): THandle;
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

function TForm1.CreateRegion(Bmp: TBitmap): THandle;
var
X, Y, StartX: Integer;
Excl: THandle;
Row: PRGBArray;
TransparentColor: TRGBTriple;
begin
Bmp.PixelFormat := pf24Bit;

Result := CreateRectRGN(0, 0, Bmp.Width, Bmp.Height);

for Y := 0 to Bmp.Height - 1 do
begin
Row := Bmp.Scanline[Y];

StartX := -1;

if Y = 0 then
TransparentColor := Row[0];

for X := 0 to Bmp.Width - 1 do
begin
if (Row[X].rgbtRed = TransparentColor.rgbtRed) and
(Row[X].rgbtGreen = TransparentColor.rgbtGreen) and
(Row[X].rgbtBlue = TransparentColor.rgbtBlue) then
begin
if StartX = -1 then StartX := X;
end
else
begin
if StartX > -1 then
begin
Excl := CreateRectRGN(StartX, Y, X + 1, Y + 1);
try
CombineRGN(Result, Result, Excl, RGN_DIFF);
StartX := -1;
finally
DeleteObject(Excl);
end;
end;
end;
end;

if StartX > -1 then
begin
Excl := CreateRectRGN(StartX, Y, Bmp.Width, Y + 1);
try
CombineRGN(Result, Result, Excl, RGN_DIFF);
finally
DeleteObject(Excl);
end;
end;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
try
Bmp.LoadFromFile('C:\YourBitmap.bmp');
FRegion := CreateRegion(Bmp);
SetWindowRGN(Handle, FRegion, True);
finally
Bmp.Free;
end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteObject(FRegion);
end;

end.

making the Enter Key act like Tab

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if Key = #13 then
begin
Key := #0;
{ check if SHIFT - Key is pressed }
if GetKeyState(VK_Shift) and $8000 <> 0 then
PostMessage(Handle, WM_NEXTDLGCTL, 1, 0)
else
PostMessage(Handle, WM_NEXTDLGCTL, 0, 0);
end;
end;

// Form1.KeyPreview := True !

Tuesday, March 13, 2007

detect if a USB device is connected or disconnected

unit U_Usb;

interface

uses
Windows, Messages, SysUtils, Classes, Forms;

type

PDevBroadcastHdr = ^DEV_BROADCAST_HDR;
DEV_BROADCAST_HDR = packed record
dbch_size: DWORD;
dbch_devicetype: DWORD;
dbch_reserved: DWORD;
end;

PDevBroadcastDeviceInterface = ^DEV_BROADCAST_DEVICEINTERFACE;
DEV_BROADCAST_DEVICEINTERFACE = record
dbcc_size: DWORD;
dbcc_devicetype: DWORD;
dbcc_reserved: DWORD;
dbcc_classguid: TGUID;
dbcc_name: short;
end;

const
GUID_DEVINTERFACE_USB_DEVICE: TGUID = '{A5DCBF10-6530-11D2-901F-00C04FB951ED}';
DBT_DEVICEARRIVAL = $8000; // system detected a new device
DBT_DEVICEREMOVECOMPLETE = $8004; // device is gone
DBT_DEVTYP_DEVICEINTERFACE = $00000005; // device interface class

type

TComponentUSB = class(TComponent)
private
FWindowHandle: HWND;
FOnUSBArrival: TNotifyEvent;
FOnUSBRemove: TNotifyEvent;
procedure WndProc(var Msg: TMessage);
function USBRegister: Boolean;
protected
procedure WMDeviceChange(var Msg: TMessage); dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property OnUSBArrival: TNotifyEvent read FOnUSBArrival write FOnUSBArrival;
property OnUSBRemove: TNotifyEvent read FOnUSBRemove write FOnUSBRemove;
end;

implementation

constructor TComponentUSB.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FWindowHandle := AllocateHWnd(WndProc);
USBRegister;
end;

destructor TComponentUSB.Destroy;
begin
DeallocateHWnd(FWindowHandle);
inherited Destroy;
end;

procedure TComponentUSB.WndProc(var Msg: TMessage);
begin
if (Msg.Msg = WM_DEVICECHANGE) then
begin
try
WMDeviceChange(Msg);
except
Application.HandleException(Self);
end;
end
else
Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.wParam, Msg.lParam);
end;

procedure TComponentUSB.WMDeviceChange(var Msg: TMessage);
var
devType: Integer;
Datos: PDevBroadcastHdr;
begin
if (Msg.wParam = DBT_DEVICEARRIVAL) or (Msg.wParam = DBT_DEVICEREMOVECOMPLETE) then
begin
Datos := PDevBroadcastHdr(Msg.lParam);
devType := Datos^.dbch_devicetype;
if devType = DBT_DEVTYP_DEVICEINTERFACE then
begin // USB Device
if Msg.wParam = DBT_DEVICEARRIVAL then
begin
if Assigned(FOnUSBArrival) then
FOnUSBArrival(Self);
end
else
begin
if Assigned(FOnUSBRemove) then
FOnUSBRemove(Self);
end;
end;
end;
end;

function TComponentUSB.USBRegister: Boolean;
var
dbi: DEV_BROADCAST_DEVICEINTERFACE;
Size: Integer;
r: Pointer;
begin
Result := False;
Size := SizeOf(DEV_BROADCAST_DEVICEINTERFACE);
ZeroMemory(@dbi, Size);
dbi.dbcc_size := Size;
dbi.dbcc_devicetype := DBT_DEVTYP_DEVICEINTERFACE;
dbi.dbcc_reserved := 0;
dbi.dbcc_classguid := GUID_DEVINTERFACE_USB_DEVICE;
dbi.dbcc_name := 0;

r := RegisterDeviceNotification(FWindowHandle, @dbi,
DEVICE_NOTIFY_WINDOW_HANDLE
);
if Assigned(r) then Result := True;
end;

end.

get the Active Window Caption

function ActiveCaption: string;
var
Handle: THandle;
Len: LongInt;
Title: string;
begin
Result := '';
Handle := GetForegroundWindow;
if Handle <> 0 then
begin
Len := GetWindowTextLength(Handle) + 1;
SetLength(Title, Len);
GetWindowText(Handle, PChar(Title), Len);
ActiveCaption := TrimRight(Title);
end;
end;

{ - - - - - - - - - - - - - - - - - - - - -}

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption := ActiveCaption;
end;

detect memory leaks

procedure TForm.DebugProcessStatus(s: string);
var
pmc: PPROCESS_MEMORY_COUNTERS;
cb: Integer;
MemStat: tMemoryStatus;
begin
MemStat.dwLength := SizeOf(MemStat);
GlobalMemoryStatus(MemStat);

// Get the total and available system memory
TotalMemoryLabel.Caption := 'Total system memory: ' +
FormatFloat('###,###', MemStat.dwTotalPhys / 1024) + ' KByte';
FreeMemoryLabel.Caption := 'Free physical memory: ' +
FormatFloat('###,###', MemStat.dwAvailPhys / 1024) + ' KByte';

// Get the used memory for the current process
cb := SizeOf(TProcessMemoryCounters);
GetMem(pmc, cb);
pmc^.cb := cb;
if GetProcessMemoryInfo(GetCurrentProcess(), pmc, cb) then
begin
NewWorkingMemory := Longint(pmc^.WorkingSetSize);
ProcessMemoryLabel.Caption := 'Process-Memory: ' +
FormatFloat('###,###', NewWorkingMemory / 1024) + ' KByte';
MemoryLeakLabel.Caption := 'Memory Loss: ' +
FormatFloat('###,###', (NewWorkingMemory - OldWorkingMemory) / 1024) + ' KByte';
OldWorkingMemory := NewWorkingMemory;
end;
FreeMem(pmc);

DebugStatusLabel.Caption := 'Status: ' + s;
end;

Monday, March 12, 2007

Creating a Chat Application (local) with Delphi

Start a new project. Put one RichEdit,EditBox,ComboBox,Timer,MediaPlayer,TcpServer,
TcpClient,PopupMenu,SaveDialog,ChckBox and one button on the form.
The program contains two units. The first one (Unit1.pas) is the main program
and the second unit (Unit2.pas) contains the procedures for encrypting and decrypting.
And here is the code:

Unit1:
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, Sockets, Menus, MPlayer,ShellAPI, ExtCtrls;

const
WM_ICONTRAY2 = WM_USER + 1;
edkey = 6539;

type
TForm1 = class(TForm)
Host: TEdit;
Button1: TButton;
TcpClient1: TTcpClient;
TcpServer1: TTcpServer;
MediaPlayer1: TMediaPlayer;
Chat: TRichEdit;
Mes: TComboBox;
PopupMenu1: TPopupMenu;
CheckBox1: TCheckBox;
Timer1: TTimer;
SaveDialog1: TSaveDialog;
Clear1: TMenuItem;
Save1: TMenuItem;
procedure TrayMessage(var Msg: TMessage); message WM_ICONTRAY2;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure TcpServer1Accept(Sender: TObject;
ClientSocket: TCustomIpClient);
procedure Clear1Click(Sender: TObject);
procedure MesKeyPress(Sender: TObject; var Key: Char);
procedure HostKeyPress(Sender: TObject; var Key: Char);
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure ChatKeyPress(Sender: TObject; var Key: Char);
procedure FormShow(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure CheckBox1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Save1Click(Sender: TObject);
procedure FormHide(Sender: TObject);
private
TrayIconData2: TNotifyIconData;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
icon1 : TIcon;
mescount : integer;
implementation
Uses Unit2;
{$R *.dfm}

procedure AddColoredLine(ARichEdit: TRichEdit; AText: string; AColor: TColor);
begin
with ARichEdit do
begin
SelStart := Length(Text);
SelAttributes.Color := AColor;
SelAttributes.Size := 8;
SelAttributes.Name := 'MS Sans Serif';
Lines.Add(AText);
end;
end;

procedure TForm1.TrayMessage(var Msg: TMessage);
begin
case Msg.lParam of
WM_LBUTTONDOWN:
begin
Form1.Show;
end;
WM_RBUTTONDOWN:
begin
Form1.Show;
end;
end;
end;

function GetComputerName: string;
var
buffer: array[0..MAX_COMPUTERNAME_LENGTH + 1] of Char;
Size: Cardinal;
begin
Size := MAX_COMPUTERNAME_LENGTH + 1;
Windows.GetComputerName(@buffer, Size);
Result := StrPas(buffer);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
TcpClient1.RemoteHost := Host.Text;
TcpClient1.Connect;
try
if TcpClient1.Connect then begin
TcpClient1.Sendln(Unit2.Encrypt(Mes.Text,edkey));
sleep(10);
AddColoredLine(Chat,'<<'+TimeToStr(now)+ '>> '+GetComputerName+'-->'+Host.Text+':'+Mes.Text,clBlack);
Shell_NotifyIcon(NIM_DELETE, @TrayIconData2);
end;
finally
TcpClient1.Disconnect;
end;
Mes.Items.Add(Mes.Text);
Mes.SelectAll;
Mes.SetFocus;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
//media file that will be played when you receive a message
MediaPlayer1.FileName := ExtractFilePath(Application.ExeName)+'\Wav\calling.wav';
if FileExists(MediaPlayer1.FileName) then
MediaPlayer1.Open;
TcpClient1.Active := false;
TcpServer1.Active := false;
TcpServer1.LocalPort := '3344';
TcpClient1.RemotePort := '3344';
TcpServer1.Active := true;
TcpClient1.Active := true;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
TcpClient1.Disconnect;
TcpClient1.Active := false;
TcpServer1.Active := false;
MediaPlayer1.Close;
Shell_NotifyIcon(NIM_DELETE, @TrayIconData2);
end;

procedure TForm1.TcpServer1Accept(Sender: TObject;
ClientSocket: TCustomIpClient);
var
s,s1 : string;
j : integer;
crc : string;
begin
inc(mescount);
if mescount > 1 then
CheckBox1.Checked := true;
sleep(200);
//Message.ico is the file of the icon that will appear when you receive a message
if FileExists(ExtractFilePath(Application.ExeName)+'Message.ico') then Begin
icon1 := TIcon.Create;
icon1.LoadFromFile(ExtractFilePath(Application.ExeName)+'Message.ico');
with TrayIconData2 do
begin
cbSize := SizeOf(TrayIconData2);
Wnd := Handle;
uID := 0;
uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
uCallbackMessage := WM_ICONTRAY2;
hIcon := icon1.Handle;
StrPCopy(szTip, Application.Title);
end;
try
Shell_NotifyIcon(NIM_ADD, @TrayIconData2);
finally
icon1.Free;
end;
end;
s := Decrypt(ClientSocket.Receiveln,edkey);

while s <> '' do begin
sleep(10);
AddColoredLine(Chat,'<<'+TimeToStr(now)+ '>>'+ClientSocket.LookupHostName(ClientSocket.RemoteHost)+'('+ClientSocket.RemoteHost+'):
'+s,clBlue);
s := Decrypt(ClientSocket.Receiveln,edkey);
if mescount < 2 then
if FileExists(MediaPlayer1.FileName) then begin
MediaPlayer1.Open;
Form1.MediaPlayer1.Play;
end;
end;
end;

procedure TForm1.Clear1Click(Sender: TObject);
begin
Chat.Clear;
end;

procedure TForm1.MesKeyPress(Sender: TObject; var Key: Char);
begin
if key = #13 then
Button1.Click;
if key = #27 then
Form1.Hide;
end;

procedure TForm1.HostKeyPress(Sender: TObject; var Key: Char);
begin
if key = #27 then
Form1.Hide;
end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if key = #27 then
Form1.Hide;
end;

procedure TForm1.ChatKeyPress(Sender: TObject; var Key: Char);
begin
if key = #27 then
Form1.Hide;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
Form1.Update;
Form1.UpdateControlState;
Form1.Refresh;
Form1.Repaint;

Mes.SelectAll;
Mes.SetFocus;
Chat.Repaint;
Shell_NotifyIcon(NIM_DELETE, @TrayIconData2);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
Chat.Repaint;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
if CheckBox1.Checked = true then
TcpServer1.Active := false
else
TcpServer1.Active := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
mescount := 0;
if CheckBox1.Checked = true then begin
CheckBox1.Checked := false;
TcpServer1.Active := true;
end;
end;

procedure TForm1.Save1Click(Sender: TObject);
begin
if SaveDialog1.Execute then
Chat.Lines.SaveToFile(SaveDialog1.FileName+'.rtf');
end;

procedure TForm1.FormHide(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @TrayIconData2);
end;

end.

Unit2:
unit Unit2;
interface

function Decrypt(const S: AnsiString; Key: Word): AnsiString;
function Encrypt(const S: AnsiString; Key: Word): AnsiString;

implementation

const
C1 = 52845;
C2 = 22719;

function Decode(const S: AnsiString): AnsiString;
const
Map: array[Char] of Byte = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, 0, 63, 52, 53,
54, 55, 56, 57, 58, 59, 60, 61, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2,
3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
20, 21, 22, 23, 24, 25, 0, 0, 0, 0, 0, 0, 26, 27, 28, 29, 30,
31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
46, 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0);
var
I: LongInt;
begin
case Length(S) of
2:
begin
I := Map[S[1]] + (Map[S[2]] shl 6);
SetLength(Result, 1);
Move(I, Result[1], Length(Result))
end;
3:
begin
I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12);
SetLength(Result, 2);
Move(I, Result[1], Length(Result))
end;
4:
begin
I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12) +
(Map[S[4]] shl 18);
SetLength(Result, 3);
Move(I, Result[1], Length(Result))
end
end
end;

function PreProcess(const S: AnsiString): AnsiString;
var
SS: AnsiString;
begin
SS := S;
Result := '';
while SS <> '' do
begin
Result := Result + Decode(Copy(SS, 1, 4));
Delete(SS, 1, 4)
end
end;

function InternalDecrypt(const S: AnsiString; Key: Word): AnsiString;
var
I: Word;
Seed: Word;
begin
Result := S;
Seed := Key;
for I := 1 to Length(Result) do
begin
Result[I] := Char(Byte(Result[I]) xor (Seed shr 8));
Seed := (Byte(S[I]) + Seed) * Word(C1) + Word(C2)
end
end;

function Decrypt(const S: AnsiString; Key: Word): AnsiString;
begin
Result := InternalDecrypt(PreProcess(S), Key)
end;

function Encode(const S: AnsiString): AnsiString;
const
Map: array[0..63] of Char = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +
'abcdefghijklmnopqrstuvwxyz0123456789+/';
var
I: LongInt;
begin
I := 0;
Move(S[1], I, Length(S));
case Length(S) of
1:
Result := Map[I mod 64] + Map[(I shr 6) mod 64];
2:
Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
Map[(I shr 12) mod 64];
3:
Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
Map[(I shr 12) mod 64] + Map[(I shr 18) mod 64]
end
end;

function PostProcess(const S: AnsiString): AnsiString;
var
SS: AnsiString;
begin
SS := S;
Result := '';
while SS <> '' do
begin
Result := Result + Encode(Copy(SS, 1, 3));
Delete(SS, 1, 3)
end
end;

function InternalEncrypt(const S: AnsiString; Key: Word): AnsiString;
var
I: Word;
Seed: Word;
begin
Result := S;
Seed := Key;
for I := 1 to Length(Result) do
begin
Result[I] := Char(Byte(Result[I]) xor (Seed shr 8));
Seed := (Byte(Result[I]) + Seed) * Word(C1) + Word(C2)
end
end;

function Encrypt(const S: AnsiString; Key: Word): AnsiString;
begin
Result := PostProcess(InternalEncrypt(S, Key))
end;

end.

Sunday, March 11, 2007

post here...

Please post here by using comments

use the Microsoft Speech API

uses Comobj;

procedure TForm1.Button1Click(Sender: TObject);
var
voice: OLEVariant;
begin
voice := CreateOLEObject('SAPI.SpVoice');
voice.Speak('Hello World!', 0);
end;

play two sounds simultaneously

uses
MMSystem;

procedure SendMCICommand(Cmd: string);
var
RetVal: Integer;
ErrMsg: array[0..254] of char;
begin
RetVal := mciSendString(PChar(Cmd), nil, 0, 0);
if RetVal <> 0 then
begin
{get message for returned value}
mciGetErrorString(RetVal, ErrMsg, 255);
MessageDlg(StrPas(ErrMsg), mtError, [mbOK], 0);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
SendMCICommand('open waveaudio shareable');
SendMCICommand('play "C:\xyz\BackgroundMusic.wav"');
SendMCICommand('play "C:\xyz\AnotherMusic.wav"');
SendMCICommand('close waveaudio');
end;

check if a String is a valid IP Address

function IsWrongIP(Ip: string): Boolean;
const
Z = ['0'..'9', '.'];
var
I, J, P: Integer;
W: string;
begin
Result := False;
if (Length(Ip) > 15) or (Ip[1] = '.') then Exit;
I := 1;
J := 0;
P := 0;
W := '';
repeat
if (Ip[I] in Z) and (J <>then
begin
if Ip[I] = '.' then
begin
Inc(P);
J := 0;
try
StrToInt(Ip[I + 1]);
except
Exit;
end;
W := '';
end
else
begin
W := W + Ip[I];
if (StrToInt(W) > 255) or (Length(W) > 3) then Exit;
Inc(J);
end;
end
else
Exit;
Inc(I);
until I > Length(Ip);
if P <>then Exit;
Result := True;
end;

show source code of a HTML document

WebBrowser1.Navigate('view-source:' + ComboBoxEx1.Text);

Thursday, March 8, 2007

animated application icon

var
theicon : boolean;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
theicon := not theicon;
case theicon of
True: Application.icon := Image1.Picture.Icon;
False: Application.icon := Image2.Picture.Icon;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
theicon := True;
Timer1.Enabled := true;
end;

form with rounded corners

procedure TForm1.FormCreate(Sender: TObject);
var
regn: HRGN;
begin
Form1.Borderstyle := bsNone;
regn := CreateRoundRectRgn(0, 0,ClientWidth,ClientHeight,40,40);
SetWindowRgn(Handle, regn, True);
end;

hide the Minimize and the Maximize buttons of a form

procedure TForm1.FormCreate(Sender: TObject);
var
l: DWORD;
begin
l := GetWindowLong(Self.Handle, GWL_STYLE);
l := l and not (WS_MINIMIZEBOX);
l := l and not (WS_MAXIMIZEBOX);
l := SetWindowLong(Self.Handle, GWL_STYLE, l);
end;

disable a MenuItem without greying it

procedure TForm1.Button1Click(Sender: TObject);
var
M: TMenu;
begin
M := Application.MainForm.Menu;
EnableMenuItem(M.Handle, M.Items[0].Command, MF_BYCOMMAND or MF_DISABLED);
end;

prevent form from moveing

private
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
//...

procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
begin
inherited;

with Message do
begin
if Result = HTCAPTION then
Result := HTNOWHERE;
end;
end;

check/uncheck a Checkbox in another window

procedure CheckCheckBox(hApp: HWND; ClassName: string; bValue: Boolean);
var
i: Word;
hCheckBox: HWND;
begin
if not IsWindow(hApp) then Exit;

hCheckBox := FindWindowEx(hApp, hCheckBox, PChar(ClassName), nil);
if IsWindow(hCheckBox) then
SendMessage(hCheckBox, BM_SETCHECK, Integer(bValue), 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
CheckCheckBox(Handle, 'TCheckBox', True, 1);
// Or
// CheckCheckBox(Handle, 'CheckBox', True, 1);
end;

if there are several CheckBoxes you will have to
hCheckBox := FindWindowEx(hApp, hCheckBox, PChar(ClassName), nil)
several times until you get the one you want

move the cursor to the currently focused control

procedure TForm1.Button1Enter(Sender: TObject);
var
cntrl: TControl;
xCent, yCent: Integer;
point: TPoint;
begin
cntrl := TControl(Sender);
xCent := cntrl.Left + (cntrl.Width div 2);
yCent := cntrl.Top + (cntrl.Height div 2);
point := ClientToScreen(Point(xCent, yCent));
SetCursorPos(point.X,point.Y);
end;