nyuuzyou/wikis huggingface dataset:
Сортировка строк с украинскими символами

{ **** UBPFD *********** by kladovka.net.ru ****
>> Сортировка строк с украинскими символами
Принцип работы функции такой же как и у стандартной функции CompareText из SysUtils. Поскольку для украинских символов строки сортируются этой функцией "как попало", то я решил написать свой CompareUkrText.
Зависимости: System
Автор: Алексей Глеб, noodlesf@mail.ru, Чернигов
Copyright: Собственное написание (Алексей Глеб)
Дата: 1 февраля 2003 г.
********************************************** }
unit UkrSort;
interface
function CompareUkrText(S1, S2: string): Integer;
var
 // массив, который заменит ASCI таблицу
 Chars: array[1..136] of Char =
 ('1','2','3','4','5','6','7','8','9','0','A','B','C','D','E','F','G',
 'H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X',
 'Y','Z','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',
 'p','q','r','s','t','u','v','w','x','y','z','А','Б','В','Г','Ґ','Д',
 'Е','Ё','Є','Ж','З','И','І','Ї','Й','К','Л','М','Н','О','П','Р','С',
 'Т','У','Ф','Х','Ц','Ч','Ш','Щ','Ъ','Ы','Ь','Э','Ю','Я','а','б','в',
 'г','ґ','д','е','ё','є','ж','з','и','і','ї','й','к','л','м','н','о',
 'п','р','с','т','у','ф','х','ц','ч','ш','щ','ъ','ы','ь','э','ю','я');
implementation
// сама функция
function CompareUkrText(S1, S2: string): Integer;
 // динам. функция получения номера символа из нашего массива
 function GetNum(C: Char): Integer;
 var
 i: Integer;
 begin
 Result := 0;
 for i := 1 to 136 do
 if Chars[i] = C then
 begin
 Result := i;
 Exit;
 end;
 end;
 // динам. функция определения "что больше???"
 function CompCh(C1, C2: Integer): Integer;
 begin
 if C1 = C2 then Result := 0;
 if C1 > C2 then Result := 1;
 if C1 < C2 then Result := -1;
 end;
var
 i, xS1, xS2, CurrR: Integer;
begin // начало функции сортировки
 Result := 0;
 CurrR := 0; // временный результат
 if S1 <> S2 then
 begin
 // сканирование строк посимвольно
 for i := 1 to Length(S1) do
 begin
 if Length(S2) >= i then
 begin
 xS1 := GetNum(S1[i]);
 xS2 := GetNum(S2[i]);
 if (xS1 <> 0) and (xS2 <> 0) and (xS1 <> xS2) then
 CurrR := CompCh(xS1, xS2)
 else
 begin
 if (xS1 = 0) or (xS2 = 0) then
 begin
 if xS2 = 0 then CurrR := 1;
 if xS1 = 0 then CurrR := -1;
 end;
 end;
 if CurrR <> 0 then
 begin
 Result := CurrR;
 Exit;
 end;
 end
 else
 begin
 Result := CurrR;
 Exit;
 end;
 end;
 end;
end;
end.
Пример использования:
function CustomSortProc(Item1, Item2: TListItem; ParamSort: Integer): Integer; stdcall;
begin
 Result := CompareUkrText(Item1.Caption, Item2.Caption);
end;
procedure TForm1.FormClick(Sender: TObject);
begin
 ListView1.CustomSort(@CustomSortProc, 0);
end;
Author: Алексей Глеб
ID: 04170
Category:Алгоритмы
Category:Сортировка
Сохранение TForm и ее свойств в BLOB-поле

=== Сохранение TForm и ее свойств в BLOB-поле ===
procedure SaveToField(FField: TBlobField; Form: TComponent);
var
 Stream: TBlobStream;
 FormName: string;
begin
 FormName := Copy(Form.ClassName, 2, 99);
 Stream := TBlobStream.Create(FField, bmWrite);
 try
 Stream.WriteComponentRes(FormName, Form);
 finally
 Stream.Free;
 end;
