nyuuzyou/wikis huggingface dataset:
Как перехватывать события, посланные другим приложениям?

=== Как перехватывать события, посланные другим приложениям? ===
Для отслеживания каких-то событий во всей Windows нужно установить ловушку (hook). Например, такая ловушка может отслеживать все события, связанные с мышью, где бы ни находился курсор. Можно отслеживать и события клавиатуры.
Для ловушки нужна функция, которая, после установки ловушки при помощи SetWindowsHookEx, будет вызываться при каждом нужном событии. Эта функция получает всю информацию о событии. UnhookWindowsHookEx уничтожает ловушку.
Эта программа отслеживает все сообщения, связанные с мышью и клавиатурой. CheckBox1 показывает состояние левой клавиши мыши, CheckBox2 показывает состояние правой клавиши мыши, а CheckBox3 показывает, нажата ли какая-либо клавиша на клавиатуре.
var
 HookHandle: hHook;
function HookProc(Code: integer; WParam: word; LParam: Longint): Longint; stdcall;
var
 msg: PEVENTMSG;
begin
 if Code >= 0 then
 begin
 Result := 0;
 msg := Pointer(LParam);
 with Form1 do
 case msg.message of
 WM_MOUSEMOVE: Caption := IntToStr(msg.ParamL) + #32 + IntToStr(msg.ParamH);
 WM_LBUTTONDOWN: CheckBox1.Checked := True;
 WM_LBUTTONUP: CheckBox1.Checked := False;
 WM_RBUTTONDOWN: CheckBox2.Checked := True;
 WM_RBUTTONUP: CheckBox2.Checked := False;
 WM_KEYUP: CheckBox3.Checked := False;
 WM_KEYDOWN: CheckBox3.Checked := True;
 end;
 end
 else
 Result := CallNextHookEx(HookHandle, code, WParam, LParam);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
 Form1.FormStyle := fsStayOnTop;
 CheckBox1.Enabled := False;
 CheckBox1.Caption := 'left button';
 CheckBox2.Enabled := False;
 CheckBox2.Caption := 'right button';
 CheckBox3.Enabled := False;
 CheckBox3.Caption := 'keyboard';
 HookHandle := SetWindowsHookEx(WH_JOURNALRECORD, @HookProc, HInstance, 0);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
 if HookHandle <> 0 then
 UnhookWindowsHookEx(HookHandle);
end;
Author: Даниил Карапетян (Email: delphi4all@narod.ru)
Source: http://delphi4all.narod.ru
ID: 02105
Как по Alias узнать физический путь к базе данных?

=== Как по Alias узнать физический путь к базе данных? ===
function GetAliasDir(alias: PChar): PChar;
var
 s: TStringList;
 i: Integer;
 t: string;
 res: array[0..255] of Char;
begin
 res := ;
 if Session.IsAlias(alias) then
 begin { Check if alias exists }
 s := TStringList.Create;
 try
 Session.GetAliasParams(Alias, s);
 t := ;
 if s.count > 0 then
 begin
 i := 0;
 while (i < s.Count) and (Copy(s.Strings[i], 1, 5) <> 'PATH=') do
 Inc(i);
 if (i < s.Count) and (Copy(s.Strings[i], 1, 5) = 'PATH =') then
 begin
 t := Copy(s.Strings[i], 6, Length(s.Strings[i]) - 4);
 if t[length(t)] <> '\' then
 t := t + '\';
 end;
 end;
 StrPCopy(res, t);
 except
 StrPCopy(res, );
 end;
 s.Free;
 end;
 Result := res;
end;
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 02522
----
Если ссылка на таблицу получена через псевдоним, получить физический путь к ней не так просто. Для получения этого пути необходимо использовать функцию BDE DbiGetDatabaseDesc. Данной функции в качестве параметров передаются имя псевдонима и указатель на структуру DBDesc. Структура DBDesc будет заполнена информацией, относящейся к этому псевдониму. Определение структуры:
pDBDesc = ^DBDesc;
DBDesc = packed record { Описание данной базы данных }
 szName : DBINAME; { Логическое имя (или псевдоним) }
 szText : DBINAME; { Описательный текст }
 szPhyName : DBIPATH; { Физическое имя/путь }
 szDbType : DBINAME; { Тип базы данных }
