nyuuzyou/wikis huggingface dataset:
Как сделать ProgressBar таким же, как на заставке Windows XP

=== Как сделать ProgressBar таким же, как на заставке Windows XP ===
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
 Dialogs, XPMan, ComCtrls, StdCtrls;
type
 TForm1 = class(TForm)
 Button1: TButton;
 ProgressBar1: TProgressBar;
 Button2: TButton;
 procedure Button1Click(Sender: TObject);
 procedure Button2Click(Sender: TObject);
 private
 { Private declarations }
 public
 { Public declarations }
 end;
var
 Form1: TForm1;
const
 PBS_MARQUEE = $08;
 PBM_SETMARQUEE = WM_USER + 10;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
 FSpeed: Integer;
begin
 FSpeed := 100;
 SetWindowLong(ProgressBar1.Handle, GWL_STYLE,
 GetWindowLong(ProgressBar1.Handle, GWL_STYLE) Or PBS_MARQUEE);
 { Включить }
 SendMessage(ProgressBar1.Handle, PBM_SETMARQUEE, 1, FSpeed);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
 { Выключить }
 SendMessage(ProgressBar1.Handle, PBM_SETMARQUEE, 0, 0);
end;
end.
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 00526
----
{ 
 Use this ProgressBar when you do not know the amount of progress toward 
 completion but wish to indicate that progress is being made. 
 This ProgressBar works only on Windows XP and the ComCtl32.dll version 
 6.00 or later is needed. To use the new ComCtrl you have to provide the manifest. 
 In Delphi 7 just drop TXPManifest on the form. For prior versions of Delphi 
 you have to include the XP manifest resource. 
}
unit MarqueeProgressBar;
interface
uses
 SysUtils, Windows, Classes, Controls, ComCtrls, Messages;
type
 TMarqueeProgressBar = class(TProgressBar)
 private
 FActive: Boolean;
 FAnimationSpeed: Integer;
 procedure SetActive(const Value: Boolean);
 procedure SetAnimationSpeed(const Value: Integer);
 procedure UpdateProgressBar;
 protected
 procedure CreateParams(var Params: TCreateParams); override;
 public
 constructor Create(AOwner: TComponent); override;
 published
 property Active: Boolean read FActive write SetActive;
 property AnimationSpeed: Integer read FAnimationSpeed write SetAnimationSpeed;
 end;
const
 PBS_MARQUEE = $08;
 PBM_SETMARQUEE = WM_USER + 10;
procedure Register;
implementation
procedure Register;
begin
 RegisterComponents('SwissDelphiCenter', [TMarqueeProgressBar]);
end;
constructor TMarqueeProgressBar.Create(AOwner: TComponent);
begin
 inherited;
 FAnimationSpeed := 60;
end;
procedure TMarqueeProgressBar.CreateParams(var Params: TCreateParams);
begin
 inherited;
 Params.Style := Params.Style or PBS_MARQUEE;
end;
procedure TMarqueeProgressBar.SetActive(const Value: Boolean);
begin
 FActive := Value;
 UpdateProgressBar;
end;
procedure TMarqueeProgressBar.SetAnimationSpeed(const Value: Integer);
begin
 FAnimationSpeed := Value;
 UpdateProgressBar;
end;
procedure TMarqueeProgressBar.UpdateProgressBar;
begin
 if FActive then
 SendMessage(Self.Handle, PBM_SETMARQUEE, 1, FAnimationSpeed)
 else
 SendMessage(Self.Handle, PBM_SETMARQUEE, 0, 0);
end;
end.
Language: en
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 00959
Как сделать ToolBar как в среде Delphi с возможностью вытаскивания кнопок?

=== Как сделать ToolBar как в среде Delphi с возможностью вытаскивания кнопок? ===
Смотри пример $Delphi\Demos\Docking\
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 00588
Как сделать WebBrowser плоским вместо 3D?

Перевод материала с сайта members.home.com/hfournier/webbrowser.htm
Следующий пример устанавливает borderStyle:
procedure TForm1.WBDocumentComplete(Sender: TObject;
 const pDisp: IDispatch; var URL: OleVariant);
var
 Doc : IHTMLDocument2;
 Element : IHTMLElement;
