nyuuzyou/wikis huggingface dataset:
Запись и чтение чисел в Blob-поле

=== Запись и чтение чисел в Blob-поле ===
Мне нужно записать серию чисел в файл Paradox в blob-поле. Числа получаются из значений компонент, размещенных на форме. Затем мне нужно будет считывать числа из blob-поля и устанавливать согласно им значения компонент. Как мне сделать это?
Вы можете начать свое исследование со следующего модуля:
unit BlobFld;
interface
uses
 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
 Forms, Dialogs, StdCtrls, Buttons, DBTables, DB, ExtCtrls, DBCtrls,
 Grids, DBGrids;
type
 TFrmBlobFld = class(TForm)
 BtnWrite: TBitBtn;
 Table1: TTable;
 DataSource1: TDataSource;
 DBNavigator1: TDBNavigator;
 LbxDisplayBlob: TListBox;
 Table1pubid: TIntegerField;
 Table1comments: TMemoField;
 Table1UpdateTime: TTimeField;
 Table1Real1: TFloatField;
 Table1Real2: TFloatField;
 Table1Real3: TFloatField;
 Table1Curr1: TCurrencyField;
 Table1Blobs: TBlobField;
 Table1Bytes: TBytesField;
 CbxRead: TCheckBox;
 procedure BtnWriteClick(Sender: TObject);
 procedure DataSource1DataChange(Sender: TObject; Field: TField);
 procedure FormShow(Sender: TObject);
 procedure FormClose(Sender: TObject; var Action: TCloseAction);
 private
 { Private-Deklarationen }
 public
 { Public-Deklarationen }
 end;
var
 FrmBlobFld: TFrmBlobFld;
implementation
{$R *.DFM}
type
 ADouble = array[1..12] of double;
 PADouble = ^ADouble;
procedure TFrmBlobFld.BtnWriteClick(Sender: TObject);
var
 i: integer;
 myBlob: TBlobStream;
 v: longint;
begin
 Table1.Edit;
 myBlob := TBlobStream.Create(Table1Blobs, bmReadWrite);
 try
 v := ComponentCount;
 myBlob.Write(v, sizeof(longint));
 for i := 0 to ComponentCount - 1 do
 begin
 v := Components[i].ComponentIndex;
 myBlob.Write(v, sizeof(longint));
 end;
 finally
 Table1.Post;
 myBlob.Free;
 end;
end;
procedure TFrmBlobFld.DataSource1DataChange(Sender: TObject; Field: TField);
var
 i: integer;
 myBlob: TBlobStream;
 t: longint;
 v: longint;
begin
 if CbxRead.Checked then
 begin
 LbxDisplayBlob.Clear;
 myBlob := TBlobStream.Create(Table1Blobs, bmRead);
 try
 myBlob.Read(t, sizeof(longint));
 LbxDisplayBlob.Items.Add(IntToStr(t));
 for i := 0 to t - 1 do
 begin
 myBlob.Read(v, sizeof(longint));
 LbxDisplayBlob.Items.Add(IntToStr(v));
 end;
 finally
 myBlob.Free;
 end;
 end;
end;
procedure TFrmBlobFld.FormShow(Sender: TObject);
begin
 Table1.Open;
end;
procedure TFrmBlobFld.FormClose(Sender: TObject;
 var Action: TCloseAction);
begin
 Table1.Close;
end;
end.
Source: Взято с http://delphiworld.narod.ru
ID: 02472
----
Как мне в таблице Paradox скопировать массив целочисленных чисел в TBlobField и наоборот? Элементы массива являются точками графика данных, который я хочу выводить, если запись доступна.
Запишите массив в поток памяти и затем используйте метод TBlob LoadFromStream. Для извлечения данных используйте метод TBlob SaveToStream (сохранение и извлечение массива из потока памяти).
Source: Взято с http://delphiworld.narod.ru
ID: 02473
Запись картинки в ADO таблицу

=== Запись картинки в ADO таблицу ===
ADOQuery1.Edit;
TBLOBField(ADOQuery1.FieldByName('myField')).LoadFromFile('c:\my.bmp');
ADOQuery1.Post;
; Примечание Vit: похоже имеется ввиду запросы вида "SELECT * FROM ..."
Source: Взято с http://delphiworld.narod.ru
ID: 02665
Запись массива на диск

