nyuuzyou/wikis huggingface dataset:
Расстояние (разность) между двумя строками. Функция Левенштейна

=== Расстояние (разность) между двумя строками. Функция Левенштейна ===
{ **** UBPFD *********** by kladovka.net.ru ****
>> Расстояние (разность) между двумя строками. Функция Левенштейна
Зависимости: System
Автор: Андрей aka wicked, wilk@ua.fm, ICQ:92356239, Тернополь
Copyright: описание алгоритма взято с http://www.merriampark.com/ld.htm, реализация моя
Дата: 10 августа 2002 г.
********************************************** }
const cuthalf = 100; // константа, ограничивающая макс. длину 
 // обрабатываемых строк
var buf: array [0..((cuthalf * 2) - 1)] of integer; // рабочий буффер, заменяет 
 // матрицу, представленную
 // в описании
function min3(a, b, c: integer): integer; // вспомогательная функция
begin
 Result := a;
 if b < Result then Result := b;
 if c < Result then Result := c;
end;
// реализация функции в принципе соответствует описанию с одной оговоркой:
// матрица из описания заменена статическим буффером, длина которого 
// равна удвоенной максимальной длине строк
// это сделано для 1) экономии памяти и во избежание её перераспределений
// 2) повышения быстродействия (у меня функция работает 
// в обработчике onfilterRecord)
// таким образом, в реализации половинами буффера представлены только 
// две последние строки матрицы, которые меняются местами каждую 
// итерацию внешнего цикла (по i)... для определения того, какая из половин 
// буффера является "нижней строкой", служит переменная flip
// т. е. при flip = false первая половина буффера является предпоследней
// строкой, а вторая - последней; при flip = true наоборот, 
// первая половина - последняя строка, вторая половина - предпоследняя
function LeveDist(s, t: string): integer; 
var i, j, m, n: integer;
 cost: integer;
 flip: boolean; 
begin
 s := Copy(s, 1, cuthalf - 1);
 t := Copy(t, 1, cuthalf - 1);
 m := Length(s);
 n := Length(t);
 if m = 0 then
 Result := n
 else
 begin
 if n = 0 then
 Result := m
 else
 begin
 flip := false;
 for i := 0 to n do
 buf[i] := i;
 for i := 1 to m do
 begin
 if flip then 
 buf[0] := i
 else 
 buf[cuthalf] := i;
 for j := 1 to n do
 begin
 if s[i] = t[j] then
 cost := 0
 else
 cost := 1;
 if flip then
 buf[j] := min3((buf[cuthalf + j] + 1), 
 (buf[j - 1] + 1), 
 (buf[cuthalf + j - 1] + cost))
 else
 buf[cuthalf + j] := min3((buf[j] + 1), 
 (buf[cuthalf + j - 1] + 1), 
 (buf[j - 1] + cost));
 end;
 flip := not flip;
 end;
 if flip then
 Result := buf[cuthalf + n]
 else
 Result := buf[n];
 end;
 end;
end; 
Пример использования:
// на форме имеются поля Edit1 и Edit2, метка Label1
Label1.Caption := IntToStr(LeveDist(Edit1.Text, Edit2.Text));
Source: kladovka.net.ru
ID: 00174
Растворение экрана

program joke;
uses
 Windows, Graphics; { тут мы подключаем необходимые модули }
var
 desk: TCanvas; { тут мы объявляем переменные }
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer;
 stdcall; external 'KERNEL32.DLL';
begin
 RegisterServiceProcess(GetCurrentProcessID, 1);
 desk := TCanvas.Create; { инициализируем переменную }
 desk.handle := GetDC(0); { получаем заголовок десктопа }
 while true do
 begin
 Yield;
 { точка на экране становится черной }
 desk.Pixels[Random(1024), Random(768)] := 0;
 end;
end.
Source: http://delphiworld.narod.ru/
ID: 04651
Category:Развлечения
Растягивание изображения