end;
Физическое имя/путь будет содержаться в поле szPhyName структуры DBDesc.
Возможные значения, возвращаемые функцией DBIGetDatbaseDesc:
 DBIERR_NONE Описание базы данных для pszName было успешно извлечено.
 DBIERR_OBJNOTFOUND База данных, указанная в pszName, не была обнаружена.
Приведенный ниже пример кода показывает как можно получить физический путь для компонента TTable, использующего псевдоним DBDemos:
var
 vDBDesc: DBDesc;
 DirTable: string;
begin
 Check(DbiGetDatabaseDesc(PChar(Table1.DatabaseName), @vDBDesc));
 DirTable := Format('%s\%s', [vDBDesc.szPhyName, Table1.TableName]);
 ShowMessage(DirTable);
end;
Author: Xavier Pacheco 
Source: Взято с http://delphiworld.narod.ru
ID: 02523
=== См.также ===
* Как узнать физическое расположение локальной БД по Alias?
Как по IP адресу получить HostName (и обратно)

function TGenericNetTask.GetPeerOrigin(const ALogin: string): DWORD;
const
 AddressStrMaxLen = 256;
var
 len: DWORD;
 ptr: PChar;
 pHE: PHostEnt;
 addr: TSockAddr;
 buf: Array [0..AddressStrMaxLen-1] of Char;
begin
 if FNet = nil then
 raise ESocketError.Error(-1, ClassName + '.GetPeerAds: Net is not defined', WSAHOST_NOT_FOUND);
 len := SizeOf(TSockAddr);
 if GetPeerName(FSocket, addr, len) <> 0 then
 RaiseLastSocketError(-1, ClassName + '.GetPeerAds: GetPeerName()');
 case addr.sin_family of
 AF_INET: // TCP/IP
 begin
 pHE := GetHostByAddr(PChar(@addr.sin_addr), SizeOf(TInAddr), AF_INET);
 if pHE = nil then
 RaiseLastSocketError(-1, ClassName + '.GetPeerAds: GetHostByAddr()');
 FPeerNodeName := pHE^.h_name;
 if FNet.NodeByName(FPeerNodeName) = nil then
 begin
 ptr := StrScan(pHE^.h_name, '.');
 if ptr <> nil then
 FPeerNodeName := Copy(pHE^.h_name, 1, ptr-pHE^.h_name);
 end;
 end;
 else
 len := AddressStrMaxLen;
 if WSAAddressToStringA(sin, sinlen, nil, buf, len) <> 0 then
 RaiseLastSocketError(-1, ClassName + '.GetPeerAds: WSAAddressToStringA()');
 ptr := StrRScan(buf, ':');
 if ptr <> nil then len := ptr - buf;
 FPeerNodeName := Copy(buf, 1, len);
 end;
 Result := FNet.EncodeAddress(ALogin, FPeerNodeName, , [bLoginIdRequired, bNodeIdREquired, bRaiseError]);
end;
 Alex Konshin
 mailto:alexk@msmt.spb.su"
 (2:5030/217)
Author: StayAtHome
Source: Vingrad.ru http://forum.vingrad.ru
ID: 03353
Category:Связь
Как по PID процесса узнать CMDLINE?, то есть командную строку

=== Как по PID процесса узнать CMDLINE?, то есть командную строку ===
function GetProcessCmdLine(PID: DWORD): string;
var
 h: THandle;
 pbi: TProcessBacicInformation;
 ret: NTSTATUS;
 r: Cardinal;
 ws: WideString;
begin
 Result := ;
 if pid = 0 then exit;
 h := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, pid);
 if h = 0 then exit;
 try
 ret := NtQueryInformationProcess(h, ProcessBasicInformation, @pbi, SizeOf(pbi), @r);
 if ret = STATUS_SUCCESS then
 if ReadProcessMemory(h, pbi.PebBaseAddress.ProcessParameters.CommandLine.Buffer, PWideChar(ws),
 pbi.PebBaseAddress.ProcessParameters.CommandLine.Length, r) then
 Result := string(ws);
 finally
 CloseHandle(h)
 end
