nyuuzyou/wikis huggingface dataset:
Прокрутка таблицы - хитрость PeekMessage

=== Прокрутка таблицы - хитрость PeekMessage ===
На днях я решил поиграть с API-функцией PeekMessage(). Функция работает, но ловить ее нужно следующим образом.
Я прокручиваю таблицу, связанную с набором данных. "Поиск" в наборе данных замедляет процесс скролирования (условимся называть "поиском" синхронное перемещение табличного курсора в процессе скроллирования, при котором текущей записью становится запись, ближайшая к нажимаемой кнопке полосы прокрутки). Возникла задача: необходимо отменить "поиск" (процесс слежения) и переместить указатель на необходимую запись только в случае остановки пользователем процесса скроллирования, другими словами - пока пользователь осуществляет скроллирование, "поиск" необходимо отменить. Итак, ко мне в голову пришла мысль, что с помощью PeekMessage() можно выловить определенное сообщение и тем самым отменить поиск во время прокрутки. Звучит просто, но на самом деле все оказалось наоборот.
Я установил фильтр поиска сообщений на WM_MOUSEFIRST/LAST. Ситуация: пользователь непрерывно прокручивает DBGrid вниз, т.е. держит нажатой нижнюю кнопку скроллирования. В результате PeekMessage() возвращает False - нас это не устраивает, это не то, что мы хотим. Положительный результат можно получить только в случае сверхскоростных манипуляций мышью.
Если в фильтре использовать 0 и 0, чтобы поймать любое сообщение, результат всегда будет True. Причина, очевидно в том, что любой щелчок мыши в области DBGrid никак не обойдется без последствий, генерация системой сообщения PAINT яркий тому пример, поэтому PeekMessage может возвратить True в любое время, что тоже не может нам помочь.
Было бы хорошо, если бы дескриптор DBGrid получал событие OnMouseUp() во время его скроллирования. Обидно, но OnMouseUp() работает только с DBGrid, а не с полосами прокрутки. OnMouseUp() с TForm при KeyPreview:=true не работает, я проверял.
После пришла идея опросить состояние кнопок мыши с помощью функции GetKeyState(). Пока кнопка нажата (DOWN), "поиск" запрещен, и наоборот. UP (кнопка отжата) свидетельствует об окончании процесса скроллирования. Данный способ работы с окном во время манипуляций с его полосой прокрутки заработал без проблем. Теперь все в порядке: поиска во время прокрутки не происходит и табличный курсор также никуда не перемещается.
Рассмотренная тема имеет отношение к полосам прокрутки, а события OnKeyUp() и OnMouseUp() могут применяться где-нибудь еще.
Source: Взято с http://delphiworld.narod.ru
ID: 03023
Category:WinAPI
Category:DBGrid
Прокручивать TTreeView во время перемещения

=== Прокручивать TTreeView во время перемещения ===
procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
 State: TDragState; var Accept: Boolean);
begin
 if (y < 15) then {On the upper edge - should scroll up }
 SendMessage(TreeView1.Handle, WM_VSCROLL, SB_LINEUP, 0)
 else if (TreeView1.Height - y < 15) then { On the lower edge - should scroll down }
 SendMessage(TreeView1.Handle, WM_VSCROLL, SB_LINEDOWN, 0);
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 00721
Category:VCL
Category:DragAndDrop
Category:TreeView
Пропажа прав пользователей в Local IB после переноса