end;
procedure LoadFromField(FField: TBlobField; Form: TComponent);
var
 Stream: TBlobStream;
 I: integer;
begin
 try
 Stream := TBlobStream.Create(FField, bmRead);
 try
 { удаляем все компоненты }
 for I := Form.ComponentCount - 1 downto 0 do
 Form.Components[I].Free;
 Stream.ReadComponentRes(Form);
 finally
 Stream.Free;
 end;
 except
 on EFOpenError do
 { ничего };
 end;
end;
Source: Взято с http://delphiworld.narod.ru
ID: 02477
Сохранение бинарного файла в реестре с последующим его извлечением

=== Сохранение бинарного файла в реестре с последующим его извлечением ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Сохранение бинарного файла в реестре с последующим его извлечением
Функции позволяют разбить файл на блоки 16к и затем поместить бинарные
данные в реестр, а так же собрать эти данные обратно в файл при необходимости.
Не знаю зачем этот код нужен , но возможно он пригодится для скрытого
хранения данных . Не рекомендуется (!) сохранять слишком большие файлы
в реестре , потому что размеры реестра ограничены .
Зависимости: Registry,SysUtils
Copyright: KosilkA
Дата: 4 декабря 2003 г.
***************************************************** }
//////////////////////////////////////////////////
// функция разбивки и сохранения файла в реестр:
function SaveToRegistry(RootKey: HKEY; FileName, KeyName: string): Bool;
// где RootKey-раздел реестра,
// FileName-путь к файлу ,
// KeyName-ключ реестра в который будем сохранять
var
 FromF: file;
 NumRead, i: Integer;
 Buf: array[0..16383] of byte;
 reg: TRegistry;
begin
 try
 AssignFile(FromF, FileName);
 Reset(FromF, 1);
 reg := TRegistry.Create;
 reg.RootKey := RootKey;
 if reg.OpenKey(KeyName, True) = False then
 begin
 // если невозможно открыть ключ с правами записи , то что то не так
 Result := False;
 reg.Free;
 exit; // выходим
 end;
 i := 0;
 repeat // читаем и записываем в цикле
 BlockRead(FromF, Buf, SizeOf(Buf), NumRead); // читаем блок из файла
 if NumRead <> 0 then
 begin
 reg.WriteBinaryData(IntToStr(i), buf, NumRead); // сохраняем блок в реестр
 Inc(i);
 end;
 until (NumRead = 0);
 CloseFile(FromF);
 reg.CloseKey;
 reg.Free;
 Result := True;
 except
 reg.CloseKey;
 reg.Free;
 Result := False;
 end;
end;
//////////////////////////////////////////////////
// функция сборки сохраненного файла:
function BuildFromRegistry(RootKey: HKEY; KeyName, ToFileName: string): Bool;
// где RootKey - раздел реестра,
// KeyName - ключ реестра,
// ToFileName - имя выходного файла.
var
 NumWritten, i: Integer;
 ToF: file;
 Buf: array[0..16383] of byte;
 reg: TRegistry;
begin
 try
 AssignFile(ToF, ToFileName);
 Rewrite(ToF, 1);
 reg := TRegistry.Create;
 reg.RootKey := RootKey;
 if not reg.OpenKey(KeyName, True) then
 begin
 // если указанный ключ невозможно открыть - выходим
 Result := False;
 reg.Free;
 exit;
 end;
 i := 0;
 repeat
 // в цикле находим значения начиная с "0", читаем их
 // и добавляем блоки к файлу
 if reg.ValueExists(IntToStr(i)) then
 begin
 reg.ReadBinaryData(IntToStr(i), buf, reg.GetDataSize(InTtoStr(i)));
 BlockWrite(ToF, Buf, reg.GetDataSize(IntToStr(i)));
 end;
 Inc(i);
 until not reg.ValueExists(IntToStr(i));
 CloseFile(ToF);
 reg.CloseKey;
 reg.Free;
 Result := True;
 except
 reg.CloseKey;
 reg.Free;
 Result := False;
 end;