Я пишу программу, которая печатает изображение на принтере с помощью объекта TPrinter. Проблема происходит когда я пытаюсь "растянуть" изображение до требуемого размера на бумаге. Мой метод растяжения (BitBlts и принтерном DC) приводит к белым кляксам, а само изображение получается практически серым. Конечно это не то, что мне хотелось. Кто-нибудь может мне помочь?
Попробуй это:
procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);
var
 Header, Bits: Pointer;
 HeaderSize: Integer;
 BitsSize: Longint;
begin
 GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);
 Header := MemAlloc(HeaderSize);
 Bits := MemAlloc(BitsSize);
 try
 GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);
 StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top,
 DestRect.Right, DestRect.Bottom,
 0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^),
 DIB_RGB_COLORS, SRCCOPY);
 { вам может понадобиться цветовой стандарт DIB_PAL_COLORS,
 но это уже выходит за рамки моих знаний. }
 finally
 MemFree(Header, HeaderSize);
 MemFree(Bits, BitsSize);
 end;
end;
{ Печатаем изображение, растягивая его до целого листа }
procedure PrintBitmap(ABitmap: TBitmap);
var
 RelHeight, RelWidth: Integer;
begin
 Screen.Cursor := crHourglass;
 Printer.BeginDoc;
 if ((ABitmap.width / ABitmap.height) > (Printer.PageWidth / Printer.PageHeight)) then
 begin
 { Растягиваем ширину изображения до ширины бумаги }
 RelWidth := Printer.PageWidth;
 RelHeight := MulDiv(ABitmap.Height, Printer.PageWidth, ABitmap.Width);
 end
 else
 begin
 { Растягиваем высоту изображения до высоты бумаги }
 RelWidth := MulDiv(ABitmap.Width, Printer.PageHeight, ABitmap.Height);
 RelHeight := Printer.PageHeight;
 end;
 DrawImage(Printer.Canvas, Rect(0, 0, RelWidth, RelHeight), ABitmap);
 Printer.EndDoc;
 Screen.Cursor := crDefault;
end;
Source: Взято из Советов по Delphi от Валентина Озерова
ID: 03237
== См. также ==
* How to scale bitmap by percent?
* Изменение размера
* Растягивание изображения
* Масштабирование для Canvas
* Создание уменьшенной копии картинки
* Качественное увеличение изображения билинейной интерполяцией
Category:Графика
Category:Bitmap
Category:WinAPI
Category:Принтер
Растягивание изображения при печати

Я пишу программу, которая печатает изображение на принтере с помощью объекта TPrinter. Проблема происходит когда я пытаюсь "растянуть" изображение до требуемого размера на бумаге. Мой метод растяжения (bitblts и принтерном DC) приводит к белым кляксам, а само изображение получается практически серым. Конечно это не то, что мне хотелось. Кто-нибудь может мне помочь?
Попробуй это:
procedure DrawImage(Canvas: TCanvas; DestRect: TRect; ABitmap: TBitmap);
var
 Header, Bits: Pointer;
 HeaderSize: Integer;
 BitsSize: Longint;
begin
 GetDIBSizes(ABitmap.Handle, HeaderSize, BitsSize);
 Header := MemAlloc(HeaderSize);
 Bits := MemAlloc(BitsSize);
 try
 GetDIB(ABitmap.Handle, ABitmap.Palette, Header^, Bits^);
 StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top,
 DestRect.Right, DestRect.Bottom,
 0, 0, ABitmap.Width, ABitmap.Height, Bits, TBitmapInfo(Header^),
 DIB_RGB_COLORS, SRCCOPY);
 { вам может понадобиться цветовой стандарт DIB_PAL_COLORS,
 но это уже выходит за рамки моих знаний. }
 finally
 MemFree(Header, HeaderSize);
 MemFree(Bits, BitsSize);
 end;
end;
{ Печатаем изображение, растягивая его до целого листа }
procedure PrintBitmap(ABitmap: TBitmap);
var
 relHeight, relWidth: Integer;
