nyuuzyou/wikis huggingface dataset:
Загрузить все записи в Stringlist одним махом?

=== Загрузить все записи в Stringlist одним махом? ===
Loading millions of records into a stringlist can be very slow }
procedure TForm1.SlowLoadingIntoStringList(StringList: TStringList);
begin
 StringList.Clear;
 with SourceTable do
 begin
 Open;
 DisableControls;
 try
 while not EOF do
 begin
 StringList.Add(FieldByName('OriginalData').AsString);
 Next;
 end;
 finally
 EnableControls;
 Close;
 end;
 end;
end;
{ This is much, much faster }
procedure TForm1.QuickLoadingIntoStringList(StringList: TStringList);
begin
 with CacheTable do
 begin
 Open;
 try
 StringList.Text := FieldByName('Data').AsString;
 finally
 Close;
 end;
 end;
end;
{ How can this be done?
 In Microsoft SQL Server 7, you can write a stored procedure that updates every night
 a cache table that holds all the data you want in a single column and row.
 In this example, you get the data from a SourceTable and put it all in a Cachetable.
 The CacheTable has one blob column and must have only one row.
 Here it is the SQL code: }
CREATE TABLE CacheTable
(Data Text NULL)
GO
Create
procedure PopulateCacheTable as
begin
 set NOCOUNT on
 DECLARE @ptrval binary(16), @Value varchar(600) - - a good Value for the expected maximum Length
 - - You must set 'select into/bulkcopy' option to True in order to run this sp
 DECLARE @dbname nvarchar(128)
 set @dbname = db_name()
 EXEC sp_dboption @dbname, 'select into/bulkcopy', 'true'
 - - Declare a cursor
 DECLARE scr CURSOR for
 SELECT OriginalData + char(13) + char(10) - - each line in a TStringList is separated by a #13#10
 FROM SourceTable
 - - The CacheTable Table must have only one record
 if EXISTS (SELECT * FROM CacheTable)
 Update CacheTable set Data = ''
 else
 Insert CacheTable VALUES()
 - - Get a Pointer to the field we want to Update
 SELECT @ptrval = TEXTPTR(Data) FROM CacheTable
 Open scr
 FETCH Next FROM scr INTO @Value
 while @ @FETCH_STATUS = 0
 begin
 - - This UPDATETEXT appends each Value to the end of the blob field
 UPDATETEXT CacheTable.Data @ptrval NULL 0 @Value
 FETCH Next FROM scr INTO @Value
 end
 Close scr
 DEALLOCATE scr
 - - Reset this option to False
 EXEC sp_dboption @dbname, 'select into/bulkcopy', 'false'
end
GO
You may need to increase the BLOB SIZE parameter if you use BDE
Source: Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 02644
Загрузка 256-цветного TBitmap

Windows не очень полезен, когда мы имеем дело с 256-цветными изображениями. Что делаю я (поскольку думаю, что это самый простой метод): я создаю в памяти изображение таким образом, чтобы TBitmap.LoadFromStream мог "принять" его. Данным методом я загружаю "сырой" ресурс изображения и размещаю его, используя информационный заголовок файла изображения. Вот потомок TBitmap, инкапсулирующий вышесказанное:
type
 TMyBitmap = class(TBitmap)
 public
 procedure Load256ColorBitmap(Instance: THandle; BitmapName: PChar);
 end;
procedure TMyBitmap.Load256ColorBitmap(Instance: THandle; BitmapName: PChar);
var
 HDib: THandle;
 Size: LongInt;
 Info: PBitmapInfo;
 FileHeader: TBitmapFileHeader;
 S: TMemoryStream;
