Реляционные базы данных?

Итак, Реляционная база данных упрощённо является набором таблиц. Таблица же есть основной строительный кирпичик базы данных. Расмотрим структуру таблицы. Для начала представте себе таблицу, например в Word...
Что в ней есть?

Во-первых есть строки и колонки (raw and columns). В базах данных, в отличие от Word есть строгие ограничения на их содержимое, да и терминология немного другая:
1) Колонка называется тоже columns, но чаще употребляется понятие "поле" (field). Колонка всегда имеет имя (по которому ее можно найти) и обязана хранить данные только одного какого-либо типа - например целые числа, строки, дату/время и т.п. Создавая таблицу вы обязаны указать какой тип имеет каждое поле, другими словами, вы заранее должны определится, какого сорта данные будут хранится в колонке. Например, вот примерно так может выглядеть структура таблицы для хранения данных об участнике этого форума:

·Ник - строка (25 символов)
·ФИО - строка (250 символов)
·Дата регистрации - Дата/время
·Количество постингов - Целое
·Показывать email - True/False

Обратите внимание что для строк я указал конкретную длину, а для остальных ничего не указывал. Зачем? Ответ прост - каждая строка должна занимать строго одинаковое место (об исключениях потом), и это сделано для быстроты поиска. Действительно , если бы каждая строка имела разную длину, то чтобы найти например 1000 строку, надо было бы перечитать все 999 предыдущих строк, но если известно, что каждая строка занимает например 1Кб, то чтобы прочитать 1000 строку достаточно прочитать 1 Кб с 999Кб... Другая сторона этого - например мне надо сравнить даты в приведенной выше таблице - сделать это просто - я точно знаю что первую дату можно прочитать с 276 байта, и так же точно я знаю точные координаты каждой даты. Именно в этом и лежит одна из сторон высокой скорости работы баз данных (другие способы ускорения работы рассмотрим позже).

2) Строка - в базах данных имеет специфическое название - запись (Record) - к Дельфийскому типу Record этот термин не имеет никакого отношения. Хотя большинство БД дают возможность перейти и прочитать например 10 запись, надо с самого начала попытаться никогда этим не пользоваться. Почему? Да просто потому что БД практически всегда подразумевают совместный доступ нескольких пользователей к одним и тем же данным, и если Вы хотите перейти на 10 запись, а другой пользователь в это время удалит запись номер 5, то вы перейдёте вовсе не на ту запись что ожидалось. А как же быть? У вас есть 2 способа - либо вы находите нужную запись по значению поля - например для нашей таблицы это будет выглядеть примерно так:

"Найти пользователя [Вася] в первой колонке"

В результате вы получите доступ ко всем полям записи для "Васи". Либо вы берёте все записи и перебираете их в цикле пока не найдёте нужный - это гораздо худший способ, так как работает на 2-3 порядка медленнее и имеет другие неприятные последствия (об этом позже), но он возможен и иногда применяется.

Репортинг, работа с принтером

Cодержание раздела:

·
·
·
·

(

раздел)

(

раздел)

(

раздел)

(

раздел)

См. также статьи в других разделах:

Режим замены

Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength edit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "Insert".

Пример:

type
TForm1 = class(TForm)
        Memo1: TMemo;
        procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
        procedure Memo1KeyPress(Sender: TObject; var Key: Char);
private
    {Private declarations}
        InsertOn : bool;
public
    {Public declarations}
end;

var
   Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
    if (Key = VK_INSERT) and (Shift = []) then
        InsertOn := not InsertOn;
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
    if ((Memo1.SelLength = 0) and (not InsertOn)) then
        Memo1.SelLength := 1;
end;

Автор:

Song

Взято из

RGB --> CMYK

procedure RGBTOCMYK(R : byte;
                    G : byte;
                    B : byte;
                    var C : byte;
                    var M : byte;
                    var Y : byte;
                    var K : byte);
begin
  C := 255 - R;
  M := 255 - G;
  Y := 255 - B;
  if C  0 then
    begin
      c := c - k;
      m := m - k;
      y := y - k;
    end;
end;

RGB --> Gray

function RgbToGray(RGBColor: TColor): TColor;
var
  Gray: byte;
begin
  Gray := Round((0.30 * GetRValue(RGBColor)) +
    (0.59 * GetGValue(RGBColor)) +
    (0.11 * GetBValue(RGBColor)));
  Result := RGB(Gray, Gray, Gray);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Shape1.Brush.Color := RGB(255, 64, 64);
  Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color);
end;

Рисование без мерцания

Автор: Mike Scott

...вот я и удивляюсь - почему я получаю мерцание, если я вызываю Repaint или Refresh, а не метод OnPaint напрямую? Или это просто "вариация на тему"?

Имеются две фазы обновления окна. В первой фазе, при выводе окна, Windows посылает ему сообщение WM_ERASEBKGND, сообщающее о необходимости стирания фона перед процедурой рисования. Затем посылается сообщение WM_PAINT, служащее сигналом для закрашивания "переднего плана".

Тем не менее, вы можете пропустить первую фазу, которая вызывает мерцание, одним из двух способов: первый способ заключается в том, что вы форсируете обновление сами, с помощью вызова функции Windows API InvalidateRect. На входе он получает дескриптор окна, указатель на закрашиваемую область - передаем NIL, если вы хотите отрисовать всю область окна - и третий параметр, сообщающий о необходимости очистки фона. Вот как раз последний параметр и должен содержать значение FALSE, если вы сами будете в методе Paint полностью отрисовывать всю область:

InvalidateRect(Handle, NIL, FALSE ) ;

Handle должен быть дескриптором формы или элемента управления.

Описав первый способ, я скажу, что существует другое подходящее решение - использовать функциональность VCL. Вы можете указать VCL не стирать фон, добавляя [ csOpaque ] к значению свойства ControlStyle, как показано ниже:

ControlStyle := ControlStyle + [ csOpaque ] ;

Это ограничивает заполнение заднего фона, но вы все еще можете видеть процесс "наполнения" области изображением, т.е. процесс рисования. В этом случае вы можете отделаться от эффекта мельтешения, рисуя на TBitmap и выводя его затем на экран командой CopyRect.

Если вы хотите углубиться в тему дальше, то я отошлю вас к моей статье "Optimizing Display Updates in Delphi" (Оптимизация обновления экрана в Delphi), опубликованной в первом выпуске журнала "Delphi magazine".

Взято из

Рисование фрактальных графов

Автор: Михаил Марковский

...Очередная нетленка, которую я предлагаю Вам, написана мной самостоятельно (идею и примеры, реализованные в программе, я нашел в апрельском номере журнала "Химия и жизнь" за 1995 год). Теоретически она производит трансляцию L-систем с выводом образовавшихся фрактальных графов, а практически рисует кусты и деревья. Вроде бесполезно, но очень красиво. Эта программа написана для TP7, хотя легко переносится на Delphi (как то я уже переводил ее, но модуль бесследно исчез). Буду надеяться, что она придется Вам по душе.

usesgraph, crt;

const
 GrafType = 1; {1..3}

type
 PointPtr = ^Point;
 Point = record
 X, Y: Word;
 Angle: Real;
 Next: PointPtr
 end;
 GrfLine = array[0..5000] of
 Byte;
 ChangeType = array[1..30] of
 record
 Mean: Char;
 NewString: string
 end;

var
 K, T, Dx, Dy, StepLength, GrafLength: Word;
 grDriver, Xt: Integer;
 grMode: Integer;
 ErrCode: Integer;
 CurPosition: Point;
 Descript: GrfLine;
 StartLine: string absolute Descript;
 ChangeNumber, Generation: Byte;
 Changes: ChangeType;
 AngleStep: Real;
 Mem: Pointer;

procedure Replace(var Stroka: GrfLine;
 OldChar: Char;
 Repl: string);
var
 I, J: Word;
begin
 if (GrafLength = 0) or (Length(Repl) = 0) then
 Exit;
 I := 1;
 while I <= GrafLength do
 begin
 if Chr(Stroka[I]) = OldChar then
 begin
 for J := GrafLength downto I + 1 do
 Stroka[J + Length(Repl) - 1] := Stroka[J];
 for J := 1 to Length(Repl) do
 Stroka[I + J - 1] := Ord(Repl[J]);
 I := I + J;
 GrafLength := GrafLength + Length(Repl) - 1;
 continue
 end;
 I := I + 1
 end
end;

procedure PushCoord(var Ptr: PointPtr;

 C: Point);
var

 P: PointPtr;
begin

 New(P);
 P^.X := C.X;
 P^.Y := C.Y;
 P^.Angle := C.Angle;
 P^.Next := Ptr;
 Ptr := P
end;

procedure PopCoord(var Ptr: PointPtr;

 var Res: Point);
begin

 if Ptr <> nil then
 begin
 Res.X := Ptr^.X;
 Res.Y := Ptr^.Y;
 Res.Angle := Ptr^.Angle;
 Ptr := Ptr^.Next
 end
end;

procedure FindGrafCoord(var Dx, Dy: Word;

 Angle: Real;
 StepLength: Word);
begin

 Dx := Round(Sin(Angle) * StepLength * GetMaxX / GetMaxY);
 Dy := Round(-Cos(Angle) * StepLength);
end;

procedure NewAngle(Way: ShortInt;

 var Angle: Real;
 AngleStep: Real);
begin

 if Way >= 0 then
 Angle := Angle + AngleStep
 else
 Angle := Angle - AngleStep;
 if Angle >= 4 * Pi then
 Angle := Angle - 4 * Pi;
 if Angle < 0 then
 Angle := 4 * Pi + Angle
end;

procedure Rost(var Descr: GrfLine;

 Cn: Byte;
 Ch: ChangeType);
var
 I: Byte;
begin

 for I := 1 to Cn do
 Replace(Descr, Ch[I].Mean, Ch[I].NewString);
end;

procedure Init1;
begin

 AngleStep := Pi / 8;
 StepLength := 7;
 Generation := 4;
 ChangeNumber := 1;
 CurPosition.Next := nil;
 StartLine := 'F';
 GrafLength := Length(StartLine);
 with Changes[1] do
 begin
 Mean := 'F';
 NewString := 'FF+[+F-F-F]-[-F+F+F]'
 end;
end;

procedure Init2;
begin

 AngleStep := Pi / 4;
 StepLength := 3;
 Generation := 5;
 ChangeNumber := 2;
 CurPosition.Next := nil;
 StartLine := 'G';
 GrafLength := Length(StartLine);
 with Changes[1] do
 begin
 Mean := 'G';
 NewString := 'GFX[+G][-G]'
 end;
 with Changes[2] do
 begin
 Mean := 'X';
 NewString := 'X[-FFF][+FFF]FX'
 end;
end;

procedure Init3;
begin

 AngleStep := Pi / 10;
 StepLength := 9;
 Generation := 5;
 ChangeNumber := 5;
 CurPosition.Next := nil;
 StartLine := 'SLFF';
 GrafLength := Length(StartLine);
 with Changes[1] do
 begin
 Mean := 'S';
 NewString := '[+++G][---G]TS'
 end;
 with Changes[2] do
 begin
 Mean := 'G';
 NewString := '+H[-G]L'
 end;
 with Changes[3] do
 begin
 Mean := 'H';
 NewString := '-G[+H]L'
 end;
 with Changes[4] do
 begin
 Mean := 'T';
 NewString := 'TL'
 end;
 with Changes[5] do
 begin
 Mean := 'L';
 NewString := '[-FFF][+FFF]F'
 end;
end;

begin

 case GrafType of
 1: Init1;
 2: Init2;
 3: Init3;
 else
 end;
 grDriver := detect;
 InitGraph(grDriver, grMode, '');
 ErrCode := GraphResult;
 if ErrCode <> grOk then
 begin
 WriteLn('Graphics error:', GraphErrorMsg(ErrCode));
 Halt(1)
 end;
 with CurPosition do
 begin
 X := GetMaxX div 2;
 Y := GetMaxY;
 Angle := 0;
 MoveTo(X, Y)
 end;
 SetColor(white);
 for K := 1 to Generation do
 begin
 Rost(Descript, ChangeNumber, Changes);
 Mark(Mem);
 for T := 1 to GrafLength do
 begin
 case Chr(Descript[T]) of
 'F':
 begin
 FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
 with CurPosition do
 begin
 Xt := X + Dx;
 if Xt < 0 then
 X := 0
 else
 X := Xt;
 if X > GetMaxX then
 X := GetMaxX;
 Xt := Y + Dy;
 if Xt < 0 then
 Y := 0
 else
 Y := Xt;
 if Y > GetMaxY then
 Y := GetMaxY;
 LineTo(X, Y)
 end
 end;
 'f':
 begin
 FindGrafCoord(Dx, Dy, CurPosition.Angle, StepLength);
 with CurPosition do
 begin
 Xt := X + Dx;
 if Xt < 0 then
 X := 0
 else
 X := Xt;
 if X > GetMaxX then
 X := GetMaxX;
 Xt := Y + Dy;
 if Xt < 0 then
 Y := 0
 else
 Y := Xt;
 if Y > GetMaxY then
 Y := GetMaxY;
 MoveTo(X, Y)
 end
 end;
 '+': NewAngle(1, CurPosition.Angle, AngleStep);
 '-': NewAngle(-1, CurPosition.Angle, AngleStep);
 'I': NewAngle(1, CurPosition.Angle, 2 * Pi);
 '[': PushCoord(CurPosition.Next, CurPosition);
 ']':
 begin
 PopCoord(CurPosition.Next, CurPosition);
 with CurPosition do
 MoveTo(X, Y)
 end
 end
 end;
 Dispose(Mem);
 Delay(1000)
 end;
 repeat
 until KeyPressed;
 CloseGraph
end.

Взято из

Рисование графов

...вы могли бы использовать объект TCanvas, чем рисовать самому. В вашем случае сгодится компонент TImage, он имеет bitmap и свойство canvas, на котором очень удобно рисовать.

Пример: (Создайте новую форму, добавьте к ней Image и Button. Добавьте следующий код к обработчику события нажатия кнопки)

var
x, l: Integer;
  y, a: Double;
begin
  Image1.Picture.Bitmap := TBitmap.Create;
  Image1.Picture.Bitmap.Width := Image1.Width;
  Image1.Picture.Bitmap.Height := Image1.Height; {Эти три строчки могут быть
  размещены в обработчике Form1.Create}
  l := Image1.Picture.Bitmap.Width;
  for x := 0 to l do
  begin
    a := (x / l) * 2 * Pi; {Преобразуем позицию по оси X к углу между 0 & 2Pi}
    y := Sin(a); {Ваша функция должна находиться здесь}
    y := y * (Image1.Picture.Bitmap.Height / 2); {Масштабируем по оси Y}
    y := y * -1; {Инвертируем Y, верх экрана это 0 !}
    y := y + (Image1.Picture.Bitmap.Height / 2);
      {Добавляем компенсацию для среднего 0}
    Image1.Picture.Bitmap.Canvas.Pixels[Trunc(x), Trunc(y)] := clBlack;
  end;
end;

Я обнаружил, что лучшим решением будет рисование на холсте. Предпочтительно делать это в отдельной процедуре, которая принимает в качестве параметров TCanvas и TRect. Таким способом мы может передать в качестве параметров холст вашего окна и клиентскую область для рисования на экране, и холст принтера и область клиента для ее позиционирования и печати. Чтобы посмотреть доступные для рисования подпрограммы, взгляните на методы холста.

Взято из

Рисование КРИВЫХ в Delphi

Автор: Dmitry Streblechenko

У кого-нибудь есть исходный код или какая-либо информация для рисования кривых Безье? Я должен использовать их в своем компоненте.

Я делал это недавно; мне было лениво разбираться с тем, как рисовать кривые Безье с помощью Win API, поэтому я использовал функцию Polyline().

Примечание: для координатных точек я использовал реальные величины типа floating (я применял некоторый тип виртуального экрана), округляя их до целого.

PBezierPoint= ^TBezierPoint;
TBezierPoint = record
  X, Y: double;   // основной узел
  Xl, Yl: double; // левая контрольная точка
  Xr, Yr: double; // правая контрольная точка
end;

// P1 и P2 - две точки TBezierPoint, расположенные между 0 и 1:
// когда t=0 X=P1.X, Y=P1.Y; когда t=1 X=P2.X, Y=P2.Y;

procedure BezierValue(P1, P2: TBezierPoint; t: double; var X, Y: double);
var
  t_sq, t_cb, r1, r2, r3, r4: double;