end;
// Пример использования:
// сохранить:
SaveToRegistry(HKEY_CURRENT_USER, Application.ExeName, '\Software\MyData\test');
// извлечь:
BuildFromRegistry(HKEY_CURRENT_USER, '\Software\MyData\test', 'MyBuildApp.exe');
Author: Sergey, gloom@imail.ru, Koenigsberg
Source: http://delphibase.endimus.com
ID: 02291
Сохранение всего содержимого буфера обмена в файл

=== Сохранение всего содержимого буфера обмена в файл ===
Из рассылки "Мастера DELPHI. Новости мира компонент,..."
var
 fs: TFileStream;
procedure TForm1.bClearClick(Sender: TObject);
begin
 OpenClipBoard(0);
 EmptyClipboard;
 CloseClipBoard;
end;
procedure TForm1.BSaveClick(Sender: TObject);
var
 CBF: Cardinal;
 CBFList: TList;
 i: Integer;
 h: THandle;
 p: Pointer;
 CBBlockLength, Temp: Cardinal;
 FS: TFileStream;
begin
 if OpenClipBoard(0)then
 begin
 CBFList := TList.Create;
 CBF := 0;
 repeat
 CBF := EnumClipboardFormats(CBF);
 if CBF <> 0 then
 CBFList.Add(Pointer(CBF));
 until CBF = 0;
 // Edit1.Text := IntToStr(CBFList.Count);
 if CBFList.Count > 0 then
 begin
 FS := TFileStream.Create('e:\cp.dat', fmCreate);
 Temp := CBFList.Count;
 FS.Write(Temp, SizeOf(Integer));
 for i := 0 to CBFList.Count-1 do
 begin
 h := GetClipboardData(Cardinal(CBFList[i]));
 if h > 0 then
 begin
 CBBlockLength := GlobalSize(h);
 if h > 0 then
 begin
 p := GlobalLock(h);
 if p <> nil then
 begin
 Temp := Cardinal(CBFList[i]);
 FS.Write(Temp, SizeOf(Cardinal));
 FS.Write(CBBlockLength, SizeOf(Cardinal));
 FS.Write(p^, CBBlockLength);
 end;
 GlobalUnlock(h);
 end;
 end;
 end;
 FS.Free;
 end;
 CBFList.Free;
 CloseClipBoard;
 end;
end;
procedure TForm1.bLoadClick(Sender: TObject);
var
 h: THandle;
 p: Pointer;
 CBF: Cardinal;
 CBBlockLength: Cardinal;
 i, CBCount: Integer;
 FS: TFileStream;
begin
 if OpenClipBoard(0)then
 begin
 FS := TFileStream.Create('e:\cp.dat', fmOpenRead);
 if FS.Size = 0 then Exit;
 FS.Read(CBCount, SizeOf(Integer));
 if CBCount = 0 then Exit;
 for i := 1 to CBCount do
 begin
 FS.Read(CBF, SizeOf(Cardinal));
 FS.Read(CBBlockLength, SizeOf(Cardinal));
 h := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, CBBlockLength);
 if h > 0 then
 begin
 p := GlobalLock(h);
 if p = nil then
 GlobalFree(h)
 else
 begin
 FS.Read(p^, CBBlockLength);
 GlobalUnlock(h);
 SetClipboardData(CBF, h);
 end;
 end;
 end;
 FS.Free;
 CloseClipBoard;
 end;
end;
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 01891
ID: 01892
Сохранение данных в Clipboard

=== Сохранение данных в Clipboard ===
Мне нужно использовать clipboard для сохранения данных в собственном формате и я хочу для этого написать набор процедур ввода/вывода с использованием потоков (streams). Возможно ли создать объект TMemoryStream, заполнить его и поместить в Clipboard? 
Не только возможно, именно так поступают функции Clipboard.GetComponent и Clipboard.SetComponent. Сначала вы должны зарегистрировать свой собственный формат данных для Clipboard с помощью функции RegisterClipboardFormat: 
 CF_MYFORMAT := RegisterClipboardFormat('My Format Description');