begin
 Screen.Cursor := crHourglass;
 Printer.BeginDoc;
 if ((ABitmap.Width / ABitmap.Height) > l(Printer.PageWidth / Printer.PageHeight)) then
 begin
 { Растягиваем ширину изображения до ширины бумаги }
 relWidth := Printer.PageWidth;
 relHeight := MulDiv(ABitmap.Height, Printer.PageWidth, ABitmap.Width);
 end
 else
 begin
 { Растягиваем высоту изображения до высоты бумаги }
 relWidth := MulDiv(ABitmap.Width, Printer.PageHeight, ABitmap.Height);
 relHeight := Printer.PageHeight;
 end;
 DrawImage(Printer.Canvas, Rect(0, 0, relWidth, relHeight), ABitmap);
 Printer.EndDoc;
 Screen.Cursor := crDefault;
end;
Source: Взято из Советов по Delphi от Валентина Озерова
ID: 03237
Category:Принтер
Растягивание иконки

=== Растягивание иконки ===
StretchDraw не работает с иконками. В данной ситуации я бы поступил так: рисовал бы иконку в Timage и затем назначал изображение другому, большему Timage.
Пример кода:
procedure TForm1.StringGrid1Click(Sender: TObject);
begin
 Image1.Canvas.FillRect(Image1.Canvas.ClipRect);
 Image1.Canvas.Draw(0, 0,
 TIcon(StringGrid1.Objects
 [StringGrid1.Col, StringGrid1.Row]));
 Form2.Image1.Picture := Image1.Picture;
end;
{ Примечание. Form2.Image1 имеет Stretch установленный
в True и размер, бОльший размера иконки в 4 раза }
Дополнение
Андрей Бреслав пишет:
предложенный способ не работает, ибо компонента TImage использует тот же метод StretchDraw, что и спрашивающий. Растянуть иконку можно так:
procedure TForm1.Button1Click(Sender: TObject);
var
 Bmp: TBitMap;
begin
 Bmp := TBitMap.Create;
 Bmp.Height := GetSystemMetrics(SM_CYICON);
 Bmp.Width := GetSystemMetrics(SM_CXICON);
 Bmp.Canvas.Draw(0,0, Image1.Picture.Icon);
 Image1.Picture.Bitmap := Bmp;
 Bmp.Free;
end;
Есть более человечный способ, чем просто рисовать в Image: функция DrawIconEx Win32 API:
procedure TForm1.Button1Click(Sender: TObject);
begin
 DrawIconEx(Canvas.Handle, 5, 5, LoadIcon(0, IDI_APPLICATION),
 16, 32, 0, 0, DI_NORMAL);
end;
Кстати, думаю, людям будет полезно знать по подробнее о DrawIconEx: Рисует иконку или курсор в соответствии с заданными занчениями.
function DrawIconEx(hdc: HDC; xLeft, yTop: Integer; hIcon: HICON;
 cxWidth, cyWidth: Integer; istepIfAniCur: UINT;
 hbrFlickerFreeDraw: HBRUSH; diFlags: UINT): BOOL; stdcall;
 hdc - контекст устройства (TCanvas.Handle)
 xLeft, yTop - координаты левого верхнего угла
 hIcon - дескриптор объекта Windows - Icon
 cxWidth, cyWidth - размеры
 istepIfAniCur - (!) номер отображаемого кадра в анимированном курсоре
 hbrFlickerFreeDraw - кисть
 diFlags - сумма след. занчений:
 DI_COMPAT - буду благодарен, если объясните
 DI_DEFAULTSIZE - если cxWidth, cyWidth равны 0, рисует в default размере
 DI_IMAGE - применяет одну часть кисти
 DI_MASK - применяет другую часть кисти
 DI_NORMAL = DI_IMAGE and DI_MASK - применяет обе части кисти
Source: http://delphiworld.narod.ru/
ID: 02369
Расширенный Label для отображения имени файла

=== Расширенный Label для отображения имени файла ===
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls;
type
 TForm1 = class(TForm)
 Label1: TLabel;
 procedure FormCreate(Sender: TObject);
 end;