begin
  t_sq := t * t;
  t_cb := t * t_sq;
  r1 := (1 - 3 * t + 3 * t_sq - t_cb) * P1.X;
  r2 := (3 * t - 6 * t_sq + 3 * t_cb) * P1.Xr;
  r3 := (3 * t_sq - 3 * t_cb) * P2.Xl;
  r4 := (t_cb) * P2.X;
  X := r1 + r2 + r3 + r4;
  r1 := (1 - 3 * t + 3 * t_sq - t_cb) * P1.Y;
  r2 := (3 * t - 6 * t_sq + 3 * t_cb) * P1.Yr;
  r3 := (3 * t_sq - 3 * t_cb) * P2.Yl;
  r4 := (t_cb) * P2.Y;
  Y := r1 + r2 + r3 + r4;
end;

Для рисования кривой Безье разделяем интервал между P1 и P2 на несколько отрезков (их количество влияет на точность воспроизведения кривой, 3 - 4 точки вполне достаточно), затем в цикле создаем массив точек, используем описанную выше процедуру с параметром t от 0 до 1 и рисуем данный массив точек, используя функцию polyline().

Взято из

Рисование в разных местах, захват изображения

Cодержание раздела:

Рождение, жизнь и гибель формы.

(Перевод одноимённой статьи с сайта delphi.about.com )

В Windows основной элемент пользовательского интерфейса - форма. В Delphi каждый проект имеет по крайней мере одно окно - главное окно приложения. Все окна в Delphi основаны на объекте TForm. В данной статье мы рассмотрим основные события учавствующие в "жизни формы".

Форма
Формы имеют свои свойства, события и методы, при помощи которых Вы можете управлять видом и поведением формы. Форма, это обычный компонент Delphi, но в отличие от других, её нет на панели компонентов. Обычно форма создаётся при создании нового проекта (File | New Application). Вновь созданная форма будет главной формой приложения.

Дополнительные формы в проекте создаются через File | New Form. Так же существуют и другие способы создания форм, но здесь мы не будем рассматривать их...

Как и любой другой компонент (объект) форма имеет свои методы и реагирует на события. Давайте рассмотрим некоторые из этих событий...

Рождение

OnCreate -> OnShow -> OnActivate-> OnPaint -> OnResize -> OnPaint ...

OnCreate
Событие OnCreate возникает при создании TForm и только один раз. При создании формы (у каторой свойство Visible установлено в True), события произойдут в следующем порядке: OnCreate, OnShow, OnActivate, OnPaint.
В обработчике события OnCreate можно сделать какие-либо инициализационные действия, однако, любые объекты созданные в OnCreate будут уничтожены в событии OnDestroy.

OnShow
Это событие генерируется, когда форма станет видимой. OnShow вызывается сразу перед тем, как форма станет видимой. Это событие случается, если установить свойство формы Visible в True, либо при вызове методов Show или ShowModal.

OnActivate
Это событие генерируется, когда форма становится активной, тоесть когда форма получает фокус ввода. Это событие можно использовать для того, чтобы сменить элемент формы который должен получить фокус.

OnPaint, OnResize
Эти события вызываются каждый раз, когда форма изначально создаётся. При этом OnPaint вызывается каждый раз, когда какому-нибудь элементу формы необходимо перерисоваться (это событие можно использовать, если необходимо при этом рисовать на форме что-то особенное).

Жизнь
Когда форма создана и все её элементы ждут своих событий, чтобы обрабатывать их, жизнь формы продолжается до тех пор, пока кто-нибудь не нажмёт крестик в верхнем правом углу формы!

Уничтожение
При уничтожении формы, события генерируются в следующем порядке:

... OnCloseQuery -> OnClose-> OnDeactivate -> OnHide -> OnDestroy

OnCloseQuery
Если мы попытаемся закрыть форму при помощи метода Close либо другим доступным способом (Alt+F4 либо через системное меню), то сгенерируется событие OnCloseQuery. Таким образом, это событие можно использовать, чтобы предотвратить закрытие формы. Обычно, событие OnCloseQuery используется для того, чтобы спросить пользователя - уверен ли он (возможно в приложении остались несохранённые данные).

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if MessageDlg('Really close this window?', mtConfirmation, [mbOk, mbCancel], 0) = mrCancel then
CanClose := False;
end;

Обработчик события OnCloseQuery содержит переменную CanClose, которая определяет, можно ли форме закрыться. Изначальное значение этой переменной True. Однако в обработчике OnCloseQuery можно установить возвращаемое значение CloseQuery в False, чтобы прервать выполнение метода Close.

OnClose
Если OnCloseQuery вернул CanClose=True (что указывает на то, что форма должна быть закрыта), то будет будет сгенерировано событие OnClose.
Событие OnClose даёт последний шанс, чтобы предотвратить закрытие формы. Обработчик OnClose имеет параметр Action со следующими четырьмя возможными значениями:
caNone. Форме не разрешено закрыться. Всё равно, что мы установим CanClose в False в OnCloseQuery.
caHide. Вместо закрытия, форма будет скрыта.
caFree. Форма будет закрыта, и занятые ей ресурсы будут освобождены.
caMinimize. Вместо закрытия, форма будет минимизирована. Это значение устанавливается поумолчанию у дочерних форм MDI.

Замечание: Когда пользователь шутдаунит Windows, то будет вызвано OnCloseQuery, а не OnClose. Если Вы не хотите, чтобы Windows завершила свою работу, то поместите свой код в обработчик события OnCloseQuery, хотя CanClose=False не сделает, того, что надо здесь.

OnDestroy
После того, как метод OnClose будет обработан и форма будет закрыта, то будет вызвано событие OnDestroy. В OnCreate обычно делаются действия, противоположные тем, которые проделывались в OnCreate, то есть уничтожение созданных объектов и освобождение выделенной памяти.

Естевственно, что когда главная форма проекта будет закрыто, то приложение будет завершено.

Взято с Исходников.ru

RTF-->HTML

Приведу программу, которую я использую для преобразования содержимого RichEdit в SGML-код. Она не формирует полный HTML-аналог, но вы сами можете добавить необходимый RTF-код и его интерпретацию в HTML-тэги.

Код содержит интуитивно понятные комментарии и строки на шведском языке, нецелесообразные для перевода.

functionrtf2sgml(text: string): string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
 temptext: string;
 start: integer;