begin
 Doc := IHTMLDocument2(TWebBrowser(Sender).Document);
 if Doc = nil then Exit;
 Element := Doc.body;
 if Element = nil then Exit;
 case Make_Flat of
 TRUE: Element.style.borderStyle := 'none';
 FALSE: Element.style.borderStyle := ;
 end;
end;
Author: Donovan J. Edye 
Source: http://blackman.km.ru/myfaq/cont4.phtml
ID: 03456
Category:Связь
Category:WebBrowser
Как сделать balloon tooltips?

=== Как сделать balloon tooltips? ===
uses 
 Commctrl; 
procedure ShowBalloonTip(Control: TWinControl; Icon: integer; Title: pchar; Text: PWideChar; 
BackCL, TextCL: TColor); 
const 
 TOOLTIPS_CLASS = 'tooltips_class32'; 
 TTS_ALWAYSTIP = $01; 
 TTS_NOPREFIX = $02; 
 TTS_BALLOON = $40; 
 TTF_SUBCLASS = $0010; 
 TTF_TRANSPARENT = $0100; 
 TTF_CENTERTIP = $0002; 
 TTM_ADDTOOL = $0400 + 50; 
 TTM_SETTITLE = (WM_USER + 32); 
 ICC_WIN95_CLASSES = $000000FF; 
type 
 TOOLINFO = packed record 
 cbSize: Integer; 
 uFlags: Integer; 
 hwnd: THandle; 
 uId: Integer; 
 rect: TRect; 
 hinst: THandle; 
 lpszText: PWideChar; 
 lParam: Integer; 
 end; 
var 
 hWndTip: THandle; 
 ti: TOOLINFO; 
 hWnd: THandle; 
begin 
 hWnd := Control.Handle; 
 hWndTip := CreateWindow(TOOLTIPS_CLASS, nil, 
 WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP, 
 0, 0, 0, 0, hWnd, 0, HInstance, nil); 
 if hWndTip <> 0 then 
 begin 
 SetWindowPos(hWndTip, HWND_TOPMOST, 0, 0, 0, 0, 
 SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE); 
 ti.cbSize := SizeOf(ti); 
 ti.uFlags := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS; 
 ti.hwnd := hWnd; 
 ti.lpszText := Text; 
 Windows.GetClientRect(hWnd, ti.rect); 
 SendMessage(hWndTip, TTM_SETTIPBKCOLOR, BackCL, 0); 
 SendMessage(hWndTip, TTM_SETTIPTEXTCOLOR, TextCL, 0); 
 SendMessage(hWndTip, TTM_ADDTOOL, 1, Integer(@ti)); 
 SendMessage(hWndTip, TTM_SETTITLE, Icon mod 4, Integer(Title)); 
 end; 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
 ShowBalloonTip(Button1, 1, 'Title', 
 'Balloon tooltip, http://kingron.myetang.com; updated by Calin', clBlue, clNavy); 
end;
----
interface
uses Commctrl; 
const 
 TTS_BALLOON = $40; 
 TTM_SETTITLE = (WM_USER + 32); 
var 
 hTooltip: Cardinal; 
 ti: TToolInfo; 
 buffer : array[0..255] of char; 
implementation
procedure CreateToolTips(hWnd: Cardinal); 
begin 
 hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON, 
 Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), 
 Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil); 
 if hToolTip <> 0 then 
 begin 
 SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or 
 SWP_NOSIZE or SWP_NOACTIVATE); 
 ti.cbSize := SizeOf(TToolInfo); 
 ti.uFlags := TTF_SUBCLASS; 
 ti.hInst := hInstance; 
 end; 
end; 
procedure AddToolTip(hwnd: DWORD; lpti: PToolInfo; IconType: Integer; Text, Title: PChar); 
var 
 Item: THandle; 
 Rect: TRect; 
begin 
 Item := hWnd; 
 if (Item <> 0) and (GetClientRect(Item, Rect)) then 
 begin 
 lpti.hwnd := Item; 
 lpti.Rect := Rect; 
 lpti.lpszText := Text; 
 SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti)); 
 FillChar(buffer, SizeOf(buffer), #0); 
 lstrcpy(buffer, Title); 
 if (IconType > 3) or (IconType < 0) then IconType := 0; 
 SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer)); 
 end; 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
 CreateToolTips(Form1.Handle); 
 AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title'); 
