nyuuzyou/wikis huggingface dataset:
Создание таблицы FOXPRO

=== Создание таблицы FOXPRO ===
if SaveDialog1.Execute then
begin
 if FileExists(SaveDialog1.FileName) then
 DeleteFile(SaveDialog1.FileName);
 // QUERY.DataSource НЕ ЗАПОЛНЕНО иначе взрыв гарантирован
 with Session do
 begin
 ConfigMode := cmSession;
 try
 AddStandardAlias('TEMPDB', extractfilepath(savedialog1.filename),
 'FOXPRO'); //FOXPRO
 finally
 ConfigMode := cmAll;
 end;
 end;
 with database1 do
 begin
 databasename := 'tst';
 LoginPrompt := False;
 Params.Values['PATH'] := ExtractFilePath(SaveDialog1.FileName);
 DriverName := 'Microsoft FoxPro Driver (*.dbf)';
 AliasName := 'TEMPDB';
 end;
 
 Query1.ParamCheck := False;
 Query1.DatabaseName := 'tst';
 Query1.SQL.Clear;
 vrem := Trim(ChangeFileExt(ExtractFileName(SaveDialog1.FileName), ' '));
 Query1.SQL.Add('CREATE TABLE + vrem + (');
 Query1.SQL.Add('last_name CHAR(20),');
 Query1.SQL.Add('first_name CHAR(15),');
 Query1.SQL.Add('salary DECIMAL(10,2));'); // NUMERIC
 Query1.ExecSQL;
 Query1.Close;
end; // от savedialog
Source: Взято с http://delphiworld.narod.ru
ID: 02936
Category:Базы данных
Category:FoxPro
Создание таблицы по образу и подобию

=== Создание таблицы по образу и подобию ===
Создайте во время выполнения программы пустую таблицу, скопируйте структуру существующей, включая первичный индекс. На практике это выглядит примерно так:
var
 Table2: TTable;
begin
 Table1.FieldDefs.Update;
 Table1.IndexDefs.Update;
 Table2 := TTable.Create(nil);
 Table2.DatabaseName := Table1.DatabaseName;
 Table2.TableName := 'MyTable';
 Table2.TableType := Table1.TableType;
 Table2.FieldDefs.Assign(Table1.FieldDefs);
 Table2.IndexDefs.Assign(Table1.IndexDefs);
 Table2.CreateTable ;
end;
ID: 02604
----
На ум сразу приходит операция присваивания значения свойству (стоящему с левой стороны от ':='), при которой Delphi в своих недрах вызывает метод 'write' и передает ему в виде единственного параметра все то, что находится в правой части выражения. Если свойство не имеет метода write, оно предназначено только для чтения. Вот определение свойства FieldDefs объекта TDataSet в файле DB.PAS:
property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;
Как вы можете видеть, у него есть метод write. Следовательно, код:
Destination.FieldDefs := Source.FieldDefs;
в действительности делает такую операцию:
Destination.SetFieldDefs(Source.FieldDefs);
(за исключением того, что вы не можете использовать эту строку, поскольку SetFieldDefs определен в секции Private.)
Вот определение свойства IndexDefs объекта TTable в файле DBTABLES.PAS file:
property IndexDefs: TIndexDefs read FIndexDefs;
В этом случае метод write отсутствует, поэтому свойство имеет атрибут только для чтения. Тем не менее, для самого объекта TIndexDefs существует метод Assign. Следовательно, следующий код должен работать:
Source.IndexDefs.Update;
Destination.IndexDefs.Assign(Source.IndexDefs);
Перед вызовом Assign для Source.IndexDefs вызывайте метод Update, чтобы быть уверенным в том, что вы получите то, что хотите.
Метод SetFieldDefs является процедурой с одной строкой кода, в которой вызывается метод FieldDefs Assign.
Также можно проверить, определен ли реально индекс, и, если нет, то при вызове IndexDefs.Assign вы можете получить исключение типа "List Index Out Of Bounds" (или что-то типа этого). Например, так:
if Source.IndexDefs.Count > 0 then
Вам нужно будет это сделать, поскольку метод TIndexDefs.Assign не проверяет это перед копированием индекс-информации. Также вам нет необходимости вызывать Clear до работы с IndexDefs, поскольку метод Assign сделает это и без вашего участия.
Source: Взято с http://delphiworld.narod.ru
ID: 02605
Создание таблицы с автоинкрементальным полем