begin
 text := stringreplaceall(text, '&', '##amp;');
 text := stringreplaceall(text, '##amp', '&amp');
 text := stringreplaceall(text, '\' + chr(39) + 'e5', 'å');
 text := stringreplaceall(text, '\' + chr(39) + 'c5', 'Å');
 text := stringreplaceall(text, '\' + chr(39) + 'e4', 'ä');
 text := stringreplaceall(text, '\' + chr(39) + 'c4', 'Ä');
 text := stringreplaceall(text, '\' + chr(39) + 'f6', 'ö');
 text := stringreplaceall(text, '\' + chr(39) + 'd6', 'Ö');
 text := stringreplaceall(text, '\' + chr(39) + 'e9', 'é');
 text := stringreplaceall(text, '\' + chr(39) + 'c9', 'É');
 text := stringreplaceall(text, '\' + chr(39) + 'e1', 'á');
 text := stringreplaceall(text, '\' + chr(39) + 'c1', 'Á');
 text := stringreplaceall(text, '\' + chr(39) + 'e0', 'à');
 text := stringreplaceall(text, '\' + chr(39) + 'c0', 'À');
 text := stringreplaceall(text, '\' + chr(39) + 'f2', 'ò');
 text := stringreplaceall(text, '\' + chr(39) + 'd2', 'Ò');
 text := stringreplaceall(text, '\' + chr(39) + 'fc', 'ü');
 text := stringreplaceall(text, '\' + chr(39) + 'dc', 'Ü');
 text := stringreplaceall(text, '\' + chr(39) + 'a3', '£');
 text := stringreplaceall(text, '\}', '#]#');
 text := stringreplaceall(text, '\{', '#[#');
 text := stringreplaceall(text, '{\rtf1\ansi\deff0\deftab720', ''); {Skall alltid tas bort}
 text := stringreplaceall(text, '{\fonttbl', ''); {Skall alltid tas bort}
 text := stringreplaceall(text, '{\f0\fnil MS Sans Serif;}', ''); {Skall alltid tas bort}
 text := stringreplaceall(text, '{\f1\fnil\fcharset2 Symbol;}', ''); {Skall alltid tas bort}
 text := stringreplaceall(text, '{\f2\fswiss\fprq2 System;}}', ''); {Skall alltid tas bort}
 text := stringreplaceall(text, '{\colortbl\red0\green0\blue0;}', ''); {Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
 text := stringreplaceall(text, '\cf0', '');
 temptext := hamtastreng(text, '\deflang', '\pard'); {Plocka fran deflang till pard for att fa }
 text := stringreplace(text, temptext, ''); {oavsett vilken lang det ar. Norska o svenska ar olika}
{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
 while pos('\fs', text) > 0 do

 begin
 application.processmessages;
 start := pos('\fs', text);
 Delete(text, start, 5);
 end;
 text := stringreplaceall(text, '\pard\plain\f0 ', '');
 text := stringreplaceall(text, '\par \plain\f0\b\ul ', '<MELLIS>');
 text := stringreplaceall(text, '\plain\f0\b\ul ', '<MELLIS>');
 text := stringreplaceall(text, '\plain\f0', '</MELLIS>');
 text := stringreplaceall(text, '\par }', '');
 text := stringreplaceall(text, '\par ', '');
 text := stringreplaceall(text, '#]#', '}');
 text := stringreplaceall(text, '#[#', '{');
 text := stringreplaceall(text, '\\', '\');
 result := text;
end;

//Нижеприведенный кусок кода вырезан из довольно большой программы, вызывающей вышеприведенную функцию.
//Я знаю что мог бы использовать потоки вместо использования отдельного файла, но у меня не было времени для реализации этого

utfilnamn := mditted.exepath + stringreplace(stringreplace(extractfilename(pathname), '.TTT', ''), '.ttt', '') + 'ut.RTF';
brodtext.lines.savetofile(utfilnamn);
temptext := '';
assignfile(tempF, utfilnamn);
reset(tempF);
try
 while not eof(tempF) do
 begin
 readln(tempF, temptext2);
 temptext2 := stringreplaceall(temptext2, '\' + chr(39) + 'b6', '');
 temptext2 := rtf2sgml(temptext2);
 if temptext2 <> '' then temptext := temptext + temptext2;
 application.processmessages;
 end;
finally
 closefile(tempF);
end;
deletefile(utfilnamn);
temptext := stringreplaceall(temptext, '</MELLIS> ', '</MELLIS>');
temptext := stringreplaceall(temptext, ' ', '');
temptext := stringreplaceall(temptext, '' + chr(0), '');
temptext := stringreplaceall(temptext, '</MELLIS>', '</MELLIS>');
temptext := stringreplaceall(temptext, '', '');
temptext := stringreplaceall(temptext, '</MELLIS>', '</MELLIS>');
temptext := stringreplaceall(temptext, '</MELLIS>', '<#MELLIS>');
temptext := stringreplaceall(temptext, '<#MELLIS>', '</MELLIS>');
temptext := stringreplaceall(temptext, '', '');
temptext := stringreplaceall(temptext, ' ', '');
temptext := stringreplaceall(temptext, '-', '_');
temptext := stringreplaceall(temptext, '_', '<CITAT>_');
while pos('<CITAT>_', temptext) > 0 do
 begin
 application.processmessages;
 temptext2 := hamtastreng(temptext, '<CITAT>_', '');
 temptext := stringreplace(temptext, temptext2 + '', temptext2 + '</CITAT>');
 temptext := stringreplace(temptext, '<CITAT>_', '<CITAT>-');
 end;
writeln(F, '<BRODTEXT>' + temptext + '</BRODTEXT>');

Взято из

Советов по Delphi от

Сборник Kuliba

RTL Delphi (краткий справочник)

Cодержание раздела:

См. также статьи в других разделах:

RTTI и другие трюки с информацией о классах, модулях и т.п.

Cодержание раздела:

См. также другие разделы:

Runtime error 230 when running Kylix application outside of the IDE

Why am I getting runtime error 230 when running my application outside of the Kylix IDE?

This error generally means your application cannot find a needed library.
Tunning the command source \kylix\bin\kylixpath in Linux should fix this. See the file deploy.txt that comes with Kylix.

Русификация Kylix

В этой статье я решил рассказать тебе, как можно заставить Kylix уважать русский язык. Для этого нужно полностью русифицировать Linux. Это не так уж и сложно и мы сейчас полностью опишем этот процесс.

Для Kylix желательно использовать кодовую страницу KOI-8r, которая является практически стандартом русского языка в Linux. Для того, чтобы Kylix мог понимать русские шрифты, нужно сделать следующее:

1. Открыть файл /etc/sysconfig/i18n и добавить в него следующие недостающие строки:

LANG=ru
LANGUAGE=ru_RU.KOI8-R:ru #опционально
LC_CTYPE=ru_RU.KOI8-R
LC_NUMERIC=ru_RU.KOI8-R
LC_TIME=ru_RU.KOI8-R
LC_COLLATE=ru_RU.KOI8-R
LC_MONETARY=ru_RU.KOI8-R
LC_MESSAGES=ru_RU.KOI8-R
LC_ALL=ru_RU.KOI8-R
SYSFONT=UniCyr_8x16
SYSFONTACM=koi8-r

Если какие-то из этих строк уже есть в файле, то нужно отредактировать существующие.

В системе уже должны быть установлены русские шрифты. В последних дистрибутивах почти всегда идут шрифты Cronyx Cyrillic, которых достаточно для нормальной работы Kylix.

И последнее, что надо сделать - настрокить переключение клавиатуры в файле /etc/X11/XF86Config. Там нужно отредактировать следующие строки:

Option "XkbLayout" "ru(winkeys)"
Option "XkbOptions" "grp:ctrl_shift_toggle"

Последняя строка показывает как будет переключатся раскладка. В данном случае будет использоваться сочетание клавишь Ctrl+Shift.

Вот и всё!!! Желательно ещё и перегрузить Linux, чтобы он заговорил по русски.

Взято с сайта

S-регистры модема

S0Звонок, на который необходимо ответить (Ring After Which To Answer)
S1 Количество звонков (Ring Count)
S2 Символ отмены (Hayes Escape Character)
S3 Символ перевода строки (Carriage Return Character)
S4 Символ пропуска строки (Line Feed Character)
S5 Символ пробела (Backspace Character)
S6 Ожидание перед вызывом (Wait Before Blind Dialing)
S7 Ожидание ответа (Wait For Carrier)
S8 Время паузы для запятой (Pause Time For Comma)
S9 Время восстановления (Carrier Recovery Time)
S10 Время задержки для поднятия трубки после потери соединения (Lost Carrier Hang Up Delay)
S11 Время DTMF соединения (DTMF Dialing Speed)
S12 Время защиты отмены (Hayes Escape Guard Time)
S16 Выполнение теста (Test in Progress)
S18 Тест таймера модема (Modem Test Timer)
S19 Настройки автосинхронизации (AutoSync Options)
S25 Обнаружено изменение DTD (Detect DTD Change)
S26 Интервал задержки RTS для CTS (RTS To CTS Delay Interval)
S30 Неактивное время ожидания (Inactivity Timeout)
S31 Символ XON (XON Character)
S32 Символ XOFF (XON Character)
S36 Ошибка согласования TDeatment (Negotiation Failure TDeatment)
S37 Ускорение DCE линии (Desired DCE Line Speed)
S38 Время ожидания снятия трубки (Hang-up Timeout)
S43 Текущая скорость линии (Current Line Speed)
S44 Техническая конструкция (Framing Technique)
S46 Выбор протокола/компрессии (Protocol/Compression Selection)
S48 Действие характеристики согласования (Feature Negotiation Action)
S49 Низкий предел буфера (Buffer Low Limit)
S50 Высокий предел буфера (Buffer High Limit)
S70 Максимальное число ReTDansmissions (Maximum Number of ReTDansmissions)
S73 Неактивное время ожидания (No Activity Timeout)
S82 Выбор прерывания (Break Selection)
S86 Код причины неудачной связи (Connection Failure Cause Code)
S91 Выбор уровня TDansmit коммутируемой линии (Select Dial-up Line TDansmit Level)
S95 Расширенный результат кода битовой карты (Extended Result Code Bit Map)
S97 Позднее время соединения - снятия трубки (V.32 Late Connecting Handshake Timing)
S105 Размер кадра (Frame Size)
S108 Селектор качества сигнала (Signal Quality Selector)
S109 Селектор скорости соединения (Carrier Speed Selector)
S110 Селектор V.32/V.32 bis (V.32/V.32 bis Selector)
S113 Тональный вызов ConTDol (Calling Tone ConTDol)
S121 Использование DTD (Use of DTD)
S141 Таймер фазы обнаружения (Detection Phase Timer)
S142 Онлайновый формат символов (Online Character Format)
S144 Выбор скорости автобода (Autobaud Speed Group Selection)

Взято из

Советов по Delphi от

Сборник Kuliba

Самый быстрый способ узнать количество записей в таблице

When using the standard dataset.recordcount in my client-server (win nt against sqlserver7 db, targettable has 500.000 records) i can go for lunch and stil be waiting (:-

Answer:

For those of you who don't know why u should not use the standard dataset.recordcount when developing client server database applications.
This article is especialy for those cs db apps against a sqlserver 7 db.

since the standard dataset.recordcount iterates from begin of the table through the end of the table to result in the recordcount. This is a crime when developing cs db apps (against sqlserver7).

simply use another way of obtaining the number of records. I use a sql for obtaining the number of records in a sqlserver table.

drop a tquery on the form

provide this tquery with the follow SQL:

SQL:

selectdistinct max(itbl.rows)
from sysindexes as itbl
inner join sysobjects as otbl on (itbl.id = otbl.id)
where (otbl.type = 'U') and (otbl.name = :parTableName)

notice the parameter: parTableName type string

use this tquery to find out how many rows in the table

TIP: try to make your own tYourSqlServerCountQuery and thus override the recordcount property.
ByTheWay: use this only for sqlserver

for other cs db apps simply use a count sql (coming upnext time...)

Взято с

Delphi Knowledge Base

Сценарии комбинаций потоковых моделей

Сценарий #1: Клиент STA и однопотоковый сервер

Внутренний сервер.

Клиентский поток STA, создающий объект в однопотоковом сервере, принимает прямое подключение к объекту, если этот поток живет в главном STA клиента. В противном случае COM создает объект в главном STA клиента и получает прокси (заместителя) к требуемому потоку. Почему COM поступает так? Ответ простой: однопотоковый сервер сообщил COM, что он может обслуживать поступающие вызовы к своим объектам только в одном потоке. COM заметит это и несомненно выполнит этот однопотоковый запрос, не "потревожив" сервер. Следовательно, любой многопотоковый клиент, желающий сообщить что-либо этому серверу, будет способен сделать это только потому, что COM заставить выполнить этот запрос в одном потоке STA. Для клиента STA COM выберет главный STA в качестве единственного потока STA.

Внешний сервер.
Все клиентские потоки STA будут пользоваться заместителями, маршалируемыми и обслуживаемыми главным (единственным) STA внешнего сервера.

Сценарий #2: Клиент STA и сервер MTA

Внутренний сервер.

Клиентский поток STA, создающий объект из сервера MTA, получит прокси (заместителя) к этому объекту, маршалированного из созданного COM MTA в клиентском приложении. На первый взгляд это кажется странным, так как по определению объект MTA должен иметь возможность прямого доступа вне зависимости от того, какой поток создан, или откуда к нему производится доступ. Другими словами, почему бы COM не создавать объект непосредственно в STA запрашивающего клиента? Давайте попробуем понять, что произойдет, если COM создаст экземпляр объекта непосредственно в клиентском STA. Если COM создает объект MTA непосредственно в клиенте STA, то с точки зрения клиента, объект живет в этом STA, но с точки зрения сервера объект в действительности живет в MTA, т.е. он выглядит так, как будто он может осуществлять все вызовы из любого потока в любое время. Теперь, если клиент пытается передать интерфейс обратного вызова методу этого объекта MTA (очевидно, что этот интерфейс нужен объекту, расположенному в клиенте, а этот объект поддерживает только STA, так как клиент работает в модели STA) и сервер пытается осуществить обратный вызов через этот интерфейс, то у сервера нет способа узнать, что этот интерфейс не в состоянии обслуживать одновременные вызовы из нескольких потоков сервера (который размещается в MTA). Другими словами клиентский объект, реализующий интерфейс обратного вызова может "задохнуться", если сервер начнет производить одновременные вызовы из разных потоков. Следовательно, создавая объект всозданном COM MTA и передавая прокси (заместителя) обратно к затребовавшему его STA, любые обратные вызовы, исходящие от сервера, будут производиться этим MTA и выстраиваться последовательно через прокси в STA, который содержит объект, обслуживающий обратный вызов.

Внешний сервер.
Все клиентские потоки STA, которым необходимо использование прокси, маршалируются и обслуживаются в MTA внешнего сервера.

Сценарий #3: Клиент MTA и однопотоковый сервер

Внутренний сервер.

Клиентский поток MTA, создающий объект из однопотокового сервера, будет принимать прокси к этому объекту, маршалированный созданным COM главным STA в клиенте (полагая, что клиент еще не создан главным STA). Очевидно, COM не может допускать прямого создания объектов однопотокового сервера в MTA, так как он не сможет пережить одновременные вызовы из потоков MTA.

Внешний сервер.
Все клиентские потоки MTA будут пользоваться прокси (заместителями), маршалированными и обслуживаемыми главным (единственным) STA внешнего сервера.

Сценарий #4: Клиент MTA и сервер STA

Внутренний сервер.

Клиентский поток MTA, создающий объект из сервера STA, получит прокси (заместителя) к этому объекту, маршалированного, созданным COM STA в клиентском приложении. Только это имеет смысл, так как сервер сказал COM, что он может поддерживать только STA и поэтому нет способа, чтобы COM прямо создавал объект в MTA, в котором другие потоки MTA преспокойно "завалят" его! Таким образом, если он живет в STA, любые вызовы, производимые потоками MTA, будут выстраиваться последовательно к STA, который, по соглашению, как раз и является тем, с чем может работать сервер.
Внешний сервер.

Все клиентские потоки MTA будут пользоваться прокси, маршалированными и обслуживаемыми в каждом соответствующем STA внешнего сервера.

Сценарий #5: Однопотоковый клиент и сервер STA

Внутренний сервер.

В этом случае, очевидно, имеется только один главный поток в клиентском приложении, в котором COM будет непосредственно создавать все объекты сервера STA.

Внешний сервер.
Клиентский главный поток STA будет пользоваться прокси, маршалированным и обслуживаемым в каждом соответствующем STA внешнего сервера.

Сценарий #6: Однопотоковый клиент и сервер MTA

Внутренний вервер.

Этот сценарий является недоделанным вариантом сценария #2, в котором имеется только один STA в клиенте, главный STA. Таким образом, по тем же причинам, что и при сценарии #2, COM будет создавать объект в созданном COM MTA и возвращать прокси к главному потоку STA. Внешний сервер. Клиентский главный поток будет пользоваться прокси, маршалируемым и обслуживаемым в MTA внешнего сервера.
Ну вот мы и рассмотрели все возможные несовместимые комбинации потоковых моделей клиентов и серверов. Мы увидели, как COM предоставляет возможность этим клиентам и серверам работать совместно. Теперь я бы хотел рассказать о необычайно интересном вопросе смешанного использования потоковых моделей. С появлением STA и MTA иногда стала появляться необходимость взаимодействия клиентов и серверов с потоками STA в одних местах и с потоками MTA в других местах внутри одного приложения. Обычно такая потребность появляется по бизнес-причинам, появляющимся при тщательном изучении того, как Ваши клиентское и серверное приложения будут взаимодействовать друг с другом. Например, Ваш сервер может нуждаться в использовании некоторых объектов для решения задач реального времени, в то время как другие не должны (или не могут) работать в режиме "производительности реального времени". В этом случае логично иметь объекты "реального времени", создаваемые в MTA, где они могут реализовать максимальную производительность, и, в то же время, иметь остальные объекты, обслуживаемые в одном или многих STA. То, что я должен описать здесь, называется Смешанная потоковая модель (Mixed Threading Model), обозначая тем самым, что Ваше приложение пользуется комбинацией (смесью) различных потоковых моделей для своих объектов.
В действительности в смешанной модели нет ничего нового. Клиентское приложение может, например, создавать целый букет рабочих потоков, живущих в MTA, в то время как другая группа потоков STA обслуживает какие-то другие потребности.
Серверное приложение также может работать аналогично, т.е. организовывать гроздь объектов в MTA для получения максимальной производительности и, в то же время, порождать кучу потоков STA для других объектов. Мне нет никакой необходимости демонстрировать, как клиент или сервер собирается создавать STA и MTA в рамках единственного процесса, так как Вы уже знакомы с технологией как это делается. Необходимо только создать букет потоков, каждый из которых входит либо в STA, либо в MTA и, бум!, Вы получили смешанную потоковую модель, работающую в Вашем приложении. Об этой смешанной модели важно знать то, что она существует и может оказаться очень удобной для решения каких-то проблем, которые могут встретиться Вам при создании Вами клиентских и серверных приложений. Поддержка смешанной потоковой модели для внешних серверов заключается просто в создании букета потоков и явным указанием для каждого потока его STA или MTA.
Для внутренних серверов, однако, мы можем ожидать, что COM полагается на строковый параметр ThreadingModel, как и в случае однопотокового STA. Сервером объектов может быть использован строковый параметр "ThreadingModel=Both" для указания, что COM может свободно создавать этот объект в STA или в MTA, т.е. он поддерживает как STA, так и MTA.
Но как COM узнает, должен он создавать объект в STA или в MTA? Как я уже говорил ранее, внутренний сервер обычно рассчитывает, что клиентское приложение явно создает потоки STA и MTA, содержащие серверные объекты. В случае, когда "ThreadingModel=Both", подразделение клиентского потока прямо определяет, где COM будет создавать этот объект. Другими словами, если клиентский поток STA создает объект - COM явно создает его в STA. Если клиентский поток MTA создает объект - COM однозначно создаст его в MTA.

ScreenMate

Многие из вас знакомы с этим термином. Так характеризуют программы, которые выводят на экран спрайтового персонажа, не создавая при этом окна. Я очень давно искал данный пример в сети, и теперь решил вас порадовать. Программа состоит из нескольких узлов, кои будут приведены ниже...

p.s К сожалению вам надо позаботиться о кадрах анимации этого персонажа самим т.к рисунки я послать немогу...

{*******************************************************}
{ }
 { Delphi VCL Extensions (RX) }
 { }
 { Copyright (c) 1995, 1996 AO ROSNO }
 { Copyright (c) 1997, 1998 Master-Bank }
 { }
{*******************************************************}

unit Animate;

interface

{$I RX.INC}

uses Messages, {$IFDEF WIN32}Windows, {$ELSE}WinTypes, WinProcs,
{$ENDIF}
 SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, Menus,
 ExtCtrls;

type
 TGlyphOrientation = (goHorizontal, goVertical);

 { TRxImageControl }

 TRxImageControl = class(TGraphicControl)
 private
 FDrawing: Boolean;
 protected
 FGraphic: TGraphic;
 function DoPaletteChange: Boolean;
 procedure DoPaintImage; virtual; abstract;
 procedure PaintDesignRect;
 procedure PaintImage;
 procedure PictureChanged;
 public
 constructor Create(AOwner: TComponent); override;
 end;

 { TAnimatedImage }

 TAnimatedImage = class(TRxImageControl)
 private
 { Private declarations }
 FActive: Boolean;
 FAutoSize: Boolean;
 FGlyph: TBitmap;
 FImageWidth: Integer;
 FImageHeight: Integer;
 FInactiveGlyph: Integer;
 FOrientation: TGlyphOrientation;
 FTimer: TTimer;
 FNumGlyphs: Integer;
 FGlyphNum: Integer;
 FStretch: Boolean;
 FTransparentColor: TColor;
 FOpaque: Boolean;
 FTimerRepaint: Boolean;
 FOnFrameChanged: TNotifyEvent;
 FOnStart: TNotifyEvent;
 FOnStop: TNotifyEvent;
 procedure DefineBitmapSize;
 procedure ResetImageBounds;
 procedure AdjustBounds;
 function GetInterval: Cardinal;
 procedure SetAutoSize(Value: Boolean);
 procedure SetInterval(Value: Cardinal);
 procedure SetActive(Value: Boolean);
 procedure SetOrientation(Value: TGlyphOrientation);
 procedure SetGlyph(Value: TBitmap);
 procedure SetGlyphNum(Value: Integer);
 procedure SetInactiveGlyph(Value: Integer);
 procedure SetNumGlyphs(Value: Integer);
 procedure SetStretch(Value: Boolean);
 procedure SetTransparentColor(Value: TColor);
 procedure SetOpaque(Value: Boolean);
 procedure ImageChanged(Sender: TObject);
 procedure UpdateInactive;
 procedure TimerExpired(Sender: TObject);
 function TransparentStored: Boolean;
 procedure WMSize(var Message: TWMSize); message WM_SIZE;
 protected
 { Protected declarations }
 function GetPalette: HPALETTE; override;
 procedure Loaded; override;
 procedure Paint; override;
 procedure DoPaintImage; override;
 procedure FrameChanged; dynamic;
 procedure Start; dynamic;
 procedure Stop; dynamic;
 public
 { Public declarations }
 constructor Create(AOwner: TComponent); override;
 destructor Destroy; override;
 procedure DoPaintImageOn(Mycanvas: Tcanvas; x, y: integer);
 virtual;
 published
 { Published declarations }
 property Active: Boolean read FActive write SetActive default
 False;
 property Align;
 property AutoSize: Boolean read FAutoSize write SetAutoSize
 default True;
 property Orientation: TGlyphOrientation read FOrientation write
 SetOrientation
 default goHorizontal;
 property Glyph: TBitmap read FGlyph write SetGlyph;
 property GlyphNum: Integer read FGlyphNum write SetGlyphNum
 default 0;
 property Interval: Cardinal read GetInterval write SetInterval
 default 100;
 property NumGlyphs: Integer read FNumGlyphs write SetNumGlyphs
 default 1;
 property InactiveGlyph: Integer read FInactiveGlyph write
 SetInactiveGlyph default -1;
 property TransparentColor: TColor read FTransparentColor write
 SetTransparentColor
 stored TransparentStored;
 property Opaque: Boolean read FOpaque write SetOpaque default
 False;
 property Color;
 property Cursor;
 property DragCursor;
 property DragMode;
 property ParentColor default True;
 property ParentShowHint;
 property PopupMenu;
 property ShowHint;
 property Stretch: Boolean read FStretch write SetStretch default
 True;
 property Visible;
 property OnClick;
 property OnDblClick;
 property OnMouseMove;
 property OnMouseDown;
 property OnMouseUp;
 property OnDragOver;
 property OnDragDrop;
 property OnEndDrag;
{$IFDEF WIN32}
 property OnStartDrag;
{$ENDIF}
 property OnFrameChanged: TNotifyEvent read FOnFrameChanged write
 FOnFrameChanged;
 property OnStart: TNotifyEvent read FOnStart write FOnStart;
 property OnStop: TNotifyEvent read FOnStop write FOnStop;
 end;

implementation

uses RxConst, VCLUtils;

{ TRxImageControl }

constructor TRxImageControl.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 ControlStyle := [csClickEvents, csCaptureMouse, csOpaque,
{$IFDEF WIN32}csReplicatable, {$ENDIF}csDoubleClicks];
 Height := 105;
 Width := 105;
 ParentColor := True;
end;

procedure TRxImageControl.PaintImage;
var
 Save: Boolean;
begin
 Save := FDrawing;
 FDrawing := True;
 try
 DoPaintImage;
 finally
 FDrawing := Save;
 end;
end;

procedure TRxImageControl.PaintDesignRect;
begin
 if csDesigning in ComponentState then
 with Canvas do
 begin
 Pen.Style := psDash;
 Brush.Style := bsClear;
 Rectangle(0, 0, Width, Height);
 end;
end;

function TRxImageControl.DoPaletteChange: Boolean;
var
 ParentForm: TCustomForm;
 Tmp: TGraphic;
begin
 Result := False;
 Tmp := FGraphic;
 if Visible and (not (csLoading in ComponentState)) and (Tmp <>
 nil)
{$IFDEF RX_D3} and (Tmp.PaletteModified){$ENDIF} then
 begin
 if (GetPalette <> 0) then
 begin
 ParentForm := GetParentForm(Self);
 if Assigned(ParentForm) and ParentForm.Active and
 Parentform.HandleAllocated then
 begin
 if FDrawing then
 ParentForm.Perform(WM_QUERYNEWPALETTE, 0, 0)
 else
 PostMessage(ParentForm.Handle, WM_QUERYNEWPALETTE, 0, 0);
 Result := True;
{$IFDEF RX_D3}
 Tmp.PaletteModified := False;
{$ENDIF}
 end;
 end
{$IFDEF RX_D3}
 else
 begin
 Tmp.PaletteModified := False;
 end;
{$ENDIF}
 end;
end;

procedure TRxImageControl.PictureChanged;
begin
 if (FGraphic <> nil) then
 if DoPaletteChange and FDrawing then
 Update;
 if not FDrawing then
 Invalidate;
end;

{ TAnimatedImage }

constructor TAnimatedImage.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FTimer := TTimer.Create(Self);
 Interval := 100;
 FGlyph := TBitmap.Create;
 FGraphic := FGlyph;
 FGlyph.OnChange := ImageChanged;
 FGlyphNum := 0;
 FNumGlyphs := 1;
 FInactiveGlyph := -1;
 FTransparentColor := clNone;
 FOrientation := goHorizontal;
 FAutoSize := True;
 FStretch := True;
 Width := 32;
 Height := 32;
end;

destructor TAnimatedImage.Destroy;
begin
 FOnFrameChanged := nil;
 FOnStart := nil;
 FOnStop := nil;
 FGlyph.OnChange := nil;
 Active := False;
 FGlyph.Free;
 inherited Destroy;
end;

procedure TAnimatedImage.Loaded;
begin
 inherited Loaded;
 ResetImageBounds;
 UpdateInactive;
end;

function TAnimatedImage.GetPalette: HPALETTE;
begin
 Result := 0;
 if not FGlyph.Empty then
 Result := FGlyph.Palette;
end;

procedure TAnimatedImage.ImageChanged(Sender: TObject);
begin
 FTransparentColor := FGlyph.TransparentColor and not PaletteMask;
 DefineBitmapSize;
 AdjustBounds;
 PictureChanged;
end;

procedure TAnimatedImage.UpdateInactive;
begin
 if (not Active) and (FInactiveGlyph >= 0) and
 (FInactiveGlyph < FNumGlyphs) and (FGlyphNum <> FInactiveGlyph) then
 begin
 FGlyphNum := FInactiveGlyph;
 end;
end;

function TAnimatedImage.TransparentStored: Boolean;
begin
 Result := (FGlyph.Empty and (FTransparentColor <> clNone)) or
 ((FGlyph.TransparentColor and not PaletteMask) <>
 FTransparentColor);
end;

procedure TAnimatedImage.SetOpaque(Value: Boolean);
begin
 if Value <> FOpaque then
 begin
 FOpaque := Value;
 PictureChanged;
 end;
end;

procedure TAnimatedImage.SetTransparentColor(Value: TColor);
begin
 if Value <> TransparentColor then
 begin
 FTransparentColor := Value;
 PictureChanged;
 end;
end;

procedure TAnimatedImage.SetOrientation(Value: TGlyphOrientation);
begin
 if FOrientation <> Value then
 begin
 FOrientation := Value;
 DefineBitmapSize;
 AdjustBounds;
 Invalidate;
 end;
end;

procedure TAnimatedImage.SetGlyph(Value: TBitmap);
begin
 FGlyph.Assign(Value);
end;

procedure TAnimatedImage.SetStretch(Value: Boolean);
begin
 if Value <> FStretch then
 begin
 FStretch := Value;
 PictureChanged;
 if Active then
 Repaint;
 end;
end;

procedure TAnimatedImage.SetGlyphNum(Value: Integer);
begin
 if Value <> FGlyphNum then
 begin
 if (Value < FNumGlyphs) and (Value >= 0) then
 begin
 FGlyphNum := Value;
 UpdateInactive;
 FrameChanged;
 PictureChanged;
 end;
 end;
end;

procedure TAnimatedImage.SetInactiveGlyph(Value: Integer);
begin
 if Value < 0 then
 Value := -1;
 if Value <> FInactiveGlyph then
 begin
 if (Value < FNumGlyphs) or (csLoading in ComponentState) then
 begin
 FInactiveGlyph := Value;
 UpdateInactive;
 FrameChanged;
 PictureChanged;
 end;
 end;
end;

procedure TAnimatedImage.SetNumGlyphs(Value: Integer);
begin
 FNumGlyphs := Value;
 if FInactiveGlyph >= FNumGlyphs then
 begin
 FInactiveGlyph := -1;
 FGlyphNum := 0;
 end
 else
 UpdateInactive;
 FrameChanged;
 ResetImageBounds;
 AdjustBounds;
 PictureChanged;
end;

procedure TAnimatedImage.DefineBitmapSize;
begin
 FNumGlyphs := 1;
 FGlyphNum := 0;
 FImageWidth := 0;
 FImageHeight := 0;
 if (FOrientation = goHorizontal) and (FGlyph.Height > 0) and
 (FGlyph.Width mod FGlyph.Height = 0) then
 FNumGlyphs := FGlyph.Width div FGlyph.Height
 else if (FOrientation = goVertical) and (FGlyph.Width > 0) and
 (FGlyph.Height mod FGlyph.Width = 0) then
 FNumGlyphs := FGlyph.Height div FGlyph.Width;
 ResetImageBounds;
end;

procedure TAnimatedImage.ResetImageBounds;
begin
 if FNumGlyphs < 1 then
 FNumGlyphs := 1;
 if FOrientation = goHorizontal then
 begin
 FImageHeight := FGlyph.Height;
 FImageWidth := FGlyph.Width div FNumGlyphs;
 end
 else {if Orientation = goVertical then}
 begin
 FImageWidth := FGlyph.Width;
 FImageHeight := FGlyph.Height div FNumGlyphs;
 end;
end;

procedure TAnimatedImage.AdjustBounds;
begin
 if not (csReading in ComponentState) then
 begin
 if FAutoSize and (FImageWidth > 0) and (FImageHeight > 0) then
 SetBounds(Left, Top, FImageWidth, FImageHeight);
 end;
end;

type
 TParentControl = class(TWinControl);

Взято из

Sending a file via DCOM

I would like to send a file through DCOM however I can only send standard types. How can I send bytes across to a client?

You need to use a variant array (VarArrayLock should be useful as well).

Sending an image to the printer

Sending a bitmap based on the screen to the printer is an
invalid operation that will usually fail, unless the print
driver has been designed to detect this error condition and
compensate for the error. This means you should use the VCL
canvas methods Draw, StretchDraw,CopyRect, BrushCopy, and
the like to transfer a bitmap to the printer, since the
underlying bitmap is based on the screen, and is device
dependent. The only way to reliably print an image is to
use DIBs (Device Independent Bitmaps). Getting a valid DIB can
be difficult, as there are many Windows API functions that must
be used correctly. Further, many video drivers incorrectly fill
in the DIB structure in regards to the color table in the DIB.

The following example demonstrates an attempt to overcome
some of these problems and limitations. The example should
compile successfully under all versions of Delphi/C++ Builder.

The core function in the example, BltTBitmapAsDib(), accepts
a handle to a device to image to, the x and y coordinates you
wish the bitmap to be imaged at, the width and height you wish
the image to be (stretching and shrinking is acceptable), and
the TBitmap you wish to image.

uses Printers;

type
  PPalEntriesArray = ^TPalEntriesArray; {for palette re-construction}
  TPalEntriesArray = array[0..0] of TPaletteEntry;

procedure BltTBitmapAsDib(DestDc : hdc;   {Handle of where to blt}
                          x : word;       {Bit at x}
                          y : word;       {Blt at y}
                          Width : word;   {Width to stretch}
                          Height : word;  {Height to stretch}
                          bm : TBitmap);  {the TBitmap to Blt}
var
  OriginalWidth :LongInt;               {width of BM}
  dc : hdc;                             {screen dc}
  IsPaletteDevice : bool;               {if the device uses palettes}
  IsDestPaletteDevice : bool;           {if the device uses palettes}
  BitmapInfoSize : integer;             {sizeof the bitmapinfoheader}
  lpBitmapInfo : PBitmapInfo;           {the bitmap info header}
  hBm : hBitmap;                        {handle to the bitmap}
  hPal : hPalette;                      {handle to the palette}
  OldPal : hPalette;                    {temp palette}
  hBits : THandle;                      {handle to the DIB bits}
  pBits : pointer;                      {pointer to the DIB bits}
  lPPalEntriesArray : PPalEntriesArray; {palette entry array}
  NumPalEntries : integer;              {number of palette entries}
  i : integer;                          {looping variable}
begin
{If range checking is on - lets turn it off for now}
{we will remember if range checking was on by defining}
{a define called CKRANGE if range checking is on.}
{We do this to access array members past the arrays}
{defined index range without causing a range check}
{error at runtime. To satisfy the compiler, we must}
{also access the indexes with a variable. ie: if we}
{have an array defined as a: array[0..0] of byte,}
{and an integer i, we can now access a[3] by setting}
{i := 3; and then accessing a[i] without error}
{$IFOPT R+}
  {$DEFINE CKRANGE}
  {$R-}
{$ENDIF}

{Save the original width of the bitmap}
  OriginalWidth := bm.Width;

{Get the screen's dc to use since memory dc's are not reliable}
  dc := GetDc(0);
{Are we a palette device?}
  IsPaletteDevice :=
    GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
{Give back the screen dc}
  dc := ReleaseDc(0, dc);

{Allocate the BitmapInfo structure}
  if IsPaletteDevice then
    BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
  else
    BitmapInfoSize := sizeof(TBitmapInfo);
  GetMem(lpBitmapInfo, BitmapInfoSize);

{Zero out the BitmapInfo structure}
  FillChar(lpBitmapInfo^, BitmapInfoSize, #0);

{Fill in the BitmapInfo structure}
  lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
  lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;
  lpBitmapInfo^.bmiHeader.biHeight := bm.Height;
  lpBitmapInfo^.bmiHeader.biPlanes := 1;
  if IsPaletteDevice then
    lpBitmapInfo^.bmiHeader.biBitCount := 8
  else
    lpBitmapInfo^.bmiHeader.biBitCount := 24;
  lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
  lpBitmapInfo^.bmiHeader.biSizeImage :=
    ((lpBitmapInfo^.bmiHeader.biWidth *
      longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *
      lpBitmapInfo^.bmiHeader.biHeight;
  lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
  lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
  if IsPaletteDevice then begin
    lpBitmapInfo^.bmiHeader.biClrUsed := 256;
    lpBitmapInfo^.bmiHeader.biClrImportant := 256;
  end else begin
    lpBitmapInfo^.bmiHeader.biClrUsed := 0;
    lpBitmapInfo^.bmiHeader.biClrImportant := 0;
  end;

{Take ownership of the bitmap handle and palette}
  hBm := bm.ReleaseHandle;
  hPal := bm.ReleasePalette;

{Get the screen's dc to use since memory dc's are not reliable}
  dc := GetDc(0);

  if IsPaletteDevice then begin
   {If we are using a palette, it must be}
   {selected into the dc during the conversion}
    OldPal := SelectPalette(dc, hPal, TRUE);
   {Realize the palette}
    RealizePalette(dc);
  end;
{Tell GetDiBits to fill in the rest of the bitmap info structure}
  GetDiBits(dc,
            hBm,
            0,
            lpBitmapInfo^.bmiHeader.biHeight,
            nil,
            TBitmapInfo(lpBitmapInfo^),
            DIB_RGB_COLORS);

{Allocate memory for the Bits}
  hBits := GlobalAlloc(GMEM_MOVEABLE,
                       lpBitmapInfo^.bmiHeader.biSizeImage);
  pBits := GlobalLock(hBits);
{Get the bits}
  GetDiBits(dc,
            hBm,
            0,
            lpBitmapInfo^.bmiHeader.biHeight,
            pBits,
            TBitmapInfo(lpBitmapInfo^),
            DIB_RGB_COLORS);

  if IsPaletteDevice then begin
   {Lets fix up the color table for buggy video drivers}
    GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
   {$IFDEF VER100}
      NumPalEntries := GetPaletteEntries(hPal,
                                         0,
                                         256,
                                         lPPalEntriesArray^);
   {$ELSE}
      NumPalEntries := GetSystemPaletteEntries(dc,
                                               0,
                                               256,
                                               lPPalEntriesArray^);
   {$ENDIF}
    for i := 0 to (NumPalEntries - 1) do begin
      lpBitmapInfo^.bmiColors[i].rgbRed :=
        lPPalEntriesArray^[i].peRed;
      lpBitmapInfo^.bmiColors[i].rgbGreen :=
        lPPalEntriesArray^[i].peGreen;
      lpBitmapInfo^.bmiColors[i].rgbBlue :=
        lPPalEntriesArray^[i].peBlue;
    end;
    FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
  end;

  if IsPaletteDevice then begin
   {Select the old palette back in}
    SelectPalette(dc, OldPal, TRUE);
   {Realize the old palette}
    RealizePalette(dc);
  end;

{Give back the screen dc}
  dc := ReleaseDc(0, dc);

{Is the Dest dc a palette device?}
  IsDestPaletteDevice :=
    GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;

  if IsPaletteDevice then begin
   {If we are using a palette, it must be}
   {selected into the dc during the conversion}
    OldPal := SelectPalette(DestDc, hPal, TRUE);
   {Realize the palette}
    RealizePalette(DestDc);
  end;

{Do the blt}
  StretchDiBits(DestDc,
                x,
                y,
                Width,
                Height,
                0,
                0,
                OriginalWidth,
                lpBitmapInfo^.bmiHeader.biHeight,
                pBits,
                lpBitmapInfo^,
                DIB_RGB_COLORS,
                SrcCopy);

  if IsDestPaletteDevice then begin
   {Select the old palette back in}
    SelectPalette(DestDc, OldPal, TRUE);
   {Realize the old palette}
    RealizePalette(DestDc);
  end;

{De-Allocate the Dib Bits}
  GlobalUnLock(hBits);
  GlobalFree(hBits);

{De-Allocate the BitmapInfo}
  FreeMem(lpBitmapInfo, BitmapInfoSize);

{Set the ownership of the bimap handles back to the bitmap}
  bm.Handle := hBm;
  bm.Palette := hPal;

  {Turn range checking back on if it was on when we started}
{$IFDEF CKRANGE}
  {$UNDEF CKRANGE}
  {$R+}
{$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if PrintDialog1.Execute then begin
    Printer.BeginDoc;
    BltTBitmapAsDib(Printer.Canvas.Handle,
                    0,
                    0,
                    Image1.Picture.Bitmap.Width,
                    Image1.Picture.Bitmap.Height,
                    Image1.Picture.Bitmap);
    Printer.EndDoc;
  end;
end;

Сервисы NT

Cодержание раздела:

Шаблоны в Object Pascal

Шаблоны в Object Pascal
( перевод одноимённой статьи с сайта community.borland.com )

Наверное каждый Delphi программист хоть раз общался с программистом C++ и объяснял насколько
Delphi мощнее и удобнее. Но в некоторый момент, программист C++ заявляет примерно следующее
"OK, но Delphi использует Pascal, а значит не поддерживает множественное наследование и шаблоны,
поэтому он не так хорош как C++."

Насчёт множественного наследования можно легко заявить, что Delphi имеет интерфейсы, которые
прекрасно справляются со своей задачей, но вот насчёт шаблонов Вам прийдётся согласится, так как
Object Pascal не поддерживает их.

Давайте посмотрим на эту проблему по-внимательней
Шаблоны позволяют делать универсальные контейнеры такие как списки, стеки, очереди, и т.д.
Если Вы хотите осуществить что-то подобное в Delphi, то у Вас есть два пути:

Использовать контейнер TList, который содержит указатели. В этом случае Вам прийдётся всё
время делать явное приведение типов.
Сделать подкласс контейнера TCollection или TObjectList, и убрать все методы, зависящие от типов
каждый раз, когда Вы захотите использовать новый тип данных.
Третий вариант, это сделать модуль с универсальным классом контейнера, и каждый раз, когда нужно
использовать новый тип данных, нам прийдётся в редакторе искать и вносить исправления. Было бы
здорово, если всю эту работу за Вас делал компилятор.... вот этим мы сейчас и займёмся!

Например, возьмём классы TCollection и TCollectionItem. Когда Вы объявляете нового потомка TCollectionItem
, то так же Вы наследуете новый класс от TOwnedCollection и переопределяете большинство методов, чтобы
их можно было вызывать с новыми типами.

Давайте посмотрим, как создать универсальную коллекцию шаблонов класса:

Шаг 1: Создайте новый текстовый файл (не юнитовский) с именем TemplateCollectionInterface.pas:

_COLLECTION_ = class (TOwnedCollection)
protected
function  GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;
procedure SetItem (const aIndex : Integer;
                    const aValue : _COLLECTION_ITEM_);
public
constructor Create (const aOwner : TComponent);

function Add                                 : _COLLECTION_ITEM_;
function FindItemID (const aID    : Integer) : _COLLECTION_ITEM_;
function Insert     (const aIndex : Integer) : _COLLECTION_ITEM_;
property Items      [const aIndex : Integer] : _COLLECTION_ITEM_ read GetItem write SetItem;
end;

Обратите внимание, что нет никаких uses или interface clauses, только универсальное объявление
типа, в котором _COLLECTION_ это имя универсальной коллекции класса, а _COLLECTION_ITEM_
это имя методов, содержащихся в нашем шаблоне.

Шаг 2: Создайте второй текстовый файл и сохраните его как TemplateCollectionImplementation.pas:

constructor _COLLECTION_.Create (const aOwner : TComponent);
begin
inherited Create (aOwner, _COLLECTION_ITEM_);
end;

function _COLLECTION_.Add : _COLLECTION_ITEM_;
begin
Result := _COLLECTION_ITEM_ (inherited Add);
end;

function _COLLECTION_.FindItemID (const aID : Integer) : _COLLECTION_ITEM_;
begin
Result := _COLLECTION_ITEM_ (inherited FindItemID (aID));
end;

function _COLLECTION_.GetItem (const aIndex : Integer) : _COLLECTION_ITEM_;
begin
Result := _COLLECTION_ITEM_ (inherited GetItem (aIndex));
end;

function _COLLECTION_.Insert (const aIndex : Integer) : _COLLECTION_ITEM_;
begin
Result := _COLLECTION_ITEM_ (inherited Insert (aIndex));
end;

procedure _COLLECTION_.SetItem (const aIndex : Integer;
                                const aValue : _COLLECTION_ITEM_);
begin
inherited SetItem (aIndex, aValue);
end;

Снова нет никаких uses или interface clauses , а только код универсального типа.

Шаг 3: Создайте новый unit-файл с именем MyCollectionUnit.pas:

unit MyCollectionUnit;

interface

uses Classes;

type TMyCollectionItem = class (TCollectionItem)
     private
      FMyStringData  : String;
      FMyIntegerData : Integer;
     public
      procedure Assign (aSource : TPersistent); override;
     published
      property MyStringData  : String  read FMyStringData  write FMyStringData;
      property MyIntegerData : Integer read FMyIntegerData write FMyIntegerData;
     end;

     // !!! Указываем универсальному классу на реальный тип

     _COLLECTION_ITEM_ = TMyCollectionItem;

     // !!! директива добавления интерфейса универсального класса

     {$INCLUDE TemplateCollectionInterface}

     // !!! переименовываем универсальный класс

     TMyCollection = _COLLECTION_;

implementation

uses SysUtils;

// !!! препроцессорная директива добавления универсального класса

{$INCLUDE TemplateCollectionImplementation}

procedure TMyCollectionItem.Assign (aSource : TPersistent);
begin
if aSource is TMyCollectionItem then
begin
  FMyStringData  := TMyCollectionItem(aSource).FMyStringData;
  FMyIntegerData := TMyCollectionItem(aSource).FMyIntegerData;
end
else inherited;
end;

end.

Вот и всё! Теперь компилятор будет делать всю работу за Вас! Если Вы измените интерфейс
универсального класса, то изменения автоматически распространятся на все модули, которые
он использует.

Второй пример
Давайте создадим универсальный класс для динамических массивов.

Шаг 1: Создайте текстовый файл с именем TemplateVectorInterface.pas:

_VECTOR_INTERFACE_ = nterface
function  GetLength : Integer;
procedure SetLength (const aLength : Integer);

function  GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;
procedure SetItems (const aIndex : Integer;
                     const aValue : _VECTOR_DATA_TYPE_);

function  GetFirst : _VECTOR_DATA_TYPE_;
procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);

function  GetLast  : _VECTOR_DATA_TYPE_;
procedure SetLast  (const aValue : _VECTOR_DATA_TYPE_);

function  High  : Integer;
function  Low   : Integer;

function  Clear                              : _VECTOR_INTERFACE_;
function  Extend   (const aDelta : Word = 1) : _VECTOR_INTERFACE_;
function  Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

property  Length                         : Integer             read GetLength write SetLength;
property  Items [const aIndex : Integer] : _VECTOR_DATA_TYPE_  read GetItems  write SetItems; default;
property  First                          : _VECTOR_DATA_TYPE_  read GetFirst  write SetFirst;
property  Last                           : _VECTOR_DATA_TYPE_  read GetLast   write SetLast;
end;

_VECTOR_CLASS_ = class (TInterfacedObject, _VECTOR_INTERFACE_)
private
FArray : array of _VECTOR_DATA_TYPE_;
protected
function  GetLength : Integer;
procedure SetLength (const aLength : Integer);

function  GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;
procedure SetItems (const aIndex : Integer;
                     const aValue : _VECTOR_DATA_TYPE_);

function  GetFirst : _VECTOR_DATA_TYPE_;
procedure SetFirst (const aValue : _VECTOR_DATA_TYPE_);

function  GetLast  : _VECTOR_DATA_TYPE_;
procedure SetLast  (const aValue : _VECTOR_DATA_TYPE_);
public
function  High  : Integer;
function  Low   : Integer;

function  Clear                              : _VECTOR_INTERFACE_;
function  Extend   (const aDelta : Word = 1) : _VECTOR_INTERFACE_;
function  Contract (const aDelta : Word = 1) : _VECTOR_INTERFACE_;

constructor Create (const aLength : Integer);
end;

Шаг 2: Создайте текстовый файл и сохраните его как TemplateVectorImplementation.pas:

constructor _VECTOR_CLASS_.Create (const aLength : Integer);
begin
inherited Create;

SetLength (aLength);
end;

function _VECTOR_CLASS_.GetLength : Integer;
begin
Result := System.Length (FArray);
end;

procedure _VECTOR_CLASS_.SetLength (const aLength : Integer);
begin
System.SetLength (FArray, aLength);
end;

function _VECTOR_CLASS_.GetItems (const aIndex : Integer) : _VECTOR_DATA_TYPE_;
begin
Result := FArray [aIndex];
end;

procedure _VECTOR_CLASS_.SetItems (const aIndex : Integer;
                                   const aValue : _VECTOR_DATA_TYPE_);
begin
FArray [aIndex] := aValue;
end;

function _VECTOR_CLASS_.High : Integer;
begin
Result := System.High (FArray);
end;

function _VECTOR_CLASS_.Low : Integer;
begin
Result := System.Low (FArray);
end;

function _VECTOR_CLASS_.GetFirst : _VECTOR_DATA_TYPE_;
begin
Result := FArray [System.Low (FArray)];
end;

procedure _VECTOR_CLASS_.SetFirst (const aValue : _VECTOR_DATA_TYPE_);
begin
FArray [System.Low (FArray)] := aValue;
end;

function _VECTOR_CLASS_.GetLast : _VECTOR_DATA_TYPE_;
begin
Result := FArray [System.High (FArray)];
end;

procedure _VECTOR_CLASS_.SetLast (const aValue : _VECTOR_DATA_TYPE_);
begin
FArray [System.High (FArray)] := aValue;
end;

function _VECTOR_CLASS_.Clear : _VECTOR_INTERFACE_;
begin
FArray := Nil;

Result := Self;
end;

function _VECTOR_CLASS_.Extend (const aDelta : Word) : _VECTOR_INTERFACE_;
begin
System.SetLength (FArray, System.Length (FArray) + aDelta);

Result := Self;
end;

function _VECTOR_CLASS_.Contract (const aDelta : Word) : _VECTOR_INTERFACE_;
begin
System.SetLength (FArray, System.Length (FArray) - aDelta);

Result := Self;
end;
Шаг 3: Создайте unit файл с именем FloatVectorUnit.pas:

unit FloatVectorUnit;

interface

uses Classes;                           // !!! Модуль "Classes" содержит объявление класса TInterfacedObject

type _VECTOR_DATA_TYPE_ = Double;       // !!! тип данных для класса массива Double

     {$INCLUDE TemplateVectorInterface}

     IFloatVector = _VECTOR_INTERFACE_; // !!! give the interface a meanigful name
     TFloatVector = _VECTOR_CLASS_;     // !!! give the class a meanigful name

function CreateFloatVector (const aLength : Integer = 0) : IFloatVector; // !!! дополнительная функция

implementation

{$INCLUDE TemplateVectorImplementation}

function CreateFloatVector (const aLength : Integer = 0) : IFloatVector;
begin
Result := TFloatVector.Create (aLength);
end;

end.

Естевственно, можно дополнить универсальный класс дополнительными
функциями. Всё зависит от Вашей фантазии!

Использование шаблонов
Вот пример использования нового векторного интерфейса:

procedure TestFloatVector;
var aFloatVector : IFloatVector;
     aIndex       : Integer;
begin
aFloatVector := CreateFloatVector;

aFloatVector.Extend.Last := 1;
aFloatVector.Extend.Last := 2;

for aIndex := aFloatVector.Low to aFloatVector.High do
begin
  WriteLn (FloatToStr (aFloatVector [aIndex]));
end;
end.

Единственное требование при создании шаблонов таким способом, это то, что
каждый новый тип должен быть объявлен в отдельном модуле, а так же Вы должны
иметь исходники для универсальных классов.

Комментарии и вопросы присылайте по адресу rossen_assenov@yahoo.com!

Взято с Исходников.ru

Схемы и возможности

Each function listed below returns information about capabilities or the schema.

DbiOpenCfgInfoList:
Returns a handle to an in-memory table listing all the nodes in the configuration file accessible by
the specified path.

DbiOpenDatabaseList:
Creates an in-memory table containing a list of accessible databases and their descriptions.

DbiOpenDriverList:
Creates an in-memory table containing a list of driver names available to the client application.

DbiOpenFamilyList:
Creates an in-memory table listing the family members associated with a specified table.

DbiOpenFieldList:
Creates an in-memory table listing the fields in a specified table and their descriptions.

DbiOpenFieldTypesList:
Creates an in-memory table containing a list of field types supported by the table type for the driver type.

DbiOpenFunctionArgList:
Returns a list of arguments to a data source function.

DbiOpenFunctionList:
Returns a description of a data source function.

DbiOpenIndexList:
Opens a cursor on an in-memory table listing the indexes on a specified table, along with
their descriptions.

DbiOpenIndexTypesList:
Creates an in-memory table containing a list of all supported index types for the driver type.

DbiOpenLockList:
Creates an in-memory table containing a list of locks acquired on the table.

DbiOpenRintList :
Creates an in-memory table listing the referential integrity links for a specified table, along with
their descriptions.

DbiOpenSecurityList:
Creates an in-memory table listing record-level security information about a specified table.

DbiOpenTableList:
Creates an in-memory table with information about all the tables accessible to the client application.

DbiOpenTableTypesList:
Creates an in-memory table listing table type names for the given driver.

DbiOpenVchkList:
Creates an in-memory table containing records with information about validity checks for fields
within the specified table.

Взято с

Delphi Knowledge Base

Should I install Kylix as root or a regular user?

Installing Kylix as root has the advantage of allowing all users to access the Kylix installation, provided you install it into a "shared" location. I reccomend installing Kylix as root into the directory /usr/local/kylix. However, if you are going to be the only user using Kylix, you may want to install it as that user into your home directory.

To install as root, type su from the command prompt and enter the super user password. Then, run the Kylix installer.

Примечание от Vit: обычно при установке от имени root возникает ошибка -10

Симфония на клавиатуре(статья)

( Перевод одноимённой статьи с сайта delphi.about.com )
Начиная с самого рассвета компьютерной промышленности, клавиатура была первичным устройством ввода информации, и вероятнее всего сохранит свою позицию ещё долгое время.
События клавиатуры, наряду с событиями мыши, являются основными элементами взаимодействия пользователя с программой. В данной статье пойдёт речь о трёх событиях, которые позволяют отлавливать нажатия клавиш в приложении Delphi: OnKeyDown, OnKeyUp и OnKeyPress.
Для получения ввода с клавиатуры, приложения Delphi могут использовать два метода. Самый простой способ, это воспользоваться одним из компонентов, автоматически реагирущем на нажатия клавиш, таким как Edit. Второй способ заключается в создании процедур в форме, которые будут обрабатывать нажатия и отпускания клавиш. Эти обработчики могут обрабатывать как нажатия одиночных клавиш, так и комбинаций. Итак, вот эти события:
OnKeyDown - вызывается, когда на клавиатуре нажимается любая клавиша. OnKeyUp - вызывается, когда любая клавиша на клавиатуре отпускается. OnKeyPress - вызывается, когда нажимается клавиша, отвечающая за определённый ASCII символ.
Теперь самое время посмотреть, как выглядят в программе заголовки обработчиков:

procedure TForm1.FormKeyDown
(Sender: TObject; var Key: Word; Shift: TShiftState);
...
procedure TForm1.FormKeyUp
(Sender: TObject; var Key: Word; Shift: TShiftState);
...
procedure TForm1.FormKeyPress
(Sender: TObject; var Key: Char);

Все события имеют один общий параметр, обычно называемый Key. Этот параметр используется для передачи кода нажатой клавиши. Параметр Shift (в процедурах OnKeyDown и OnKeyUp), указывает на то, была ли нажата клавиша в сочетании с Shift, Alt, и Ctrl.
Фокус
Фокус, это способность получать пользовательский ввод через мышь или клавиатуру. Получать события от клавиатуры могут только те объекты, которые имеют фокус. На форме активного приложения в один момент времени может быть активным (иметь фокус) только один компонент.
Некоторые компоненты, такие как TImage, TPaintBox, TPanel и TLabel не могут получать фокус, другими словами, это компоненты, наследованные от TGraphicControl. Так же не могут получать фокус невидимые компоненты, такие как TTimer.
OnKeyDown, OnKeyUp
События OnKeyDown и OnKeyUp обеспечивают самый низкий уровень ответа клавиатуры. Обработчики OnKeyDown и OnKeyUp могут реагировать на все клавиши клавиатуры, включая функциональные и комбинации с клавишами Shift, Alt, и Ctrl.
События клавиатуры - не взаимоисключающие. Когда пользователь нажимает клавишу, то генерируются два события OnKeyDown и OnKeyPress, а когда отпускает, то только одно: OnKeyUp. Если пользователь нажмёт одну из клавиш, которую OnKeyPress не сможет определить, то будет сгенерировано только одно событие OnKeyDown, а при отпускании OnKeyUp.
OnKeyPress
OnKeyPress возвращает различные значения ASCII для 'g' и 'G,'. Однако, OnKeyDown и OnKeyUp не делают различия между верхним и нижним регистром.
Параметры Key и Shift
Параметр Key можно изменять, чтобы приложение получило другой код нажатой клавиши. Таким образом можно ограничивать набор различных символов, которые пользователь может ввести с клавиатуры. Например разрешить вводить только цифры. Для этого добавьте в обработчик события OnKeyPress следующий код и установите KeyPreview в True (см. ниже).

if Key in ['a'..'z'] + ['A'..'Z'] then Key:=#0

Это выражение проверяет, содержит ли параметр Key символы нижнего регистра ('a'..'z') и символы верхнего регистра ('A'..'Z'). Если так, то в параметр заносится значение нуля, чтобы предотвратить ввод в компонент Edit (например).
В Windows определены специальные константы для каждой клавиши. Например, VK_RIGHT соответствует коду клавиши для правой стрелки.
Чтобы получить состояния специальных клавиш, таких как TAB или PageUp можно воспользоваться API функцией GetKeyState. Клавиши состояния могут находиться в трёх состояниях: отпущена, нажата, и включена. Если старший бит равен 1, то клавиша нажата, иначе отпущена. Для проверки этого бита можно воспользоваться API функцией HiWord. Если младший бит равен 1, то клавиша включена. Вот пример получения сосотояния специальной клавиши:

if HiWord(GetKeyState(vk_PageUp)) <> 0 then
 ShowMessage('PageUp - DOWN')
else
 ShowMessage('PageUp - UP');

В событиях OnKeyDown и OnKeyUp, Key является беззнаковым двухбайтовым (Word) значением, которое представляет виртуальную клавишу Windows. Для получания значения символа можно воспользоваться функцией Chr. В событии OnKeyPress параметр Key является значением Char, которое представляет символ ASCII.
События OnKeyDown и OnKeyUp имеют параметр Shift с типом TShiftState. В Delphi тип TShiftState определён как набор флагов, определяющих состояние Alt, Ctrl, и Shift при нажатии клавиши.
Например, следующий код (из обработчика OnKeyUp) соединяет строку 'Ctrl +' с нажатой клавишей и отображает результат в заголовке формы:

if ssCtrl in Shift then
 Form1.Caption:= 'Ctrl +' + Chr(Key);

Если нажать Ctrl + A, то будут сгенерированы следующие события:

KeyDown (Ctrl) // ssCtrl
KeyDown (Ctrl+A) //ssCtrl + 'A'
KeyPress (A)
KeyUp (Ctrl+A)

Переадресация событий клавиатуры в форму
Клавиатурный обработчик может работать на двух уровнях: на уровне компонентов и на уровне формы. Свойство формы KeyPreview определяет, будут ли клавиатурные события формы вызываться перед клавиатурными событиями компонентов, так как форма может получать все нажатия клавиш, предназначенные для компонента имеющего в данный момент фокус.
Чтобы перехватить нажатия клавиш на уровне формы, до того как они будут переданы компонентам на форме, необходимо установить свойство KeyPreview в True. После этого компонент как и раньше будет получать события, однако сперва они будут попадать в форму, чтобы дать возможность программе разрешить или запретить ввод различных символов.
Допустим, У Вас на форме есть несколько компонентов Edit и процедура Form.OnKeyPress выглядит следующим образом:

procedure TForm1.FormKeyPress
(Sender: TObject; var Key: Char);
begin
if Key in ['0'..'9'] then Key := #0
end;

Если один из компонентов Edit имеет фокус и свойство KeyPreview установлено в False, то этот код не будет выполнен - другими словами, если пользователь нажмёт клавишу '5', то в компоненте Edit, имеющем фокус, появится символ "5".
Однако, если KeyPreview установлено в True, то событие формы OnKeyPress будет выполнено до того, как компонент Edit увидит нажатую клавишу. Поэтому, если пользователь нажмёт клавишу '5', то в Key будет подставлено нулевое значение, предотвращая тем самым попадание числовых символов в Edit.

ПРИЛОЖЕНИЕ: Таблица кодов виртуальных клавиш.

Symbolic
constant name Value
(hexadecimal) Keyboard (or mouse) equivalent VK_LBUTTON 01 Left mouse button VK_RBUTTON 02 Right mouse button VK_CANCEL 03 Control-break processing VK_MBUTTON 04 Middle mouse button (three-button mouse) VK_BACK 08 BACKSPACE key VK_TAB 09 TAB key VK_CLEAR 0C CLEAR key VK_RETURN 0D ENTER key VK_SHIFT 10 SHIFT key VK_CONTROL 11 CTRL key VK_MENU 12 ALT key VK_PAUSE 13 PAUSE key VK_CAPITAL 14 CAPS LOCK key VK_ESCAPE 1B ESC key VK_SPACE 20 SPACEBAR VK_PRIOR 21 PAGE UP key VK_NEXT 22 PAGE DOWN key VK_END 23 END key VK_HOME 24 HOME key VK_LEFT 25 LEFT ARROW key VK_UP 26 UP ARROW key VK_RIGHT 27 RIGHT ARROW key VK_DOWN 28 DOWN ARROW key VK_SELECT 29 SELECT key VK_PRINT 2A PRINT key VK_EXECUTE 2B EXECUTE key VK_SNAPSHOT 2C PRINT SCREEN key VK_INSERT 2D INS key VK_DELETE 2E DEL key VK_HELP 2F HELP key 30 0 key 31 1 key 32 2 key 33 3 key 34 4 key 35 5 key 36 6 key 37 7 key 38 8 key 39 9 key 41 A key 42 B key 43 C key 44 D key 45 E key 46 F key 47 G key 48 H key 49 I key 4A J key 4B K key 4C L key 4D M key 4E N key 4F O key 50 P key 51 Q key 52 R key 53 S key 54 T key 55 U key 56 V key 57 W key 58 X key 59 Y key 5A Z key VK_NUMPAD0 60 Numeric keypad 0 key VK_NUMPAD1 61 Numeric keypad 1 key VK_NUMPAD2 62 Numeric keypad 2 key VK_NUMPAD3 63 Numeric keypad 3 key VK_NUMPAD4 64 Numeric keypad 4 key VK_NUMPAD5 65 Numeric keypad 5 key VK_NUMPAD6 66 Numeric keypad 6 key VK_NUMPAD7 67 Numeric keypad 7 key VK_NUMPAD8 68 Numeric keypad 8 key VK_NUMPAD9 69 Numeric keypad 9 key VK_SEPARATOR 6C Separator key VK_SUBTRACT 6D Subtract key VK_DECIMAL 6E Decimal key VK_DIVIDE 6F Divide key VK_F1 70 F1 key VK_F2 71 F2 key VK_F3 72 F3 key VK_F4 73 F4 key VK_F5 74 F5 key VK_F6 75 F6 key VK_F7 76 F7 key VK_F8 77 F8 key VK_F9 78 F9 key VK_F10 79 F10 key VK_F11 7A F11 key VK_F12 7B F12 key VK_F13 7C F13 key VK_F14 7D F14 key VK_F15 7E F15 key VK_F16 7F F16 key VK_F17 80H F17 key VK_F18 81H F18 key VK_F19 82H F19 key VK_F20 83H F20 key VK_F21 84H F21 key VK_F22 85H F22 key VK_F23 86H F23 key VK_F24 87H F24 key VK_NUMLOCK 90 NUM LOCK key VK_SCROLL 91 SCROLL LOCK key VK_LSHIFT A0 Left SHIFT key VK_RSHIFT A1 Right SHIFT key VK_LCONTROL A2 Left CONTROL key VK_RCONTROL A3 Right CONTROL key VK_LMENU A4 Left MENU key VK_RMENU A5 Right MENU key VK_PLAY FA Play key VK_ZOOM FB Zoom key
Взято с Исходников.ru

Символы разного цвета в StringGrid

Ниже представлен юнит, который позволяет поместить текст в String Grid с символами различного цвета:

unit Strgr;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Grids, StdCtrls, DB;

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
      Rect: TRect; State: TGridDrawState);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint;
  Rect: TRect; State: TGridDrawState);
const
  CharOffset = 3;
begin
  with StringGrid1.canvas do
  begin
    font.color := clMaroon;
    textout(rect.left + CharOffset, rect.top + CharOffset, 'L');
      font.color := clNavy;
    textout(rect.left + CharOffset + TextWidth('L'),
      rect.top + CharOffset, 'loyd');
  end;
end;

end.

Взято с Исходников.ru

Синхронизация двух компонентов ScrollBox

Решить задачу помогут обработчики событий OnScroll (в данном примере два компонента ScrollBox (ScrollBar1 и ScrollBar2) расположены на форме TMainForm):

procedureTMainForm.ScrollBar1Scroll(Sender: TObject;
ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
ScrollBar2.Position:=ScrollPos;
end;

procedure TMainForm.ScrollBar2Scroll(Sender: TObject;
ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
ScrollBar1.Position := ScrollPos;
end;

Взято с

Синтаксис SQL-функции Substring

SUBSTRING('DelphiWorld - это супер!!!' from 1 to 6)

Взято из

Системная дата и время

Cодержание раздела:

См. также статьи в других разделах:

Системные функции и WinAPI

Cодержание раздела:

(раздел)

Системные папки, имя компьютера

Cодержание раздела:

См. также статьи в других разделах:

Системные сообщения (сокращения)

BM  - ButtonMode
BN  - Button
BS  - ButtonStyle
CB  - ComboBox
CBN - Combo Box Notifications
CBS - ComboBoxStyle
EM  - EditMessage
ES  - EditStyle
FM  - FileManager
LB  - ListBox
LBN - ListBox Notifications
LBS - ListBoxStyle
MB  - MessageButton (Typen)
PS  - PenStyle
SB  - ScrollBar
SBS - ScrollBarStyle
SM  - SystemMetrics
SPI - SystemParametersInfo
WM  - WindowMessage
WS  - WindowStyle

Сканирование доменов локальной сети

Переменная List заполняется списком доменов. Функция возвращает код ошибки обращения к сети.

Function FillNetLevel(xxx: PNetResource; list: TStrings) : Word;
Type
 PNRArr = ^TNRArr;
 TNRArr = array[0..59] of TNetResource;
Var
 x: PNRArr;
 tnr: TNetResource;
 I : integer;
 EntrReq,
 SizeReq,
 twx: Integer;
 WSName: string;
begin
 Result := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,
 RESOURCEUSAGE_CONTAINER, xxx, twx);
 If Result = ERROR_NO_NETWORK Then Exit;
 if Result = NO_ERROR then
 begin
 New(x);
 EntrReq := 1;
 SizeReq := SizeOf(TNetResource)*59;
 while (twx <> 0) and
 (WNetEnumResource(twx, EntrReq, x, SizeReq) <> ERROR_NO_MORE_ITEMS) do
 begin
 For i := 0 To EntrReq - 1 do
 begin
 Move(x^[i], tnr, SizeOf(tnr));
 case tnr.dwDisplayType of
 RESOURCEDISPLAYTYPE_DOMAIN:
 begin
 if tnr.lpRemoteName <> '' then
 WSName:= tnr.lpRemoteName
 else WSName:= tnr.lpComment;
 list.Add(WSName);
 end;
 else FillNetLevel(@tnr, list);
 end;
 end;
 end;
 Dispose(x);
 WNetCloseEnum(twx);
 end;
end;

Источник:

Сколько открыто дочерних окон?

Form1.MDIChildCount

Закрыть все окна:

withForm1 do
for I := 0 to MDIChildCount-1
do MDIChildren[I].Close;

Взято с

Скорость работы процессора, точный таймер

Данная тема уже обсуждалась, но у меня есть своя реализация сабжа. Начиная с Pentium MMX, Intel ввели в процессор счетчик тактов на 64 бита (Присутствует точно и в К6). Для того чтобы посмотреть на его содержание, была введена команда "rdtsc" (подробное описание в интеловской мануале). Эту возможность можно использовать для реализации сабжа.
Поскольку Дельфи не в курсе насчет rdtsc, то пришлось юзать опкод (0F31).
Привожу простенький примерчик юзания, Вы уж извините - немножко кривоват получился, да и ошибка компилятора какая-то вылезла :( (V4 Bld5.104 Upd 2). Кому интересно, поделитесь своими соображениями по этому поводу. Особенно интересует работа в режиме когда меняется частота процессора (Duty Cycle, Standby).

// (C) 1999 ISV
unit Unit1;interfaceuses  Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms,Dialogs,  StdCtrls, Buttons, ExtCtrls;
type  TForm1 = class(TForm)
    Label1: TLabel;
    Timer1: TTimer;
    Label2: TLabel;
    Label3: TLabel;
    Button1: TButton;
    Button2: TButton;
    Label4: TLabel;
    procedure Timer1Timer(Sender: TObject);
    procedure FormActivate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
    Counter:integer;
      //Счетчик срабатывания таймера
Start:int64;
//Начало роботы
Previous:int64;
//Предыдущее значение
PStart,PStop:int64;
//Для примера выч. времени
CurRate:integer;
     //Текущая частота проца
function GetCPUClick:int64;
function GetTime(Start,Stop:int64):double;
end;
var  Form1: TForm1;implementation{$R *.DFM}
// Функция работает на пнях ММХ или выше а
// также проверялась на К6
function TForm1.GetCPUClick:int64;
begin
  asm    db  0fh,31h
// Опкод для команды rdtsc    mov dword ptr result,eax    mov dword ptr result[4],edx
end;
// Не смешно :(. Без ?той штуки
// Компайлер выдает Internal error C1079
Result:=Result;
end;
// Время в секундах между старт и стоп
function TForm1.GetTime(Start,Stop:int64):double;
begin
  try    result:=(Stop-Start)/CurRate  except    result:=0;
end;
end;
// Обработчик таймера считает текущую частоту, выводит ее, а также
// усредненную частоту, текущий такт с момента старта процессора.
// При постоянной частоте процессора желательно интервал братьпобольше
// 1-5с для точного прощета частоты процессора.
procedure TForm1.Timer1Timer(Sender: TObject);
  var    i:int64;
begin
  i:=GetCPUClick;
  if Counter=0    then Start:=i    else
begin
      Label2.Caption:=Format('Частота общая:%2f',[(i-Start)/(Counter*Timer1.Interval*1000)]);
      Label3.Caption:=Format('Частота текущая:%2f',[(i-Previous)/(Timer1.Interval*1000)]);
      CurRate:=Round(((i-Previous)*1000)/(Timer1.Interval));
    end;
  Label1.Cap примера
procedure TForm1.Button1Click(Sender: TObject);
begin
  PStart:=GetCPUClick;
end;
// Останавливаем отсчет времени и показуем соко
// прошло секунд
procedure TForm1.Button2Click(Sender: TObject);
begin
  PStop:=GetCPUClick;
  Label4.Caption:=Format!
('Время между нажатиями:%gсек',[GetTime(PStart,PStop)])
end;
end.

Взято с сайта

Скрытые настройки Дельфи

Some undocumented registry settings of Delphi 5 (which -slightly adapted- might also work with Delphi 4 and below) modify the behavior of the Delphi component palette in a manner you may like!
Most values are stored as strings, and boolean values are represented as "1" for true and "0" for false. All values are stored in

HKEY_CURRENT_USER

As always, use of this information is at your own risk... ;-)

Software\Borland\Delphi\5.0\Extras\AutoPaletteSelect

will cause a tab on the component palette to be automatically selected when the mouse is hovering over it. If the mouse is in the top two- thirds (2/3) of the tab, the palette for that tab will automatically be displayed.

Software\Borland\Delphi\5.0\Extras\AutoPaletteScroll

will make you scroll left and right automatically whenever the mouse is positioned over the relevant arrow.

Software\Borland\Delphi\5.0\Editor\Options\NoCtrlAltKeys

Disables menu item Ctrl+Alt key sequences for international keyboards

Software\Borland\Delphi\5.0\Form Design\AlwaysEnableMiddleEast

Forces Right-to-Left text in the form designer (?)

Software\Borland\Delphi\5.0\Extras\FontNamePropertyDisplayFontNames

Display the fonts in the object inspector dropdown in the font's actual style (slow with many fonts installed). See also DsgnIntf.FontNamePropertyDisplayFontNames in D5.

Software\Borland\Delphi\5.0\Compiling\ShowCodeInsiteErrors

Show compilation errors found by CodeInsite in the message view window

Software\Borland\Delphi\5.0\Globals\PropValueColor

Fill in with a string like "clGreen" to change the color of the right half (properties) of the Object Inspector.

Software\Borland\Delphi\5.0\Disabled Packages

This is the place you put Delphi Direct :)

Software\Borland\Delphi\5.0\Globals\TwoDigitYearCenturyWindow

Default value for TwoDigitYearCenturyWindow (see the help file)

Software\Borland\Delphi\5.0\Component Templates\CCLibDir

Alternative component templates directory (shared/network)

Software\Borland\Delphi\5.0\FormDesign\DefaultFont="Arial,8" [D4] or "Arial,8,Bold" [D5]

The default for new forms (you might prefer using the repository's default form checkbox instead)

Software\Borland\Delphi\5.0\Wizards

Alternate key to store Expert/Wizard DLLs to load at startup

Software\Borland\Delphi\5.0\Debugging\DontPromptForJITDebugger

Don't ask to change the current JIT debugger (?)

Software\Borland\Delphi\5.0\Version Control\VCSManager

The DLL used for the version control interface in the IDE.

Software\Borland\Delphi\5.0\Globals\PrivateDir

A way to specify an alternative directory for the location for the Delphi configuration files when running the application from a network drive or the CD-ROM.

Software\Borland\Delphi\5.0\Main Window\Palette Visible
Software\Borland\Delphi\5.0\Main Window\Speedbar Visible
Software\Borland\Delphi\5.0\Main Window\Palette Hints
Software\Borland\Delphi\5.0\Main Window\Speedbar Hints
Software\Borland\Delphi\5.0\Main Window\Split Position

These seem to have no effect at runtime, but are read by the IDE. The actually used values come from

HKEY_CURRENT_USER\Software\Borland\Delphi\5.0\Toolbars

Software\Borland\Delphi\5.0\ProjectManager\Dockable
Software\Borland\Delphi\5.0\PropertyInspector\Dockable
Software\Borland\Delphi\5.0\CallStackWindow\Dockable
Software\Borland\Delphi\5.0\ModuleWindow\Dockable

Read but unused settings. Used values come from DSK files.

There are lots of other interesting registry keys that aren't modifiable in the IDE, but they all have values written by default, so you can find and play with them much easier.

Взято с

Delphi Knowledge Base

Смена свойств приложения, открываемого, по умолчанию в среде при её запуске

Большинство стандартных темплейтов зашиты в delphide70.bpl (70 - версия), остальные - в каталоге Objrepos. Описаны же последние в файле bin\delphi32.dro. Т.о:
1. Добавляем в "delphi32.dro" строки:

[C:\ProgramFiles\Lang\Delphi7\ObjRepos\MyApp\MyApp]
Type=ProjectTemplate
Page=Projects
Name=My Application
Description=This is my application template
Author=Eugene
Icon=C:\Program Files\Lang\Delphi7\ObjRepos\MyApp\MyApp.ico
DefaultProject=1
Designer=dfm

(для темплейтов формы Type=FormTemplate, DefaultMainForm=0/1, DefaultNewForm=0/1)
2. Размещаем нашу темплейт-прогу в каталоге "C:\Program Files\Lang\Delphi7\ObjRepos\MyApp\" и называем её "MyApp.dpr".
3. Жмём "File/New/Application" (т.к. у нас DefaultProject=1), либо заходим во вкладку "Projects", а затем кликаем два раза по "My Application".
4. Радуемся!

Автор:

Jin X

Взято из

Смешиваем два цвета.

Самый простой способ смешать два цвета c1 и c2, это вычислить средние значения rgb-значений. Данный пример не отличается особой быстротой, поэтому если Вам нужно быстро смешивать цвета, то прийдётся пошевелить мозгами...

function GetMixColor (c1, c2: TColor): TColor;
begin
  // вычисляем средние значения Красного, Синего и Зелёного значений
  // цветов c1 и c2:
  Result := RGB (
                  (GetRValue (c1) + GetRValue (c2)) div 2,
                  (GetGValue (c1) + GetGValue (c2)) div 2,
                  (GetBValue (c1) + GetBValue (c2)) div 2
                );
end;

Взято с Исходников.ru

Собираем тестовый пример

Теперь, давайте соберем код. Прошу учесть, что практически не делается никаких проверок - это демонстрационный код. Но работающий.

В начале код dll c объектом.

library CalcDll;

uses
 SysUtils,
 Classes;

type

HResult=Longint;

ICalcBase=interface //чисто абстрактный интерфейс
 procedure SetOperands(x,y:integer);
 procedure Release;
end;

ICalc=interface(ICalcBase)
 ['{149D0FC0-43FE-11D6-A1F0-444553540000}']
 function Sum:integer;
 function Diff:integer;
end;

ICalc2=interface(ICalcBase)
 ['{D79C6DC0-44B9-11D6-A1F0-444553540000}']
 function Mult:integer;
 function Divide:integer;
end;

MyCalc=class(TObject,ICalc,ICalc2) //два интерфейса
 fx,fy:integer;
public
 procedure SetOperands(x,y:integer);
 function Sum:integer;
 function Diff:integer;
 function Divide:integer;
 function Mult:integer;
 procedure Release;
 function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
 function _AddRef:Longint; stdcall;
 function _Release:Longint; stdcall;
end;

const
S_OK = 0;
E_NOINTERFACE = HRESULT($80004002);

procedure MyCalc.SetOperands(x,y:integer);
begin
fx:=x; fy:=y;
end;

function MyCalc.Sum:integer;
begin
 result:=fx+fy;
end;

function MyCalc.Diff:integer;
begin
 result:=fx-fy;
end;

function MyCalc.Divide:integer;
begin
 result:=fx div fy;
end;

function MyCalc.Mult:integer;
begin
 result:=fx*fy;
end;

procedure MyCalc.Release;
begin
Free;
end;

function MyCalc.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
 if GetInterface(IID, Obj) then
 Result := S_OK
 else
 Result := E_NOINTERFACE;
end;

function MyCalc._AddRef;
begin
end;

function MyCalc._Release;
begin
end;

procedure CreateObject(const IID: TGUID; var ACalc);
var
Calc:MyCalc;
begin
Calc:=MyCalc.Create;
if not Calc.GetInterface(IID,ACalc) then
 Calc.Free;
end;

exports
CreateObject;

begin
end.

А теперь тестер.

unit tstcl;

interface

uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 StdCtrls,ComObj;

type

//обратите внимание! Используем один унифицированный интерфейс
 IUniCalc=interface
 procedure SetOperands(x,y:integer);
 procedure Release;
 function Sum:integer;
 function Diff:integer;
 end;

 TForm1 = class(TForm)
 Button1: TButton;
 Button2: TButton;
 Button3: TButton;
 procedure FormCreate(Sender: TObject);
 procedure FormDestroy(Sender: TObject);
 procedure Button1Click(Sender: TObject);
 procedure Button2Click(Sender: TObject);
 procedure Button3Click(Sender: TObject);
 end;

var
 Form1: TForm1;
 _Mod:Integer; //хэндл модуля
 СreateObject:procedure (IID:TGUID; out Obj); //процедура из dll.

 Calc:IUniCalc; //это указатель на интерфейс котрый мы будем получать
 ICalcGUID:TGUID;
 ICalc2GUID:TGUID;
 flag:boolean; // какой интерфейс активный.

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
 _Mod:=LoadLibrary(PChar('C:\Kir\COM\SymplDll\CalcDll.dll'));

 //Эти GUID я просто скопировал из исходника CalcDll.dll
 ICalcGUID:=StringToGUID('{149D0FC0-43FE-11D6-A1F0-444553540000}');
 ICalc2GUID:=StringToGUID('{D79C6DC0-44B9-11D6-A1F0-444553540000}');
 flag:=true;

 СreateObject:=GetProcAddress(_Mod,'CreateObject');

 СreateObject(ICalcGUID,Calc);
 if Calc<>nil then
 Calc.SetOperands(10,5);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 if Calc<>nil then
 Calc.Release;
 FreeLibrary(_Mod);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 ShowMessage(IntToStr(Calc.diff));
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
 ShowMessage(IntToStr(Calc.Sum));
end;

procedure TForm1.Button3Click(Sender: TObject);
var
 tmpCalc:IUniCalc;
begin
 if flag then
 Calc.QueryInterface(ICalc2GUID,tmpCalc)
 else
 Calc.QueryInterface(ICalcGUID,tmpCalc);
 flag:=not flag;
 Calc:=tmpCalc;
end;

end.

Обратите вснимание, что происходит при нажатии на кнопку3. Мы используем ту же самую переменную, для работы со вторым интерфейсом! Этот пример показывает, что получая указатель на интерфейс, его методы мы получаем за счет смещения, от адреса который этот указатель содержит. Короче, мы получаем адрес таблицы методов.
Потыкайте, посмотрите что происходит.

События, происходящие в приложениях Delphi при завершении работы Windows

Я провел небольшое исследование, и вот что я выяснил:
При закрытии приложения (используя системное меню или вызывая метод закрытия формы), возникают следующие события:
FormCloseQuery - действие по умолчанию, устанавливает переменную CanClose в значание TRUE и продолжает закрытие формы.
FormClose
FormDestroy
Если приложение активно и вы пытаетесь завершить работу Windows (Shut Down), происходят следующие события (с соблюдением последовательности):
FormCloseQuery
FormDestroy
Мы видим, что метод FormClose в этом случае не вызывается.
Теперь воспроизведем всю последовательность событий, происходящую при попытке завершить работу Windows:
Windows посылает сообщение WM_QUERYENDSESSION всем приложениям и ожидает ответ.
Каждое приложение получает сообщение и возвращает одну из величин: не равную нулю - приложение готово завершить свою работу, 0 - приложение не может завершить свою работу.
Если одно из приложений возвращает 0, Windows не завершает свою работу, а снова рассылает всем окнам сообщение, на этот раз WM_ENDSESSION.
Каждое приложение должно снова подтвердить свою готовность завершить работу, поэтому операционная система ожидает ответа TRUE, резонно предполагая, что оставшиеся приложения с момента предыдущего сообщения закрыли свои сессии и готовы завершить работу. Теперь посмотрим, как на это реагирует Delphi-приложение: приложение возвращает значение TRUE и немедленно вызывает метод FormDestroy, игнорируя при этом метод FormClose. Налицо проблема.
Завершение работы Windows.
Первое решение проблемы: приложение Delphi на сообщение WM_QUERYENDSESSION должно возвратить 0, не дав при этом Windows завершить свою работу. При этом бессмысленно пытаться воспользоваться методом FormCloseQuery, поскольку нет возможности определить виновника завершения работы приложения (это может являться как результатом сообщения WM_QUERYENDSESSION, так и просто действием пользователя при попытке закрыть приложение).
Другое решение состоит в том, чтобы при получении сообщения WM_QUERYENDSESSION самим выполнить необходимые действия, вызвав метод FormClose.

unit Unit1;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,
  Dialogs;
type
  TForm1 = class(TForm)
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
{--------------------------------------------------------}
{ Объявляем свой обработчик сообщения WM_QUERYENDSESSION }
{--------------------------------------------------------}
    procedure WMQueryEndSession(
      var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;
  public
{ Public declarations }
  end;
var
  Form1: TForm1;

implementation
{$R *.DFM}

{--------------------------------------------------------------}
{ Создаем процедуру обработки сообщения WM_QUERYENDSESSION. }
{ Приложение получит только это сообщение при попытке Windows }
{ завершить работу }
{--------------------------------------------------------------}

procedure TForm1.WMQueryEndSession(var Message: TWMQueryEndSession);
begin
  inherited; { сначала сообщание должен обработать наследуемый метод }
{--------------------------------------------------------------------}
{ в этой точке вы также можете сообщить Windows о неготовности }
{ приложения завершить работу... }
{ Message.Result:=0; }
{-------------------------------------------или----------------------}
{ вызов процедуры освобождения ресурсов, предусмотренной в FormClose }
{ MyCleanUpProcedure; }
{--------------------------------------------------------------------}
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  MyCleanUpProcedure;
end;

end.

Взято с Исходников.ru

Соединение с интернетом

Cодержание раздела:

См. также другие разделы:

Сохранение и чтение файлов в 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;

Взято из

Сохранение и выдёргивание ресурсов в DLL или EXE?

Иногда возникает необходимость вшить ресурсы в исполняемый файл Вашего приложения (например чтобы предотвратить их случайное удаление пользователем, либо, чтобы защитить их от изменений). Данный пример показывает как вшить любой файл как ресурс в EXE-шнике.

Далее рассмотрим, как создать файл ресурсов, содержащий корию какого-либо файла. После создания такого файла его можно легко прицепить к Вашему проекту директивой {$R}. Файл ресурсов, который мы будем создавать имеет следующий формат:

+ заголовок
+ заголовок для нашего RCDATA ресурса
+ собственно данные - RCDATA ресурс

В данном примере будет показано, как сохранить в файле ресурсов только один файл, но думаю, что так же легко Вы сможете сохранить и несколько файлов.

Заголовок ресурса выглядит следующим образом:

TResHeader = record
 DataSize: DWORD; // размер данных
 HeaderSize: DWORD; // размер этой записи
 ResType: DWORD; // нижнее слово = $FFFF => ordinal
 ResId: DWORD; // нижнее слово = $FFFF => ordinal
 DataVersion: DWORD; // *
 MemoryFlags: WORD;
 LanguageId: WORD; // *
 Version: DWORD; // *
 Characteristics: DWORD; // *
end;

Поля помеченны звёздочкой Мы не будем использовать.

Приведённый код создаёт файл ресурсов и копирует его в данный файл:

procedure CreateResourceFile(
 DataFile, ResFile: string; // имена файлов
 ResID: Integer // id ресурсов
);
var
 FS, RS: TFileStream;
 FileHeader, ResHeader: TResHeader;
 Padding: array[0..SizeOf(DWORD)-1] of Byte;
begin

 { Open input file and create resource file }
 FS := TFileStream.Create( // для чтения данных из файла
 DataFile, fmOpenRead);
 RS := TFileStream.Create( // для записи файла ресурсов
 ResFile, fmCreate);

 { Создаём заголовок файла ресурсов - все нули, за исключением
 HeaderSize, ResType и ResID }
 FillChar(FileHeader, SizeOf(FileHeader), #0);
 FileHeader.HeaderSize := SizeOf(FileHeader);
 FileHeader.ResId := $0000FFFF;
 FileHeader.ResType := $0000FFFF;

 { Создаём заголовок данных для RC_DATA файла
 Внимание: для создания более одного ресурса необходимо
 повторить следующий процесс, используя каждый раз различные
 ID ресурсов }
 FillChar(ResHeader, SizeOf(ResHeader), #0);
 ResHeader.HeaderSize := SizeOf(ResHeader);
 // id ресурса - FFFF означает "не строка!"
 ResHeader.ResId := $0000FFFF or (ResId shl 16);
 // тип ресурса - RT_RCDATA (from Windows unit)
 ResHeader.ResType := $0000FFFF
 or (WORD(RT_RCDATA) shl 16);
 // размер данных - есть размер файла
 ResHeader.DataSize := FS.Size;
 // Устанавливаем необходимые флаги памяти
 ResHeader.MemoryFlags := $0030;

 { Записываем заголовки в файл ресурсов }
 RS.WriteBuffer(FileHeader, sizeof(FileHeader));
 RS.WriteBuffer(ResHeader, sizeof(ResHeader));

 { Копируем файл в ресурс }
 RS.CopyFrom(FS, FS.Size);

 { Pad data out to DWORD boundary - any old
 rubbish will do!}
 if FS.Size mod SizeOf(DWORD) <> 0 then
 RS.WriteBuffer(Padding, SizeOf(DWORD) -
 FS.Size mod SizeOf(DWORD));

 { закрываем файлы }
 FS.Free;
 RS.Free;
end;

Данный код не совсем красив, и отсутствует обработка ошибок. Правильнее будет создать класс, включающий в себя данный пример.

Извлечение ресурсов из EXE
теперь рассмотрим пример, показывающий, как извлекать ресурсы из исполняемого модуля.

Вся процедура заключается в создании потока ресурса, создании файлового потока и копировании из потока ресурса в поток файла.

procedure ExtractToFile(Instance:THandle; ResID:Integer; ResType, FileName:String);
var
 ResStream: TResourceStream;
 FileStream: TFileStream;
begin
 try
 ResStream := TResourceStream.CreateFromID(Instance, ResID, pChar(ResType));
 try
 //if FileExists(FileName) then
 //DeleteFile(pChar(FileName));
 FileStream := TFileStream.Create(FileName, fmCreate);
 try
 FileStream.CopyFrom(ResStream, 0);
 finally
 FileStream.Free;
 end;
 finally
 ResStream.Free;
 end;
 except
 on E:Exception do
 begin
 DeleteFile(FileName);
 raise;
 end;
 end;
end;

Всё, что требуется, это получить Instance exe-шника или dll (у Вашего приложения это Application.Instance или Application.Handle, для dll Вам прийдётся получить его самостоятельно :)

ResID тот же самый ID , который был присвоен ресурсу

ResType WAVEFILE, BITMAP, CURSOR, CUSTOM - это типы ресурсов, с которыми возможно работать, но у меня получилось успешно проделать процедуру только с CUSTOM

FileName - это имя файла, который мы хотим создать из ресурса

Взято с Исходников.ru

Сохранение параметров шрифта в INI-файле

functionFontToStr(font: TFont): string;
 procedure yes(var str: string);
 begin

 str := str + 'y';
 end;
 procedure no(var str: string);
 begin

 str := str + 'n';
 end;
begin

 {кодируем все атрибуты TFont в строку}
 Result := '';
 Result := Result + IntToStr(font.Color) + '|';
 Result := Result + IntToStr(font.Height) + '|';
 Result := Result + font.Name + '|';
 Result := Result + IntToStr(Ord(font.Pitch)) + '|';
 Result := Result + IntToStr(font.PixelsPerInch) + '|';
 Result := Result + IntToStr(font.size) + '|';
 if fsBold in font.style then
 yes(Result)
 else
 no(Result);
 if fsItalic in font.style then
 yes(Result)
 else
 no(Result);
 if fsUnderline in font.style then
 yes(Result)
 else
 no(Result);
 if fsStrikeout in font.style then
 yes(Result)
 else
 no(Result);
end;

procedure StrToFont(str: string; font: TFont);
begin

 if str = '' then
 Exit;
 font.Color := StrToInt(tok('|', str));
 font.Height := StrToInt(tok('|', str));
 font.Name := tok('|', str);
 font.Pitch := TFontPitch(StrToInt(tok('|', str)));
 font.PixelsPerInch := StrToInt(tok('|', str));
 font.Size := StrToInt(tok('|', str));
 font.Style := [];
 if str[0] = 'y' then
 font.Style := font.Style + [fsBold];
 if str[1] = 'y' then
 font.Style := font.Style + [fsItalic];
 if str[2] = 'y' then
 font.Style := font.Style + [fsUnderline];
 if str[3] = 'y' then
 font.Style := font.Style + [fsStrikeout];
end;

function tok(sep: string; var s: string): string;

 function isoneof(c, s: string): Boolean;
 var
 iTmp: integer;
 begin
 Result := False;
 for iTmp := 1 to Length(s) do
 begin
 if c = Copy(s, iTmp, 1) then
 begin
 Result := True;
 Exit;
 end;
 end;
 end;
var

 c, t: string;
begin

 if s = '' then
 begin
 Result := s;
 Exit;
 end;
 c := Copy(s, 1, 1);
 while isoneof(c, sep) do
 begin
 s := Copy(s, 2, Length(s) - 1);
 c := Copy(s, 1, 1);
 end;
 t := '';
 while (not isoneof(c, sep)) and (s <> '') do
 begin
 t := t + c;
 s := Copy(s, 2, length(s) - 1);
 c := Copy(s, 1, 1);
 end;
 Result := t;
end;

Взято из

Сохранение TForm и ее свойств в BLOB-поле

procedureSaveToField(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;

Взято из

Сохранение точных размеров при печати

Приведенный ниже модуль демонстрирует принцип использования GetDeviceCaps для получения исчерпывающей информации о вашем принтере, включая HORZRES и VERTRES (горизонтальное и вертикальное разрешение в пикселах) на дюйм бумаги. Используя значения LOGPIXELSX и LOGPIXELSY, вы можете откалибровать принтер для точного задания количества точек на дюйм в горизонтальном и вертикальном направлениях.

В дополнение к информации о принтере, приведенный модуль демонстрирует способ печати, при котором изображение выводится на принтер "естественного" размера; также показана возможность размещения изображения на бумаге в определенной позиции и определенного размера (т.е. с применением масштабирования). Я думаю это должно вам помочь в деле управления принтером.

Пример также демонстрирует вывод на печать синусной кривой в конкретной позиции печати с заданными в дюймах размерами. Я думаю вы без труда разберетесь как перейти на метрическую систему размеров.

unitTstpr2fm;

{Пример использования объекта Printer из модуля TPrinter.

Приведен избыточный стиль программирования для облегчения
восприятия материала.

Демонстрация величин, возвращаемых функцией Windows API GetDeviceCaps.

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls;

type

TForm1 = class(TForm)
Print: TButton;
Image1: TImage;
procedure PrintClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var

 Form1: TForm1;

implementation

uses
 Printers;

{Константы WINAPI GetDeviceCaps получены из C++ windows.h и wingdi.h}

{Отдельные константы здесь приведены только для информации о их наличии}
const
 DRIVERVERSION = 0;
 TECHNOLOGY = 2; {Смотри windows.h для значения маски}
 HORZSIZE = 4;
 VERTSIZE = 6;
 HORZRES = 8;
 VERTRES = 10;
 BITSPIXEL = 12;
 PLANES = 14;
 NUMBRUSHES = 16;
 NUMPENS = 18;
 NUMMARKERS = 20;
 NUMFONTS = 22;
 NUMCOLORS = 24;
 PDEVICESIZE = 26;
 CURVECAPS = 28; {Смотри windows.h для значения маски}
 LINECAPS = 30; {Смотри windows.h для значения маски}
 POLYGONALCAPS = 32; {Смотри windows.h для значения маски}
 TEXTCAPS = 34; {Смотри windows.h для значения маски}
 CLIPCAPS = 36; {Смотри windows.h для значения маски}
 RASTERCAPS = 38; {Смотри windows.h для значения маски}
 ASPECTX = 40;
 ASPECTY = 42;
 ASPECTXY = 44;

 LOGPIXELSX = 88;
 LOGPIXELSY = 90;

 SIZEPALETTE = 104;
 NUMRESERVED = 106;
 COLORRES = 108;

 PHYSICALWIDTH = 110; {Смотри определение в windows.h}
 PHYSICALHEIGHT = 111; {Смотри определение в windows.h}
 PHYSICALOFFSETX = 112; {Смотри определение в windows.h}
 PHYSICALOFFSETY = 113; {Смотри определение в windows.h}
 SCALINGFACTORX = 114; {Смотри определение в windows.h}
 SCALINGFACTORY = 115; {Смотри определение в windows.h}

 DeviceCapsString: array[1..34] of string =
 ('DRIVERVERSION', 'TECHNOLOGY', 'HORZSIZE',
 'VERTSIZE', 'HORZRES', 'VERTRES',
 'BITSPIXEL', 'PLANES', 'NUMBRUSHES',
 'NUMPENS', 'NUMMARKERS', 'NUMFONTS',
 'NUMCOLORS', 'PDEVICESIZE', 'CURVECAPS',
 'LINECAPS', 'POLYGONALCAPS', 'TEXTCAPS',
 'CLIPCAPS', 'RASTERCAPS', 'ASPECTX',
 'ASPECTY', 'ASPECTXY', 'LOGPIXELSX',
 'LOGPIXELSY', 'SIZEPALETTE', 'NUMRESERVED',
 'COLORRES', 'PHYSICALWIDTH', 'PHYSICALHEIGHT',
 'PHYSICALOFFSETX', 'PHYSICALOFFSETY', 'SCALINGFACTORX',
 'SCALINGFACTORY');

 DeviceCapsIndex: array[1..34] of INTEGER =
 (0, 2, 4, 6, 8, 10, 12, 14, 16, 18,
 20, 22, 24, 26, 28, 30, 32, 34, 36, 38,
 40, 42, 44, 88, 90, 104, 106, 108, 110, 111,
 112, 113, 114, 115);

{$R *.DFM}

function iPosition(const i: INTEGER): INTEGER;
begin

 RESULT := Integer(i * LongInt(Printer.PageWidth) div 1000)
end {iPosition};

function jPosition(const j: INTEGER): INTEGER;
begin

 RESULT := Integer(j * LongInt(Printer.PageHeight) div 1000)
end {jPosition};

procedure TForm1.PrintClick(Sender: TObject);

var
 DestinationRectangle: TRect;
 GraphicAspectRatio: DOUBLE;
 i: INTEGER;
 j: INTEGER;
 iBase: INTEGER;
 iPixelsPerInch: WORD;
 jBase: INTEGER;
 jDelta: INTEGER;
 jPixelsPerInch: WORD;
 OffScreen: TBitMap;
 PixelAspectRatio: DOUBLE;
 SourceRectangle: TRect;
 TargetRectangle: TRect;
 value: INTEGER;
 x: DOUBLE;
 y: DOUBLE;
begin

 Printer.Orientation := poLandscape;
 Printer.BeginDoc;

{Делаем прямоугольник для показа полей}
 Printer.Canvas.Rectangle(0, 0, Printer.PageWidth, Printer.PageHeight);

{Свойства принтера и страницы}
 Printer.Canvas.Font.Name := 'Times New Roman';
 Printer.Canvas.Font.Size := 12;
 Printer.Canvas.Font.Style := [fsBold];
 Printer.Canvas.TextOut(iPosition(50), jPosition(40), 'Свойства принтера и страницы');

 Printer.Canvas.Font.Style := [];
 Printer.Canvas.Font.Size := 10;
 iBase := iPosition(50);
 jBase := 60;
 jDelta := 18;
 Printer.Canvas.TextOut(iPosition(50), jPosition(jBase),
 Printer.Printers.Strings[Printer.PrinterIndex]);
 INC(jBase, jDelta);

 Printer.Canvas.TextOut(iBase, jPosition(jBase),
 'Пикселей: ' + IntToStr(Printer.PageWidth) + ' X ' +
 IntToStr(Printer.PageHeight));
 INC(jBase, jDelta);

 Printer.Canvas.TextOut(iBase, jPosition(jBase),
 'Дюймов: ' + FormatFloat('0.000',
 Printer.PageWidth / Printer.Canvas.Font.PixelsPerInch) + ' X ' +
 FormatFloat('0.000',
 Printer.PageHeight / Printer.Canvas.Font.PixelsPerInch));
 INC(jBase, 2 * jDelta);

 Printer.Canvas.TextOut(iBase, jPosition(jBase),
 'Шрифт: ' + Printer.Canvas.Font.Name + ' Размер: ' +
 IntToStr(Printer.Canvas.Font.Size));
 INC(jBase, jDelta);

 Printer.Canvas.TextOut(iBase, jPosition(jBase),
 'Пикселей в дюйме: ' + IntToStr(Printer.Canvas.Font.PixelsPerInch));
 INC(jBase, jDelta);

 Printer.Canvas.TextOut(iBase, jPosition(jBase),
 '''ТЕКСТ'': ' + IntToStr(Printer.Canvas.TextWidth('ТЕКСТ')) + ' X ' +
 IntToStr(Printer.Canvas.TextHeight('ТЕКСТ')) + '
 пикселей');

{Значения GetDeviceCaps}
 INC(jBase, 2 * jDelta);
 Printer.Canvas.Font.Size := 12;
 Printer.Canvas.Font.Style := [fsBold];
 Printer.Canvas.TextOut(iBase, jPosition(jBase), 'GetDeviceCaps');
 INC(jBase, jDelta);

 Printer.Canvas.Font.Size := 10;
 Printer.Canvas.Font.Style := [];

 for j := LOW(DeviceCapsIndex) to HIGH(DeviceCapsIndex) do
 begin
 value := GetDeviceCaps(Printer.Handle, DeviceCapsIndex[j]);
 Printer.Canvas.TextOut(iBase, jPosition(jBase), DeviceCapsString[j]);

 if (DeviceCapsIndex[j] < 28) or (DeviceCapsIndex[j] > 38) then
 Printer.Canvas.TextOut(iPosition(250), jPosition(jBase), Format('%-8d', [value]))
 else
 Printer.Canvas.TextOut(iPosition(250), jPosition(jBase), Format('%.4x', [value]));

 INC(jBase, jDelta);

 end;

{Помещаем изображение в левый нижний угол}
 Printer.Canvas.Draw(iPosition(300), jPosition(100),
 Form1.Image1.Picture.Graphic);

{Помещаем то же изображение, имеющее ширину 1" и пропорциональную
высоту в позиции 4"-правее и 1"-ниже верхнего левого угла}
 GraphicAspectRatio := Form1.Image1.Picture.Height /
 Form1.Image1.Picture.Width;

 iPixelsPerInch := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
 jPixelsPerInch := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
 PixelAspectRatio := jPixelsPerInch / iPixelsPerInch;

 TargetRectangle := Rect(4 * iPixelsPerInch, {4"}
 jPixelsPerInch, {1"}
 6 * iPixelsPerInch, {6" -- 2" ширина}
 jPixelsPerInch +
 TRUNC(2 * iPixelsPerInch * GraphicAspectRatio *
 PixelAspectRatio));

 Printer.Canvas.TextOut(4 * iPixelsPerInch, jPixelsPerInch -
 Printer.Canvas.TextHeight('X'),
 '2" ширина от (4", 1")');
 Printer.Canvas.StretchDraw(TargetRectangle, Form1.Image1.Picture.Graphic);

{Создаем изображение в памяти и затем копируем его на холст принтера}
 SourceRectangle := Rect(0, 0, 3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1);

{Это не должно работать! Rectangle = Left, Top, Right, Bottom
Top и Bottom считаются зарезервированными?}
 DestinationRectangle := Rect(4 * iPixelsPerInch, 6 * jPixelsPerInch,
 7 * iPixelsPerInch - 1, 4 * jPixelsPerinch - 1);

 Printer.Canvas.TextOut(4 * iPixelsPerInch, 4 * jPixelsPerInch -
 Printer.Canvas.TextHeight('X'),
 IntToStr(3 * iPixelsPerInch) + ' пикселей на ' +
 IntToStr(2 * jPixelsPerInch) + ' пикселей -- ' +
 '3"-на-2" в (4",4")');

 OffScreen := TBitMap.Create;
 try
 OffScreen.Width := SourceRectangle.Right + 1;
 OffScreen.Height := SourceRectangle.Bottom + 1;
 with OffScreen.Canvas do
 begin
 Pen.Color := clBlack;
 Brush.Color := clWhite;
 Rectangle(0, 0, 3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1);
 Brush.Color := clRed;
 MoveTo(0, 0);
 LineTo(3 * iPixelsPerInch - 1, 2 * jPixelsPerInch - 1);

 Brush.Color := clBlue;
 MoveTo(0, 0);
 for i := 0 to 3 * iPixelsPerInch - 1 do
 begin
 x := 12 * PI * (i / (3 * iPixelsPerInch - 1));
 y := jPixelsPerInch + jPixelsPerInch * SIN(x);
 LineTo(i, TRUNC(y));
 end

 end;

 Printer.Canvas.CopyRect(DestinationRectangle, OffScreen.Canvas,
 SourceRectangle);
 finally
 OffScreen.Free
 end;

{Список шрифтов для данного принтера}
 iBase := iPosition(750);
 Printer.Canvas.Font.Name := 'Times New Roman';
 Printer.Canvas.Font.Size := 12;
 Printer.Canvas.Font.Style := [fsBold];
 Printer.Canvas.TextOut(iBase, jPosition(40), 'Шрифты');

 Printer.Canvas.Font.Style := [];
 Printer.Canvas.Font.Size := 10;
 jDelta := 16;
 for j := 0 to Printer.Fonts.Count - 1 do
 begin
 Printer.Canvas.TextOut(iBase, jPosition(60 + jDelta * j), Printer.Fonts.Strings[j])
 end;

 Printer.EndDoc;

end;

end.

Взято из

Советов по Delphi от

Сборник Kuliba

Сохранение всего содержимого буфера обмена в файл

Из рассылки "Мастера 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:Cardin!
al;
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;

Взято с Vingrad.ru

Сохранить строку в памяти?+пример работы с атомами

Например через атомы:

К счастью количество атомов ограничено 0xFFFF, так что простые функции перебора работают достаточно быстро. Вот пример как сохранять и читать значение через атомы:

const UniqueSignature='GI7324hjbHGHJKdhgn90jshUH*hjsjshjdj';

Procedure CleanAtoms;
var P:PChar;
 i:Word;
begin
GetMem(p, 256);
For i:=0 to $FFFF do
begin
 GlobalGetAtomName(i, p, 255);
 if StrPos(p, PChar(UniqueSignature))<>nil then GlobalDeleteAtom(i);
end;
FreeMem(p);
end;

Procedure WriteAtom(Str:string);
begin
CleanAtoms;
GlobalAddAtom(PChar(UniqueSignature+Str));
end;

Function ReadAtom:string;
var P:PChar;
 i:Word;
begin
GetMem(p, 256);
For i:=0 to $FFFF do
begin
GlobalGetAtomName(i, p, 255);
if StrPos(p, PChar(UniqueSignature))<>nil then break;
end;
result:=StrPas(p+length(UniqueSignature));
FreeMem(p);
end;

procedure TReadFromAtom.Button1Click(Sender: TObject);
begin
WriteAtom(Edit1.text);
end;

procedure TReadFromAtom.Button2Click(Sender: TObject);
begin
Showmessage(ReadAtom);
end;

Примечание: константа "UniqueSignature" должна быть достаточно длинной, чтобы однозначно идентифицировать атом, в тоже время длина хранимой строки вместе с UniqueSignature не должна превышать 255 символов. Данная конструкция может хранить только 1 значение. Для хранения нескольких значений надо назначить несколько разных UniqueSignature и использовать сходные процедуры.

Автор ответа: Vit
Взято с Vingrad.ru