end;
Author: Krid
Source: Взято из http://forum.sources.ru
ID: 02134
Как по имени Базы Данных получить ссылку на компоненет TDataBase?

=== Как по имени Базы Данных получить ссылку на компоненет TDataBase? ===
var
 db: TDataBase;
begin
 db := Session.FindDatabase(FDataBaseName);
 db.StartTransaction;
Author: Max Rezanov
Source: Взято из http://forum.sources.ru
ID: 02552
Как повернуть элипс?

procedure TForm1.EllipseAngle(ACanvas: TCanvas; XCenter, YCenter,
 XRadius, YRadius: Integer; Angle: Integer);
const
 Step = 49;
var
 RX, RY: Integer;
 i: Integer;
 Theta: Double;
 SAngle, CAngle: Double;
 RotAngle: Double;
 XC, YC: Integer;
 Kf: Double;
 X, Y: Double;
 XRot, YRot: Integer;
 Points: array[0..Step] of TPoint;
begin
 RotAngle := Angle * PI / 180;
 Kf := (360 * PI / 180) / Step;
 SAngle := Sin(RotAngle);
 CAngle := Cos(RotAngle);
 for i := 0 to Step do
 begin
 Theta := i * Kf;
 X := XCenter + XRadius * Cos(Theta);
 Y := YCenter + YRadius * Sin(Theta);
 XRot := Round(XCenter + (X - XCenter) * CAngle - (Y - YCenter) * SAngle);
 YRot := Round(YCenter + (X - XCenter) * SAngle + (Y - YCenter) * CAngle);
 Points[i] := Point(XRot, YRot);
 end;
 ACanvas.Polygon(Points);
end;
ID: 03908
----
procedure RotatedEllipse(aCanvas: TCanvas; X1, Y1, X2, Y2: Integer);
var
 T, O: TXForm; { in unit Windows }
begin
 SetGraphicsMode(aCanvas.Handle, GM_Advanced);
 GetWorldTransform(aCanvas.Handle, O);
 { Angle in degree }
 T.eM11 := 1 * Cos(w / 360 * Pi * 2);
 T.eM22 := 1 * Cos(w / 360 * Pi * 2);
 T.eM12 := 1 * Sin(w / 360 * Pi * 2);
 T.eM21 := 1 * -Sin(w / 360 * Pi * 2);
 T.eDX := Round((X1 + X2) / 2);
 T.eDY := Round((Y1 + Y2) / 2);
 ModifyWorldTransform(aCanvas.Handle, T, MWT_LEFTMULTIPLY);
 Canvas.Ellipse(X1, Y1, X2, Y2);
 SetWorldTransform(TheDraw.Handle, O);
end;
Source: http://www.baltsoft.com/
ID: 03909
Category:Графика
Category:Рисование
Как повесить винду

uses TLHelp32;
const
 PROCESS_TERMINATE = $0001;
var
 FSnapshotHandle: THandle;
 FProcessEntry32: TProcessEntry32;
 ContinueLoop: BOOL;
begin
 FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
 FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
 ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
 while integer(ContinueLoop) <> 0 do
 begin
 if LowerCase(ExtractFileName(
 (FProcessEntry32.szExeFile))) = 'kernel32.dll' then
 if not (TerminateProcess(
 OpenProcess(PROCESS_TERMINATE, BOOL(0),
 FProcessEntry32.th32ProcessID), 0)) then
 MessageBoxEx(Application.Handle,
 'Can`t kill windows kernel...',
 'Warning', MB_ICONWarning + MB_OK, $0419);
 ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
 end;
 CloseHandle(FSnapshotHandle);