end; 
{ 
IconType can be: 
 0 - No icon 
 1 - Information 
 2 - Warning 
 3 - Error 
} 
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 01278
Как сделать colorize?

function Colorize(RGB, Luma: Cardinal);
var
 l, r, g, b: Single;
begin
 Result := Luma;
 if Luma = 0 then { it's all black anyway}
 Exit;
 l := Luma / 255;
 r := RGB and $FF * l;
 g := RGB shr 8 and $FF * l;
 b := RGB shr 16 and $FF * l;
 Result := Round(b) shl 16 or Round(g) shl 8 or Round(r);
end;
Source: http://www.baltsoft.com/
ID: 03864
Category:Графика
Category:Цвета и палитры
Как сделать greyscale dithering?

procedure Greyscale(dib8, dib24: TFastDIB; Colors: Byte);
type
 TDiv3 = array[0..767] of Byte;
 TScale = array[0..255] of Byte;
 TLineErrors = array[-1.. - 1] of DWord;
 PDiv3 = ^TDiv3;
 PScale = ^TScale;
 PLineErrors = ^TLineErrors;
var
 x, y, i, Ln, Nxt: Integer;
 pc: PFColor;
 pb: PByte;
 Lines: array[0..1] of PLineErrors;
 Div3: PDiv3;
 Scale: PScale;
 pti: PDWord;
 dir: ShortInt;
begin
 dib8.FillColors(0, Colors, tfBlack, tfWhite);
 New(Div3);
 pb := Pointer(Div3);
 for i := 0 to 255 do
 begin
 pb^ := i;
 Inc(pb);
 pb^ := i;
 Inc(pb);
 pb^ := i;
 Inc(pb);
 end;
 New(Scale);
 pb := Pointer(Scale);
 x := (Colors shl 16) shr 8;
 y := x;
 for i := 0 to 255 do
 begin
 pb^ := y shr 16;
 Inc(y, x);
 Inc(pb);
 end;
 GetMem(Lines[0], 24 * (dib24.Width + 2));
 GetMem(Lines[1], 24 * (dib24.Width + 2));
 pc := PFColor(dib24.Bits);
 for x := 0 to dib24.Width - 1 do
 begin
 Lines[0, x] := Div3[pc.r + pc.g + pc.b] * 16;
 Inc(pc);
 end;
 pc := Ptr(Integer(pc) + dib24.Gap);
 dir := 1;
 for y := 1 to dib24.Height do
 begin
 Nxt := y mod 2;
 Ln := 1 - Nxt;
 if y < dib24.Height then
 begin
 for x := 0 to dib24.Width - 1 do
 begin
 Lines[Nxt, x] := Div3[pc.r + pc.g + pc.b] * 16;
 Inc(pc);
 end;
 pc := Ptr(Integer(pc) + dib24.Gap);
 end;
 x := 0;
 if dir = -1 then
 x := dib24.Width - 1;
 pti := @Lines[Ln, x];
 pb := @dib8.Pixels8[y - 1, x];
 while ((x > -1) and (x < dib24.Width)) do
 begin
 pti^ := pti^ div 16;
 if pti^ > 255 then
 pti^ := 255
 else if pti^ < 0 then
 pti^ := 0;
 pb^ := Scale[pti^];
 i := pti^ - dib8.Colors[pb^].r;
 if i <> 0 then
 begin
 Inc(Lines[Ln, x + dir], i * 7);
 Inc(Lines[Nxt, x - dir], i * 3);
 Inc(Lines[Nxt, x], i * 5);
 Inc(Lines[Nxt, x + dir], i);
 end;
 Inc(pb, dir);
 Inc(pti, dir);
 Inc(x, dir);
 end;
 Inc(pb, dib8.Gap);
 dir := -dir;
 end;
 Dispose(Lines[0]);
 Dispose(Lines[1]);
 Dispose(Scale);
 Dispose(Div3);
end;
Source: http://www.baltsoft.com/
ID: 03874
Category:Графика
Category:Bitmap
Category:Цвета и палитры
Как сделать mount?

{ The following example shows a Linux-Console application, which mount
 the floppy.
}
program Project1;
{$APPTYPE CONSOLE}
uses
 Libc;
begin
 if mount('/dev/fd0', '/mnt/floppy', 'vfat', MS_RDONLY, nil) = -1 then
 WriteLn('Mount return : ', Errno, '(', strerror(errno), ')')
 else
 WriteLn('Floppy mounted');
end.
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04617
Category:Kylix
Category:Linux
Как сделать pop-up Combobox по позиции курсора в Memo?

=== Как сделать pop-up Combobox по позиции курсора в Memo? ===
unit CBoxInMemo;
interface
uses
 Windows, Classes, Controls, Graphics, Forms, StdCtrls;
type
 TFrmCboxInMemo = class(TForm)
 Button1: TButton;
 Memo1: TMemo;
 Label1: TLabel;
 ComboBox1: TComboBox;
 procedure Button1Click(Sender: TObject);
 procedure ComboBox1Exit(Sender: TObject);
 procedure ComboBox1Click(Sender: TObject);
 private
 { Private declarations }
 public
 { Public declarations }
 end;
var
 FrmCboxInMemo: TFrmCboxInMemo;
implementation
{$R *.DFM}
procedure TFrmCboxInMemo.Button1Click(Sender: TObject);
var
 clientPos: TPoint;
 lineHeight: Integer;
 tmpFont: TFont;
begin
 GetCaretPos(clientPos);
 {Use the following calculation of line height only if you want your combobox
 to appear below the char position you are referencing.}
 tmpFont := Canvas.Font;
 Canvas.Font := Memo1.Font;
 lineHeight := Canvas.TextHeight('Xy');
 Canvas.Font := tmpFont;
 with ComboBox1 do
 begin
 {Adjustment of Top by lineHeight only necessary if combobox is to appear below line.}
 Top := clientPos.Y + Memo1.Top + lineHeight;
 Left := clientPos.X + Memo1.Left;
 Visible := true;
 SetFocus;
 end;
end;
procedure TFrmCboxInMemo.ComboBox1Exit(Sender: TObject);
begin
 ComboBox1.Visible := false;
end;
procedure TFrmCboxInMemo.ComboBox1Click(Sender: TObject);
begin
 ComboBox1.Visible := false;
end;
end.
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 00386
Как сделать procedure/function с переменным количеством параметров?

=== Как сделать procedure/function с переменным количеством параметров? ===
{ .... }
type
 VA_FN = function(const par1, par2{, ...}: Pointer): Boolean;
 cdecl varargs;
{ .... }
//
// varargs without "external" keyword
//
function fn(const par1, par2{, ...}: Pointer): Boolean; cdecl;
var
 last_arg: Pointer absolute par2;
 ptr_args: array[0..MAXLONG shr 2] of Pointer absolute last_arg;
 dw_args: array[0..MAXLONG shr 2] of Cardinal absolute last_arg;
 s_args: array[0..MAXLONG shr 2] of PChar absolute last_arg;
 w_args: array[0..MAXLONG shr 2] of WideString absolute last_arg;
begin
 // ptr_args[1] is first optional argument
 Result := (ptr_args[1] {par3} = Pointer(1)) and
 (dw_args[2] {par4} = 2) and
 (string(ptr_args[3]) = 'CHAR') and
 (w_args[4] = 'WCHAR');
end;
procedure test_fn;
begin
 // VA_FN typecast
 VA_FN(@fn)({par1}nil, {par2}nil, {par3}Pointer(1), {par4}2, {par5}'CHAR',
 {par6}WideString('WCHAR'));
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 00079
Как сделать wipe эффект

unit ClockWipe;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls;
type
 TPkt = array[0..361] of TPoint;
type
 TForm1 = class(TForm)
 Image1: TImage;
 Image2: TImage;
 Button1: TButton;
 procedure FormPaint(Sender: TObject);
 procedure Button1Click(Sender: TObject);
 private
 procedure ClockWipe(re: TRect; Bmp: TBitmap);
 procedure SetPolygonRegion(Pkt: TPkt; PktCount: Integer; Bmp: TBitmap);
 function GetArcPoint(cPoint: TPoint; radius, winkel: Integer): TPoint;
 public
 { Public Declarations }
 end;
var
 Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
 Canvas.Draw(0, 0, Image1.Picture.Bitmap);
 ClockWipe(Image2.Picture.Bitmap.Canvas.ClipRect, Image2.Picture.Bitmap);
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
 Canvas.Draw(0, 0, Image1.Picture.Bitmap);
end;
procedure TForm1.ClockWipe(re: TRect; Bmp: TBitmap);
var
 radius, winkel, cv: Integer;
 cP: TPoint;
 Pkt: TPkt;
begin
 radius := Round(Sqrt(Sqr((re.right - re.left) div 2) + Sqr((re.bottom - re.top) div 2)));
 cP := Point((re.right - re.left) div 2, (re.bottom - re.top) div 2);
 Pkt[0] := cP;
 for winkel := 0 to 360 do
 Pkt[winkel + 1] := GetArcPoint(cP, radius, winkel + 90);
 for cv := 0 to 361 do
 if (cv - 1) / 20 = (cv - 1) div 20 then
 begin
 Sleep(50);
 SetPolygonRegion(Pkt, cv + 1, Image2.Picture.Bitmap);
 end;
end;
procedure TForm1.SetPolygonRegion(Pkt: TPkt; PktCount: Integer; Bmp: TBitmap);
var
 Region: HRGN;
begin
 Region := CreatePolygonRGN(Pkt, PktCount, WINDING);
 if Region <> 0 then
 begin
 SelectClipRgn(Canvas.handle, Region);
 Canvas.Draw(0, 0, Bmp);
 SelectClipRgn(Canvas.handle, 0);
 DeleteObject(Region);
 end;
end;
function TForm1.GetArcPoint(cPoint: TPoint; radius, winkel: Integer): TPoint;
begin
 Result.x := Round(cPoint.x + radius * Cos(winkel * 2 * pi / 360));
 Result.y := Round(cPoint.y - radius * Sin(winkel * 2 * pi / 360));
end;
end.
Source: http://www.baltsoft.com/
ID: 03892
Category:Графика
Category:Bitmap
Как сделать анимацию минимизации формы?

=== Как сделать анимацию минимизации формы? ===
In FormShow:
var
 RecS, RecL: TRect;
begin
 RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);
 RecL := ThisForm.BoundsRect;
 DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecS, RecL);
 { ... }