Далее вы должны выполнить шаги: 
# Создать поток (memory stream) и записать туда данные.
# Создать глобальный буфер в памяти и скопировать поток туда.
# Вызвать Clipboard.SetAsHandle(), чтобы поместить буфер в Clipboard. 
Пример: 
var
 hBuf: THandle;
 Bufptr: Pointer;
 MStream: TMemoryStream;
begin
 MStream := TMemoryStream.Create;
 try
 { write your data to the stream }
 hBuf := GlobalAlloc(GMEM_MOVEABLE, MStream.Size);
 try
 BufPtr := GlobalLock(hBuf);
 try
 Move(MStream.Memory^, BufPtr^, MStream.Size);
 Clipboard.SetAsHandle(CF_MYFORMAT, hBuf);
 finally
 GlobalUnlock(hBuf);
 end;
 except
 GlobalFree(hBuf);
 raise;
 end;
 finally
 MStream.Free;
 end;
end;
Внимание: не уничтожайте буфер, созданный с GlobalAlloc. Поскольку вы поместили его в Clipboard, это уже дело clipboard'а его уничтожить. Опять же, получая буфер из Clipboard, не уничтожайте этот буфер - просто сделайте копию содержимого. 
Для обратного получения потока и данных, сделайте что-нибудь вроде этого: 
var
 hBuf: THandle;
 BufPtr: Pointer;
 MStream: TMemoryStream;
begin
 hBuf := Clipboard.GetAsHandle(CF_MYFORMAT);
 if hBuf <> 0 then
 begin
 BufPtr := GlobalLock(hBuf);
 if BufPtr <> nil then
 try
 MStream := TMemoryStream.Create;
 try
 MStream.WriteBuffer(BufPtr^, GlobalSize(hBuf));
 MStream.Position := 0;
 { read your data from the stream }
 finally
 MStream.Free;
 end;
 finally
 GlobalUnlock(hBuf);
 end;
 end;
end;
Source: http://delphiworld.narod.ru/
ID: 01883
Сохранение данных из ListView в *.xls

{ **** UBPFD *********** by kladovka.net.ru ****
>> Сохранение данных из ListView в *.xls
Сохранение данных из ListView в *.xls
Зависимости: ComObj
Автор: dDan, ddan2002@mail.ru
Copyright: dDan
Дата: 3 декабря 2003 г.
********************************************** }
procedure ListToExcel(ListView: TListView);
var
 row, i: Integer;
 Range, Sheet: VAriant;
begin
 try
 Excel := CreateOleObject('Excel.Application');
 except
 raise Exception.Create('Невозможно подключиться к серверу Excel');
 end;
 Screen.Cursor := crHourGlass;
 Excel.SheetsInNewWorkBook := 1;
 Excel.WorkBooks.Add;
 Sheet := Excel.Workbooks[1].Sheets[1];
 Range := Sheet.Columns;
 Range.Columns[1].ColumnWidth := 30; // Количество Столбцов и их ширина
 Range.Columns[n].ColumnWidth := 30;
 Range.Columns[n+1].ColumnWidth := 30;
 Range.Columns.Font.Size := 8;
 Range := Sheet.Range['a1:f1'];
 Range.Font.Size := 15;
 Range.Font.Bold := True;
 Range.Columns.Interior.ColorIndex := 6;
 Range.HorizontalAlignment := 3;
 Sheet.Cells[1,2] := 'Данные на ' + DateToStr(Date); // Заголовок
 Range := Sheet.Range['a2:f2'];
 Range.Font.Size := 10;
 Range.Font.Bold := True;
 Sheet.Cells[2,1] := 'АА'; // Названия столбцов
 Sheet.Cells[2,n] := 'ББ';
 Sheet.Cells[2,n+1] := 'вв';
 Row := 3;
 for i := 0 to List.Items.Count-1 do
 begin
 Sheet.Cells[Row, 1] := ListView.Items.Item[i].Caption;
 Sheet.Cells[Row, 2] := ListView.Items.Item[i].SubItems[n];
 Sheet.Cells[Row, 3] := ListView.Items.Item[i].SubItems[n+1];
 Inc(Row);
 end;
 Screen.Cursor := crDefault;
 if SaveDialog.Execute then
 Excel.WorkBooks[1].SaveAs(exs.FileName); // Сохраняем
 Excel.Visible := True; // Показываем Excel