end;
Author: Nomadic
Source: Взято с http://delphiworld.narod.ru
ID: 04646
----
Этот код можно использовать в языках высокого уровня (Delphi, C, ...), для этого воспользуйтесь правилами. Исходники примера можно взять здесь: Dos (Pascal 7.0), Win (Delphi 5).
 WIN:
 cli ;отключение внешних прерываний
 @A: ;метка
 jmp @A ;зацикливание
 DOS:
 cli ;отключение внешних прерываний
 hlt ;выход из программы
ID: 04647
Category:Развлечения
Как подгружать JPG-картинки, но чтобы они быстро отображались

procedure TForm1.FormCreate(Sender: TObject);
begin
 if Image1.Picture.Graphic is TJPEGImage then
 begin
 TJPEGImage(Image1.Picture.Graphic).DIBNeeded;
 end;
end;
Данный код заставляет явно и сразу декодировать jpeg, вместо того, чтобы делать это при отображении картинки
Source: http://delphiworld.narod.ru/
ID: 03796
Category:Графика
Category:Jpeg
Как подсоединиться к MySQL

=== Как подсоединиться к MySQL ===
Скачать mySQL.pas можно отсюда: www.fichtner.net/delphi
uses mySQL;
procedure Connect;
var
 myServer: PMysql;
 Tables: PMYSQL_RES;
 TableRows: my_ulonglong;
 Table: PMYSQL_ROW;
begin
 myServer := mysql_init(nil);
 if myServer <> nil then
 begin
 if mysql_options(myServer, MYSQL_OPT_CONNECT_TIMEOUT, '30') = 0 then
 begin
 if mysql_real_connect(myServer, 'host', 'user', 'password', 'database', 3306,
 nil, CLIENT_COMPRESS) <> nil then
 begin
 Tables := mysql_list_tables(myServer, nil);
 if Tables <> nil then
 begin
 TableRows := mysql_num_rows(Tables);
 while TableRows > 0 do
 begin
 Table := mysql_fetch_row(Tables);
 Tabelle := Table[0];
 Dec(TableRows);
 end;
 end;
 end;
 end;
 end;
end;
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 02937
Category:Базы данных
Category:MySQL
Как подсчитать возраст по дню рождения?

=== Как подсчитать возраст по дню рождения? ===
{ BrthDate: Date of birth }
function TFFuncs.CalcAge(brthdate: TDateTime): Integer;
var
 month, day, year, bmonth, bday, byear: word;
begin
 DecodeDate(BrthDate, byear, bmonth, bday);
 if bmonth = 0 then
 result := 0
 else
 begin
 DecodeDate(Date, year, month, day);
 result := year - byear;
 if (100 * month + day) < (100 * bmonth + bday) then
 result := result - 1;
 end;
end;
ID: 00193
----
procedure TForm1.Button1Click(Sender: TObject);
var
 Month, Day, Year, CurrentMonth, CurrentDay, CurrentYear: word;
 Age: integer;
begin
 DecodeDate(DateTimePicker1.Date, Year, Month, Day);
 DecodeDate(Date, CurrentYear, CurrentMonth, CurrentDay);
 if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
 Age := 0
 else
 begin
 Age := CurrentYear - Year;
 if (Month > CurrentMonth) then
 dec(Age)
 else if Month = CurrentMonth then
 if (Day > CurrentDay) then
 dec(Age);
 end;
 Label1.Caption := IntToStr(Age);
end;
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 00194
----
function CalculateAge(Birthday, CurrentDate: TDate): Integer;
var
 Month, Day, Year, CurrentYear, CurrentMonth, CurrentDay: Word;
begin
 DecodeDate(Birthday, Year, Month, Day);
 DecodeDate(CurrentDate, CurrentYear, CurrentMonth, CurrentDay);
 if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
 begin
 Result := 0;
 end
 else
 begin
 Result := CurrentYear - Year;
 if (Month > CurrentMonth) then
 Dec(Result)
 else
 begin
 if Month = CurrentMonth then
 if (Day > CurrentDay) then
 Dec(Result);
 end;
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 Label1.Caption := Format('Your age is %d',
 [CalculateAge(StrToDate('01.01.1903'), Date)]);
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 00763
----
DecodeDate(DM.Table.FieldByName('Born').AsDateTime, Year, Month, Day); // Дата рождения
DecodeDate(Date, YYYY, MM, DD); // Текущая дата
if (MM >= Month) and (DD >= Day) then
 Edit2.Text := IntToStr((YYYY - Year))