=== Создание таблицы с автоинкрементальным полем ===
Допустим у вас имеется форма с кнопкой. Щелчок на кнопке с помощью DbiCreateTable должен создать таблицу Paradox с автоинкрементальным (приращиваемым) полем.
unit Autoinc;
interface
uses
 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
 Forms, Dialogs, DBTables, DB, ExtCtrls, DBCtrls, Grids, DBGrids, StdCtrls,
 DbiTypes, DbiErrs, DBIProcs;
const
 szTblName = 'CR8PXTBL'; { Имя создаваемой таблицы. }
 szTblType = szPARADOX; { Используемый тип таблицы. }
 { При создании таблицы используется полное описание поля }
const
 fldDes: array[0..1] of FLDDesc = (
 ({ Поле 1 - AUTOINC }
 iFldNum: 1; { Номер поля }
 szName: 'AUTOINC'; { Имя поля }
 iFldType: fldINT32; { Тип поля }
 iSubType: fldstAUTOINC; { Подтип поля }
 iUnits1: 0; { Размер поля }
 iUnits2: 0; { Десятичный порядок следования ( 0 ) }
 iOffset: 0; { Смещение в записи ( 0 ) }
 iLen: 0; { Длина в байтах ( 0 ) }
 iNullOffset: 0; { Для Null-битов ( 0 ) }
 efldvVchk: fldvNOCHECKS; { Проверка корректности ( 0 ) }
 efldrRights: fldrREADWRITE { Права }
 ),
 ({ Поле 2 - ALPHA }
 iFldNum: 2; szName: 'ALPHA';
 iFldType: fldZSTRING; iSubType: fldUNKNOWN;
 iUnits1: 10; iUnits2: 0;
 iOffset: 0; iLen: 0;
 iNullOffset: 0; efldvVchk: fldvNOCHECKS;
 efldrRights: fldrREADWRITE
 ));
type
 TForm1 = class(TForm)
 Button1: TButton;
 Database1: TDatabase;
 procedure Button1Click(Sender: TObject);
 private
 { Private declarations }
 public
 { Public declarations }
 end;
var
 Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
 TblDesc: CRTblDesc;
 uNumFields: Integer;
 Rslt: DbiResult;
 ErrorString: array[0..dbiMaxMsgLen] of Char;