end;
Author: dDan
ID: 04407
Category:COM
Category:MS Office
Сохранение и загрузка двумерного динамического массива

=== Сохранение и загрузка двумерного динамического масива ===
type
 T2DBooleanArray = array of array of Boolean;
procedure Save2DBooleanArray(const A: T2DBooleanArray; S: TStream);
var
 writer: TWriter;
 i: Integer;
begin
 Assert(Assigned(S));
 writer := TWriter.Create(S, 8096);
 try
 writer.WriteInteger(Length(A));
 for i := 0 to Length(A) - 1 do
 begin
 writer.WriteInteger(Length(A[i]));
 writer.Write(A[i, 0], Length(A[i]) * sizeof(A[i, 0]));
 end; { For }
 finally
 writer.Free;
 end; { Finally }
end;
procedure Load2DBooleanArray(var A: T2DBooleanArray; S: TStream);
var
 reader: TReader;
 i, numrows, numcols: Integer;
begin
 Assert(Assigned(S));
 reader := TReader.Create(S, 8096);
 try
 numrows := reader.ReadInteger;
 SetLength(A, numrows);
 for i := 0 to numrows - 1 do
 begin
 numcols := reader.ReadInteger;
 SetLength(A[i], numcols);
 reader.Read(A[i, 0], numcols * sizeof(A[i, 0]));
 end; { For }
 finally
 reader.Free;
 end; { Finally }
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 00250
Сохранение и чтение TStringGrid

=== Сохранение и чтение TStringGrid ===
procedure SaveGrid;
var
 f: textfile;
 x, y: integer;
begin
 AssignFile(f, 'Filename');
 Rewrite(f);
 WriteLn(f, StringGrid.ColCount);
 WriteLn(f, StringGrid.RowCount);
 for X := 0 to StringGrid.ColCount - 1 do
 for y := 0 to StringGrid.RowCount - 1 do
 WriteLn(F, StringGrid.Cells[x, y]);
 CloseFile(f);
end;
procedure LoadGrid;
var
 f: textfile;
 temp, x, y: integer;
 tempstr: string;
begin
 AssignFile(f, 'Filename');
 Reset(f);
 ReadLn(f, temp);
 StringGrid.ColCount := temp;
 ReadLn(f, temp);
 StringGrid.RowCount := temp;
 for X := 0 to StringGrid.ColCount - 1 do
 for y := 0 to StringGrid.RowCount - 1 do
 begin
 ReadLn(F, tempstr);
 StringGrid.Cells[x, y] := tempstr;
 end;
 CloseFile(f);
end;
Source: http://delphiworld.narod.ru/
ID: 01058
----
// Save a TStringGrid to a file 
procedure SaveStringGrid(StringGrid: TStringGrid; const FileName: TFileName);
var
 f: TextFile;
 i, k: Integer;
begin
 AssignFile(f, FileName);
 Rewrite(f);
 with StringGrid do
 begin
 // Write number of Columns/Rows 
 Writeln(f, ColCount);
 Writeln(f, RowCount);
 // loop through cells 
 for i := 0 to ColCount - 1 do
 for k := 0 to RowCount - 1 do
 Writeln(F, Cells[i, k]);
 end;
 CloseFile(F);
end;
// Load a TStringGrid from a file 
procedure LoadStringGrid(StringGrid: TStringGrid; const FileName: TFileName);
var
 f: TextFile;
 iTmp, i, k: Integer;
 strTemp: String;