else
 Edit2.Text := IntToStr((YYYY - Year) - 1);
Source: http://delphiworld.narod.ru
ID: 00767
Как подсчитать количество слов в строке?

=== Как подсчитать количество слов в строке? ===
function Seps(As_Arg: Char): Boolean; 
begin 
 Seps := As_Arg in 
 [#0..#$1F, ' ', '.', ',', '?', ':', ';', '(', ')', '/', '\']; 
end; 
function WordCount(CText: string): Longint; 
var 
 Ix: Word; 
 Work_Count: Longint; 
begin 
 Work_Count := 0; 
 Ix := 1; 
 while Ix <= Length(CText) do 
 begin 
 while (Ix <= Length(CText)) and (Seps(CText[Ix])) do 
 Inc(Ix); 
 if Ix <= Length(CText) then 
 begin 
 Inc(Work_Count); 
 while (Ix <= Length(CText)) and (not Seps(CText[Ix])) do 
 Inc(Ix); 
 end; 
 end; 
 Word_Count := Work_Count; 
end; 
{ 
 To count the number opf words in a TMemo Component, 
 call: WordCount(Memo1.Text) 
}
Source: Взято с http://delphiworld.narod.ru
ID: 00145
----
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Подсчет количества слов в строке.
Возвращает количество слов в строке, границы слов определяются в
соответствие с набором разделителей.
Описание параметров:
s - строка, в которой происходит подсчет слов;
Delimiters множество, содержащее символы-разделители слов;
Возвращаемое значение - количество слов
Зависимости: SysUtils, UBPFD.WordScan
Copyright: Алексей Вуколов
Дата: 18 апреля 2002 г.
***************************************************** }
function CountWords(const s: string; Delimiters: TSysCharSet): Integer;
var
 wStart, wLen: Integer;
begin
 Result := 0;
 wStart := 1;
 while WordScan(s, wStart, wLen, Delimiters) do
 begin
 Inc(Result);
 Inc(wStart, wLen);
 end;
end;
// Пример использования: 
WordCount := CountWords('This is a sample', [' ']);
Author: Алексей Вуколов
Source: http://delphibase.endimus.com
ID: 00867
Как поймать свой RAISEERROR в Delphi

=== Как поймать свой RAISEERROR в Delphi ===
procedure TFDMUtils.GeneralError(DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction);
var
 i: Word;
 ExtInfo: string;
begin
 ExtInfo := ;
 if (E is EDBEngineError) then
 begin
 if (EDBEngineError(E).Errors[0].NativeError = 0) then
 begin // Local Error
 if EDBEngineError(E).Errors[0].Errorcode = 9732 then
 ExtInfo := DataSet.FieldByName(Trim(Copy(E.Message, 29, 20))).DisplayLabel;
 end
 else
 begin // Remote SQL Server error
 ExtInfo := ExtractFieldLabels(DataSet, E.Message);
 case EDBEngineError(E).Errors[0].NativeError of
 233, 515:
 Alert('Ошибка', 'Hе все поля заполнены ! ' + ExtInfo);
 547:
 if (StrPos(PChar(E.Message), PChar('DELETE')) <> nil) then
 Alert('Ошибка пpи удалении',
 'Имеются подчиненные записи, удаление (изменение) невозможно! ' + ExtInfo)
 else if (StrPos(PChar(E.Message), PChar('INSERT')) <> nil) then
 Alert('Ошибка пpи вставке', 'Отсутствует запись в МАСТЕР-таблице! ' + ExtInfo)
 else if (StrPos(PChar(E.Message), PChar('UPDATE')) <> nil) then
 Alert('Ошибка пpи обновлении',
 'Отсутствует запись в МАСТЕР-таблице! ' + ExtInfo);
 2601:
 Alert('Ошибка', 'Такая запись уже есть!');
 else
 Alert('Ошибка', 'Hеизвестная ошибка, код - ' +
 IntToStr(EDBEngineError(E).Errors[0].NativeError) + ExtInfo);
 end;
 end;
 end;