=== Пропажа прав пользователей в Local IB после переноса ===
Я создал БД с правами пользователей в Local IB. После переноса этой БД на IB for NT все пользователи куда-то "пропали". В чем дело ?
Причина в том, что информация о пользователях IB хранится в специальном файле ISC4.GDB, и является общей для всех БД на конкретном компьютере. Очевидно что в вашем случае на сервере IB for NT отсутствовали пользователи, заведенные вами для Local IB. Вам придется создать всех ваших пользователей и для IB for NT (при помощи Server Manager). То же самое будет и при переносе базы данных между серверами IB. Т.е. на обоих серверах пользователи должны быть созданы отдельно.
Если версии IB и платформы на обоих серверах совпадают, то ISC4.GDB можно просто скопировать. Разумеется, при отсутствии подсоединений. (еще лучше вообще выключить сервер БД на время копирования isc4.gdb).
Перенести isc4.gdb между платформами можно следующим способом: сделать backup isc4.gdb, восстановить на нужном сервере эту БД в другое имя (например isc4_new.gdb), остановить сервер IB, удалить старую isc4.gdb и переименовать isc4_new.gdb.
Author: Дмитрий Кузьменко (http://www.ibase.ru)
ID: 02898
Category:Базы данных
Category:Interbase
Пропорциональное отображение в TScrollBar или TStringGrid

=== Пропорциональное отображение в TScrollBar или TStringGrid ===
// Getting a TScrollbar control to Show a proportional thumb: 
procedure TForm1.Button1Click(Sender: TObject);
var
 info: TScrollInfo;
begin
 FillChar(info, SizeOf(info), 0);
 with info do
 begin
 cbsize := SizeOf(info);
 fmask := SIF_PAGE;
 nPage := ScrollBar1.LargeChange;
 end;
 SetScrollInfo(ScrollBar1.Handle, SB_CTL, info, True);
end;
// Same for a TStringGrid 
procedure TForm1.Button1Click(Sender: TObject);
var
 info: TScrollInfo;
begin
 FillChar(info, SizeOf(info), 0);
 with info do
 begin
 cbsize := SizeOf(info);
 fmask := SIF_ALL;
 GetScrollInfo(StringGrid1.Handle, SB_VERT, info);
 fmask := fmask or SIF_PAGE;
 nPage := 5 * (nmax - nmin) div StringGrid1.RowCount;
 // whatever number of cells you consider a "page" 
 end;
 SetScrollInfo(StringGrid1.Handle, SB_VERT, info, True);
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01103
Просмотр состояния корзины

=== Просмотр состояния корзины ===
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls, ShellAPI;
const
 SHERB_NOCONFIRMATION = $1;
 SHERB_NOPROGRESSUI = $2;
 SHERB_NOSOUND = $4;
type
 TForm1 = class(TForm)
 btnGetRecicleBinFileCount: TButton;
 btnEmptyRecicleBin: TButton;
 btnDelToReciclebin: TButton;
 procedure btnGetRecicleBinFileCountClick(Sender: TObject);
 procedure btnEmptyRecicleBinClick(Sender: TObject);
 procedure btnDelToReciclebinClick(Sender: TObject);
 end;
type
 TSHQueryRBInfo = packed record
 cbSize : DWORD;
 i64Size,
 i64NumItems : TLargeInteger;
 end;
 PSHQueryRBInfo = ^TSHQueryRBInfo;
 function SHEmptyRecycleBin(hwnd: HWND; pszRootPath: PChar;
 dwFlags: DWORD): HRESULT; stdcall;
 external 'shell32.dll' name 'SHEmptyRecycleBinA';
 function SHQueryRecycleBin (pszRootPath: PChar;
 var SHQueryRBInfo: TSHQueryRBInfo): HRESULT; stdcall;
 external 'Shell32.dll' name 'SHQueryRecycleBinA'; 
var
 Form1: TForm1;
implementation
{$R *.dfm}
// Просмотр состояния корзины (краткая информация)
procedure TForm1.btnGetRecicleBinFileCountClick(Sender: TObject);
var
 Info: TSHQueryRBInfo;
 Err: HRESULT;
begin
 ZeroMemory(@Info, SizeOf(Info));
 Info.cbSize := SizeOf(Info);
 Err := SHQueryRecycleBin(nil, Info);
 if Err = S_OK then
 ShowMessage(Format('Всего в корзине %d элементов, их общий размер: %d',
 [Info.i64NumItems, Info.i64Size]))
 else
 ShowMessage(SysErrorMessage(Err));
end;
end.
Пример работы с корзиной можно скачать здесь: https://forum.sources.ru/index.php?showtopic=75189
Author: Rouse_
Source: Взято из http://forum.sources.ru
ID: 01709
Простейшая авторизация в ISAPI/CGI приложениях

Самый простой способ защитить директорию на web сервере - это применить авторизацию. Этот пример показывает как это сделать используя только ISAPI приложение.
Совместимость: Delphi 5.x (или выше)
- Эти две строчки заставляют браузер спросить имя пользователя и пароль:
Response.StatusCode := 401; // Запрос логина и пароля
Response.WWWAuthenticate := 'Basic realm="Delphi"'; // Заголовок
- Браузер посылает имя пользователя и пароль и мы получаем их:
Request.Authorization
- Но информация закодирована в Base64. Существует довольно много исходников, которые показывают как кодировать/декодировать в Base64. Следующая строчка возвращает декодированные данные в mAuthorization.
FBase64.DecodeData(Copy(Request.Authorization, 6, Length(Request.Authorization)), mAuthorization);
Source: Взято из http://forum.sources.ru
ID: 03421
Category:Связь
Category:Web
Простейший CGI на Дельфи

program helloworld;
{$E cgi}
begin
 Write('Content type: Text/HTML' + #13#10#13#10);
 Write('Hello World!');
end.
Всё, что этот код делает, это выводит в поток вывода 'Hello World!'. Открываем новый проект. Удаляем все из DPR файла, заполняем приведенным кодом. Компилируем. Полученный файл helloworld.cgi ставим в папку cgi-bin IIS сервера, убеждаемся что в настройках сервера разрешено исполнение серверных скриптов и сам сервер включен, далее открываем браузер и вводим адрес, у меня это:
 httр://vitaly/cgi-bin/helloworld.cgi
любуемся надписью "Hello World!" в браузере.
А вот чуть более сложный пример - вывод потока (в данном случае если поток содержит картинку) в браузер:
procedure OutputStream(m: TStream);
var
 h: Integer;
 j: Cardinal;
begin
 h := GetStdHandle(STD_OUTPUT_HANDLE);
 try
 WriteFile(h, 'Content type: image/x-MS-bmp' + #13#10#13#10, 32, j, nil);
 WriteFile(h, m.memory^, m.size, j, nil);
 finally
 CloseHandle(h);
 end;
end;
Теперь сделанный cgi можно использовать в качестве картинки.
Естественно, что работать такой CGI ,будет только в среде Windows (для работы под Linux надо подумать над компилляцией в среде Kilix)
Ещё типы контента:
 text/html
 text/plain
 text/richtext
 
 image/gif
 image/jpeg
 image/x-MS-bmp
 image/x-xpixmap
 
 video/mpeg
 video/quicktime
 
 audio/x-wav
 audio/basic (Sun *.au audio files)
 audio/mp3
 audio/mpeg
 audio/x-mp3
 audio/x-mpeg
 audio/m3u
 audio/x-m3u
 audio/x-aiff (aif aiff aifc)
 
 application/msword
 application/octet-stream (для exe)
 application/x-zip
 application/mac-binhex40 (hqx)
 application/pdf
 application/rtf
 application/x-latex
 application/zip
 application/rss+xml
Author: Vit
Source: Vingrad.ru http://forum.vingrad.ru
ID: 03418
Category:Связь
Category:Web
Проход дерева каталогов

=== Проход дерева каталогов ===
procedure ScanDir(Dir: string);
var
 SearchRec: TSearchRec;
begin
 if Dir <> then
 if Dir[Length(Dir)] <> '\' then
 Dir := Dir + '\';
 if FindFirst(Dir + '*.*', faAnyFile, SearchRec) = 0 then
 repeat
 if (SearchRec.name = '.') or (SearchRec.name = '..') then continue;
 if (SearchRec.Attr and faDirectory) <> 0 then
 ScanDir(Dir + SearchRec.name) // we found Directory: "Dir+SearchRec.name"
 else
 ShowMessage(Dir + SearchRec.name); // we found File: "Dir+SearchRec.name"
 until FindNext(SearchRec) <> 0;
 FindClose(SearchRec);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 ScanDir('c:');
end;
Ненамного сложнее, но возможностей поболе будет.
procedure ScanDir(Path: string; SearchMask: TStrings; ScanSub: Boolean);
var
 SearchRec: TSearchrec;
 a, i: Integer;
begin
 if ScanSub then
 begin
 FindFirst(path + '\*.*', faDirectory, SearchRec); { . found }
 FindNext(SearchRec); { .. found }
 a := FindNext(SearchRec);
 while a = 0 do
 begin
 if (SearchRec.Attr and faDirectory) > 0 then
 ScanDir(Path + '\' + SearchRec.Name, SearchMask, ScanSub);
 a := FindNext(SearchRec);
 end;
 FindClose(SearchRec);
 end;
 for i := 0 to SearchMask.Count-1 do
 begin
 a := FindFirst(Path + '\' + SearchMask[i], faAnyFile, SearchRec);
 while a = 0 do
 begin
 { operation on file }
 a := FindNext(SearchRec);
 end;
 FindClose(SearchRec);
 end;
end;
Author: Vit
Автор December
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 03154
Category:Файловая система
Процедура заполнения компонента TTreeView данными из TDataSet-совместимой выборки

=== Процедура заполнения компонента TTreeView данными из TDataSet-совместимой выборки ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Процедура заполнения компонента TTreeView данными из TDataSet-совместимой выборки
Процедура заполнения компонента TTreeView данными из TDataSet-совместимой
выборки типа: idNode int, idParentNode int, cNodeName varchar, ...
Важно: корневой узел дерева должен быть первой записью выборки.
Зависимости: Windows, SysUtils, DB, ComCtrls
Copyright: Master BRAIN (Delirium)
Дата: 18 октября 2002 г.
***************************************************** }
procedure FillTree(Tree: TTreeView; Query: TDataSet; idNode, idParent,
 cNodeName: string);
var
 i: integer;
begin
 // Корневой узел, должен быть первым в выборке Query
 Query.First;
 Tree.Items.Clear;
 Tree.Items.AddObject(nil, Query.FieldByName(cNodeName).AsString,
 Pointer(Query.FieldByName(idNode).asInteger));
 Query.Next;
 while not Query.Eof do
 begin
 i := 0;
 while i < Tree.Items.Count do
 if Tree.Items.Item[i].Data = Pointer(Query.FieldByName(idParent).asInteger) then
 begin
 Tree.Items.AddChildObject(Tree.Items.Item[i],
 Query.FieldByName(cNodeName).AsString,
 Pointer(Query.FieldByName(idNode).asInteger));
 break;
 end
 else
 Inc(i);
 Query.Next;
 end;
end;
Пример использования:
FillTree(TreeView1, ADOQuery1, 'idDoc', 'idParentDoc', 'cDocument');
Author: Delirium, Master_BRAIN@beep.ru, ICQ:118395746, Москва
Source: http://delphibase.endimus.com
ID: 03091
Category:Базы данных
Category:DBTreeView
Процедуры для открытия диалогового окна "Свойства Экрана"

=== Процедуры для открытия диалогового окна "Свойства Экрана" ===
{ **** UBPFD *********** by kladovka.net.ru ****
>> Процедуры для открытия диалогового окна "Свойства Экрана"
Зависимости: ShellApi
Copyright: Gua
Дата: 18 июля 2002 г.
********************************************** }
// Открытие диалогового окна "Display Properties"
procedure DisplayPropertiesWindow;
begin
 ShellExecute(0, 'open', PChar('rundll32.exe'), 'shell32.dll,Control_RunDLL Desk.cpl', nil, SW_normal);
end;
// Открытие диалогового окна "Display Properties" с закладкой Desktop
procedure DisplayPropertiesWindow_Desktop;
begin
 ShellExecute(0, 'open', PChar('rundll32.exe'), 'shell32.dll,Control_RunDLL Desk.cpl @0,0', nil, SW_normal);
end;
// Открытие диалогового окна "Display Properties" с закладкой Screen Saver
procedure DisplayPropertiesWindow_ScreenSaver;
begin
 ShellExecute(0, 'open', PChar('rundll32.exe'), 'shell32.dll,Control_RunDLL Desk.cpl @0,1', nil, SW_normal);
end;
// Открытие диалогового окна "Display Properties" с закладкой Settings
procedure DisplayPropertiesWindow_Settings;
begin
 ShellExecute(0, 'open', PChar('rundll32.exe'), 'shell32.dll,Control_RunDLL Desk.cpl @0,3', nil, SW_normal);
end;
ID: 01223
Процедуры передачи и приема блоков данных, с учетом фрагментации и склейки пакетов

{ **** UBPFD *********** by kladovka.net.ru ****
>> Процедуры передачи и приема блоков данных, с учетом фрагментации и склейки пакетов. Построено на TServerSocket,TClientSocket ..SendText
Отправка:
пользователь создает строку 'Строка пользователя'
дорабатываем строку до '<19>Строка пользователя'
отправляем
Принимаем:
1 принятый кусок строки добавляем в конец буферной строки bstr;
2 вызываем прочедуру которая
a) удаляет (если есть ;|) часть bstr до '<'; //(это на случай ошибки, правда такого явления я незамечал здесь но на всякий случай предусмотрел так спокойнее)
b) копирует участок '<число>' и достает из него число;
c) если длинна полученного буфера минус длинна участка '<число>' меньше bstr то ниче не делаем и выходим из процедуры.
иначе отрезаем от bstr участок '<число>' копируем кусок bstr длинной 'число' символов в ostr, удаляем этот же кусок из bstr.
d) передает ostr кому оно надо ибо ostr это то что послал пользователь отдельным куском.
все. Пом очень просто алгоритм работает безотказно и ниче тут непопишеш.
Зависимости: ScktComp
Автор: Camsonov Aleksandr, s002156@mail.ru, Tver
Copyright: SELMAP_Group_Programmers/s002156Shurik
Дата: 2 октября 2002 г.
********************************************** }
var
 Buffer:String = ;
{$R *.dfm}
function GetUserStringFromBuffer(var UserString: string): Boolean;
var
 i: Integer;
 bf: string;