end;
In FormHide:
var
 RecS, RecL: TRect;
begin
 HideTimer.Enabled := False;
 RecS := Rect(Screen.Width, Screen.Height, Screen.Width, Screen.Height);
 RecL := ThisForm.BoundsRect;
 DrawAnimatedRects(GetDesktopWindow, IDANI_CAPTION, RecL, RecS);
end;
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 00416
Как сделать анимацию немерцающей

Мерцание возникает, когда цвет точки меняется два раза подряд. Например, правильнее объект при его перемещении стирать и затем рисовать на новом месте не на экране, а в памяти, и выводить на форму уже готовое изображение поверх предыдущего. В таком случае смена цветов на экране происходит только один раз.
var
 bm: TBitMap;
procedure TForm1.FormCreate(Sender: TObject);
begin
 bm := TBitMap.Create;
 bm.Width := Form1.ClientWidth;
 bm.Height := Form1.ClientHeight;
 with bm.Canvas do
 begin
 Font.name := 'Arial';
 Font.Size := 50;
 Font.Color := clBlue;
 end;
 Timer1.Interval := 100;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
 s: string;
 Hour, Min, Sec, MSec: Word;
begin
 DecodeTime(Time, Hour, Min, Sec, MSec);
 with bm.Canvas do
 begin
 Brush.Style := bsSolid;
 Brush.Color := clWhite;
 FillRect(ClipRect);
 s := TimeToStr(Time);
 TextOut((bm.Width - TextWidth(s)) div 2,
 (bm.Height - TextHeight(s)) div 2, s);
 Pen.Mode := pmMask;
 Pen.Width := 20;
 Pen.Color := clLime;
 Brush.Style := bsClear;
 Rectangle(bm.Width div 2 - (MSec * bm.Width) div 5000,
 bm.Height div 2 - (MSec * bm.Height) div 5000,
 bm.Width div 2 + (MSec * bm.Width) div 5000,
 bm.Height div 2 + (MSec * bm.Height) div 5000);
 end;
 Form1.Canvas.Draw(0, 0, bm);