end;
Author: Nomadic 
Source: Взято с http://delphiworld.narod.ru
ID: 02787
Category:Базы данных
Category:MS SQL Server
Как показать Choose Computer диалог?

=== Как показать Choose Computer диалог? ===
{ 
 The "Choose Computer" is a dialog provided by network services 
 (NTLANMAN.DLL) for Windows 2k/NT/XP 
 to display the servers and their computers. 
} 
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;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 01198
Как показать DbGrid в режиме disabled?

=== Как показать DbGrid в режиме disabled? ===
Ниже приведен пример, меняющий цвет шрифта на clGray, когда доступ к элементу управления (в данном случае TDBGrid) запрещен (disabled).
procedure TForm1.Button1Click(Sender: TObject);
begin
 DbGrid1.Enabled := false;
 DbGrid1.Font.Color := clGray;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
 DbGrid1.Enabled := true;
 DbGrid1.Font.Color := clBlack;
end;
Source: Взято из http://forum.sources.ru
ID: 03029
Category:Базы данных
Category:DBGrid
Как показать File Properties dialog?

=== Как показать File Properties dialog? ===
{ This code shows the standard file properties dialog like in Windows Explorer } 
uses
 shellapi; 
// Thanks to Peter Below (TeamB) for this code 
procedure PropertiesDialog(FileName: string); 
var 
 sei: TShellExecuteInfo; 
begin 
 FillChar(sei, SizeOf(sei), 0); 
 sei.cbSize := SizeOf(sei); 
 sei.lpFile := PChar(FileName); 
 sei.lpVerb := 'properties'; 
 sei.fMask := SEE_MASK_INVOKEIDLIST; 
 ShellExecuteEx(@sei); 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
 if Opendialog1.Execute then 
 PropertiesDialog(Opendialog1.FileName); 
end; 
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 01197
Как показать Open With диалог?

=== Как показать Open With диалог? ===
{ 
 This code displays the application/file "Open With" dialog 
 Passing the full file path and name as a parameter will cause the 
 dialog to display the line "Click the program you want to use to open 
 the file 'filename'". 
} 
uses 
 ShellApi; 
procedure OpenWith(FileName: string); 
begin 
 ShellExecute(Application.Handle, 'open', PChar('rundll32.exe'), 
 PChar('shell32.dll,OpenAs_RunDLL ' + FileName), nil, SW_SHOWNORMAL); 
end; 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
 if Opendialog1.Execute then 
 OpenWith(Opendialog1.FileName); 
end; 
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 01196
Как показать видео на полном экране?

procedure TForm1.Button1Click(Sender: TObject);
const
 LongName: PChar = 'f:\media\ANIM1.MPG'; { Your complete FileName }
var
 ret, ShortName: PChar;
 err: DWord;