begin
 HDib := LoadResource(Instance, FindResource(Instance, BitmapName, RT_BITMAP));
 if HDib <> 0 then
 begin
 Info := LockResource(HDib);
 Size := GetSelectorLimit(Seg(Info^)) + SizeOf(TBitmapFileHeader);
 with FileHeader do
 begin
 bfType := $4D42;
 bfSize := Size;
 bfReserved1 := 0;
 bfReserved2 := 0;
 bfOffBits := SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader);
 case Info^.bmiHeader.biBitCount of
 1: bfOffBits := bfOffBits + 2 * 4;
 4: bfOffBits := bfOffBits + 16 * 4;
 8: bfOffBits := bfOffBits + 256 * 4;
 end;
 end;
 S := TMemoryStream.Create;
 try
 S.SetSize(Size);
 S.Write(FileHeader, SizeOf(TBitmapFileHeader));
 S.Write(Info^, Size - SizeOf(TBitmapFileHeader));
 S.Position := 0;
 LoadFromStream(S);
 finally
 S.Free;
 FreeResource(HDib);
 end;
 end
 else
 raise EResNotFound.Create(Format('Не могу найти ресурс изображения %s', [BitmapName]));
end;
Вот как можно это использовать:
Image1.Picture.Bitmap := TMyBitmap.Create;
TMyBitmap(Image1.Picture.Bitmap).Load256ColorBitmap(hInstance, 'BITMAP_1');
Author: Steve Schafer 
Source: http://delphiworld.narod.ru
ID: 03773
Category:Графика
Category:Bitmap
Загрузка Bitmap из .res без потери палитры

procedure LoadGraphic(naam: string);
var
 HResInfo: THandle;
 BMF: TBitmapFileHeader;
 MemHandle: THandle;
 Stream: TMemoryStream;
 ResPtr: PByte;
 ResSize: Longint;
 tmp: array [0..8] of Char;
begin
 StrPCopy(tmp, naam);
 HResInfo := FindResource(HInstance, tmp, RT_Bitmap);
 ResSize := SizeofResource(HInstance, HResInfo);
 MemHandle := LoadResource(HInstance, HResInfo);
 ResPtr := LockResource(MemHandle);
 Stream := TMemoryStream.Create;
 try
 Stream.SetSize(ResSize + SizeOf(BMF));
 BMF.bfType := $4D42;
 Stream.Write(BMF, SizeOf(BMF));
 Stream.Write(ResPtr^, ResSize);
 Stream.Seek(0, 0);
 Bitmap := TBitmap.Create;
 Bitmap.LoadFromStream(Stream);
 finally
 Stream.Free;
 end;
 FreeResource(MemHandle);
end;
Source: http://delphiworld.narod.ru
ID: 03772
Category:Графика
Category:Bitmap
Загрузка JPEG из ресурсов

uses Jpeg;
{$R test.res}
function LoadJpegRes(const ID: string): TJpegImage;
var
 RS: TResourceStream;
begin
 Result := TJpegImage.Create;
 RS := TResourceStream.Create(HInstance, ID, RT_RCDATA);
 try
 RS.Seek(0, soBeginning);
 Result.LoadFromStream(RS);
 finally
 RS.Free;
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 MyJpeg: TJpegImage;
begin
 MyJpeg := LoadJpegRes('MYJPEG');
 Image1.Canvas.Draw(0, 0, MyJpeg);
end;
Для JPEG, загнанного в ресурсы таким образом:
 MYJPEG RCDATA "Test.jpg"
Author: Smike
Source: http://forum.sources.ru
ID: 03794
Category:Графика
Category:Jpeg
Загрузка ini-файла в TTreeView

=== Загрузка ini-файла в TTreeView ===
procedure LoadIniToTree(const FName: string; Tree: TTreeView);
var
 LS, LV: TStrings;
 i, j: integer;
 root: TTreeNode;
 n: string;
 p: PString;
begin
 Tree.Items.Clear; // очищаем дерево
 with TIniFile.Create(FName) do // пытаемся открыть файл FName
 try
 LS := TStringList.Create; // список названий секций
 try
 ReadSections(LS); // читаем все секции в список
 LV := TStringList.Create; // список пар "имя=значение"
 try
 for i := 0 to LS.Count-1 do // для всех секций...
 begin
 LV.Clear; // подготовим список
 ReadSectionValues(LS[i], LV); // читаем список пар "имя=значение" для текущей секции
 root := Tree.Items.Add(nil, LS[i]); // добавляем корневой узел (имя текущей секции)
 for j := 0 to LV.Count-1 do // для всех пар "имя=значение"...
 begin
 n := LV.Names[j]; // выделяем "имя"
 // добавляем дочерний по отношению к root узел,
 // в качестве текста исп. "имя"
 // в качестве значения поля Data = "значение"
 New(p);
 p^ := LV.Values[n];
 Tree.Items.AddChildObject(root, n, p);
 end;
 end;
 finally
 LV.Free;
 end;
 finally
 LS.Free;
 end;
 finally
 Free; // корректно уничтожаем объект TIniFile
 end;