=== Запись массива на диск ===
Скажем, ваша структура данных выглядит следующим образом:
type
 TMyRec = record
 SomeField: Integer;
 SomeOtherField: Double;
 TheRest: array[0..99] of Single;
 end;
и TBlobField имеет имя MyBlobField. TMyRec назван как MyRec. Для копирования содержимого MyRec в MyBlobField необходимо сделать следующее:
var
 Stream: TBlobStream;
begin
 Stream := TBlobStream.Create(MyBlobField, bmWrite);
 Stream.Write(MyRec, SizeOf(MyRec));
 Stream.Free;
end;
Есть другой путь:
var
 Stream: TBlobStream;
begin
 Stream := TBlobStream.Create(MyBlobField, bmRead);
 Stream.Read(MyRec, SizeOf(MyRec));
 Stream.Free;
end;
Сборник Kuliba
Author: Steve Schafer
Source: Взято из Советов по Delphi от Валентина Озерова
ID: 00247
----
type
 TCharArray = array[500] of Char;
{ Примечание:
Объявление массива как параметр Var позволяет передавать только ссылку на массив,
а не копировать его целиком в стек, если же вам нужна безопасная работа с массивом,
то вам не следует передавать его как var-параметр. }
procedure WriteToFile(var aArray: TCharArray; sFileName: string);
var
 nArrayIndex: Word;
 fFileHandle: TextFile;
begin
 AssignFile(fFileHandle, sFileName);
 Rewrite(fFileHandle);
 for nArrayIndex := 1 to 500 do
 begin
 Write(fFileHandle, aArray[nArrayIndex]);
 end;
 CloseFile(fFileHandle);
end; {end Procedure, WriteToFile()}
Source: http://delphiworld.narod.ru
ID: 00793
Запись потока в BLOB-поле

=== Запись потока в BLOB-поле ===
Вся хитрость заключается в использовании StrPCopy (помещения вашей строки в PChar) и записи буфера в поток. Вы не сможете передать это в PChar непосредственно, поскольку ему нужен буфер, поэтому для получения необходимого размера буфера используйте <BufferName>[0] и StrLen().
Вот пример использования TMemoryStream и записи его в Blob-поле:
var
 cString: string;
 oMemory: TMemoryStream;
 Buffer: PChar;
begin
 cString := 'Ну, допустим, хочу эту строку!';
 { Создаем новый поток памяти }
 oMemory := TMemoryStream.Create;
 {!! Копируем строку в PChar }
 StrPCopy(Buffer, cString);
 { Пишем =буфер= и его размер в поток }
 oMemory.Write(Buffer[0], StrLen(Buffer));
 { Записываем это в поле }
 < Blob / Memo / GraphicFieldName > .LoadFromStream(oMemory);
 { Необходимо освободить ресурсы}
 oMemory.Free;
end;
Source: Взято с http://delphiworld.narod.ru
ID: 02471
Запись строки в реестр без использования класса TRegistry

=== Запись строки в реестр без использования класса TRegistry ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Запись строки в реестр без использования класса TRegistry
Функция записывает в реестр информацию в виде строки.
Входные параметры:
RootKey - идентификатор корневого раздела реестра, например
HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE и т.д.
Key - имя раздела реестра, если он не существует, то автоматически
создаётся
Name - имя параметра, для записи параметра "По умолчанию" ("Default"),
эта строка должна быть пустой
Value - значение параметра
В случае успеха функция возвращает True, или False при возникновении
ошибки записи в реестр
Зависимости: Windows
Copyright: Dimka Maslov
Дата: 13 мая 2002 г.
***************************************************** }
function RegWriteStr(RootKey: HKEY; Key, Name, Value: string): Boolean;
var
 Handle: HKEY;
 Res: LongInt;
begin
 Result := False;
 Res := RegCreateKeyEx(RootKey, PChar(Key), 0, nil, REG_OPTION_NON_VOLATILE,
 KEY_ALL_ACCESS, nil, Handle, nil);
 if Res <> ERROR_SUCCESS then
 Exit;
 Res := RegSetValueEx(Handle, PChar(Name), 0, REG_SZ, PChar(Value),
 Length(Value) + 1);
 Result := Res = ERROR_SUCCESS;
 RegCloseKey(Handle);