begin
 AssignFile(f, FileName);
 Reset(f);
 with StringGrid do
 begin
 // Get number of columns 
 Readln(f, iTmp);
 ColCount := iTmp;
 // Get number of rows 
 Readln(f, iTmp);
 RowCount := iTmp;
 // loop through cells & fill in values 
 for i := 0 to ColCount - 1 do
 for k := 0 to RowCount - 1 do
 begin
 Readln(f, strTemp);
 Cells[i, k] := strTemp;
 end;
 end;
 CloseFile(f);
end;
// Save StringGrid1 to 'c:\temp.txt': 
procedure TForm1.Button1Click(Sender: TObject);
begin
 SaveStringGrid(StringGrid1, 'c:\temp.txt');
end;
// Load StringGrid1 from 'c:\temp.txt': 
procedure TForm1.Button2Click(Sender: TObject);
begin
 LoadStringGrid(StringGrid1, 'c:\temp.txt');
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01059
Сохранение и чтение файлов в BLOB-полях

=== Сохранение и чтение файлов в BLOB-полях ===
// Загружаем из файла в блоб
procedure TForm1.Button1Click(Sender: TObject);
var
 blob: TBlobStream;
begin
 blob := yourDataset.CreateBlobStream(yourDataset.FieldByName('YOUR_BLOB'), bmWrite);
 try
 blob.Seek(0, soFromBeginning);
 fs := TFileStream.Create('c:\your_name.doc', fmOpenRead or fmShareDenyWrite);
 try
 blob.CopyFrom(fs, fs.Size)
 finally
 fs.Free
 end;
 finally
 blob.Free
 end;
end;
// Сохраняем из блоба в файл
procedure TForm1.Button1Click(Sender: TObject);
var
 blob: TBlobStream;
begin
 blob := yourDataset.CreateBlobStream(yourDataset.FieldByName('YOUR_BLOB'), bmRead);
 try
 blob.Seek(0, soFromBeginning);
 with TFileStream.Create('c:\your_name.doc', fmCreate) do
 try
 CopyFrom(blob, blob.Size)
 finally
 Free
 end;
 finally
 blob.Free
 end;
end;
Source: Взято с http://delphiworld.narod.ru
ID: 02476
Сохранение изображения экрана в файле

=== Сохранение изображения экрана в файле ===
На форме у меня стоит TImage (его можно сделать невидимым) 
var
 Dwh: HWND;
 DRect: TRect;
 DescDC: HDC;
 Canv: TCanvas;
 imgJPG: TJPEGImage;
begin
 try
 imgJPG := TJPEGImage.create;
 try
 Canv := TCanvas.Create();
 imgJPG.CompressionQuality := 100;
 Image.Width := Screen.Width;
 Image.Height := Screen.Height;
 DWH := GetDesktopWindow;
 GetWindowRect(DWH, DRect);
 DescDC := GetDeviceContext(DWH);
 Canv.Handle := DescDC;
 DRect.Left := 0;
 DRect.Top := 0;
 DRect.Right := Screen.Width;
 DRect.Bottom := Screen.Height;
 Image.Canvas.CopyRect(DRect, Canv, DRect);
 imgJPG.Assign(Image.Picture.Bitmap);
 ImgJPG.SaveToFile('M:\MyFile.jpg');
 Canv.Free;
 finally
 imgJPG.Free;
 end;
 except
 end;
end;
program ScrShop;
uses
 Windows;
procedure ApiScrCapture(FileName: string);
type
 TScr = array [0..1] of byte;
 PScr = ^TScr;
var
 hBmp: hBitmap;
 DeskDC: hDC;
 DC: hDC;
 BFH: BITMAPFILEHEADER;
 BIH: tagBITMAPINFO;
 ScrX, ScrY: integer;
 F: file;
 ScrSize: Cardinal;
 Bits: PScr;