end;
// Применение:
procedure TForm1.TreeView1Change(Sender: TObject; Node: TTreeNode);
begin
 if (TreeView1.Selected <> nil) and (TreeView1.Selected.Parent <> nil) then
 begin
 Edit1.Text := TreeView1.Selected.Text;
 Edit2.Text := String(TreeView1.Selected.Data^);
 end else
 begin
 Edit1.Text := ;
 Edit2.Text := ;
 end;
end;
// После использования не забыть освободить память, напр. так:
procedure TForm1.TreeView1Deletion(Sender: TObject; Node: TTreeNode);
begin
 if Node.Data <> nil then
 Dispose(PString(Node.Data));
end;
Author: Dynamic
ID: 00636
Загрузка иконки

=== Загрузка иконки ===
Если ваша иконка хранится в компоненте Image (видимым или иным способом), вы можете написать:
Application.Icon := Image1.Picture.Icon;
Если в файле ресурса:
Application.Icon.Handle := LoadIcon(hInstance, 'ICONNAME');
В любом случае для форсирования показа иконки необходимо вызвать следующую функцию:
InvalidateRect(Application.Handle, NIL, True);
.. и новая иконка предстанет свету.
Иконка, расположенная в .RES-файле, должна быть видима в .EXE-файле, к примеру, при просмотре файла посредством Program Manager. Иконка, расположенная в компоненте Image, в этом случае не видна.
Source: http://delphiworld.narod.ru/
ID: 02356
Загрузка нескольких RTF файлов в RichEdit

=== Загрузка нескольких RTF файлов в RichEdit ===
// Кидаем на форму RichEdit1, Button1, OpenDialog1
// и по клику кнопки создаём следующую процедуру:
procedure TForm1.Button1Click(Sender: TObject);
var
 i, nFiles: integer;
 FileNames, UnitedText, Separator, Tmp: string;
 TextStream: TStringStream;
begin
 TextStream := TStringStream.Create();
 // это разделитель между выводимыми файлами, в данном случае - 3 параграфа
 Separator := '\par \par \par ';
 UnitedText := ;
 // что бы можно было выбрать несколько файлов
 OpenDialog1.Options := OpenDialog1.Options + [ofAllowMultiSelect];
 // предусмотрительно увеличиваем максимальный объём загружаемых данных в RichEdit1
 RichEdit1.MaxLength := $7FFFFFF0;
 try // а вдруг что..
 if OpenDialog1.Execute then
 begin
 nFiles := OpenDialog1.Files.count - 1;
 for i := 0 to nFiles do
 begin
 // открываем каждый файл поочереди в RichEdit1
 FileNames := OpenDialog1.Files.Strings[i];
 RichEdit1.Lines.LoadFromFile(FileNames);
 // и записываем данные уже оттуда в поток TextStream,
 RichEdit1.Lines.SaveToStream(TextStream);
 // а из потока во временную переменную Tmp типа String
 Tmp := TextStream.DataString;
 // ставим указатель в потоке на 0
 TextStream.Position := 0;
 // проверяем - является ли данный файл первым, последним,
 // или между ними, в зависимости от этого удаляем управляющие
 // символы начала или окончания RTF-файла и всталяем разделитель.
 // дело в том, что каждый RTF-файл начинаетcz c символа '{' и заканчивается '}'.
 if i = 0 then
 Tmp := Copy(Tmp, 0, Length(Tmp) - 5)
 else if i = nFiles then
 Tmp := Separator + Copy(Tmp, 2, Length(Tmp))
 else
 Tmp := Separator + Copy(Tmp, 2, Length(Tmp) - 5);
 // записываем всё в переменную UnitedText
 UnitedText := UnitedText + Tmp;
 end;
 // помещаем уже объеденённый текст в поток
 TextStream.WriteString(UnitedText);
 TextStream.Position := 0; // ставим указатель на 0
 // и записываем потом в RichEdit1
 RichEdit1.Lines.LoadFromStream(TextStream);
 end;
 finally
 TextStream.Free;
 end;