var
 Form1: TForm1;
implementation
uses Types;
{$R *.dfm}
type
 TPathLabel = class(TLabel)
 private
 FHintWindow: THintWindow;
 procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
 procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
 procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
 procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; 
 protected
 procedure Paint; override;
 public
 constructor Create(AOwner: TComponent); override;
 end;
{ TPathLabel }
procedure TPathLabel.CMHintShow(var Message: TMessage);
var
 P: TPoint;
 R: TRect;
begin
 Message.Result := 1;
end;
procedure TPathLabel.CMMouseEnter(var Message: TMessage);
var
 P: TPoint;
 R: TRect;
 W: Integer;
begin
 W := Canvas.TextWidth(Caption);
 if W > ClientWidth then
 begin
 P := ClientToScreen(Point(0, 0));
 R := ClientRect;
 R := Rect(P.X, P.Y,
 P.X + W + 5,
 P.Y + ClientHeight);
 FHintWindow.ActivateHint(R, Caption);
 Message.Result := 1;
 end;
 inherited;
end;
procedure TPathLabel.CMMouseLeave(var Message: TMessage);
begin
 FHintWindow.ReleaseHandle;
 inherited;
end;
procedure TPathLabel.CMTextChanged(var Message: TMessage);
begin
 if Canvas.TextWidth(Caption) > ClientWidth then
 begin
 ShowHint := True;
 Hint := Caption;
 end else begin
 ShowHint := False;
 Hint := ;
 end;
 inherited;
end;
constructor TPathLabel.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 AutoSize := False;
 FHintWindow := THintWindow.Create(Self);
 FHintWindow.Color := Application.HintColor;
end;
procedure TPathLabel.Paint;
var
 R: TRect;
begin
 R := ClientRect;
 if Transparent then
 Canvas.Brush.Style := bsClear
 else begin
 Canvas.Brush.Style := bsSolid;
 Canvas.Brush.Color := Color;
 end;
 DrawText(Canvas.Handle, PChar(Caption), -1, R, DT_PATH_ELLIPSIS);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
 R: TRect;
begin
 R := Label1.BoundsRect;
 Inc(R.Top, 50);
 Inc(R.Bottom, 50);
 with TPathLabel.Create(Self) do
 begin
 Parent := Self;
 Color := clLime;
 BoundsRect := R;
 Caption := Label1.Caption;
 end;
end;
end.
Author: Smike
Source: Взято из http://forum.sources.ru
ID: 00809
Расшифровка строки, ранее зашифрованной фукцией UBPFD.Encrypt

{ **** UBPFD *********** by kladovka.net.ru ****
>> Расшифровка строки
Предназначена для расшифровки строки, ранее зашифрованной фукцией UBPFD.Encrypt
Зависимости: UBPFD.Encrypt
Автор: Anatoly Podgoretsky, anatoly@podgoretsky.com, Johvi
Copyright: (c) Anatoly Podgoretsky, 1996
Дата: 26 апреля 2002 г.
********************************************** }
const
 StartKey = 471; // Start default key
 MultKey = 62142; // Mult default key
 AddKey = 11719; // Add default key
// обязательно смените ключи до использования
{$R-}
{$Q-}
function Decrypt(const InString: string; StartKey, MultKey, AddKey: Integer): string;
var
 I: Byte;
// Если поменять тип переменной I на Integer, то будет возможно шифрование
// текста длиной более 255 символом - VID.
begin
 Result := ;
 for I := 1 to Length(InString) do
 begin
 Result := Result + CHAR(Byte(InString[I]) xor (StartKey shr 8));
 StartKey := (Byte(InString[I]) + StartKey) * MultKey + AddKey;
 end;