begin
 Result := False;
 if Length(Buffer) > 0 then
 repeat
 if Length(Buffer) > 0 then
 if Buffer[1] <> '<' then Delete(Buffer, 1, 1);
 until (Buffer[1] = '<') or (Length(Buffer) <= 1);
 if Length(Buffer) < 3 then exit;
 i := 1;
 bf := ;
 repeat
 if Length(Buffer) >= i then
 begin
 Inc(i);
 if Buffer[i] <> '>' then bf := bf + Buffer[i];
 end;
 until (Buffer[i] = '>') or (Length(Buffer) <= 1);
 if StrToInt(bf) + i > Length(Buffer) then
 exit
 else
 begin
 Delete(Buffer, 1, i);
 UserString := Copy(Buffer, 1, StrToInt(bf));
 Result := True;
 Delete(Buffer, 1, StrToInt(bf));
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 S: string;
begin
 S := '<' + IntToStr(Length(Edit1.Text)) + '>' + Edit1.Text;
 ClientSocket1.Socket.SendText(S);
 // В качестве ТЕСТА отправляю еще несколько копий этой строки
 // для того чтобы все они ушли в одном пакете. (слипание)
 ClientSocket1.Socket.SendText(S);
 ClientSocket1.Socket.SendText(S);
 ClientSocket1.Socket.SendText(S);