end;
Source: http://delphiworld.narod.ru/
ID: 01026
Загрузка файлов в THTMLViewer и TFrameBrowser

=== Загрузка файлов в THTMLViewer и TFrameBrowser ===
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, Readhtml, FramView, FramBrwz, HtmlView;
type
 TForm1 = class(TForm)
 FrameBrowser1: TFrameBrowser;
 procedure FormCreate(Sender: TObject);
 procedure FrameBrowser1GetPostRequest(Sender: TObject; IsGet: Boolean;
 const URL, Query: String; Reload: Boolean; var NewURL: String;
 var DocType: ThtmlFileType; var Stream: TMemoryStream);
 procedure FrameBrowser1ImageRequest(Sender: TObject; const SRC: String;
 var Stream: TMemoryStream);
 public
 BaseDir: string;
 end;
var
 Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
 BaseDir := 'F:\Download\';
 FrameBrowser1.LoadURL('file://F:\Download\index.htm');
end;
procedure TForm1.FrameBrowser1GetPostRequest(Sender: TObject;
 IsGet: Boolean; const URL, Query: String; Reload: Boolean;
 var NewURL: String; var DocType: ThtmlFileType;
 var Stream: TMemoryStream);
var
 S, sType: string;
 F: TFileStream;
 P: Integer;