end;
Source: http://delphiworld.narod.ru
ID: 03807
Category:Графика
Как сделать виртуальный диск?

=== Как сделать виртуальный диск? ===
{ ... }
if DefineDosDevice(DDD_RAW_TARGET_PATH, 'P:', 'F:\Backup\Music\Modules') then
 ShowMessage('Drive was created successfully')
else
 ShowMessage('Error creating drive');
 { ... }
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 01378
Как сделать графический hint?

=== Как сделать графический hint? ===
{********************************************************* 
 With the following Code you can simply create custom hints. 
 You just have to change the procedur "Paint". 
 *********************************************************} 
type 
 TGraphicHintWindow = class(THintWindow) 
 constructor Create(AOwner: TComponent); override; 
 private 
 FActivating: Boolean; 
 public 
 procedure ActivateHint(Rect: TRect; const AHint: string); override; 
 protected 
 procedure Paint; override; 
 published 
 property Caption; 
 end; 
implementation
constructor TGraphicHintWindow.Create(AOwner: TComponent); 
begin 
 inherited Create(AOwner); 
 { 
 Here you can set custom Font Properties: 
 } 
 with Canvas.Font do 
 begin 
 Name := 'Arial'; 
 Style := Style + [fsBold]; 
 Color := clBlack; 
 end; 