end;
procedure TForm1.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket);
var
 GetResult: Boolean;
 UserStr: string;
begin
 Buffer := Buffer + Socket.ReceiveText;
 // в буфер приходят слипшиеся строки
 // перезапуск функции вытаскивания кусков до False (пока куски не закончатся)
 // если отправленный текст получен неполностью тоже возвращается False
 repeat
 GetResult := GetUserStringFromBuffer(UserStr);
 if GetResult then ShowMessage(UserStr); // передается отосланная строка
 // ЦЕЛАЯ И БЕЗ МУСОРА!
 until not GetResult;
end;
Author: Camsonov Aleksandr
ID: 03568
Category:Связь
Category:Сокеты
Прочитать boot сектор

=== Прочитать boot сектор ===
Вообще-то загрузочный сектор можно прочитать вот так:
type
 TSector = array[0..511] of Byte;
var
 Boot: TSector;
begin
 ReadBoot(Drive, Boot);
Но учитывая разницу платформ 95, 98, Me и NT, 2000, XP можно сделать 2 процедуры, а в главной части проги вызывать необходимую:
// для 95, 98, Me
type
 TDiocRegisters = record
 EBX, EDX, ECX, EAX, EDI, ESI, Flags: LongWord;
 end;
 TVWin32CtlCode = (ccNone, ccVWin32IntIoctl, ccVWin32Int25,
 ccVWin32Int26, ccVWin32Int13);