begin
 S := StringReplace(URL, '|', ':', [rfReplaceAll]);
 P := Pos(':', S) + 2;
 sType := Copy(S, 1, P);
 Stream := TMemoryStream.Create;
 if AnsiLowerCase(sType) = 'file://' then
 begin
 S := StringReplace(Copy(S, P + 1, MaxInt), '/', '\', [rfReplaceAll]);
 F := TFileStream.Create(S, fmOpenRead);
 try
 Stream.CopyFrom(F, F.Size);
 finally
 F.Free;
 end;
 end;
end;
procedure TForm1.FrameBrowser1ImageRequest(Sender: TObject;
 const SRC: String; var Stream: TMemoryStream);
begin
{}
end;
end.
Author: Smike
Source: Взято из http://forum.sources.ru
ID: 03479
Задать необходимый для печати принтер

Кто-нибудь пристально изучал объект TPrinter? Вы можете задать необходимый для печати принтер, используя свойство Printer.PrinterIndex. Для примера:
// Устанавливает первый принтер, проинсталлированный в системе
Printer.PrinterIndex := 0;
// Указывает на принтер, установленный в системе по умолчанию
Printer.PrinterIndex := -1;
И все! Не нужно никаких Win API функций и глобальных переменных!
Source: Взято с http://delphiworld.narod.ru
ID: 03266
Category:Принтер
Задать пароль на MS ACCESS через ADO

=== Задать пароль на MS ACCESS через ADO ===
type
 TPasswordAction = (paSet, paChange, paRemove);
function ChangeAccessDBPassword(DatabaseName: string; action: TPasswordAction;
 OldPassword: string = ; NewPassword: string = ): boolean;
var
 DAO: _DBEngine;
 db: Database;
 ClassID: TGUID;
 V35, V36: string;
 oldPass, newPass: string;
begin
 Result := false;
 V35 := 'DAO.DBEngine.35';
 V36 := 'DAO.DBEngine.36';
 try
 try
 ClassID := ProgIDToClassID(v36);
 except
 try
 ClassID := ProgIDToClassID(v35);
 except
 raise;
 end;
 end;
 DAO := CreateComObject(ClassID) as _DBEngine;
 if action = paSet then
 begin
 db := DAO.OpenDatabase(DatabaseName, true, false, );
 db.NewPassword(#0, NewPassword);
 end
 else
 begin
 db := DAO.OpenDatabase(DatabaseName, true, false, ';pwd=' + OldPassword);
 if action = paChange then
 db.NewPassword(OldPassword, NewPassword)
 else
 db.NewPassword(OldPassword, #0);
 end;
 Result := true;
 except
 // выводим сообщение о ошибке
 on E: Exception do
 begin
 Result := false;
 ShowMessage(e.message);
 end;
 end;
end.
Пример использования: устанавливаем новый пароль - БАЗА ДОЛЖНА БЫТЬ НЕ ЗАПАРОЛЕНА, иначе будет ошибка:)
procedure TForm1.Button1Click(Sender: TObject);
var
 newPass: string;
begin
 if InputQuery('New password', 'Enter new password', newPass) then
 if ChangeAccessDBPassword(ExtractFilePath(ParamStr(0)) + 'db2.mdb', paSet, , newPass) then
 ShowMessage('OK!')
 else
 ShowMessage('Error!');
end;
// изменяем пароль
procedure TForm1.Button2Click(Sender: TObject);
var
 oldPass, newPass: string;
begin
 if InputQuery('Old password', 'Enter old password', oldPass) then
 if InputQuery('New password', 'Enter new password', newPass) then
 if ChangeAccessDBPassword(ExtractFilePath(ParamStr(0)) + 'db2.mdb', paChange, oldPass, newPass) then
 ShowMessage('OK!')
 else
 ShowMessage('Error!');
end;
// удаляем пароль
procedure TForm1.Button3Click(Sender: TObject);
var
 oldPass: string;
begin
 if InputQuery('Password', 'Enter password', oldPass) then
 if ChangeAccessDBPassword(ExtractFilePath(ParamStr(0)) + 'db2.mdb', paRemove, oldPass, ) then
 ShowMessage('OK!')
 else
 ShowMessage('Error!');
end;
Author: dron-s
Source: Взято из http://forum.sources.ru
ID: 02751
Задать расстояние между строк для TRichEdit

=== Задать расстояние между строк для TRichEdit ===
uses
 RichEdit;
procedure RE_SetLineSpacing(ARichEdit: TRichEdit; lineSpacing: Byte);
var
 pf2: ParaFormat2;
begin
 FillChar(pf2, SizeOf(pf2), 0);
 pf2.cbSize := SizeOf(PARAFORMAT2);
 pf2.dwMask := PFM_LINESPACING;
 pf2.bLineSpacingRule := lineSpacing;
 SendMessage(ARichEdit.Handle, EM_SETPARAFORMAT, 0, Longint(@pf2));
end;
// Example: Setlinespacing to 1: 
procedure TForm1.Button1Click(Sender: TObject);
begin
 RE_SetLineSpacing(RichEdit1, 1);
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01030
Закрытие всех окон IE

procedure CloseAllIE_1;
var
 ie: HWND;
begin
 // Ищем окно IE
 ie := FindWindow('IEFrame', nil);
 // пока найдено окно IE...
 while ie <> 0 do
 begin
 // ... закрываем его
 PostMessage(ie, WM_CLOSE, 0, 0);
 // ищем следующее
 ie := FindWindow('IEFrame', nil);
 end;
end;
Author: bizar
Source: http://forum.sources.ru
ID: 03521
Category:Связь
Category:WebBrowser
Закрытие програм при Logoff/Shutdown

=== Закрытие програм при Logoff/Shutdown ===
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
 Dialogs;
type
 TForm1 = class(TForm)
 procedure FormCreate(Sender: TObject);
 procedure FormClose(Sender: TObject; var Action: TCloseAction);
 private
 FSystemShutdown: Boolean;
 procedure WMQueryEndSession(var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;
 end;
var
 Form1: TForm1;
implementation
{$R *.dfm}
function SetPrivilege(PrivilegeName: String; AEnabled: Boolean): Boolean;
var
 TPPrev, TP: TTokenPrivileges;
 Token: THandle;
 dwRetLen: DWORD;
begin
 Result := False;
 if OpenProcessToken(GetCurrentProcess,
 TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, Token) then
 try
 if LookupPrivilegeValue(nil, PChar(PrivilegeName),TP.Privileges[0].LUID) then
 begin
 TP.PrivilegeCount := 1;
 if AEnabled then
 TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
 else
 TP.Privileges[0].Attributes := 0;
 dwRetLen := 0;
 Result := AdjustTokenPrivileges(Token, False, TP,
 SizeOf(TPPrev), TPPrev, dwRetLen);
 end;
 finally
 CloseHandle(Token);
 end
 else
 RaiseLastOSError;
end;
procedure TForm1.FormCreate(Sender: TObject);
const
 SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
 FSystemShutdown := False;
 if not SetPrivilege(SE_SHUTDOWN_NAME, True) then
 RaiseLastOSError;
end;
procedure TForm1.WMQueryEndSession(var Message: TWMQueryEndSession);
begin
 inherited;
 Message.Result := 0;
 AbortSystemShutdown(nil);
 FSystemShutdown := True;
 Close;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 ShowMessage('Bla...bla...bla!');
 if FSystemShutdown then
 InitiateSystemShutdown(nil, nil, 0, True, False);
end;
end.
Author: Александр (Rouse_) Багель
Source: Взято из http://forum.sources.ru
ID: 01677
Замена Application.ProcessMessages

=== Замена Application.ProcessMessages ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Замена штатного Application.ProcessMessages
Хорошо использовать в DLL или бесформенных приложениях, 
если внутри цикла возникает необходимость в использовании Application.ProcessMessages.
Зависимости: Windows, Messages
Copyright: составлено из кусков кода Borland
Дата: 7 сентября 2004 г.
***************************************************** }
procedure ProcessMessagesEx;
 function IsKeyMsg(var Msg: TMsg): Boolean;
 const
 CN_BASE = $BC00;
 var
 Wnd: HWND;
 begin
 Result := False;
 with Msg do
 if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) then
 begin
 Wnd := GetCapture;
 if Wnd = 0 then
 begin
 Wnd := HWnd;
 if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then
 Result := True;
 end
 else
 if (LongWord(GetWindowLong(Wnd, GWL_HINSTANCE)) = HInstance) then
 if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then
 Result := True;
 end;
 end;
 function ProcessMessage(var Msg: TMsg): Boolean;
 begin
 Result := False;
 if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
 begin
 Result := True;
 if Msg.Message <> WM_QUIT then
 if not IsKeyMsg(Msg) then
 begin
 TranslateMessage(Msg);
 DispatchMessage(Msg);
 end;
 end;
 end;
var
 Msg: TMsg;
begin
 while ProcessMessage(Msg) do { loop };
end;
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 00411
Замена всех цветов на оттенки одного

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Замена всех цветов на оттенки одного
Зависимости: Graphics
Автор: Fenik, chook_nu@uraltc.ru, Новоуральск
Copyright: Собственное написание (Николай федоровских)
Дата: 1 июня 2002 г.
***************************************************** }
procedure ModColors(Bitmap: TBitmap; Color: TColor);
 // извлечение красного
 function GetR(const Color: TColor): Byte;
 begin
 Result := Lo(Color);
 end;
 // извлечение зелёного
 function GetG(const Color: TColor): Byte;
 begin
 Result := Lo(Color shr 8);
 end;
 // извлечение синего
 function GetB(const Color: TColor): Byte;
 begin
 Result := Lo((Color shr 8) shr 8);
 end;
 function BLimit(B: Integer): Byte;
 begin
 if B < 0 then
 Result := 0
 else if B > 255 then
 Result := 255
 else
 Result := B;
 end;