end;
Author: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Source: http://delphibase.endimus.com
ID: 02284
Запись файла на Transact-SQL

=== Запись файла на Transact-SQL ===
Пример простейшей процедуры на Transact-SQL, создающей файл и записывающий в неё что нибудь. Для этого используется WindowsScripting.
WindowsScripting - если грубо - это набор OLE-объектов, которые можно использовать для целей управления системой. Их удобно использовать там, где невозможно достучаться к функциям Win32 API напрямую, например, в SQL Server-е. Ниже приводится исходник на Transact-SQL с комментариями, как это сделать. Надеюсь, что он достаточно хорошо прокомментирован.
DECLARE @FileName varchar(255),
----текст, который необходимо записать в файл---
@sFileText varchar(8000),
----директория файла---
@sFileDir varchar(8000),
----имя файла----------
@sFileName varchar(8000),
@FS int,
@FileID int,
@hr int,
@OLEResult int,
@source varchar(30),
@desc varchar (200),
@bFolder bit
--функция sp_OACreate создаёт OLE объект 'Scripting.FileSystemObject'----
EXECUTE @OLEResult = sp_OACreate 'Scripting.FileSystemObject', @FS OUTPUT
--обязательно обработать ошибочные ситуации---
IF @OLEResult <> 0
BEGIN
GOTO Error_Handler
END
select @sFileDir = 'c:\'
select @sFileName = @sFileDir + '123.log'
/*
у Scripting.FileSystemObject есть много интересных методов для работы с файлами
и директориями, подробнее их можно подсмотреть, например, в MSDN.
*/
--проверить - существует ли заданная директория, для этого вызовем функцию 'FolderExists'
--ранее созданого OLE объекта---
execute @OLEResult = sp_OAMethod @FS,'FolderExists',@bFolder OUT, @sFileDir
IF @OLEResult <> 0 Or @bFolder = 0
BEGIN
 --а если не существует - то создать её----
 execute @OLEResult = sp_OAMethod @FS,'CreateFolder',@bFolder OUT, @sFileDir
 IF @OLEResult <> 0 And @bFolder = 0
 BEGIN
 GOTO Error_Handler
 END
END
--создать файл---
execute @OLEResult = sp_OAMethod @FS,'CreateTextFile',@FileID OUTPUT,@FileName
IF @OLEResult <> 0
BEGIN
 GOTO Error_Handler
END
--создадим строку, которую будем записывать в файл---
set @sFileText = 'Hello first file!' + char(0)
-----------------записать строку в файл---
execute @OLEResult = sp_OAMethod @FileID, 'WriteLine', NULL, @sFileText
IF @OLEResult <> 0
BEGIN
 GOTO Error_Handler
END
goto Done
Error_Handler: --обработаем ошибку---
EXEC @hr = sp_OAGetErrorInfo null, @source OUT, @desc OUT
Done:
--очистим за собой всяческий OLE-мусор----
EXECUTE @OLEResult = sp_OADestroy @FileID
EXECUTE @OLEResult = sp_OADestr
Author: AQL
Source: Взято из http://forum.sources.ru
ID: 02792
Category:Базы данных
Category:MS SQL Server
Заполнение полей формы в TWebBrowser методом Drag-and-Drop

=== Заполнение полей формы в TWebBrowser методом Drag-and-Drop ===
{ 
 This example shows how to fill out fields in your webbrowser by 
 dragging the content of Label1 to a field of your webbrowser }
procedure TForm1.FormCreate(Sender: TObject);
begin
 Label1.DragMode := dmAutomatic;
end;
procedure TForm1.WebBrowserDragOver(Sender, Source: TObject; X,
 Y: Integer; State: TDragState; var Accept: Boolean);
var
 Item: Variant;