function VWin32(CtlCode: TVWin32CtlCode; var Regs: TDiocRegisters): Boolean; // вспомогательная процедура
var
 Device: THandle;
 Count: LongWord;
begin
 Device := CreateFile('\.\VWIN32', 0, 0, nil, 0,
 FILE_FLAG_DELETE_ON_CLOSE, 0);
 if Device = INVALID_HANDLE_VALUE then
 raise Exception.Create(SysErrorMessage(GetLastError));
 try
 Result := DeviceIoControl(Device, Ord(CtlCode), @Regs,
 SizeOf(Regs), @Regs, SizeOf(Regs), Count, nil);
 finally
 CloseHandle(Device);
 end;
end;
// само чтение
procedure ReadBoot95(Drive: Char; var Boot: TSector);
var
 Regs: TDiocRegisters;
begin
 with Regs do
 begin
 EAX := Ord(UpCase(Drive)) - Ord('A');
 EBX := LongWord(@Boot);
 ECX := 1;
 EDX := 0;
 end;
 if not VWin32(ccVWin32Int25, Regs) then
 raise Exception.Create(SysErrorMessage(GetLastError))
end;
// для NT, 2000, XP попроще
type
 TSector = array[0..511] of Byte;
procedure ReadBootNT(Drive: Char; var Boot: TSector);
var
 BytesRead: Cardinal;
 H: THandle;