begin
 SCRX := GetSystemMetrics(SM_CXSCREEN);
 SCRY := GetSystemMetrics(SM_CYSCREEN);
 ScrSize := ScrX * ScrY * 3;
 GetMem(Bits, ScrSize);
 DeskDC := GetDC(0);
 hBmp := CreateCompatibleBitmap(DeskDC, ScrX, ScrY);
 DC := CreateCompatibleDC(DeskDC);
 SelectObject(DC, hbmp);
 BitBlt(DC, 0, 0, SCRX, SCRY, DeskDC, 0, 0, SrcCopy);
 with BFH do
 begin
 bfType := $4D42;
 bfSize := SCRX * SCRY * 3 + SizeOf(BFH) + SizeOf(BIH);
 bfReserved1 := 0;
 bfReserved2 := 0;
 bfOffBits := SizeOf(BFH) + SizeOf(BIH);
 end;
 with BIH.bmiHeader do
 begin
 biSize := sizeof(BIH);
 biWidth := SCRX;
 biHeight := SCRY;
 biPlanes := 1;
 biBitCount := 24;
 biCompression := BI_RGB;
 biSizeImage := ScrSize;
 biClrImportant := 0;
 end;
 GetDiBits(DC, hbmp, 0, SCRY, Bits, BIH, DIB_RGB_COLORS);
 DeleteObject(hbmp);
 AssignFile(F, FileName);
 Rewrite(F, 1);
 Blockwrite(F, BFH, SizeOf(BFH));
 Blockwrite(F, BIH, SizeOf(BIH));
 Blockwrite(F, bits^, ScrSize);
 CloseFile(F);
 FreeMem(Bits);
end;
begin
 ApiScrCapture('1.bmp');
end.
Author: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
Source: Взято из http://forum.sources.ru
ID: 01845
----
procedure TForm1.Button1Click(Sender: TObject);
var
 DC: HDC;
 Canva: TCanvas;
 B: TBitmap;
begin
 Canva := TCanvas.Create;
 B := TBitmap.Create;
 DC := GetDC(0);
 try
 Canva.Handle := DC;
 with Screen do
 begin
 B.Width := Width;
 B.Height := Height;
 B.Canvas.CopyRect(Rect(0, 0, Width, Height),
 Canva, Rect(0, 0, Width, Height));
 B.SaveToFile('c:\Мои документы\screentofile.bmp');
 end
 finally
 ReleaseDC(0, DC);
 B.Free;
 Canva.Free
 end
end;
Source: http://delphiworld.narod.ru/
ID: 01846
Сохранение массива c изображениями

=== Сохранение массива c изображениями ===
Я решил проблему записи массива TBitmap в файл и его повторного чтения. 
Идея заключается в загрузке каждого TBitmap во временный TMemoryStream. Член TMemoryStream.Size информирует о размере данных, которые нужно сохранить на диске. Затем мы пишем размер и сопровождаем его данными типа TFileStream. Эту манипуляцию мы проделываем для каждого TBitmap в массиве. 
Для процедуры чтения сначала мы должны считать из потока размер данных TBitmap. Затем мы распределяем область для типа TMemoryStream полученного размера и считываем данные. Затем переписываем из TFileStream в TMemoryStream. И, наконец, мы читает из TMemoryStream сам TBitmap. Эту манипуляцию мы проделываем для каждого TBitmap в массиве. 
Ниже я привел код, который я реально использовал. Код из игры Bingo, которую я разрабатываю, имеет сетку 5x5, чьи ячейки содержат изображение. 
Реализация алгоритма весьма медленна, поэтому если вы имеете или найдете более быстрый алгоритм, пожалуйста, уведомите меня об этом. Если у вас есть любые вопросы, пожалуйста, свяжитесь со мной.
procedure TMainForm.SaveBoard;
var
 MemoryStream: TMemoryStream;
 FileStream: TFileStream;
 Writer: TWriter;
 Buffer: Pointer;
 Size: Longint;
 Column: Integer;
 Row: Integer;