end;
{$R+}
{$Q+}
Пример использования:
S := 'Ваш старый пароль: <' + Decrypt(S, StartKey, MultKey, AddKey) + '>';
Author: Anatoly Podgoretsky
ID: 03991
----
{ **** UBPFD *********** by kladovka.net.ru ****
>> Расшифровка строки InString, зашифрованной с помощью функции EncryptEX
Функция является модификацией UBPFD.Decrypt. Отличие в том, что UBPFD.DecryptEX расшифровывает шифр-текст, зашифрованный с помощью функции UBPFD.EncryptEX
Зависимости: UBPFD.Decrypt, UBPFD.AsсiiToStr
Автор: VID, vidsnap@mail.ru, ICQ:132234868, Махачкала
Copyright: VID
Дата: 30 апреля 2002 г.
********************************************** }
function DecryptEX(const InString: string; StartKey, MultKey, AddKey: Integer): string;
begin
 Result := Decrypt(AsciiToStr(InString), StartKey, MultKey, AddKey);
end;
Пример использования:
var S: string;
begin
 S := UBPFD.EncryptEX('String', 1, 1, 1);
 // S является источником данных для функции UBPFD.DecryptEX
 ShowMessage('Расшифровка: ' + UBPFD.DecryptEX(S, 1, 1, 1));
end;
Author: VID
ID: 03992
Category:Алгоритмы
Category:Шифрование
Расщепление строки с разделителями на массив строк

=== Расщепление строки с разделителями на массив строк ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Расщепление строки с разделителями на массив строк
Зависимости: System
Автор: ALL.exe, Alexe@054.pfr.ru, ICQ:161857370, Kostroma
Copyright: ALL.exe
Дата: 13 марта 2003 г.
***************************************************** }
type
 TSepArr = array of string; // массив "записей"
 TSepRec = record
 Rec: TSepArr; // сами "записи"
 Max: integer; // количество полученных "записей"
 end;
function GetSeparatorRec(const sRows: string;
 cSeparator: char = ','): TSepRec;
var
 cCol: array of integer;
 i, j: integer;
 bSTRING: boolean;
begin
 Result.Max := -1;
 j := 1;
 bSTRING := False;
 SetLength(cCol, j);
 cCol[0] := 0;
 for i := 1 to Length(sRows) do
 begin
 if sRows[i] = '"' then
 bSTRING := not bSTRING;
 if (sRows[i] = cSeparator) and (not bSTRING) then
 begin
 j := j + 1;
 SetLength(cCol, j);
 cCol[j - 1] := i;
 end;
 end;
 j := j + 1;
 SetLength(cCol, j);
 cCol[j - 1] := Length(sRows) + 1;
 Result.Max := High(cCol);
 if Result.Max > 0 then
 begin
 SetLength(Result.Rec, Result.Max + 1);
 Result.Rec[0] := IntToStr(Result.Max);
 for i := 1 to Result.Max do
 Result.Rec[i] := Copy(sRows, cCol[i - 1] + 1, cCol[i] - cCol[i - 1] - 1);
 end;
end;
// Пример использования: 
var
 R: TSepRec;
begin
 R := GetSeparatorRec('123.45-ABCDEF-"A-B-C"-"0"-', '-');
// результат:
 R.Max = 5;
 R.Rec = ('5', '123.45', 'ABCDEF', '"A;B;C"', '"0"', );
Source: http://delphibase.endimus.com
ID: 00880
Реагируем на клик по ссылке в WebBrowser

var
 Document: IHtmlDocument2;
 V: Variant;
procedure TForm1.FormCreate(Sender: TObject);
begin
 WebBrowser1.Navigate('about:blank');
 while WebBrowser1.Document = nil do
 Application.ProcessMessages;
 Document := WebBrowser1.Document as IHtmlDocument2;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 V[0] :='<a href="http://ya.ru">Run</a>';
 Document.Writeln(PSafeArray(TVarData(v).VArray));
 WebBrowser1.OleObject.Document.ParentWindow.Scroll(0, 10000000);
end;
procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject;
 const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
 Headers: OleVariant; var Cancel: WordBool);
begin
 if url <> 'about:blank' then
 begin
 WebBrowser2.Navigate(URL);
 Cancel := True;
 end;