begin
 FillChar(TblDesc, sizeof(CRTblDesc), #0);
 lStrCpy(TblDesc.szTblName, szTblName);
 lStrCpy(TblDesc.szTblType, szTblType);
 uNumFields := trunc(sizeof(fldDes) / sizeof(fldDes[0]));
 TblDesc.iFldCount := uNumFields;
 TblDesc.pfldDesc := @fldDes;
 Rslt := DbiCreateTable(Database1.Handle, TRUE, TblDesc);
 if Rslt <> dbiErr_None then
 begin
 DbiGetErrorString(Rslt, ErrorString);
 MessageDlg(StrPas(ErrorString), mtWarning, [mbOk], 0);
 end;
end;
end.
Source: Взято с http://delphiworld.narod.ru
ID: 02952
Category:Базы данных
Category:Paradox
Создание форм с закругленными краями

=== Создание форм с закругленными краями ===
{ 
 Die CreateRoundRectRgn lasst eine Form mit abgerundeten Ecken erscheinen. 
 The CreateRoundRectRgn function creates a rectangular 
 region with rounded corners 
}
procedure TForm1.FormCreate(Sender: TObject);
var
 rgn: HRGN;
begin
 Form1.Borderstyle := bsNone;
 rgn := CreateRoundRectRgn(0, // x-coordinate of the region's upper-left corner 
 0, // y-coordinate of the region's upper-left corner 
 ClientWidth, // x-coordinate of the region's lower-right corner 
 ClientHeight, // y-coordinate of the region's lower-right corner 
 40, // height of ellipse for rounded corners 
 40); // width of ellipse for rounded corners 
 SetWindowRgn(Handle, rgn, True);
end;
{ The CreatePolygonRgn function creates a polygonal region. }
procedure TForm1.FormCreate(Sender: TObject);
const
 C = 20;
var
 Points: array [0..7] of TPoint;
 h, w: Integer;
begin
 h := Form1.Height;
 w := Form1.Width;
 Points[0].X := C; Points[0].Y := 0;
 Points[1].X := 0; Points[1].Y := C;
 Points[2].X := 0; Points[2].Y := h - c;
 Points[3].X := C; Points[3].Y := h;
 Points[4].X := w - c; Points[4].Y := h;
 Points[5].X := w; Points[5].Y := h - c;
 Points[6].X := w; Points[6].Y := C;
 Points[7].X := w - C; Points[7].Y := 0;
 SetWindowRgn(Form1.Handle, CreatePolygonRgn(Points, 8, WINDING), True);
end;
Source: Взято из http://forum.sources.ru
ID: 00473
Создать MDI окно с координатами 0,0

=== Создать MDI окно с координатами 0,0 ===
procedure TFormX.FormCreate(Sender: TObject);
var
 r: TRect;
 client: HWND;
begin
 client := Application.MainForm.ClientHandle;
 Windows.GetClientRect(client, r);
 MapWindowPoints(client, HWND_DESKTOP, r, 2);
 BoundsRect := r;
end;
ID: 00504
Создать неактивные пиктограммы для TSpeedButton и TBitBtn во время выполнения

=== Создать неактивные пиктограммы для TSpeedButton и TBitBtn во время выполнения ===
procedure AddDisableBMP(SB : array of TObject);
var
 BM, SBM : TBitmap;
 w, x, y, NewColor, i : integer;
 PixelColor : TColor;
begin
 BM := TBitmap.Create;
 SBM := TBitmap.Create;
 try
 for i := 0 to High(SB) do
 begin
 if (SB[i] is TSpeedButton) then
 BM.Assign((SB[i] as TSpeedButton).Glyph)
 else if (SB[i] is TBitBtn) then
 BM.Assign((SB[i] as TBitBtn).Glyph)
 else
 Exit;
 if not Assigned(BM) or (BM.Width <> BM.Height) then Exit;
 w := BM.Width;
 SBM.Width := w * 2;
 SBM.Height := w;
 SBM.Canvas.Draw(0, 0, BM);
 for x := 0 to w - 1 do
 for y := 0 to w - 1 do
 begin
 PixelColor := ColorToRGB(BM.Canvas.Pixels[x, y]);
 NewColor := Round((((PixelColor shr 16) + ((PixelColor shr 8) and $00FF) +
 (PixelColor and $0000FF)) div 3)) div 2 + 96;
 BM.Canvas.Pixels[x, y] := RGB(NewColor, NewColor, NewColor);
 end;
 SBM.Canvas.Draw(w, 0, BM);
 if (SB[i] is TSpeedButton) then
 with (SB[i] as TSpeedButton) do
 begin
 Glyph.Assign(SBM);
 NumGlyphs := 2;
 end
 else
 with (SB[i] as TBitBtn) do
 begin
 Glyph.Assign(SBM);
 NumGlyphs := 2;
 end;
 BM := TBitmap.Create;
 SBM := TBitmap.Create;
 end;
 finally
 BM.Free;
 SBM.Free;
 end;
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01251
Создать новый Outlook Contact?

uses
 ComObj, Variants, SysUtils;
type
 TContact = record
 LastName: string;
 FirstName : string;
 Company : string;
 // ### Further properties. See MSDN
 end;
//------------------------------------------------------------------------------
{:Add outlook contact
@param ContactFolderPath The contact path. E.g.: for default contact folder,
 'SubFolder\Sub2\Test' for subfolders
@param Contact The contact informations.
@author 19.09.2003 Michael Klemm}
//------------------------------------------------------------------------------
procedure OutlookAddContact(ContactFolderPath: string; Contact: TContact);
const
 olFolderContacts = $0000000A;
var
 Outlook: OleVariant;
 NameSpace: OleVariant;
 ContactsRoot: OleVariant;
 ContactsFolder: OleVariant;
 OutlookContact: OleVariant;
 SubFolderName: string;
 Position: Integer;
 Found: Boolean;
 Counter: Integer;
 TestContactFolder: OleVariant;
begin
 // Connect to outlook
 Outlook := CreateOleObject('Outlook.Application');
 // Get name space
 NameSpace := Outlook.GetNameSpace('MAPI');
 // Get root contacts folder
 ContactsRoot := NameSpace.GetDefaultFolder(olFolderContacts);
 // Iterate to subfolder
 ContactsFolder := ContactsRoot;
 while ContactFolderPath <> do
 begin
 // Extract next subfolder
 Position := Pos('\', ContactFolderPath);
 if Position > 0 then
 begin
 SubFolderName := Copy(ContactFolderPath, 1, Position - 1);
 ContactFolderPath := Copy(ContactFolderPath, Position + 1, Length(ContactFolderPath));
 end
 else
 begin
 SubFolderName := ContactFolderPath;
 ContactFolderPath := ;
 end;
 if SubFolderName = then
 Break;
 // Search subfolder
 Found := False;
 for Counter := 1 to ContactsFolder.Folders.Count do
 begin
 TestContactFolder := ContactsRoot.Folders.Item(Counter);
 if LowerCase(TestContactFolder.Name) = LowerCase(SubFolderName) then
 begin
 ContactsFolder := TestContactFolder;
 Found := True;
 Break;
 end;
 end;
 // If not found create
 if not Found then
 ContactsFolder := ContactsFolder.Folders.Add(SubFolderName);
 end;
 // Create contact item
 OutlookContact := ContactsFolder.Items.Add;
 // Fill contact information
 OutlookContact.FirstName := Contact.FirstName;
 OutlookContact.LastName := Contact.LastName;
 OutlookContact.CompanyName := Contact.Company;
 // ### Further properties
 // Save contact
 OutlookContact.Save;
 // Disconnect from outlook
 Outlook := Unassigned;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04444
Category:COM
Category:MS Office
Создать процесс с правами админа

=== Создать процесс с правами админа ===
unit Main; 
interface 
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls, ShellApi; 
type 
 TForm1 = class(TForm) 
 Button1: TButton; 
 procedure Button1Click(Sender: TObject); 
 end; 
var 
 Form1: TForm1; 
implementation 
function CreateProcessWithLogonW(
 lpUsername: PWideChar; 
 lpDomain: PWideChar; 
 lpPassword: PWideChar; 
 dwLogonFlags: DWORD; 
 lpApplicationName: PWideChar; 
 lpCommandLine: PWideChar; 
 dwCreationFlags: DWORD; 
 lpEnvironment: Pointer; 
 lpCurrentDirectory: PWideChar; 
 const lpStartupInfo: _STARTUPINFOA; 
 var lpProcessInfo: PROCESS_INFORMATION): BOOL; stdcall; external 'advapi32.dll' name 'CreateProcessWithLogonW'; 
{$R *.dfm} 
procedure TForm1.Button1Click(Sender: TObject); 
var 
 hLib:THandle; 
 si: _STARTUPINFOA; 
 pi: Process_Information; 
begin 
 ZeroMemory(@Si, Sizeof(si));
 si.cb := SizeOf(si); 
 CreateProcessWithLogonw('administrator', nil, 'master', 1, nil, 'notepad', 0, nil, nil, si, pi); 
end; 
end.
Должно работать, только лучше указывать полный путь до папки запускаемого приложения... без этого у меня некоторые приложения не запускались(один из параметров после 'notepad').
Author: win_nt
Source: Взято из http://forum.sources.ru
ID: 02071
Создаём Excel файл без OLE

const
 CXlsBof: array[0..5] of Word = ($809, 8, 00, $10, 0, 0);
 CXlsEof: array[0..1] of Word = ($0A, 00);
 CXlsLabel: array[0..5] of Word = ($204, 0, 0, 0, 0, 0);
 CXlsNumber: array[0..4] of Word = ($203, 14, 0, 0, 0);
 CXlsRk: array[0..4] of Word = ($27E, 10, 0, 0, 0);
procedure XlsBeginStream(XlsStream: TStream; const BuildNumber: Word);
begin
 CXlsBof[4] := BuildNumber;
 XlsStream.WriteBuffer(CXlsBof, SizeOf(CXlsBof));
end;
procedure XlsEndStream(XlsStream: TStream);
begin
 XlsStream.WriteBuffer(CXlsEof, SizeOf(CXlsEof));
end;
procedure XlsWriteCellRk(XlsStream: TStream; const ACol, ARow: Word;
 const AValue: Integer);
var
 V: Integer;
begin
 CXlsRk[2] := ARow;
 CXlsRk[3] := ACol;
 XlsStream.WriteBuffer(CXlsRk, SizeOf(CXlsRk));
 V := (AValue shl 2) or 2;
 XlsStream.WriteBuffer(V, 4);
end;
procedure XlsWriteCellNumber(XlsStream: TStream; const ACol, ARow: Word;
 const AValue: Double);
begin
 CXlsNumber[2] := ARow;
 CXlsNumber[3] := ACol;
 XlsStream.WriteBuffer(CXlsNumber, SizeOf(CXlsNumber));
 XlsStream.WriteBuffer(AValue, 8);
end;
procedure XlsWriteCellLabel(XlsStream: TStream; const ACol, ARow: Word;
 const AValue: string);
var
 L: Word;
begin
 L := Length(AValue);
 CXlsLabel[1] := 8 + L;
 CXlsLabel[2] := ARow;
 CXlsLabel[3] := ACol;
 CXlsLabel[5] := L;
 XlsStream.WriteBuffer(CXlsLabel, SizeOf(CXlsLabel));
 XlsStream.WriteBuffer(Pointer(AValue)^, L);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 FStream: TFileStream;
 i, j: Integer;
begin
 FStream := TFileStream.Create('c:\e.xls', fmCreate);
 try
 XlsBeginStream(FStream, 0);
 for i := 0 to 99 do
 for j := 0 to 99 do
 begin
 XlsWriteCellNumber(FStream, i, j, 34.34);
 // XlsWriteCellRk(FStream, i, j, 3434);
 // XlsWriteCellLabel(FStream, i, j, Format('Cell: %d,%d', [i, j]));
 end;
 XlsEndStream(FStream);
 finally
 FStream.Free;
 end;
end;
Source: http://delphiworld.narod.ru
ID: 04391
Category:COM
Category:MS Office
Сообщения Win32 BM (кнопки)

=== Сообщения кнопок (BM_) ===
==== BM_Click - Посылает кнопке сообщение о том, что на ней произведено нажатие кнопки мышки. ====
* WParam: Не используется.
* LParam: Не используется.
* Возвращаемое значение: Не используется.
==== BM_GetCheck - Определяет, является ли селективная кнопка или чекбокс помеченным. ====
* WParam: Не используется.
* LParam: Не используется.
* Возвращаемое значение: Если селективная кнопка или чекбокс помечен, возвращается ненулевое значение. Иначе, возвращается 0. Для текстовой кнопки всегда возвращается 0. 
==== BM_GetState - Определяет состояние визуальной кнопки при нажатии кнопки мыши или клавиши пробела. ====
* WParam: Не используется.
* LParam: Не используется.
* Возвращаемое значение: Если кнопка является подсвеченной текстовой кнопкой, на кнопке сфокусирован ввод и нажата кнопка мыши или клавиша пробела, или нажата кнопка мыши, когда куpсоp находится в кнопке, возвращается ненулевое значение. Иначе возвращается 0.
==== BM_SetCheck - Помечает или удаляет отметку из селективной кнопки или чекбокса. ====
Для кнопок с двумя состояниями и чекбоксов при нулевом значении WParam отметка (если имеется) удаляется, иначе - добавляется. Для кнопок с тремя состояниями при нулевом значении WParam отметка (если имеется) и затенение (если есть) удаляются.
* WParam: 0 - отметка удаляется, 1 - отметка добавляется, 2 - кнопка затеняется.
* LParam: Не используется.
* Возвращаемое значение: Не используется.
==== BM_SetState - Изменяет состояние кнопки или чекбокса. ====
* WParam: 0 - кнопка или чекбокс рисуются нормальным обpазом. В случае ненулевого значения кнопка подсвечивается.
* LParam: Не используется.
* Возвращаемое значение: Не используется.
==== BM_SetStyle - Изменяет стиль кнопки. ====
* WParam: Определяет новый стиль кнопки. См. раздел "Стили кнопок (BS_)" в главе 1 "Стили и константы Windows".
* LParam: 0 - кнопка не будет перерисовываться сpазу же. Если значение отлично от нуля и новый стиль кнопки отличается от текущего стиля, то кнопка будет перерисована.
* Возвращаемое значение: Не используется.
Сообщения Win32 DM (диалоги)

=== Сообщения диалогов (DM_) ===
==== DM_GetDefID - Возвращает идентификатор текущей кнопки диалога. ====
* WParam: Не используется.
* LParam: Не используется.
* Возвращаемое значение: Если текущей кнопки диалога нет, HiWord возвращаемого значения равно нулю; иначе равно DC_HasDefID, а LoWord - идентификатору кнопки.
==== DM_SetDefID - Устанавливает идентификатор текущей кнопки диалога. ====
* WParam: новый идентификатор текущей кнопки.
* LParam: Не используется.
* Возвращаемое значение: Не используется.
Сортировать список по алфавиту

=== Сортировать список по алфавиту ===
{ 
 You need a TListBox and a TButton. 
 With a few modifications, you can use it with any variable 
 compatible with a TStringList. 
 If you change the operator "<" for a ">" in the 'if' clause 
 below, the order will be reversed 
}
procedure TForm1.Button1Click(Sender: TObject);
var
 i, x: Integer;
begin
 for i := 0 to (ListBox1.Items.Count - 1) do
 for x := 0 to (ListBox1.Items.Count - 1) do
 if (ListBox1.Items[x] < ListBox1.Items[i]) and (x > i) then
 begin
 ListBox1.Items.Insert(i, ListBox1.Items[x]);
 ListBox1.Items.Delete(x + 1);
 end;
 end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 00680
Сортировка выбором

Сортировка выбором.
* A[1..N] - сортируемый массив из n элементов.
 for ( i=1; i<N; i++)
Hайти наименьший из элементов i..N и поменять его местами с i-м.
Пример действий для случайного массива A[1..8]
 44 55 12 42 94 18 06 67 исходный массив
 i=1 06| 55 12 42 94 18 44 67 06 <-> 44
 i=2 06 12| 55 42 94 18 44 67 12 <-> 55
 i=3 06 12 18| 42 94 55 44 67 18 <-> 55
 i=4 06 12 18 42| 94 55 44 67 42 <-> 42
 i=5 06 12 18 42 44| 55 94 67 44 <-> 94
 i=6 06 12 18 42 44 55| 94 67 55 <-> 55
 i=7 06 12 18 42 44 55 67| 94 67 <-> 94
Вертикальной чертой отмечена граница уже отсортированной части массива.
Сортировка выбором - простейший алгоритм, на практике не используемый ввиду низкого быстродействия. Вместо этого применяют ее улучшение - пирамидальную сортировку (Heapsort), описанную в другом вопросе, а также (иногда) 'древесную сортировку' (TreeSort).
Пример на Паскале - Hиколас Вирт.
{ Сортируются записи типа item по ключу item.key }
{ для вспомогательных переменных используется тип index }
procedure SelectSort;
var
 i, j, k: index;
 x: item;
begin
 for i := 1 to n-1 do
 begin
 k := i;
 x := a[i];
 for j := i+1 to n do
 begin
 if a[j].key < x.key then
 begin
 k := j;
 x := a[j];
 end;
 end;
 a[k] := a[i];
 a[i] := x;
 end;
end;
Source: http://algolist.manual.ru
ID: 04155
----
{ **** UBPFD *********** by kladovka.net.ru ****
>> Сортировка различными методами
Сортировка одномерного массива значений типа Double методами:
2) Выбора (SelectionSort);
Зависимости: Math
Автор: iZEN, izen@mail.ru
Copyright: адаптация для Delphi
Дата: 14 сентября 2004 г.
********************************************** }
{ Сортировка SelectionSort }
procedure SelectionSort(var data: array of Double);
var
 lo, hi, i, j: Integer;
 t: Double;
begin
 lo := Low(data);
 hi := High(data);
 for i := lo to hi do
 for j := hi downto i + 1 do
 if data[i] > data[j] then
 begin
 t := data[i];
 data[i] := data[j];
 data[j] := t;
 end;
end;
Author: iZEN
ID: 04156
Category:Алгоритмы
Category:Сортировка
Сортировка двух связанных списков по целочисленным значениям одного из них

procedure SortTwoListsByIntValues(lbNum, lbNames: TStrings);
var
 i, j, b_val, b_j: Integer;
 b_val_name: string;
begin
 if lbNum.Count > 1 then
 begin
 for i := 0 to lbNum.Count - 2 do
 begin
 b_val := StrToInt(lbNum[i]);
 b_val_name := lbNames[i];
 b_j := i;
 for j := i + 1 to lbNum.Count - 1 do
 begin
 if StrToInt(lbNum[j]) < b_val then
 begin
 b_val := StrToInt(lbNum[j]);
 b_val_name := lbNames[j];
 b_j := j;
 end;
 end;
 lbNum[b_j] := lbNum[i];
 lbNum[i] := IntToStr(b_val);
 lbNames[b_j] := lbNames[i];
 lbNames[i] := b_val_name;
 end;
 end;
end;
Author: ___Nikolay
Source: http://delphiworld.narod.ru/
ID: 04174
Category:Алгоритмы
Category:Сортировка
Сортировка массива методом прямого выбора

Алгоритм сортировки массива по возрастанию методом прямого выбора может быть представлен так:
* Просматривая массив от первого элемента, найти минимальный элемент и поместить его на место первого элемента, а первый - на место минимального.
* Просматривая массив от второго элемента, найти минимальный элемент и поместить его на место второго элемента, а второй - на место минимального.
* И так далее до предпоследнего элемента.
Ниже представлена программа сортировки массива целых чисел по возрастанию
procedure TForm1.ButtonlClick(Sender: TObject);
const
 SIZE = 10;
var
 a: array[1..SIZE] of Integer;
 min: Integer; { номер минимального элемента в части
 массива от i до верхней границы массива }
 j: Integer; { номер элемента, сравниваемого с минимальным }
 buf: Integer; { буфер, используемый при обмене элементов массива }
 i, k: Integer;
begin
 // ввод массива
 for i := l to SIZE do
 a[i] := StrToInt(StringGridl.Cells[i - 1, 0]);
 Label2.Caption := ;
 for i := l to SIZE - 1 do
 begin
 { поиск минимального элемента в части массива от а[1] до a[SIZE]}
 min := i;
 for j := i + l to SIZE do
 if a[j] < a[min] then
 min := j;
 { поменяем местами a [min] и a[i] }
 buf := a[i];
 a[i] := a[min];
 a[min] := buf;
 { вывод массива }
 for k := l to SIZE do
 Label2.Caption := Label2.Caption + ' ' + IntToStr(a[k]);
 Label2.Caption := Label2.Caption + #13;
 end;
 Label2.Caption := Label2.Caption + #13 + 'Maccив отсортирован.';
end;
Source: http://delphiworld.narod.ru/
ID: 04172
Category:Алгоритмы
Category:Сортировка
Сортировка методом двунаправленного пузырька

{ **** UBPFD *********** by kladovka.net.ru ****
>> Сортировка различными методами
Сортировка одномерного массива значений типа Double методами:
1) Двунаправленный Пузырёк (BiDirBubbleSort);
Зависимости: Math
Автор: iZEN, izen@mail.ru
Copyright: адаптация для Delphi
Дата: 14 сентября 2004 г.
********************************************** }
{ Сортировка Двунаправленным Пузырьком }
procedure BiDirBubbleSort(var data: array of Double);
var
 i, j, limit, st: Integer;
 t: Double;
 Swapped: Boolean;