end; 
procedure TGraphicHintWindow.Paint; 
var 
 R: TRect; 
 bmp: TBitmap; 
begin 
 R := ClientRect; 
 Inc(R.Left, 2); 
 Inc(R.Top, 2); 
 {******************************************************* 
 The folowing Code ist an example how to create a custom 
 Hint Object. : 
 } 
 bmp := TBitmap.Create; 
 bmp.LoadfromFile('D:\hint.bmp'); 
 with Canvas do 
 begin 
 Brush.Style := bsSolid; 
 Brush.Color := clsilver; 
 Pen.Color := clgray; 
 Rectangle(0, 0, 18, R.Bottom + 1); 
 Draw(2,(R.Bottom div 2) - (bmp.Height div 2), bmp); 
 end; 
 bmp.Free; 
 // Beliebige HintFarbe 
 // custom Hint Color 
 Color := clWhite; 
 Canvas.Brush.Style := bsClear; 
 Canvas.TextOut(20, (R.Bottom div 2) - (Canvas.Textheight(Caption) div 2), Caption); 
 {********************************************************} 
end; 
procedure TGraphicHintWindow.ActivateHint(Rect: TRect; const AHint: string); 
begin 
 FActivating := True; 
 try 
 Caption := AHint; 
 // Hцhe des Hints setzen setzen 
 // Set the "Height" Property of the Hint 
 Inc(Rect.Bottom, 14); 
 // Breite des Hints setzen 
 // Set the "Width" Property of the Hint 
 Rect.Right := Rect.Right + 20; 
 UpdateBoundsRect(Rect); 
 if Rect.Top + Height > Screen.DesktopHeight then 
 Rect.Top := Screen.DesktopHeight - Height; 
 if Rect.Left + Width > Screen.DesktopWidth then 
 Rect.Left := Screen.DesktopWidth - Width; 
 if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft; 
 if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop; 
 SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height, 
 SWP_SHOWWINDOW or SWP_NOACTIVATE); 
 Invalidate; 
 finally 
 FActivating := False; 
 end; 
end; 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
 HintWindowClass := TGraphicHintWindow; 
 Application.ShowHint := False; 
 Application.ShowHint := True; 
end; 
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 01276
Как сделать дырку в окне?

=== Как сделать дырку в окне? ===
procedure TForm1.Button4Click(Sender: TObject);
var
 HRegion1, Hreg2, Hreg3: THandle;
 Col: TColor;
begin
 ShowMessage ('Ready for a real crash?');
 Col := Color;
 Color := clRed;
 PlaySound ('boom.wav', 0, snd_sync);
 HRegion1 := CreatePolygonRgn(Pts, SizeOf(Pts) div 8, alternate);
 SetWindowRgn (Handle, HRegion1, True);
 ShowMessage ('Now, what have you done?');
 Color := Col;
 ShowMessage ('Вам лучше купить новый монитор');
end;
Source: Взято из http://forum.sources.ru
ID: 00467
Как сделать картинки в TImageList прозрачными

=== Как сделать картинки в TImageList прозрачными ===
procedure TForm1.Button1Click(Sender: TObject);
var
 bm: TBitmap;
 il: TImageList;