begin
 // check if document is interactive 
 if (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then
 begin
 Item := WebBrowser.OleObject.Document.elementFromPoint(x, y);
 if Source is TLabel then
 Accept := True;
 Accept := (Item.tagname = 'INPUT') and ((Item.type = 'text') or
 (Item.type = 'password')) or (Item.tagname = 'TEXTAREA');
 end;
end;
procedure TForm1.WebBrowserDragDrop(Sender, Source: TObject; X, Y: Integer);
var
 Item: Variant;
begin
 // check if document is interactive 
 if (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then
 begin
 Item := WebBrowser.OleObject.Document.elementFromPoint(x, y);
 Item.Value := Label1.Caption;
 end;
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 00713
Category:VCL
Category:DragAndDrop
Category:WebBrowser
Заполнение списка словами из строки

=== Заполнение списка словами из строки ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Заполнение списка (TargetList) словами из строки (Text),
с возможностью указания множества разделителей
Функция заполняет список TargetList, словами (наборами символов)
из строки Text. Имеется возможность получения позиции каждого
слова в строке (ReturnWordPlaces = True); добавления в TargetList
не только слов, но и разделителей (ReturnWordDeviders = True);
указания более чем одного разделителя (все в строке WordDeviders).
Ограничением является невозможность указания разделителя,
длинной более чем 1 символ.
Result = TargetList.Count; {количество строк в TargetList}
Зависимости: sysutils, classes, system
132234868, Махачкала
Copyright: VID
Дата: 02 мая 2002 г.
***************************************************** }
function GetWordListFromText(Text, WordDeviders: string; TargetList: TStrings;
 ReturnWordPlace, ReturnWordDeviders: Boolean): Integer;
var
 X, TextLength, WP: Integer;
 W: string;
begin
 Result := 0;
 TextLength := Length(Text);
 if TextLength = 0 then
 Exit;
 if Length(WordDeviders) = 0 then
 Exit;
 if TargetList = nil then
 Exit;
 TargetList.BeginUpdate();
 TargetList.Clear;
 WordDeviders := AnsiUpperCase(WordDeviders);
 W := ;
 X := 0;
 WP := 1;
 repeat
 X := X + 1;
 if (Pos(AnsiUpperCase(Text[x]), WordDeviders) = 0) and (X <= TextLength)
 then
 W := W + Text[x]
 else
 begin
 if W <> then
 begin
 case ReturnWordPlace of
 True: TargetList.Add(W + '=' + Inttostr(WP));
 False: TargetList.Add(W);
 end;
 end;
 W := ;
 WP := X + 1;
 if ReturnWordDeviders = true then
 begin
 case ReturnWordPlace of
 True: TargetList.Add(Text[x] + '=' + Inttostr(x));
 False: TargetList.Add(TEXT[x]);
 end;
 end;
 end;
 until (X > TextLength);
 TargetList.EndUpdate;
 Result := TargetList.Count;
end;
Source: http://delphibase.endimus.com
ID: 00847
Заполняем Canvas рисунком с рабочего стола, учитывая координаты

function PaintDesktop(HDC): Boolean;
Например:
PaintDesktop(Form1.Canvas.Handle);
Author: Зайцев О.В.
Author: Владимиров А.М.
Source: Взято из http://forum.sources.ru
ID: 03739
Category:Графика
Category:Рисование
Запретить Hint в TTreeView

=== Запретить Hint в TTreeView ===
const
 TVS_NOTOOLTIPS = $80;
begin
 with treeview1 do
 SetWindowLong(Handle, GWL_STYLE,
 GetWindowLong(Handle, GWL_STYLE)
 or TVS_NOTOOLTIPS);
end;
ID: 00639
Запретить в выбранном окне кнопку закрытия x

=== Запретить в выбранном окне кнопку закрытия x ===
EnableMenuItem(GetSystemMenu(FindWindow(nil, PChar('Название Окна')), False), SC_CLOSE, MF_BYCOMMAND or MF_GRAYED);
Author: Radmin
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 02029
Запретить использовать RegEdit

=== Запретить использовать RegEdit ===
Например мы вынесли компонент класса TCheckBox, назвали его "Использовать редактор системного реестра". Задача такова: когда флажок установлен пользователь может воспользоваться редактором реестра, когда не установлен - соответственно, не может!!!
Что нужно для осуществления этой задачи? Нужно воспользоваться ключом
 HKEY_CURRENT_USER\Software\Microsoft\ Windows\CurrentVersion\Policies\System
создать в нём параметр:
 DisableRegistryTools
и задать ему в качестве значение 1, т.е. задействовать его.
Код пишем по нажатию на самом Checkbox'e:
procedure TForm1.CheckBox1Click(Sender: TObject);
var
 H: TRegistry;
begin
 H := TRegistry.Create;
 with H do
 begin
 RootKey := HKEY_CURRENT_USER;
 OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System', true);
 if CheckBox1.Checked then
 WriteInteger('DisableRegistryTools', 0)
 else
 WriteInteger('DisableRegistryTools', 1);
 CloseKey;
 Free;
 end;
end;
Не забудьте в области uses объявить модуль Registry:
uses
 Registry;
Source: http://delphiworld.narod.ru/
ID: 02304
Запрос пароля при инициализации приложения

{
Copyright © 1998 by Delphi 4 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
program Initialize;
uses
 Forms,
 Dialogs,
 Controls,
 MainFrm in 'MainFrm.pas' {MainForm};
{$R *.RES}
var
 Password: string;
begin
 if InputQuery('Password', 'Enter your password', PassWord) then
 if Password = 'D5DG' then
 begin
 // Other initialization routines can go here.
 Application.CreateForm(TMainForm, MainForm);
 Application.Run;
 end
 else
 MessageDlg('Incorrect Password, terminating program', mtError, [mbok], 0);
end.
ID: 04037
Category:Разработка приложений
Category:Безопасность
Запуск процесса в контексте другого пользователя

=== Запуск процесса в контексте другого пользователя ===
uses
 JwaWinBase; ( http://members.chello.nl/m.vanbrakel2/ )
//...
procedure TForm1.Button1Click(Sender: TObject);
var 
 si: STARTUPINFOW; 
 pif: PROCESS_INFORMATION; 
 res: Bool;
 s: string;
begin
 //set StartUpInfoW first
 si.cb := SizeOf(startupinfow);
 si.dwFlags := STARTF_USESHOWWINDOW;
 si.wShowWindow := SW_SHOWDEFAULT;
 si.lpReserved := nil;
 si.lpDesktop := nil;
 si.lpTitle := 'Konsole';
 // run CreateProcessWithLogonW...
 res := CreateProcessWithLogonW('Security', 'ArViCor', 'test', LOGON_WITH_PROFILE,
 'c:\win2kas\system32\regedt32.exe', nil
 , CREATE_DEFAULT_ERROR_MODE, nil, nil, si, pif);
 if booltostr(res) = '0' then 
 begin
 //if an error occures, show the error-code
 //this code can be 'translated' with 'net helpmsg ' on command-prompt
 str(GetLastError, s);
 ShowMessage('CreateProcessWithLogonResult: ' + booltostr(res) + #10 +
 'GetLastError: ' + s);
 end;
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 01724
Запустить приложение и подождать

=== Запустить приложение и подождать ===
function ExecuteFile(FileName, Params, WorkingDir: string; Wait: Boolean): Integer;
var
 buffer: array[0..511] of Char;
 TmpStr: string;
 i: Integer;
 StartupInfo: TStartupInfo;
 ProcessInfo: TProcessInformation;
 ext, key, FName, path: string;
 ExitCode: Cardinal;
begin
 if WorkingDir <> then
 ChDir(WorkingDir);
 ext := LowerCase(ExtractFileExt(FileName));
 path := ExtractFilePath(FileName);
 if ext <> '.exe' then
 begin
 with TRegistry.create do
 begin
 try
 RootKey := HKEY_CLASSES_ROOT;
 OpenKey(ext, False);
 Key := ReadString();
 CloseKey;
 OpenKey(key + '\Shell\open\command', False);
 key := ReadString();
 FName := ExtractFileName(key);
 if Pos('/', fname) > 0 then
 FName := Copy(FName, 1, Pos('/', FName)-1);
 FName := StringReplace(FName, '%1', , [rfReplaceAll, rfIgnoreCase]);
 if Pos(' ', FileName) > 0 then
 FileName := '"' + Filename + '"';
 TmpStr := ExtractFilePath(key) + FName + ' ' + FileName;
 if Params <> then
 TmpStr := TmpStr + ' ' + Params;
 Closekey;
 finally
 Free;
 end;
 end;
 end
 else
 begin
 TmpStr := FileName;
 TmpStr := TmpStr + ' ' + Params;
 end;
 StrPCopy(buffer, TmpStr);
 FillChar(StartupInfo, Sizeof(StartupInfo), #0);
 StartupInfo.cb := SizeOf(StartupInfo);
 StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
 StartupInfo.wShowWindow := SW_SHOWNORMAL;
 if CreateProcess(nil, buffer, nil, nil, False, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
 begin
 if Wait then
 begin
 while WaitforSingleObject(ProcessInfo.hProcess, 200) = WAIT_TIMEOUT do
 Application.ProcessMessages;
 GetExitCodeProcess(ProcessInfo.hProcess, ExitCode);
 end;
 end
 else
 Result := GetLastError();
end;
Author: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
ID: 02150
Запустить приложение с помощью ShellExecute и подождать

=== Запустить приложение с помощью ShellExecute и подождать ===
var
 exInfo: TShellExecuteInfo;
begin
 FillChar(exInfo, Sizeof(exInfo), 0);
 with exInfo do
 begin
 cbSize := Sizeof(exInfo); // required!
 fMask := SEE_MASK_NOCLOSEPROCESS;
 Wnd := Handle; // forms handle
 lpVerb := 'paintto';
 lpFile := PChar(pdffilename);
 lpParameters := PChar(printernameAndPort);
 nShow := SW_HIDE;
 end;
 if ShellExecuteEx(@exInfo) then
 begin
 while GetExitCodeProcess(exinfo.hProcess, exitcode) and (exitcode = STILL_ACTIVE) do
 Sleep(500);
 CloseHandle(exinfo.hProcess);
 DeleteFile(pdffilename);
 end
 else
 ShowMessage(SysErrorMessage(GetLastError));
ID: 02151
Запущен ли Softice?

// SoftIce in W9x
function IsSoftIce95Loaded: Boolean;
var
 hFile: THandle;
begin
 Result := False;
 hFile := CreateFileA('\.SICE', GENERIC_READ or GENERIC_WRITE,
 FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
 FILE_ATTRIBUTE_NORMAL, 0);
 if (hFile <> INVALID_HANDLE_VALUE) then
 begin
 CloseHandle(hFile);
 Result := TRUE;
 end;
end;
// SoftIce in NT OS
function IsSoftIceNTLoaded: Boolean;
var
 hFile: THandle;
begin
 Result := False;
 hFile := CreateFileA('\.NTICE', GENERIC_READ or GENERIC_WRITE,
 FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
 FILE_ATTRIBUTE_NORMAL, 0);
 if (hFile <> INVALID_HANDLE_VALUE) then
 begin
 CloseHandle(hFile);
 Result := TRUE;
 end;
end;
// to detect it
if IsSoftIce95Loaded or IsSoftIceNTLoaded then
 Application.Terminate;
{ if you insert a "Nag" (Message telling him he uses SoftIce) then a amatuer cracker w'll find this protection in notime }
// bestway of using this thing is in "project Unit"
Source: Delphi Knowledge Base: http://www.baltsoft.com/
ID: 04513
Category:Разработка приложений
Category:Защита и взлом
Запущен ли сервер удаленного доступа (RAS)

function CheckRAS: Boolean;
const
 MaxEntries = 100;
var
 BufSize: Integer;
 NumEntries: Integer;
 Entries: array[1..MaxEntries] of TRasConn;
begin
 Entries[1].dwSize := SizeOf(TRasConn);
 BufSize := SizeOf(TRasConn) * MaxEntries;
 FillChar(stat, SizeOf(TRasConnStatus), 0);
 RasEnumConnections(@Entries[1], BufSize, NumEntries);
 if NumEntries > 0 then
 Result := True
 else
 Result := False;
end;
Source: vlata.com
ID: 03327
Category:Связь
Зарегистрировать новый тип файлов

=== Зарегистрировать новый тип файлов ===
Не хуже M$ получается! У них свои типы файлов, и у нас будут свои! Всё, что для этого нужно - точно выполнять последовательность действий и научиться копировать в буфер, чтобы не писать все те коды, что будут тут изложены :)) 
Сначала, естественно, объявляем в uses модуль Registry. 
uses
 Registry;
Затем в публичных объявлениях объявляем процедуру регистрации нового типа файлов: 
public
 { Public declarations }
 procedure RegisterFileType(ext: string; FileName: string);
Описываем её так: 
procedure TForm1.RegisterFileType(ext: string; FileName: string);
var
 reg: TRegistry;
begin
 reg := TRegistry.Create;
 with reg do
 begin
 RootKey := HKEY_CLASSES_ROOT;
 OpenKey('.' + ext, True);
 WriteString(, ext + 'file');
 CloseKey;
 CreateKey(ext + 'file');
 OpenKey(ext + 'file\DefaultIcon', True);
 WriteString(, FileName + ',0');
 CloseKey;
 OpenKey(ext + 'file\shell\open\command', True);
 WriteString(, FileName + ' "%1"');
 CloseKey;
 Free;
 end;
end;
Ну а по нажатию какого-нибудь батона регистрируем! 
procedure TForm1.Button1Click(Sender: TObject);
begin
 RegisterFileType('DelphiWorld', Application.ExeName);
end;
Source: http://delphiworld.narod.ru/
ID: 01742
Заставить мерцать индикаторы клавиш CapsLock, NumLock и ScrollLock

=== Заставить мерцать индикаторы клавиш CapsLock, NumLock и ScrollLock ===
Представьте себе такую ситуацию: глупый пользователь включает тачку, а тут... светомузыка, индикаторы состояния клавиш то включатся, то погаснут... а если ещё каждую секунду проходит 500 тактов!!! Шутка, конечно злостная, но воспроизводится весьма легко. 
Всё основывается на следующем коде: 
var
 KS: TKeyboardState;
begin
 GetKeyboardState(KS);
 KS[020] := KS[020] xor 1;
 KS[144] := KS[144] xor 1;
 KS[145] := KS[145] xor 1;
 SetKeyboardstate(KS);
Source: http://delphiworld.narod.ru/
ID: 01499
Затенить компонент

procedure ShadeIt(f: TForm; c: TControl; Width: Integer; Color: TColor);
var
 rect: TRect;
 old: TColor;
begin
 if (c.Visible) then
 begin
 rect := c.BoundsRect;
 rect.Left := rect.Left + Width;
 rect.Top := rect.Top + Width;
 rect.Right := rect.Right + Width;
 rect.Bottom := rect.Bottom + Width;
 old := f.Canvas.Brush.Color;
 f.Canvas.Brush.Color := Color;
 f.Canvas.FillRect(rect);
 f.Canvas.Brush.Color := old;
 end;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
 i: Integer;
begin
 for i := 0 to Self.ControlCount - 1 do
 ShadeIt(Self, Self.Controls[i], 3, clBlack);
end;
Source: http://delphiworld.narod.ru
ID: 03728
Category:Графика
Захват части изображения

Вот пример кода, позволяющего с помощью TBitmap захватить часть изображения и сохранить его в файле. Я включил функцию копирования палитры, необходимой при работе в режиме 256 цветов.
function CopyPalette(Palette: HPalette): HPalette;
var
 nEntries: Integer;
 LogPalSize: Integer;
 LogPalette: PLogPalette;
begin
 Result := 0;
 if Palette = 0 then
 exit;
 GetObject(Palette, sizeof(nEntries), @nEntries);
 if nEntries < 1 then
 exit;
 LogPalSize := SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * (nEntries - 1);
 GetMem(LogPalette, LogPalSize);
 with LogPalette^ do
 try
 palVersion := $300;
 palNumEntries := nEntries;
 GetPaletteEntries(Palette, 0, nEntries, palPalEntry[0]);
 Result := CreatePalette(LogPalette^);
 finally
 FreeMem(LogPalette, LogPalSize);
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 Bitmap: TBitmap;
begin
 Bitmap := TBitmap.Create;
 try
 Bitmap.Width := 50;
 Bitmap.Height := 40;
 Bitmap.Palette := CopyPalette(Image1.Picture.Bitmap.Palette);
 Bitmap.Canvas.CopyRect(Rect(0, 0, 50, 40),
 Image1.Picture.Bitmap.Canvas,
 Bounds(20, 10, 50, 40));
 Bitmap.SaveToFile('c:\windows\temp\junk.bmp');
 finally
 Bitmap.Free;
 end;
end;
Source: http://delphiworld.narod.ru/
ID: 03840
Category:Графика
Category:Bitmap
Category:Цвета и палитры