begin
 limit := High(data) + 1;
 st := -1;
 while (st < limit) do
 begin
 Inc(st);
 Dec(limit);
 Swapped := False;
 j := st;
 while (j < limit) do
 begin
 if (data[j] > data[j+1]) then
 begin
 t := data[j];
 data[j] := data[j+1];
 data[j+1] := t;
 Swapped := True;
 end;
 Inc(j);
 end;
 if (not Swapped) then
 Exit
 else
 Swapped := False;
 j := limit - 1;
 repeat
 if (data[j] > data[j+1]) then
 begin
 t := data[j];
 data[j] := data[j+1];
 data[j+1] := t;
 Swapped := True;
 end;
 Dec(j);
 until (j < st);
 if (not Swapped) then Exit;
 end;
end;
Author: iZEN
ID: 04165
Category:Алгоритмы
Category:Сортировка
Сортировка строк в MEMO

=== Сортировка строк в MEMO ===
procedure TForm1.Button3Click(Sender: TObject);
var
 t: TStringList;
begin
 // создаем
 t := TStringList.Create;
 // присваиваем переменной t строки из Memo
 t.AddStrings(memo1.lines);
 // сортируем
 t.Sort;
 memo1.Clear;
 // присваиваем memo уже отсортированные строки
 memo1.Lines.AddStrings(t);
end;
Source: http://delphiworld.narod.ru/
ID: 01011