begin
 MemoryStream := TMemoryStream.Create;
 FileStream := TFileStream.Create(SaveFilename, fmCreate);
 Writer := TWriter.Create(FileStream, $1000);
 try
 for Column := 0 to 4 do
 for Row := 0 to 4 do
 begin
 MemoryStream.Clear;
 Bitmaps[Column, Row].SaveToStream(MemoryStream);
 Buffer := MemoryStream.Memory;
 Size := MemoryStream.Size;
 Writer.WriteInteger(Size);
 Writer.Write(Buffer^, Size);
 end;
 finally
 Writer.Free;
 FileStream.Free;
 MemoryStream.Free;
 end;
end;
procedure TMainForm.Open1Click(Sender: TObject);
var
 MemoryStream: TMemoryStream;
 FileStream: TFileStream;
 Buffer: Pointer;
 Reader: TReader;
 Column: Integer;
 Row: Integer;
 Size: Longint;
begin
 OpenDialog2.Filename := SaveFilename;
 if not OpenDialog2.Execute then
 Exit;
 MemoryStream := TMemoryStream.Create;
 FileStream := TFileStream.Create(OpenDialog2.Filename, fmOpenRead);
 Reader := TReader.Create(FileStream, $1000);
 try
 for Column := 0 to 4 do
 for Row := 0 to 4 do
 begin
 Size := Reader.ReadInteger;
 MemoryStream.SetSize(Size);
 Buffer := MemoryStream.Memory;
 Reader.Read(Buffer^, Size);
 Bitmaps[Column, Row].LoadFromStream(MemoryStream);
 end;
 finally
 Reader.Free;
 FileStream.Free;
 MemoryStream.Free;
 end;
 DrawGrid1.Repaint;
 SaveFilename := OpenDialog2.Filename;
 Caption := 'Bingo-создатель - ' + ExtractFilename(SaveFilename);
end;
Author: Michael Vincze
Source: http://delphiworld.narod.ru
ID: 00245
Сохранение типа данных множество (TFontStyles)

=== Сохранение типа данных множество (TFontStyles) ===
{ You do that simple by converting it to an integer, and then stores that: }
 type
 pFontStyles = ^TFontStyles;
 pInteger = ^integer;
 function FontStylesToInteger(const Value: TFontStyles): integer;
 begin
 Result := pInteger(@Value)^;
 end;
 function IntegerToFontStyles(const Value: integer): TFontStyles;
 begin
 Result := pFontStyles(@Value)^;
 end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 00782
Сохранить F1Book в Blob поле

=== Сохранить F1Book в Blob поле ===
uses vcf1, dbtables;
procedure SaveSpreadsheet(F1Book: TF1Book);
var
 BlobStream: TBlobStream;
 MyBlob: HGlobal;
 pblob: Pointer;
begin
 with Datamodule1.Query1 do
 begin
 Set8087CW($133f);
 try
 Application.ProcessMessages;
 F1Book.SaveWindowInfo;
 MyBlob := GlobalAlloc(GMEM_MOVEABLE, 2000);
 try
 F1Book.WriteToBlob(MyBlob, 0);
 pBlob := globalLock(MyBlob);
 try
 Blobstream := TBlobStream.Create(TBlobField(FieldByName('QUOTE_BLOB')),
 bmWrite);
 try
 Blobstream.Write(pBlob^, GlobalSize(myBlob));
 finally
 Blobstream.Free;
 end;
 finally
 globalUnlock(MyBlob);
 end;
 F1book.IF1Book_Modified := False;
 finally
 globalFree(myblob);
 end;
 finally
 Set8087CW(Default8087CW);
 Application.ProcessMessages;
 end;
 end;
end;
//Depending on your Delphi Version (<D4), you will need:
var
 Default8087CW: Word = $1332;
procedure Set8087CW(NewCW: Word);
asm
 MOV Default8087CW,AX
 FLDCW Default8087CW
end;
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 02482