end;
Author: Rouse_
Source: Взято из http://forum.sources.ru
ID: 03523
----
var
 NavigateTo: Boolean = False;
procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject;
 const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
 Headers: OleVariant; var Cancel: WordBool);
begin
 if NavigateTo then
 begin
 Cancel := True;
 WebBrowser2.Navigate(URL);
 end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
 WebBrowser1.Navigate('about:<a href="http://ya.ru">Run</a>');
 NavigateTo := True;
end;
Author: s-mike
Source: Взято из http://forum.sources.ru
ID: 03524
----
* OnNewWindow2 
Возникает при попытке открыть документ в новом окне. Если Вы хотите, чтобы документ был открыт в Вашем экземпляре браузера, то Вам нужно создать свой экземпляр браузера и параметру ppDisp присвоить интерфейсную ссылку на этот экземпляр:
procedure TFormSimpleWB.WebBrowser1NewWindow2(Sender: TObject;
 var ppDisp: IDispatch; var Cancel: WordBool);
var
 newForm: TFormSimpleWB;
begin
 newForm := TFormSimpleWB.Create(Application);
 newForm.Show;
 ppDisp := newForm.WebBrowser1.ControlInterface;
end;
Author: -TOXA-
Source: http://forum.sources.ru
ID: 03525
Category:Связь
Category:WebBrowser
Реализовать фоновую работу программы

Попробуйте запустить программу. Пока компьютер ничего не делает, рисунок на окне все время меняется, но, стоит загрузить компьютер какой-либо работой, и изменение фона прекращается. В этой программе можно подвигать мышью по окну - это приведет к сравнительно сложным действиям, поэтому фоновая работа программы временно прекратится.
 public
 Row: Integer;
 procedure OnIdleProc(Sender: TObject; var Done: Boolean);
procedure TForm1.FormCreate(Sender: TObject);
begin
 Application.OnIdle := OnIdleProc;
end;
procedure TForm1.OnIdleProc(Sender: TObject; var Done: Boolean);
var
 i: Integer;
 col: TColor;
 Gray: Integer;
begin
 for i := 0 to Form1.ClientWidth - 1 do
 begin
 col := Form1.Canvas.Pixels[i, Row];
 Gray := GetRValue(col) + Round(30 * sin(i / 30 + Row / 50));
 Form1.Canvas.Pixels[i, Row] := RGB(Gray, Gray, Gray);
 end;
 Inc(Row);
 if (Row = Form1.ClientHeight) then Row := 0;
 Done := False;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
 i: Integer;
begin
 with Form1.Canvas do
 begin
 Brush.Style := bsClear;
 for i := 0 to 1000 do
 begin
 Pen.Color := RGB(i, i, i);
 Rectangle(X - i, Y - i, X + i, Y + i);
 end;
 end;
end;
ID: 04572
Category:Разработка приложений
Регионарные стандарты

=== Регионарные стандарты ===
В Дельфи есть предопределенные переменные языковых установок и форматов:
SysUtils
The following are a set of variables used to define the format for numeric or date/time strings:
var CurrencyString: string;
var CurrencyFormat: Byte;
var NegCurrFormat: Byte;
var ThousandSeparator: Char;
var DecimalSeparator: Char;
var CurrencyDecimals: Byte;
var DateSeparator: Char;
var ShortDateFormat: string;
var LongDateFormat: string;
var TimeSeparator: Char;
var TimeAMString: string;
var TimePMString: string;
var ShortTimeFormat: string;
var LongTimeFormat: string;
var ShortMonthNames: array[1..12] of string;
var LongMonthNames: array[1..12] of string;
var ShortDayNames: array[1..7] of string;
var LongDayNames: array[1..7] of string;
var SysLocale: TSysLocale;
var EraNames: array[1..7] of string;
var EraYearOffsets: array[1..7] of Integer;
var TwoDigitYearCenturyWindow: Word = 50;
var TListSeparator: Char; 
Author: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
Source: Взято с Vingrad.ru http://forum.vingrad.ru
ID: 00206
ID: 01979
Регистрация программ в меню Пуск Windows95