begin
 H := CreateFile(PChar(Format('\.\%s:', [UpCase(Drive)])),
 GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
 if H = INVALID_HANDLE_VALUE then
 raise Exception.Create(SysErrorMessage(GetLastError));
 try
 if not ReadFile(H, Boot, SizeOf(Boot), BytesRead, nil) then
 raise Exception.Create(SysErrorMessage(GetLastError));
 finally
 CloseHandle(H);
 end;
end;
// а юзать так
var
 Boot: TSector;
begin
 case Win32Platform of
 VER_PLATFORM_WIN32_WINDOWS:
 ReadBoot95(Drive, Boot);
 VER_PLATFORM_WIN32_NT:
 ReadBootNT(Drive, Boot);
 end;
end;
Boot и есть необходимый массив.
Author: startinger
Source: Взято из http://forum.sources.ru
ID: 01380
Прочитать свойства системы

=== Прочитать свойства системы ===
{
 The SYSTEM_INFO structure contains information about the current computer
 system. This includes the architecture and type of the processor, the number of
 processors in the system, the page size, and other such information.
}
procedure TForm1.Button1Click(Sender: TObject);
var
 SysInfo: TSystemInfo;
begin
 GetSystemInfo(SysInfo);
 with ListBox1.Items, SysInfo do
 begin
 Add('ProcessorArchitecture:' + IntToStr(wProcessorArchitecture));
 Add(FloatToStr(dwPageSize) + ' Kb page size');
 Add(Format('Lowest memory address accessible to applications and DLL - %p',
 [lpMinimumApplicationAddress]));
 Add(Format('Highest memory address accessible to applications and DLL - %p',
 [lpMaximumApplicationAddress]));
 Add('OEMID:' + IntToStr(dwOemId));
 Add('ActiveProcessorMask:' + IntToStr(dwActiveProcessorMask));
 Add(IntToStr(dwNumberOfProcessors) + ' - number of processors');
 Add('ProcessorType:' + IntToStr(dwProcessorType));
 case wProcessorLevel of
 3: Add('Intel 80386 processor level');
 4: Add('Intel 80486 processor level');
 5: Add('Intel Pentium processor level');
 end;
 Add(FloatToStr(dwAllocationGranularity / 1024) +
 ' Kb - granularity with which virtual memory is allocated');
 Add('ProcessorRevision:' + IntToStr(wProcessorRevision));
 end;
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01629
----
Часто при создании систем привязки программ к компьютеру или окон типа System Info или About Box необходимо определить данные о пользователе и о системе. Это можно сделать следующим образом (из примеров по Delphi - программа COA): 
var
 Buffer: Array[0..30] of Char; // Буфер под ASCIIZ строку
begin
 // Открыли библиотеку User
 hInstUser := LoadLibrary('USER');
 LoadString(hInstUser, 514, Buffer, 30);
 // Имя пользователя
 LabelUserName.Caption := StrPas(Buffer);
 LoadString(hInstUser, 515, Buffer, 30);
 FreeLibrary(hInstUser);
 // Компания
 LabelCompName.Caption := StrPas(Buffer);
 WinVer := GetVersion;
 // Версия Windows
 LabelWinVer.Caption := Format('Windows %u.%.2u',
 [LoByte(LoWord(WinVer)), HiByte(LoWord(WinVer))]);
 // Версия DOS
 LabelDosVer.Caption := Format('DOS %u.%.2u',
 [HiByte(HiWord(WinVer)), LoByte(HiWord(WinVer))]);
 WinFlags := GetWinFlags;
 // Режим
 if WinFlags AND WF_ENHANCED > 0 then
 LabelWinMode.Caption := '386 Enhanced Mode'
 else if WinFlags AND WF_PMODE > 0 then
 LabelWinMode.Caption := 'Standard Mode'
 else
 LabelWinMode.Caption := 'Real Mode';
 // Сопроцессор
 if WinFlags AND WF_80x87 > 0 then
 ValueMathCo.Caption := 'Present'
 else
 ValueMathCo.Caption := 'Absent';
 // Свободно ресурсов
 Fmt := GetFreeSystemResources(GFSR_SYSTEMRESOURCES);
 ValueFSRs.Caption := Format('%d%% Free', [Fmt1]);
 // Свободно памяти
 ValueMemory.Caption := FormatFloat(',#######', MemAvail DIV 1024) + ' KB Free';
end;
Source: http://delphiworld.narod.ru
ID: 01630