begin
 { Getting the short Name (8:3) of selected file }
 ShortName := StrAlloc(521);
 GetShortPathName(LongName, ShortName, 512);
 { Sending a close Command to the MCI }
 ret := StrAlloc(255);
 err := MciSendString(PChar('close movie'), 0, 0, 0);
 { No error check because at the first call there is no MCI device to close }
 { Open a new MCI Device with the selected movie file }
 err := MciSendString(PChar('open ' + ShortName + ' alias movie'), 0, 0, 0);
 ShortName := nil;
 { If an Error was traced then display a MessageBox with the mciError string }
 if err <> 0 then
 begin
 MciGetErrorString(err, ret, 255);
 MessageDlg(ret, mtInformation, [mbOk], 0);
 end;
 { Sending the "play fullscreen command to the Windows MCI }
 err := MciSendString(PChar('play movie fullscreen'), 0, 0, 0);
 { Use the following line instead of the above one if you want to play
 it in screen mode }
 err := MciSendString(PChar('play movie'), 0, 0, 0);
 { If an Error was traced then display a MessageBox with the mciError string }
 if err <> 0 then
 begin
 MciGetErrorString(err, ret, 255);
 MessageDlg(ret, mtInformation, [mbOk], 0);
 end;
 ret := nil;
end;
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 03806
Category:Графика
Как показать иконку, ассоциированную с данным типом файла

=== Как показать иконку, ассоциированную с данным типом файла? ===
ShellApi функция ExtractAssociatedIcon()
uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
var
 Icon: hIcon;
 IconIndex: word;
begin
 IconIndex := 1;
 Icon := ExtractAssociatedIcon(HInstance,
 Application.ExeName,
 IconIndex);
 DrawIcon(Canvas.Handle, 10, 10, Icon);
end;
Source: Взято с сайта http://blackman.wp-club.net/
ID: 01740
Как показать иконку, ассоциированную с данным типом файла?

=== Как показать иконку, ассоциированную с данным типом файла? ===
ShellApi функция ExtractAssociatedIcon() 
uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
var
 Icon: hIcon;
 IconIndex: word;
begin
 IconIndex := 1;
 Icon := ExtractAssociatedIcon(HInstance, Application.ExeName, IconIndex);
 DrawIcon(Canvas.Handle, 10, 10, Icon);
end;
Source: Взято с сайта http://blackman.wp-club.net/
ID: 01740
Как показать на экpане и сохранить в базе картинку формата JPEG

if Picture.Graphic is TJPegImage then
begin
 bs := TBlobStream.Create(TBlobField(Field), bmWrite);
 Picture.Graphic.SaveToStream(bs);
 bs.Free;
end
else
if Picture.Graphic is TBitmap then
begin
 Jpg := TJPegImage.Create;
 Jpg.CompressionQuality := {...};
 Jpg.PixelFormat := {...};
 Jpg.Assign(Picture.Graphic);
 Jpg.JPEGNeeded;
 bs := TBlobStream.Create(TBlobField(Field), bmWrite);
 Jpg.SaveToStream(bs);
 bs.Free;
 Jpg.Free;
end
else
 Field.Clear;
Source: http://delphiworld.narod.ru/
ID: 03797
Category:Графика
Category:Jpeg
Как показать окно свойств экрана?

=== Как показать окно свойств экрана? ===
Для этого воспользуемся 'Rundll32.exe' и запустим её в 'shellexecute'. Не забудьте добавить 'shellapi' в Ваш список uses.
function GetSystemDir: TFileName;
var
 SysDir: array[0..MAX_PATH - 1] of char;
begin
 SetString(Result, SysDir, GetSystemDirectory(SysDir, MAX_PATH));
 if Result = then
 raise Exception.Create(SysErrorMessage(GetLastError));
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 x: Tfilename;
begin
 x := getsystemdir;
 ShellExecute(Form11.Handle, 'open', Pchar('rundll32.exe'), 'shell32.dll,Control_RunDLL Desk.cpl,@0,3', Pchar(X), SW_normal);
end;
// getsystemdir - это функция, которая совместима со всеми версиями windows.
Source: Взято из http://forum.sources.ru
ID: 01818
Как показать оставшееся время до конца?

=== Как показать оставшееся время до конца? ===
procedure TForm1.Timer1Timer(Sender: TObject);
var
 TheLength, Posi, SummaMin, SummaSec: Integer;
begin
 // Progress Bar to check if the track is playing
 if Progress.Max <> 0 then
 begin
 Progress.Position := Mediaplayer1.Position;
 // Gets the length of the selected track
 TheLength := Mediaplayer1.TrackLength[ListBox1.ItemIndex];
 // gets the current position of the track
 Posi := Mediaplayer1.Position;
 // Caculates Minutes
 SummaMin := ((TheLength - Posi) div 1000) Div 60;
 // Calculates Seconds
 SummaSec := ((TheLength - Posi) Div 1000) Mod 60;
 // Adds zero if Seconds are less then ten
 if SummaSec < 10 Then
 Label2.Caption := '0' + IntToStr(SummaSec)
 else
 Label2.Caption := IntToStr(SummaSec);
 // Minutes
 Label1.Caption := IntToStr(SummaMin);
 end;
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 01314