type
 TRGB = record
 B, G, R: Byte;
 end;
 pRGB = ^TRGB;
var
 r1, g1, b1: Byte;
 x, y: Integer;
 Dest: pRGB;
 A: Double;
begin
 Bitmap.PixelFormat := pf24Bit;
 r1 := Round(255 / 100 * GetR(Color));
 g1 := Round(255 / 100 * GetG(Color));
 b1 := Round(255 / 100 * GetB(Color));
 for y := 0 to Bitmap.Height - 1 do
 begin
 Dest := Bitmap.ScanLine[y];
 for x := 0 to Bitmap.Width - 1 do
 begin
 with Dest^ do
 begin
 A := (r + b + g) / 300;
 with Dest^ do
 begin
 R := BLimit(Round(r1 * A));
 G := BLimit(Round(g1 * A));
 B := BLimit(Round(b1 * A));
 end;
 end;
 Inc(Dest);
 end;
 end;
end;
// Пример использования:
ModColors(FBitmap, RGB(218, 219, 230));
Author: Fenik
Source: http://delphibase.endimus.com
ID: 03871
Category:Графика
Category:Bitmap
Category:Цвета и палитры
Замена подстрок

=== Замена подстрок ===
Стандартная функция StringReplace()
Author: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
ID: 01155
----
function ReplaceSub(str, sub1, sub2: string): string;
var
 aPos: Integer;
 rslt: string;