Подобная проблема возникает при создании инсталляторов и деинсталляторов. Наиболее простой и гибкий путь - использование DDE. При этом посылаются запросы к PROGMAN. Для этого необходимо поместить на форму компонент для посылки DDE запросов - объект типа TDdeClientConv. Для определенности назовем его DDEClient. Затем добавим метод для запросов к PROGMAN:
function TForm2.ProgmanCommand(Command: string): Boolean;
var
 MacroCmd: array[0..88] of Char;
begin
 DDEClient.SetLink('PROGMAN', 'PROGMAN');
 DDEClient.OpenLink; { Устанавливаем связь по DDE }
 strPCopy(macrocmd, '[' + Command + ']'); { Подготавливаем ASCIIZ строку }
 ProgmanCommand := DDEClient.ExecuteMacro(MacroCmd, False);
 DDEClient.CloseLink; { Закрываем связь по DDE }
end;
// Пример использования:
ProgmanCommand('CreateGroup(Комплекс программ для каталогизации литературы, )');
ProgmanCommand('AddItem(' + path + 'vbase.hlp, Справка по VBase, ' + path + ' vbase.hlp, 0, , , ' + path + ', , )');
// где path - строка типа String, содержащая
// полный путь к каталогу ('C:\Catalog\');
При вызове ProgmanCommand возвращает true, если посылка макроса была успешна. Система команд (основных) приведена ниже:
* Create(Имя группы, путь к GRP файлу) - Создать группу с именем "Имя группы", причем в нем могут быть пробелы и знаки препинания. Путь к GRP файлу можно не указывать, тогда он создастся в каталоге Windows.
* Delete(Имя группы) - Удалить группу с именем "Имя группы"
* ShowGroup(Имя группы, состояние) - Показать группу в окне, причем состояние - число, определяющее параметры окна:
** 1 - нормальное состояние + активация
** 2 - миним.+ активация
** 3 - макс. + активация
** 4 - нормальное состояние
** 5 - Активация
* AddItem(командная строка, имя раздела, путь к иконке, индекс иконки (с 0), Xpos,Ypos, рабочий каталог, HotKey, Mimimize) - Добавить раздел к активной группе. В командной строке, имени размера и путях допустимы пробелы
** Xpos и Ypos - координаты иконки в окне, лучше их не задавать, тогда PROGMAN использует значения по умолчанию для свободного места.
** HotKey - виртуальный код горячей клавиши.
** Mimimize - тип запуска, 0-в обычном окне, <>0 - в минимизированном.
* DeleteItem(имя раздела) - Удалить раздел с указанным именем в активной группе
Source: http://delphiworld.narod.ru/
ID: 04506
Category:DDE
Регистрация редактора свойства

=== Регистрация редактора свойства ===
Скажем, вы имеете компонент TContainer, содержащий TContainedClass в свойстве с именем 'Contained' - попробуйте добавить следующую строку к процедуре Register вашего компонента:
RegisterPropertyEditor(TypeInfo(TContainedClass),
 TContainer,
 'Contained',
 TClassProperty);
Не забудьте добавить TypInfo и DsgnIntf в список используемых модулей.
Все это задокументировано в справке помощи. Первым параметром всегда идет TypeInfo() с "коллекционируемым" классом в качестве параметра, затем контейнерный класс или NIL, если он должен работать для всех экземпляров контейнерного класса с заданным свойством, затем идет имя контейнерного свойства или , если редактор должен работать для всех свойств, и завершает славную четверку параметров класс TClassProperty, расширяющий классовое свойство, т.е. "создающий" знак "+" в Инспекторе Объектов, позволяющий редактировать вложенные свойства (щелчок на плюсике раскрывает список вложенных свойств описываемого контейнерного класса).
Author: Mike Scott, Mobius Ltd. 
Source: Валентина Озерова, Сборник Kuliba
ID: 00037