begin
 bm := TBitmap.Create;
 bm.LoadFromFile('C:\DownLoad\TEST.BMP');
 il := TImageList.CreateSize(bm.Width, bm.Height);
 il.DrawingStyle := dsTransparent;
 il.Masked := true;
 il.AddMasked(bm, clRed);
 il.Draw(Form1.Canvas, 0, 0, 0);
 bm.Free;
 il.Free;
end;
Source: http://delphiworld.narod.ru/
ID: 01259
Как сделать картинки из TImageList прозрачными?

=== Как сделать картинки из TImageList прозрачными? ===
procedure TForm1.Button1Click(Sender: TObject);
var
 bm: TBitmap;
 il: TImageList;
begin
 bm := TBitmap.Create;
 bm.LoadFromFile('C:\DownLoad\TEST.BMP');
 il := TImageList.CreateSize(bm.Width, bm.Height);
 il.DrawingStyle := dsTransparent;
 il.Masked := true;
 il.AddMasked(bm, clRed);
 il.Draw(Form1.Canvas, 0, 0, 0);
 bm.Free;
 il.Free;
end;
ID: 00658
Как сделать клавишу-акселератор (keyboard shortcut) компонету, у которого нет заголовка

=== Как сделать клавишу-акселератор (keyboard shortcut) компоненту, у которого нет заголовка ===
Возможный вариант - присвоить ссылку на этот компонент свойству FocusControl TLabel'а. В примере используется невидимый Label для создания "быстрой" клавиши (Alt+M) компонента Memo. Чтобы использовать пример, разместите на форме компонент TMemo, Label и несколько других компонентов, которые могут принимать фокус ввода. Запустите программу, переведите фокус ввода куда-нибудь вне Memo и нажмите Alt+M - фокус ввода вернется в Memo. 
procedure TForm1.FormCreate(Sender: TObject);
begin 
 Label1.Visible := False;
 Label1.Caption := '&M';
 Label1.FocusControl := Memo1;
end;
Source: http://delphiworld.narod.ru/
ID: 01558
Как сделать меню как в Дельфи?

=== Как сделать меню как в Дельфи? ===
# Разместите на форме TControlBar. (закладка Additional) Установите Align = Client. 
# Разместите TToolBar (закладка Win32) внутри TControlBar.
# Установите в True свойства Flat и ShowCaptions этого TToolBar.
# Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar правой кнопкой и выбрав NewButton)
# Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать при перемещении курсора между главными пунктами меню (если меню уже показано).
# Разместите на форме TMainMenu и убедитесь, что оно НЕ присоединено как меню главной формы. (посмотрите свойство Menu формы).
# Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer)
# Для каждой TToolButton установите ее MenuItem равным соответствующему пункту TMainMenu.
 DELPHI VCL FAQ Перевод с английского
 Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
 специально для Королевства Дельфи
Source: Взято из 
ID: 01303
Как сделать окно системно-модальным?

=== Как сделать окно системно-модальным? ===
Используйте функцию Windows API SetSysModalWindow(). Код ниже демонстрирует технологию работы с этой функцией. В любой момент времени может быть возможен только один модально-системный диалог, чей дескриптор возвращается функцией SetSysModalWindow(). Вам необходимо запомнить возвращаемую функцией величину для того, чтобы завершить показ диалога таким образом. Вот как примерно это должно выглядеть: 
procedure TForm1.Button1Click(Sender: TObject);
var
 x: word ;
begin
 x := SetSysModalWindow(AboutBox.Handle) ;
 AboutBox.ShowModal;
 SetSysModalWindow(x) ;
end;
Source: Взято с http://delphiworld.narod.ru
ID: 00437
Как сделать окошко подсказки в редакторе как Delphi по CTRL-J

=== Как сделать окошко подсказки в редакторе как Delphi по CTRL-J ===
Допустим у тебя TMemo.. 
# Делаешь ListBox, заполняешь, visible := false, parent := Memo
# У Memo в обработчике Memo.onKeyDown что-нибудь типа: 
if (key = Ord('J')) and (ssCtrl in Shift) then
begin
 lb.Left := Memo.CaretPos.x;
 lb.Top := Memo.CaretPos.y + lb.height;
 lb.Visible := True;
 lb.SetFocus;
end;
он показывается.. а дальше работай с листбоксом, вставляй в мемо нужный текст, пряч листбокс 
Source: http://delphiworld.narod.ru/
ID: 00995