begin
 aPos := Pos(sub1, str);
 rslt := ;
 while (aPos <> 0) do
 begin
 rslt := rslt + Copy(str, 1, aPos - 1) + sub2;
 Delete(str, 1, aPos + Length(sub1) - 1);
 aPos := Pos(sub1, str);
 end;
 Result := rslt + str;
end; 
ID: 00844
----
function ReplaceStr(const S, Srch, Replace: string): string;
{замена подстроки в строке}
var
 I: Integer;
 Source: string;
begin
 Source := S;
 Result := ;
 repeat
 I := Pos(Srch, Source);
 if I &gt;
 0 then
 begin
 Result := Result + Copy(Source, 1, I - 1) + Replace;
 Source := Copy(Source, I + Length(Srch), MaxInt);
 end
 else
 Result := Result + Source;
 until I&lt;
 = 0;
end;
http://delphiworld.narod.ru/
DelphiWorld 6.0
Source: http://delphiworld.narod.ru
ID: 00845
----
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Замена в строке всех вхождений одной подстроки, на другую
Зависимости: -
Автор: Евгений Валяев (RhinoFC), rhinofc@sniiggims.ru, ICQ:55263922, Новосибирск
Copyright: RhinoFC
Дата: 5 июня 2002 г.
***************************************************** }
function StrReplace(const Str, Str1, Str2: string): string;
// str - исходная строка
// str1 - подстрока, подлежащая замене
// str2 - заменяющая строка
var
 P, L: Integer;
begin
 Result := str;
 L := Length(Str1);
 repeat
 P := Pos(Str1, Result); // ищем подстроку
 if P > 0 then
 begin
 Delete(Result, P, L); // удаляем ее
 Insert(Str2, Result, P); // вставляем новую
 end;
 until P = 0;
end;
Source: http://delphibase.endimus.com
ID: 00846
----
Записать в реестр данные бинарного вида

=== Записать в реестр данные бинарного вида ===
var
 Reg: TRegistry;
 buf: array [0..4] of byte;
 i: Integer;
begin
 Reg := TRegistry.Create;
 try
 Reg.RootKey := HKEY_CURRENT_USER;
 if Reg.OpenKey('\Software', True) then
 begin
 for i := 1 to 4 do
 buf[i] := 0;
 buf[0] := 1;
 Reg.WriteBinaryData('Value', buf, SizeOf(buf));
 Reg.CloseKey;
 end;
 finally
 Reg.Free;
 inherited;
 end;
 {...}
end;
Source: http://delphiworld.narod.ru/
ID: 02283
Записать содержимое окна OpenGL в BMP файл

gr - объект, в канве которого я рисую с помощью OpenGL
bt := TBitmap.Create;
with bt do
begin
 Width := gr.Width;
 Height := gr.Height;
 Canvas.CopyRect(ClientRect, gr.Canvas, gr.ClientRect);
 SaveToFile('e:\bt.bmp');
 Free;
end;
Source: http://delphiworld.narod.ru/
ID: 03951
Category:Графика
Category:OpenGL
Запись в лог-файл через стандартный вывод

Перенаправление стандартного вывода в заданный файл, удобно для записи логов при помощи WriteLn()
initialization
 if not System.IsConsole then
 begin
 {$PUSH}
 {$IOCHECKS OFF}
 AssignFile(System.Output, 'log.txt');
 ReWrite(System.Output);
 {$POP}
 
 if IOResult() <> 0 then
 System.Output := System.StdOut;
 end;
finalization
 
 CloseFile(System.Output);
end.
Source: https://forum.lazarus.freepascal.org/index.php/topic,61765.0.html
Category:Файловая система