Изменение свойств печати во время ее выполнения

Изменение свойств печати во время ее выполнения

Как разрешить изменения свойств принтера (например, лоток с бумагой, ориентация и др.) между страницами печати одного документа в шести шагах.

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


*** ШАГИ ***
Создайте копию модуля Printers.pas и переименуйте его в NewPrint.pas.

***НЕ делайте изменения в самом модуле Printers.pas, если вы сделаете это, то получите во время компиляции приложения ошибку "Unable to find printers.pas" (не могу найти printer.pas). (Я уже получае ее, поэтому и упоминаю об этом здесь...)***


Переместите модуль NewPrint.pas в директорию Lib.

(Используйте "C:\Program Files\Borland\Delphi Х\Lib" )



Измените ИМЯ МОДУЛЯ на NewPrint.pas

с:
unit Printers 

на:
    unit NewPrint 


Добавьте декларацию следующего PUBLIC метода класса TPrinter в секции Interface модуля NewPrint.pas:

    procedure NewPageDC(DM: PDevMode); 


Добавьте следующую процедуру в секцию реализации NewPrint.pas:

procedure TPrinter.NewPageDC(DM: PDevMode);
begin
  CheckPrinting(True);
  EndPage(DC);
{Проверяем наличие новых установок для принтера}
  if Assigned(DM) then
    ResetDC(DC, DM^);
  StartPage(DC);
  Inc(FPageNumber);
  Canvas.Refresh;
end;


Вместо добавления "Printers" в секцию USES вашего приложения (список используемых модулей), добавьте "NewPrint".

Теперь вдобавок к старым методам (таким как BeginDoc, EndDoc, NewPage и др.), у вас появилась возможность изменения свойств принтера "на лету", т.е. между страницами при печати одного и того же документа. (Пример приведен ниже.)
Вместо вызова:

    Printer.NewPage; 

напишите:

    Printer.NewPageDC(DevMode); 

Вот небольшой пример:

procedure TForm1.Button1Click(Sender: TObject);
var
  ADevice, ADriver, APort: array[0..255] of char;
  ADeviceMode: THandle;
  DevMode: PDevMode;
begin
  with Printer do
    begin
      GetPrinter(ADevice, ADriver, APort, ADeviceMode);
      SetPrinter(ADevice, ADriver, APort, 0);
      GetPrinter(ADevice, ADriver, APort, ADeviceMode);
      DevMode := GlobalLock(ADeviceMode);
      if not Assigned(DevMode) then
        ShowMessage('Не могу установить принтер.')
      else
        begin
          with DevMode^ do
            begin
{Применяем здесь любые настройки, необходимые для изменения установок печати}
              dmDefaultSource := DMBIN_UPPER;
{этот код приведен в "Windows.pas"}
            end;
          GlobalUnlock(ADeviceMode);
          SetPrinter(ADevice, ADriver, APort, ADeviceMode);
        end;
    end;
  Printer.BeginDoc;
  Printer.Canvas.TextOut(50, 50, 'Эта страница печатается из ВЕРХНЕГО ЛОТКА.');
  with DevMode^ do
    begin
{Применяем здесь любые настройки, необходимые для изменения установок печати}
      dmDefaultSource := DMBIN_LOWER;
{этот код приведен в "Windows.pas"}
    end;
  Printer.NewPageDC(DevMode);
  Printer.Canvas.TextOut(50, 50, 'Эта страница печатается из НИЖНЕГО ЛОТКА.');
  Printer.EndDoc;
end;


Примечание от автора:

Я использовал это во многих своих программах, поэтому я уверен в работоспособности кода.

Данный кода был создан в Delphi Client/Server 2.01 под WinNT 4.0, но впоследствии был
проверен на других версиях Delphi, а также под Windows95.
Правда я еще не поробовал его под Delphi 4... Если вы имеете любые комментарии или улучшения,
не постесняйтесь отправить их мне...

Взято из

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

Сборник Kuliba

Изменить громкость

Изменить громкость

Эта программа увеличивает громкость выбранного канала на 1000:



usesMMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var
  vol: longint;
  LVol, RVol: integer;
begin
  AuxGetVolume(ListBox1.ItemIndex, @Vol);
  LVol := Vol shr 16;
  if LVol < MaxWord - 1000 then
    LVol := LVol + 1000
  else
    LVol := MaxWord;
  RVol := (Vol shl 16) shr 16;
  if RVol < MaxWord - 1000 then
    RVol := RVol + 1000
  else
    RVol := MaxWord;
  AuxSetVolume(ListBox1.ItemIndex, LVol shl 16 + RVol);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  cap: TAuxCaps;
begin
  for i := 0 to auxGetNumDevs - 1 do
  begin
    auxGetDevCaps(i, Addr(cap), SizeOf(cap));
    ListBox1.Items.Add(cap.szPname)
  end;
end;

procedure SetVolume(X: Word);
var
  iErr: Integer;
  i: integer;
  a: TAuxCaps;
begin
  for i := 0 to auxGetNumDevs do
  begin
    auxGetDevCaps(i, Addr(a), SizeOf(a));
    if a.wTechnology = AUXCAPS_CDAUDIO then
      break;
  end;

  // Устанавливаем одинаковую громкость для левого и правого каналов.
  // VOLUME := LEFT*$10000 + RIGHT*1

  iErr := auxSetVolume(i, (X * $10001));
  if (iErr‹›0) then
    ShowMessage('No audio devices are available!');
end;

function GetVolume: Word;
var
  iErr: Integer;
  i: integer;
  a: TAuxCaps;
  vol: word;
begin
  for i := 0 to auxGetNumDevs do
  begin
    auxGetDevCaps(i, Addr(a), SizeOf(a));
    if a.wTechnology = AUXCAPS_CDAUDIO then
      break;
  end;
  iErr := auxGetVolume(i, addr(vol));
  GetVolume := vol;
  if (iErr‹›0) then
    ShowMessage('No audio devices are available!');
end;

unit Volumes;
 
interface 
 
uses 
  Windows, Messages, Classes, ExtCtrls, ComCtrls, MMSystem; 

const 
  CDVolume       = 0; 
  WaveVolume     = 1; 
  MidiVolume     = 2; 
 
type 
  TVolumeControl = class(TComponent) 
  private
    FDevices     : array[0..2] of Integer; 
    FTrackBars   : array[0..2] of TTrackBar; 
    FTimer       : TTimer; 
    function       GetInterval: Integer; 
    procedure      SetInterval(AInterval: Integer);
    function       GetVolume(AIndex: Integer): Byte; 
    procedure      SetVolume(AIndex: Integer; aVolume: Byte); 
    procedure      InitVolume; 
    procedure      SetTrackBar(AIndex: Integer; ATrackBar: TTrackBar); 
    { Private declarations } 
    procedure      Update(Sender: TObject); 
    procedure      Changed(Sender: TObject); 
  protected 
    { Protected declarations } 
    procedure      Notification(AComponent: TComponent; AOperation: 
TOperation); override; 
  public 
    { Public declarations } 
    constructor    Create(AOwner: TComponent); override; 
    destructor     Destroy; override; 
  published 
    { Published declarations } 
    property       Interval: Integer read GetInterval write SetInterval default 
500; 
    property       CDVolume: Byte index 0 read GetVolume write SetVolume stored 
False; 
    property       CDTrackBar: TTrackBar index 0 read FTrackBars[0] write 
SetTrackBar; 
    property       WaveVolume: Byte index 1 read GetVolume write SetVolume 
stored False; 
    property       WaveTrackBar: TTrackBar index 1 read FTrackBars[1] write 
SetTrackBar; 
    property       MidiVolume: Byte index 2 read GetVolume write SetVolume
stored False; 
    property       MidiTrackBar: TTrackBar index 2 read FTrackBars[2] write 
SetTrackBar; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('Any', [TVolumeControl]); 
end; 
 
type 
    TVolumeRec = record 
    case Integer of 
    0: (LongVolume: Longint); 
    1: (LeftVolume, 
        RightVolume : Word); 
    end; 
 
    function       TVolumeControl.GetInterval: Integer; 
    begin 
      Result := FTimer.Interval; 
    end; 
 
    procedure      TVolumeControl.SetInterval(AInterval: Integer);
    begin 
      FTimer.Interval := AInterval; 
    end; 
 
    function       TVolumeControl.GetVolume(AIndex: Integer): Byte; 
    var Vol: TVolumeRec; 
    begin 
      Vol.LongVolume := 0; 
      if FDevices[AIndex] < >  -1 then 
      case AIndex of 
      0: auxGetVolume(FDevices[AIndex], @Vol.LongVolume); 
      1: waveOutGetVolume(FDevices[AIndex], @Vol.LongVolume); 
      2: midiOutGetVolume(FDevices[AIndex], @Vol.LongVolume); 
      end; 
      Result := (Vol.LeftVolume + Vol.RightVolume) shr 9; 
    end; 
 
    procedure      TVolumeControl.SetVolume(aIndex: Integer; aVolume: Byte); 
    var Vol: TVolumeRec; 
    begin 
      if FDevices[AIndex] < >  -1 then 
      begin 
        Vol.LeftVolume := aVolume shl 8; 
        Vol.RightVolume := Vol.LeftVolume; 
        case AIndex of 
        0: auxSetVolume(FDevices[AIndex], Vol.LongVolume); 
        1: waveOutSetVolume(FDevices[AIndex], Vol.LongVolume); 
        2: midiOutSetVolume(FDevices[AIndex], Vol.LongVolume);
        end; 
      end; 
    end; 
 
    procedure      TVolumeControl.SetTrackBar(AIndex: Integer; ATrackBar: 
TTrackBar); 
    begin 
      if ATrackBar < >  FTrackBars[AIndex] then 
      begin 
        FTrackBars[AIndex] := ATrackBar; 
        Update(Self); 
      end; 
    end; 
 
 AOperation: TOperation); 
    var I: Integer; 
    begin 
      inherited Notification(AComponent, AOperation); 
      if (AOperation = opRemove) then 
      for I := 0 to 2 do if (AComponent = FTrackBars[I]) 
      then FTrackBars[I] := Nil; 
    end; 
 
    procedure      TVolumeControl.Update(Sender: TObject); 
    var I: Integer; 
    begin 
      for I := 0 to 2 do 
      if Assigned(FTrackBars[I]) then
      with FTrackBars[I] do 
      begin 
        Min := 0; 
        Max := 255; 
        if Orientation = trVertical 
        then Position := 255 - GetVolume(I) 
        else Position := GetVolume(I); 
        OnChange := Self.Changed; 
      end; 
    end; 
 
    constructor    TVolumeControl.Create(AOwner: TComponent); 
    begin 
      inherited Create(AOwner); 
      FTimer := TTimer.Create(Self); 
      FTimer.OnTimer := Update; 
      FTimer.Interval := 500; 
      InitVolume; 
    end; 
 
    destructor     TVolumeControl.Destroy; 
    var I: Integer; 
    begin 
      FTimer.Free; 
      for I := 0 to 2 do 
      if Assigned(FTrackBars[I]) then 
      FTrackBars[I].OnChange := Nil; 
      inherited Destroy;
    end; 
 
    procedure      TVolumeControl.Changed(Sender: TObject); 
    var I: Integer; 
    begin 
      for I := 0 to 2 do 
      if Sender = FTrackBars[I] then 
      with FTrackBars[I] do 
      begin 
        if Orientation = trVertical 
        then SetVolume(I, 255 - Position) 
        else SetVolume(I, Position); 
      end; 
    end; 
 
    procedure      TVolumeControl.InitVolume; 
    var AuxCaps     : TAuxCaps; 
        WaveOutCaps : TWaveOutCaps; 
        MidiOutCaps : TMidiOutCaps; 
        I,J         : Integer; 
    begin 
      FDevices[0] := -1; 
      for I := 0 to auxGetNumDevs - 1 do 
      begin 
        auxGetDevCaps(I, @AuxCaps, SizeOf(AuxCaps)); 
        if (AuxCaps.dwSupport and AUXCAPS_VOLUME) < >  0 then 
        begin 
          FTimer.Enabled := True;
          FDevices[0] := I; 
          break; 
        end; 
      end; 
      FDevices[1] := -1; 
      for I := 0 to waveOutGetNumDevs - 1 do 
      begin 
        waveOutGetDevCaps(I, @WaveOutCaps, SizeOf(WaveOutCaps)); 
        if (WaveOutCaps.dwSupport and WAVECAPS_VOLUME) < >  0 then 
        begin 
          FTimer.Enabled := True; 
          FDevices[1] := I; 
          break; 
        end; 
      end; 
      FDevices[2] := -1; 
      for I := 0 to midiOutGetNumDevs - 1 do 
      begin 
        MidiOutGetDevCaps(I, @MidiOutCaps, SizeOf(MidiOutCaps)); 
        if (MidiOutCaps.dwSupport and MIDICAPS_VOLUME) < >  0 then 
        begin 
          FTimer.Enabled := True; 
          FDevices[2] := I; 
          break; 
        end; 
      end;
    end;

end.

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



procedure TForm1.TrackBar1Change(Sender: TObject);
var
 s: dword;
 a,b: word;
 h: hWnd;
begin
 a:=trackbar1.position;
 b:=trackbar2.position;
 s:=(a shl 16) or b;
 waveOutSetVolume(h,s);
end;

 


свойство Max в каждом TrackBar'e должно равняться 65535 (то есть MaxWord)

Взято с

Изменить размер поля или его тип

Изменить размер поля или его тип

Автор: Reinhard Kalinke

Единственный способ изменить размер поля или его тип - использовать DBIDoRestructure. Вот простой пример, который может вам помочь в этом:


functionBDEStringFieldResize(ATable: TTable; AFieldName: string; ANewSize:
  integer): boolean;
type
  TRestructStatus = (rsFieldNotFound, rsNothingToDo, rsDoIt);
var
  hDB: hDBIdb;
  pTableDesc: pCRTblDesc;
  pFldOp: pCROpType; {фактически это массив array of pCROpType}
  pFieldDesc: pFldDesc; {фактически это массив array of pFldDesc}
  CurPrp: CurProps;
  CSubType: integer;
  CCbrOption: CBRType;
  eRestrStatus: TRestructStatus;
  pErrMess: DBIMsg;
  i: integer;
begin
  Result := False;
  eRestrStatus := rsFieldNotFound;
  AFieldName := UpperCase(AFieldName);
  pTableDesc := nil;
  pFieldDesc := nil;
  pFldOp := nil;

  with ATable do
  try

    {убедимся что имеем исключительный доступ и сохраним dbhandle:}
    if Active and (not Exclusive) then
      Close;
    if (not Exclusive) then
      Exclusive := True;
    if (not Active) then
      Open;
    hDB := DBHandle;

    {готовим данные для DBIDoRestructure:}
    BDECheck(DBIGetCursorProps(Handle, CurPrp));
    GetMem(pFieldDesc, CurPrp.iFields * sizeOf(FldDesc));
    BDECheck(DBIGetFieldDescs(Handle, pFieldDesc));
    GetMem(pFldOp, CurPrp.iFields * sizeOf(CROpType));
    FillChar(pFldOp^, CurPrp.iFields * sizeOf(CROpType), 0);

    {ищем в цикле (через fielddesc) наше поле:}
    for i := 1 to CurPrp.iFields do
    begin
      {для ввода мы имеем серийные номера вместо
      Pdox ID, возвращаемых DbiGetFieldDescs:}
      pFieldDesc^.iFldNum := i;
      if (Uppercase(StrPas(pFieldDesc^.szName)) = AFieldName)
        and (pFieldDesc^.iFldType = fldZSTRING) then
      begin
        eRestrStatus := rsNothingToDo;
        if (pFieldDesc^.iUnits1 <> ANewSize) then
        begin
          pFieldDesc^.iUnits1 := ANewSize;
          pFldOp^ := crModify;
          eRestrStatus := rsDoIt;
        end;
      end;
      inc(pFieldDesc);
      inc(pFldOp);
    end; {for}

    {"регулируем" массив указателей:}
    dec(pFieldDesc, CurPrp.iFields);
    dec(pFldOp, CurPrp.iFields);

    {в случае отсутствия операций возбуждаем исключение:}
    case eRestrStatus of
      rsNothingToDo: raise Exception.Create('Ничего не сделано');
      rsFieldNotFound: raise Exception.Create('Поле не найдено');
    end;

    GetMem(pTableDesc, sizeOf(CRTblDesc));
    FillChar(pTableDesc^, SizeOf(CRTblDesc), 0);
    StrPCopy(pTableDesc^.szTblName, TableName);
    {StrPCopy(pTableDesc^.szTblType,szPARADOX); {}
    pTableDesc^.szTblType := CurPrp.szTableType;
    pTableDesc^.iFldCount := CurPrp.iFields;
    pTableDesc^.pecrFldOp := pFldOp;
    pTableDesc^.pfldDesc := pFieldDesc;

    Close;

    BDECheck(DbiDoRestructure(hDB, 1, pTableDesc, nil, nil, nil, False));

  finally
    if pTableDesc <> nil then
      FreeMem(pTableDesc, sizeOf(CRTblDesc));
    if pFldOp <> nil then
      FreeMem(pFldOp, CurPrp.iFields * sizeOf(CROpType));
    if pFieldDesc <> nil then
      FreeMem(pFieldDesc, CurPrp.iFields * sizeOf(FldDesc));
    Open;
  end; {пробуем с table1}
  Result := True;
end;

Взято из

Примечание Vit: На счёт "Единственный способ" - этот товарищ несколько погорячился. Все базы данных поддерживают SQL запрос вида

ALTER TABLE...

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

Изменяем заголовок окна

Изменяем заголовок окна

Автор: Christian Cristofori

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

Сперва необходимо определить сообщение поумолчанию:

Const 
  DefMsgNorm = 'MyApp version 1.0'; 
  DefMsgIcon = 'MyApp. (Use F12 to turn of)'; 

И добавить две глобальных переменных:

Var 
  ActMsgNorm : String; 
  ActMsgIcon : String; 

Затем при открытии основной формы инициализируем переменные из констант.

Procedure TFormMain.FormCreate( Sender : TObject ); 
Begin 
  ActMsgNorm := DefMsgNorm; 
  ActMsgIcon := DefMsgIcon; 
  Application.Title := ActMsgNorm; 
End; 

Затем достаточно в обработчик OnResize добавить следующий код:

Procedure TFormMain.FormResize( Sender : TObject ); 
Begin 
  If ( FormMain.WindowState = wsMinimized ) Then 
    Application.Title := ActMsgIcon 
  Else 
    Application.Title := ActMsgNorm; 
End; 


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

Изображения и InterBase Blob-поля

Изображения и InterBase Blob-поля

dBASE и Paradox таблицы имеют в своем арсенале BLOB-поля, позволяющие хранить бинарные данные, в том числе bitmap-формат, отображаемый с помощью компонента TDBImage. В Database Desktop данный тип полей указан как Binary и Graphic (для dBASE и Paradox таблиц, соответственно). Тем не менее, процесс сохранения изображений в InterBase BLOB-полях и их использование в компонентах TDBImage не такой уж простой.

Таблицы InterBase не имеют простого типа BLOB-поля. Есть три варианта, или подтипа: тип 0, тип 1 и подтип, определенный пользователем. Типы 0 и 1 - "встроенные" типы. Тип 0 - BLOB-поля (тип по умолчанию) для хранения общих бинарных данных. Тип 1 - BLOB-поля для хранения текстовых BLOB-данных. Ни один из предопределенных типов не допускает автоматического извлечения данных изображения из BLOB-поля для его последующего отображения в компоненте TDBImage. BLOB-поля типа 0 могут использоваться для хранения данных bitmap-формата, но данные должны извлекаться и передаваться в объект типа TBitmap программным путем. Вот пример ручного извлечения данных изображения, хранящихся в BLOB-поле типа 0 (Table1BLOBField), и его показ в компоненте TImage (не предназначенным для работы с БД) :



procedureTForm1.ExtractBtnClick(Sender: TObject);
begin
  Image1.Picture.Bitmap.Assign(Table1BLOBField);
end;




Естественно, поскольку это должно делаться вручную, данный процесс менее желателен в приложении, нежели автоматическое отображение данных изображения в комбинации BDE и компонента TDBImage. Здесь происходит определение подтипа определенного пользователем BLOB-поля. При работе с данными подтип BLOB-поля учитывается, т.к. сохраненные первыми данные устанавливают тип данных для этого поля для всей таблицы целиком. Таким образом, если данные bitmap-формата оказывается первым загружаемым типом, то данный формат будет единственно возможным для данного поля. До сих пор по умолчанию тип бинарного BLOB-поля (предопределенный тип 0) позволял BDE читать и отображать данные в компоненте TDBImage без особых проблем.

Утилиты Database Desktop допускают создание бинарных BLOB-полей только типа 0 и не имеют возможности самим определять подтипы BLOB-полей. Из-за такого ограничения таблицы, подразумевающие хранение и вывод изображений, должны создаваться с помощью SQL-запросов. Обычно это делается посредством утилиты WISQL, но вполне достаточно выполнение SQL-запроса с помощью компонента TQuery. Ниже приведен SQL-запрос, создающий таблицу с определенным пользователем подтипом BLOB-поля:



CREATE TABLE WITHBMP
(
  FILENAME CHAR(12),
  BITMAP   BLOB SUB_TYPE -1
)




После создания таблицы с совместимыми BLOB-полями, для хранения данных изображения в BLOB-поле и его вывода в компоненте TDBImage используются те же самые методы, что и при работе с таблицами dBASE и Paradox.

Имеется множество способов загрузки изображений в BLOB-поле. Три самых простых метода включают в себя:

копирование данных из буфера обмена Windows в компонент TDBImage, связанный с BLOB-полем
использование метода LoadFromFile компонента TBLOBField
использование метода Assign для копирования объекта типа TBitmap в значение свойства Picture компонента TBDBImage.
Первый способ, когда происходит копирование изображения из буфера обмена, вероятно, наиболее удобен в случае, когда необходимо добавить изображение в таблицу при использовании приложения конечным пользователем. В этом случае компонент TDBImage используется в роли интерфейса между BLOB-полем таблицы и изображением, хранящимся в буфере обмена. Метод PasteFromClipboard компонента TDBImage как раз и занимается тем, что копирует изображение из буфера обмена в TDBImage. При сохранении записи изображение записывается в BLOB-поле таблицы.
Поскольку буфер обмена Windows может содержать данные различных форматов, то желательно перед вызовом метода CopyFromClipboard осуществлять проверку формата хранящихся в нем данных. Для этого необходимо создать объект TClipboard и использовать его метод HasFormat, позволяющий определить формат хранящихся в буфере данных. Имейте в виду, что для создания объекта TClipboard вам необходимо добавить модуль Clipbrd в секцию uses того модуля, в котором будет создаваться экземпляр объекта.

Вот исходный код примера, копирующий содержание буфера обмена в компонент TDBImage, если содержащиеся в буфере данные имеют формат изображения:



procedure TForm1.Button1Click(Sender: TObject);
var
  C: TClipboard;
begin
  C := TClipboard.Create;
  try
    if Clipboard.HasFormat(CF_BITMAP) then
      DBImage1.PasteFromClipboard
    else
      ShowMessage('Буфер обмена не содержит изображения!');
  finally
    C.Free;
  end;
end;





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

Этот способ использует метод LoadFromFile компонента TBLOBField, который применяется в Delphi для работы с dBASE-таблицами и двоичными Windows полями или таблицами Paradox и графическими Windows полями; в обоих случаях с помощью данного метода возможно загрузить изображение и сохранить его в таблице.

Методу LoadFromFile компонента TBLOBField необходим единственный параметр типа String: имя загружаемого файла с изображением. Значение данного параметра может быть получено при выборе файла пользователем с помощью компонента TOpenDialog и его свойства FileName.

Вот пример, демонстрирующий работу метода LoadFromFile компонента TBLOBField с именем Table1Bitmap (поле с именем Bitmap связано с таблицей TTable, имеющей имя Table1):



procedure TForm1.Button2Clicck(Sender: TObject);
begin
  Table1Bitmap.LoadFromFile(
    'c:\delphi\images\splash\16color\construc.bmp');
end;




Третий способ для копирования содержимого объекта типа TBitmap в свойство Picture компонента TDBImage использует метод Assign. Объект типа TBitmap может быть как свойством Bitmap свойства-объекта Picture компонента TImage, так и отдельного объекта TBitmap. Как и в методе, копирующем данные из буфера обмена в компонент TDBImage, данные изображения компонента TDBImage сохраняются в BLOB-поле после успешного сохранения записи.

Ниже приведен пример, использующий метод Assign. В нашем случае используется отдельный объект TBitmap. Для помещения изображения в компонент TBitmap был вызван его метод LoadFromFile.



procedure TForm1.Button3Click(Sender: TObject);
var
  B: TBitmap;
begin
  B := TBitmap.Create;
  try
    B.LoadFromFile('c:\delphi\images\splashh\16color\athena.bmp');
    DBImage1.Picture.Assign(B);
  finally
    B.Free;
  end;
end;

Взято с

Изучаем ассемблер в Delphi

Изучаем ассемблер в Delphi

Автор: Ian Hodger

Основное предназначение этой статьи, заполнить пробелы в оригинальной документации по Borland Delphi Developer, при этом весь программный код, а так же теория, полность совместимы со всеми версиями Delphi.

Основное направление статьи, это познакомиться с использованием ассемблера в Object Pascal. Однако, не будем пропускать и те аспекты программирования, которые будут требовать пояснения для конкретных примеров, приведённых в этой статье.

Использование Ассемблера в Борландовком Delphi
Перед тем, как начать, хотелось бы определиться с уровнем знаний, необходимых для нормального усвоения данного материала. Необходимо быть знакомым со встроенными средствами отладки в Delphi. Так же необходимо иметь представление о таких терминах как тип реализации (instantiation), null pointer и распределение памяти. Если в чём-то из вышеупомянутого Вы сомневаетесь, то постарайтесь быть очень внимательны и осторожны при воплощении данного материала на практике. Кроме того, будет обсуждаться только 32-битный код, так что понадобится компилятор не ниже Delphi 2.0.

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

(1) Обработка большого количества данных. Nb. В данный случай не входит ситуация, когда используется язык запроса данных.

(2) В высокоскоростных подпрограммах работы с дисплеем. Nb. Имеется ввиду использование простых процедур на чистом паскале, но никак не внешних библиотек и DirectX.

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

Что такое Ассемблер?
Надеюсь, что Все читатели этой статьи имеют как минимум поверхностное представление о работе процессора. Грубо говоря, это калькулятор с большим объёмом памяти. Память, это не более чем упорядоченная последовательнось двоичных цифр. Каждая такая цифра является байтом. Каждый байт может содержать в себе значение от 0 до 255, а так же имеет свой уникальный адрес, при помощи которого процессор находит нужные значения в памяти. Процессор так же имеет набор регистров (это можно расценить как глобальные переменные). Например eax,ebx,ecx и edx, это универсальные 32-битные регистры. Это значит, что самое большое число, которое мы можем записать в регистр eax, это 2 в степени 32 минус 1, или 4294967295.

Как мы уже выяснили, процессор манипулирует значениями регистров. Машинный код операции прибавления 10 к значению регистра eax будет выглядеть следующим образом
05/0a/00/00/00
Однако, такая запись абсолютно не читабельна и, как следствие, не пригодна при отладке программы. Так вот Ассемблер, это простое представление машинных команд в более удобном виде. Теперь давайте посмотрим, как будет выглядеть прибавление 10 к eax в ассемблерном представлении:
add eax,10 {a := a + 10}
А вот так выглядит вычитаение значения ebx из eax
sub eax,ebx {a := a - b }
Чтобы сохранить значние, можно просто поместить его в другой регистр
mov eax,ecx {a := c }
или даже лучше, сохранить значение по определённому адресу в памяти
mov [1536],eax {сохраняет значение eax по адресу 1536}
и конечно же взять его от туда
mov eax,[1536]

Однако, тут есть важный момент, про который забывать не желательно. Так как регистр 32-битный(4 байта), то его значение будет записано сразу в четыре ячейки памяти 1536, 1537, 1538 и 1539.

А теперь давайте посмотрим, как компилятор преобразует действия с переменными в машинный код. Допустим у нас есть строка
Count := 0;
Для компилятора это означает, что надо просто запомнить значение. Следовательно, компилятор генерирует код, который сохраняет значение в памяти по определённому адресу и следит, чтобы не произошло никаких накладок, и обзывает этот адрес как 'Count'. Вот как выглядит такой код

mov eax,0 
mov Count,eax 

Компилятор не может использовать строку типа

mov Count,0
из-за того, что как минимум один параметр инструкции должен являться регистром.
(см. примечание в конце *)

Если посмотреть на строку
Count := Count + 1;
то её ассемблерное представление будет выглядеть как
mov eax,Count
add eax,1
mov Count,eax
(см. примечание в конце **)
Для переменных, тип которых отличается от целого, всё усложняется. Однако, рассмотрим эту тему немного позже, а сейчас предлагаю закрепить теорию практическими примерами.

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

function Sum(X,Y:integer):integer; 
begin 
 Result := X+Y; 
end; 

А вот так будет выглядеть оперция сложения двух целых чисел на ассемблере:

function Sum(X,Y:integer):integer; 
begin 
 asm
  mov eax,X
  add eax,Y
  mov Result,eax
 end;
end;

Этот код прекрасно работает, однако он не даёт нам преимущества в скорости, а так же потерялось восприятие кода. Но не стоит огорчаться, так как те немногие знания, которые Вы почерпнули из этого материала, можно использовать с большей пользой. Допустим, нам необходимо преобразовать явные значения Red,Green, и Blue в цвета типа TColor, подходящие для использования в Delphi. Тип TColor описан как 24-битный True Colour хранящийся в формате целого числа, то есть четыре байта, старший из которых равен нулю, а далее по порядку красный, зелёный, синий.

function GetColour(Red,Green,Blue:integer):TColor; 
begin 
 asm
{ecx будет содержать значение TColor}
  mov ecx,0 
{начинаем с красной компоненты}
  mov eax,Red 
{необходимо убедиться, что красный находится в диапазоне 0<=Red<=255}
  and eax,255 
{сдвигаем значение красного в правильное положение}
  shl eax,16 
{выравниваем значение TColor}
  xor ecx,eax 
{проделываем тоже самое с зелёным}
  mov eax,Green 
  and eax,255
  shl eax,8
  xor ecx,eax
{и тоже самое с синим}
  mov eax,Blue 
  and eax,255
  xor ecx,eax
  mov Result, ecx
 end;
end; 

Заметьте, что я использовал несколько бинарных операций. Эти операции также определены непосредственно в Object Pascal.

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

Примечание * от Jin X
Чушь! Во-первых, параметры обязаны быть регистрами только в очень редких случаях (например, при чтении/записи из/в порт: out 20h,al), а во-вторых, компилятор Delphi7 генерирует именно mov Count,12345678h при использовании Count := $12345678. Но! Когда мы делаем Count := 0, то генерируется пара xor eax,eax + mov Count,eax , причём лишь в целях экономии памяти (такая запись короче в машинном представлении).

Примечание ** от Jin X
это тоже не есть правда, компилятор делает гораздо проще: inc Count

Извлечение изображения из BLOB-поля

Извлечение изображения из BLOB-поля

Извлечение изображения из BLOB-поля таблицы dBASE или Paradox -- без первой записи изображения в файл -- простейший процесс использования метода Assign для сохранения содержимого BLOB-поля в объекте, имеющим тип TBitmap. Отдельный объект TBitmap или свойство Bitmap объекта Picture, в свою очередь являющегося свойством компонента TIMage, могут служить примером совместимой цели для данной операции.

Вот пример кода, демонстрирующего использование метода Assign для копирования изображения из BLOB-поля в компонент TImage.

procedureTForm1.Button1Click(Sender: TObject);
begin
  Image1.Picture.Bitmap.Assign(Table1Bitmap);
end;

В данном примере, объект Table1Bitmap типа TBLOBField - BLOB-поле таблицы dBASE. Данный TBLOBField-объекты был создан с помощью редактора полей (Fields Editor). Если редактор полей для создания TFields для полей таблицы не используется, получить доступ к полям можно с помощью метода FieldByName или свойства Fields, оба они являются членами компонентов TTable или TQuery. В случае ссылки на BLOB-поле таблицы с помощью одного из приведенных членов, перед использованием метода Assign указатель на поле должен быть прежде приведен к типу объекта TBLOBField. Для примера:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Image1.Picture.Bitmap.Assign(TBLOBField(Table1.Fields[1]));
end;

Изображение, хранящееся в BLOB-поле, может быть скопировано непосредственно в отдельный TBitmap объект. Ниже приведен пример, демонстрирующий создание объекта TBitmap и сохранения в нем изображения из BLOB-поля.

procedure TForm1.Button2Click(Sender: TObject);
var
  B: TBitmap;
begin
  B := TBitmap.Create;
  try
    B.Assign(Table1Bitmap);
    Image1.Picture.Bitmap.Assign(B);
  finally
    B.Free;
  end;
end;

 

Взято из

Ярлыки, файловые ассоциации, расширения

Ярлыки, файловые ассоциации, расширения

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











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

Является ли шрифт шрифтом с фиксированной шириной?

Является ли шрифт шрифтом с фиксированной шириной?

procedureTConsole.FontChanged(Sender: TObject);
var
  DC: HDC;
  Save: THandle;
  Metrics: TTextMetric;
  Temp: string;
begin
  if Font.Handle <> FOldFont.Handle then
  begin
    DC := GetDC(0);
    Save := SelectObject(DC, Font.Handle);
    GetTextMetrics(DC, Metrics);
    SelectObject(DC, Save);
    ReleaseDC(0, DC);
    if not (((Metrics.tmPitchAndFamily and ff_Modern) <> 0) and
      ((Metrics.tmPitchAndFamily and $01) = 0)) then
    begin
      Temp := 'TConsole: ' + Font.Name +
        ' не является шрифтом с фиксированной шириной';
      Font.Name := FOldFont.Name; { Возвращаем предыдущие атрибуты шрифта }
      raise EInvalidFont.Create(Temp);
    end;
    SetMetrics(Metrics);
  end;
  FOldFont.Assign(Font);
  if csDesigning in ComponentState then
    InternalClrScr;
end;

Взято из

Язык программирования Дельфи

Язык программирования Дельфи

Нет, я не ошибся! Начиная с версии Delphi 7 фирма Борланд официально называет язык программирования Delphi и Kylix языком "Дельфи". В этом разделе собраны вопросы по работе с конструкциями языка Дельфи, не затрагивая конкретной реализации большинства классов VCL.

Vit

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

·
·  
·  
·  
·  
·  
·  

 

·
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  

·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·

·
·  
·  
·  
·  
·  
·  
·  
·  
·  
·

 

·
·  
·  
·  
·  
·  
·  
·  
·

 

·
·  
·  
·  
·  
·  
·  
·  
·

 

·
·  
·  
·  
·

 

·
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·

 

·
·  
·  
·  
·  
·  
·  
·  
·  

·  
·  
·  
·  

·
·

 

·

Эффект плавного перехода

эффект плавного перехода

Автор: David C. Ullrich
...существует ли для этого эффекта какой-либо алгоритм генерации изображений вместо использования кисточки?

Я был скептически настроен к механизму использования кистей, чтобы получить что-либо похожее на эффект перехода/ухода ("fade") по сравнению со стеркой ("wipe"), но вчера вечером я нашел следующее решение, которое делает невероятное - осуществляет плавный переход от одного изображения к другому:



procedureWaitAWhile(n: longint);
var
  StartTime: longint;
begin
  StartTime := timeGetTime;
  while timeGetTime < StartTime + n do
    ;
end;

procedure TForm1.Image1Click(Sender: TObject);
var
  BrushBmp, BufferBmp, Buffer2Bmp, ImageBmp, Image2Bmp: TBitmap;
  j, k, row, col: longint;
begin
  row := 0;
  col := 0;
  BrushBmp := TBitmap.Create;
  with BrushBmp do
  begin
    Monochrome := false;
    Width := 8;
    Height := 8;
  end;
  imageBmp := TBitmap.create;
  imagebmp.loadfromfile('c:\huh.bmp');
  image2bmp := TBitmap.Create;
  image2bmp.LoadFromFile('c:\whatsis.bmp');
  {При 256 цветах лучше иметь ту же самую палитру!}
  BufferBmp := TBitmap.Create;
  with BufferBmp do
  begin
    Height := 200;
    Width := 200;
    canvas.brush.bitmap := TBitmap.Create;
  end;
  Buffer2Bmp := TBitmap.Create;
  with Buffer2Bmp do
  begin
    Height := 200;
    Width := 200;
    canvas.brush.bitmap := TBitmap.Create;
  end;
  for k := 1 to 16 do
  begin
    WaitAWhile(0); {Для пентиума необходимо добавить задержку}
    for j := 0 to 3 do
    begin
      row := (row + 5) mod 8;
      col := (col + 1) mod 8;
      if row = 0 then
        col := (col + 1) mod 8;
      BrushBmp.canvas.Pixels[row, col] := clBlack;
    end;
    with BufferBmp do
    begin
      canvas.copymode := cmSrcCopy;
      canvas.brush.bitmap.free;
      canvas.brush.style := bsClear;
      canvas.brush.bitmap := TBitmap.Create;
      canvas.brush.bitmap.Assign(BrushBmp);
      canvas.Rectangle(0, 0, 200, 200);
      canvas.CopyMode := cmMergeCopy;
      canvas.copyrect(rect(0, 0, 200, 200), imageBmp.canvas,
        rect(0, 0, 200, 200));
    end;
    with Buffer2Bmp do
    begin
      canvas.copymode := cmSrcCopy;
      canvas.brush.bitmap.free;
      canvas.brush.style := bsClear;
      canvas.brush.bitmap := TBitmap.Create;
      canvas.brush.bitmap.Assign(BrushBmp);
      canvas.Rectangle(0, 0, 200, 200);
      canvas.copymode := cmSrcErase;
      canvas.copyrect(rect(0, 0, 200, 200), image2bmp.canvas,
        rect(0, 0, 200, 200));
    end;
    BufferBmp.Canvas.CopyMode := cmSrcPaint;
    BufferBmp.Canvas.Copyrect(rect(0, 0, 200, 200),
      Buffer2Bmp.Canvas, rect(0, 0, 200, 200));
    canvas.copymode := cmSrcCopy;
    canvas.copyrect(rect(0, 0, 200, 200), BufferBmp.Canvas,
      rect(0, 0, 200, 200));
  end;

  BufferBmp.canvas.brush.bitmap.free;
  Buffer2Bmp.canvas.brush.bitmap.free;
  BrushBmp.Free;
  BufferBmp.Free;
  Buffer2Bmp.Free;
  ImageBmp.Free;
  image2Bmp.Free;
end;




Комментарии: На Pentium I я реально использую 64 кисточки, изменив приведенные выше строки на следующие:



for k:= 1 to 64 do
begin
  WaitAWhile(50);
  for j:=0 to 0 do

 


При организации указанной задержки возможно получение плавного перехода.

Заполняя кисть в другом порядке, вы можете получить ряд других эффектов, но приведенная выше версия единственная, которую мне удалось получить максимально похожей на эффект перехода, но вы можете, скажем, написать:



begin
  row:=(row+1) mod 8;
  (*col:=(col+1) mod 8;*)
  if row=0 then
    col:=(col+1) mod 8;




и получить своего рода эффект перехода типа "venetian-blind wipe" (дословно - стерка венецианского хрусталя).

Вопрос: Я чуствую, что я делаю что-то неправильно, существует какая-то хитрость с кистью. Мне нужно все четыре строчки:



canvas.brush.bitmap.free;
canvas.brush.style:=bsClear;
canvas.brush.bitmap:=TBitmap.Create;
canvas.brush.bitmap.Assign(BrushBmp);




чтобы все работало правильно; но я совсем не понимаю, почему первые три строки являются обязательными, но если я их выкидываю, Assign сработывает только один раз(!?!?!). Это реально работает? Есть способ другого быстрого назначения brush.bitmaps? (В документации в качестве примера указано на Brush.Bitmap.LoadFromFile, но должно быть лучшее решение. Хорошо, допустим приведенный способ лучший, но он кажется неправильным...)

Взято с

Экспорт ADO таблиц в разные форматы

Экспорт ADO таблиц в разные форматы

{ 
Exporting ADO tables into various formats 

In this article I want to present a component I built in order to 
supply exporting features to the ADOTable component. ADO supplies 
an extended SQL syntax that allows exporting of data into various  
formats. I took into consideration the following formats: 

1)Excel 
2)Html 
3)Paradox 
4)Dbase 
5)Text 

You can see all supported output formats in the registry: 
"HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\ISAM formats" 

This is the complete source of my component } 

unit ExportADOTable; 

interface 

uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  Db, ADODB; 

type 
  TExportADOTable = class(TADOTable) 
  private 
    { Private declarations } 
    //TADOCommand component used to execute the SQL exporting commands 
    FADOCommand: TADOCommand; 
  protected 
    { Protected declarations } 
  public 
    { Public declarations } 
    constructor Create(AOwner: TComponent); override; 

    //Export procedures 
    //"FiledNames" is a comma separated list of the names of the fields you want to export 
    //"FileName" is the name of the output file (including the complete path) 
    //if the dataset is filtered (Filtered = true and Filter <> ''), then I append  
    //the filter string to the sql command in the "where" directive 
    //if the dataset is sorted (Sort <> '') then I append the sort string to the sql command in the  
    //"order by" directive 
    
    procedure ExportToExcel(FieldNames: string; FileName: string; 
      SheetName: string; IsamFormat: string); 
    procedure ExportToHtml(FieldNames: string; FileName: string); 
    procedure ExportToParadox(FieldNames: string; FileName: string; IsamFormat: string); 
    procedure ExportToDbase(FieldNames: string; FileName: string; IsamFormat: string); 
    procedure ExportToTxt(FieldNames: string; FileName: string); 
  published 
    { Published declarations } 
  end; 

procedure Register; 

implementation 

procedure Register; 
begin 
  RegisterComponents('Carlo Pasolini', [TExportADOTable]); 
end; 

constructor TExportADOTable.Create(AOwner: TComponent); 
begin 
  inherited; 

  FADOCommand := TADOCommand.Create(Self); 
end; 


procedure TExportADOTable.ExportToExcel(FieldNames: string; FileName: string; 
  SheetName: string; IsamFormat: string); 
begin 
  {IsamFormat values 
   Excel 3.0 
   Excel 4.0 
   Excel 5.0 
   Excel 8.0 
  } 

  if not Active then 
    Exit; 
  FADOCommand.Connection  := Connection;   
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' + 
    SheetName + ']' + ' IN ' + '"' + FileName + '"' + '[' + IsamFormat + 
    ';]' + ' From ' + TableName; 
  if Filtered and (Filter <> '') then 
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter; 
  if (Sort <> '') then 
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort; 
  FADOCommand.Execute; 
end; 

procedure TExportADOTable.ExportToHtml(FieldNames: string; FileName: string); 
var 
  IsamFormat: string; 
begin 
  if not Active then 
    Exit; 

  IsamFormat := 'HTML Export'; 

  FADOCommand.Connection  := Connection; 
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' + 
    ExtractFileName(FileName) + ']' +  
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat + 
    ';]' + ' From ' + TableName; 
  if Filtered and (Filter <> '') then 
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter; 
  if (Sort <> '') then 
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort; 
  FADOCommand.Execute; 
end; 


procedure TExportADOTable.ExportToParadox(FieldNames: string; 
  FileName: string; IsamFormat: string); 
begin 
  {IsamFormat values 
  Paradox 3.X 
  Paradox 4.X 
  Paradox 5.X 
  Paradox 7.X 
  } 
  if not Active then 
    Exit; 

  FADOCommand.Connection  := Connection; 
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' + 
    ExtractFileName(FileName) + ']' +  
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat + 
    ';]' + ' From ' + TableName; 
  if Filtered and (Filter <> '') then 
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter; 
  if (Sort <> '') then 
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort; 
  FADOCommand.Execute; 
end; 

procedure TExportADOTable.ExportToDbase(FieldNames: string; FileName: string; 
  IsamFormat: string); 
begin 
  {IsamFormat values 
  dBase III 
  dBase IV 
  dBase 5.0 
  } 
  if not Active then 
    Exit; 

  FADOCommand.Connection  := Connection; 
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' + 
    ExtractFileName(FileName) + ']' +  
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat + 
    ';]' + ' From ' + TableName; 
  if Filtered and (Filter <> '') then 
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter; 
  if (Sort <> '') then 
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort; 
  FADOCommand.Execute; 
end; 

procedure TExportADOTable.ExportToTxt(FieldNames: string; FileName: string); 
var 
  IsamFormat: string; 
begin 
  if not Active then 
    Exit; 

  IsamFormat := 'Text'; 

  FADOCommand.Connection  := Connection; 
  FADOCommand.CommandText := 'Select ' + FieldNames + ' INTO ' + '[' + 
    ExtractFileName(FileName) + ']' +  
    ' IN ' + '"' + ExtractFilePath(FileName) + '"' + '[' + IsamFormat + 
    ';]' + ' From ' + TableName; 
  if Filtered and (Filter <> '') then 
    FADOCommand.CommandText := FADOCommand.CommandText + ' where ' + Filter; 
  if (Sort <> '') then 
    FADOCommand.CommandText := FADOCommand.CommandText + ' order by ' + Sort; 
  FADOCommand.Execute; 
end; 

end. 

{ 
Note that you can use an already existing database as destination but not an already existing 
table in the database itself: if you specify an already exixting table you will receive 
an error message. You might insert a verification code inside every exporting procedure of my 
component, before the execution of the sql exporting command, in order to send a request of   
deleting the already present table or aborting the exporting process. 

carlo Pasolini, Riccione(italy), e-mail: ccpasolini@libero.it 
} 

Взято с сайта

Экспорт анимированных 3D персонажей из 3D STUDIO MAX 3.0 для DELPHI и OpenGL

Экспорт анимированных 3D персонажей из 3D STUDIO MAX 3.0 для DELPHI и OpenGL

Введение

В свое время я здорово помучался, решая вопрос - каким же образом создатели игр ухитряются делать трехмерные персонажи двигающиеся в реальном времени. Я предположил, что части тела у персонажей отделены от основного тела, что позволяет независимо поворачивать и перемещать их. Знаете, в Direct3D даже есть понятие фрейма, фрейм - это основное тело, к нему прикрепляются другие тела. Когда фрейм движется, прикрепленные к нему объекты движутся вместе с ним, кроме того, прикрепленные объекты могут двигаться и самостоятельно не влияя на движение фрейма. Все это замечательно подходит для создания механических объектов и персонажей, но совершенно не годится для создания объектов живого мира. Для таких объектов характерна плавность линий и отсутствие изломов на местах стыков частей объекта. Создатели компьютерных игр замечательно решили эту проблему.

Как создается двумерная анимация? Рисуется несколько кадров движения, затем поледовательно выводятся на экран и таким образом создается иллюзия движения. То же самое происходит в современных трехмерных компьютерных играх. Создается несколько 3D моделей (сеток), характеризующих фазы движения персонажа в различные моменты времени, затем поледовательно выводятся на экран, создавая иллюзию движения. Возможно, это приводит к повышенному расходу оперативной памяти, поскольку все сетки желательно хранить в памяти, но зато значительно упрощается процесс программирования и, скорее всего, увеличивается скорость работы приложения.

Следующая проблема возникла при попытке экспорта объектов из 3D Studio Max в какой-либо открытый формат, например DXF. Нет ничего сложного в создании трехмерного персонажа с последующей его анимаций, если пользоваться 3D Studio и Character Studio, вся проблема состоит в том, как экспортировать объект чтобы потом файл с сетками объекта можно было использовать в своем приложении. Для этого требуется покадровый экспорт анимированного персонажа, то есть в итоге должен получится файл, содержащий несколько сеток объекта изображающих фазы движений объекта в различные моменты времени, или несколько файлов содержащих одну сетку соответствующую определенному кадру движения. Однако, несмотря на обилие поддерживаемых форматов файлов, 3D Studio Max не обладает возможностью покадрового экспорта трехмерных объектов. Так, напрмер, файл формата 3DS может хранить информацию о положении объекта, его повороте и масштабе, но не в состоянии сохранять деформации сетки в различных кадрах анимации, а именно это нам и нужно. Про файлы формата DXF и ASC даже говорить в данном случае смешно. Я объясню, почему нам нужно сохранять именно деформацию сетки. Дело в том, что наш объект должен состоять из единой, цельной сетки, а не из нескольких объектов, чтобы не было стыков на местах соединений конечностей с телом. Создать анимацию, так чтобы персонаж мог двигать своими конечностями, в этом случае, можно только деформируя сетку, а именно перемещая одни вершины сетки относительно других. Так, например, чтобы персонаж поднял руку нужно переместить вершины руки вверх относительно вершин тела. Теперь, я надеюсь, все понятно? Итак, оказалось, что 3DStudio не в состоянии сохранить подобную анимацию. Однако, не все так печально. Например, есть такой дополнительный модуль для 3DStudio, называется Bones Pro Max, а у него есть инструмент SnapShot, который позволяет делать снимки различных кадров движения объекта. В результате его работы у Вас на рабочем поле 3D Studio Max появляется целое стадо одинаковых трехмерных объектов в различных позах. Правду сказать, я его не нашел, да и выпущен он был уже давно еще под первую версию 3D Studio Max. Поэтому я решил идти другим путем и окунулся во внутренний язык 3D Studi Max - Max Script. Результатом моей деятельности стала простенькая утилита Meshes Export for Games and Animation (MEGA), которая позволяет делать все, о чем я сказал выше и некоторые другие полезные вещи.

Знакомство с утилитой MEGA V 1.0

Для ознакомления с этой утилитой Вам понадобится графический пакет 3D Studio Max 3.0 и, собственно, сама утилита. Она расположена в папке Utility и называется MEGA.ms. Это не исполняемый файл, а текстовый файл с набором команд для 3D Studio Max написанных на языке Max Script.

Запустите 3D Studio Max и создайте простой объект - сферу. Я полагаю, что даже те, кто никогда не видел этого графического редактора, без труда справятся с таким простым заданием.

Теперь, щелкайте на сфере правoй кнопкой мыши пока не появится контекстное меню. Как правило, с первого раза оно не появляется. В контекстном меню выберите строку Convert to Editable Mesh (Преобразовать в Редактируемую Сетку). Обратите внимание: объект, непременно, должен быть Редактируемой Сеткой, если в выходном файле мы хотим получить список вершин и граней, иначе мы получим имя объекта и его свойства, такие как, радиус, количество сегментов - для сферы, высоту, ширину и глубину - для параллелепипеда и т.д.

Перейдите на командную панель (она расположена справа) и выберите вкладку с изображением молотка. Это вкладка утилит. Нажмите кнопку MAXScript, внизу панели развернется свиток MAXScript'a. Нажмите кнопку Запуск Макроса, появится диалоговое окно открытия файла. Запустите файл MEGA.ms. Внизу командной панели в списке утилит должна появится надпись MEGA, однако это еще не означает, что утилита уже запущена. Чтобы ее запустить, необходимо раскрыть спиок утилит и выделить строку MEGA. Внизу панели должен раскрыться свиток MEGA.

Введите в поле From зачение 1, в поле To - 100, в поле Step - 100. Нажмите кнопку Save As..., в диалоговом окне введите имя файла, куда бдете сохранять и нажмите кнопку сохранить. Объект экспортирован в файл с расширением GMS.

Как работает утилита: При экспорте файла, берется значение из поля From и ползунок счетчика кадров расположенный внизу экрана премещается на позицию, соответствующую этому значению. Затем в выходной файл экспортируется объект в том виде, в каком он пребывает на данный момент на экране. После чего снова передвигается ползунок кадров на величину, введенную в поле Step. Снова записывается модель соответствующая этому кадру. И так до тех пор, пока ползунок не переместится на позицию соответствующую значению, введенному в поле To. Поскольку в данном примере мы не создавали анимацию, то нам нужен был только один кадр. Утилита экспортировала кадр №1, затем добавила к нему значение 100. Номер кадра стал равен 101. Поскольку это значение больше значения введенного в поле To, процесс экспорта на этом остановился. Если бы в поле From было введено значение 0, то было бы экспортировано 2 кадра с номерами 0 и 100 соответственно. Если пометить галочкой опцию Selected Only, то экспортироваться будут только выделенные объекты, это иногда бывает очень нужно, в противном случае будут экспортированы все объекты сцены. Теперь рекомендую рассмотреть формат файла GMS.

Формат файла GMS

Файл GMS это текстовый файл открытого формата, что означает, что даже человек не знакомый с его описанием может создать приложение, считывающее из него информацию. Тем не менее, приведу на всякий случай описание этого файла.



// Указывает на начало нового объекта,
// следующая строка указывает тип объекта
New object
TriMesh() // Объект - сетка
// Указывает, что следующая строка содержит количество
// вершин и граней для данного объекта
numverts numfaces
Mesh vertices:
// Здесь располагается блок вершин объекта в виде координат X Y Z
end vertices

Mesh faces:
// Здесь располагается блок граней объекта в виде индексов 1 2 3,
// где каждый индекс - индекс в массиве вершин, указывает на вершину грани
end faces

Faset normals:
// Здесь располагается блок фасетных нормалей в виде координат X Y Z.
// Их количество равно количеству граней
end faset normals

Smooth normals:
// Здесь располагается блок сглаживающих нормалей в виде координат X Y Z.
// Их количество равно количеству вершин.
end smooth normals

end mesh // Конец описания объекта Tri Mesh
end of file // Конец файла




Примерно так выглядит файл, когда мы экспортируем сетчатый объект. Если объект не сетчатый, то файл будет выглядеть следующим образом:



// Указывает на начало нового объекта,
// следующая строка указывает тип объекта
New object
<Тип объекта>, например: Box

// Здесь идут параметры, зависящие от типа объекта
// (Поверхности Безье и NURBS - поверхности не поддерживаются)

end <Тип объекта> // Конец описания объекта
end of file // Конец файла




Загрузка файла формата GMS в Delphi

Пример загрузки файла GMS находится в папке Ch01. В проекте присутствует два модуля: frmMain.pas и Mesh.pas. Откомпилировав и запустив проект на выполнение вы должны увидеть вращающийся Тор (по-нашему: "Баранка"). Несмотря на то, что объект можно считать стандартным, он был в 3D Studio преобразован в сетку, поэтому в данном случае это именно сетчатый объект. Нажав пункт меню "загрузить", вы можете посмотреть любой объект из папки GMS или загрузить свою сферу, которую сделали сами, если правильно руководствовались моими инструкциями в разделе: Знакомство с утилитой MEGA V1.0. Теперь рассмотрим данный пример подробно. Почти весь код модуля frmMain.pas написан не мной. Он взят из книги "OpenGL графика в проектах Delphi" Михаила Краснова. Этот модуль выполняет инициализацию приложения и циклическую функцию отрисовки окна, поэтому подробно мы его рассматривать не будем. Если код покажется Вам непонятным, значит Вы недостаточно знакомы с OpenGL, в этом случае Вам надлежит обратится к первоисточнику (в смысле - к книге). Код модуля Mesh.pas выполняет загрузку данных из файла и отображение объектов в окне. Рассмотрим его подробнее:



//Объявление типов данных
type
  // Указатель на вершину
  PGLVertex = ^TGLVertex;
  TGLVertex = record
    // Вершина, как три значения с плавающей точкой
    x, y, z: GLFloat;
  end;
  // Указатель на вектор
  PGLVector = ^TGLVector;
  // Вектор, как массив из трех элементов с плавающей точкой
  TGLVector = array[0..2] of GLFloat;
  // Указатель на грань
  PGLFace = ^TGLFace;
  // Грань, как массив из трех целочисленных значений
  TGLFace = array[0..2] of GLInt;
  // Указатель на массив вершин
  PGLVertexArray = ^TGLVertexArray;
  // Массив вершин
  TGLVertexArray = array[Word] of TGLVertex;
  // Указатель на массив граней
  PGLFacesArray = ^TGLFacesArray;
  // Массив граней
  TGLFacesArray = array[word] of TGLFace;




Здесь требуется небольшое пояснение. Как вы заметили, грань объявлена, как массив из трех целочисленных чисел. Дело в том, что граней почти всегда больше чем вершин. Поэтому все вершины запоминаются в отдельном массиве, а грань - это три индекса в этом массиве, указывающие на вершины принадлежащие грани. Одна вершина может принадлежать нескольким граням.

Теперь рассмотрим описание объекта сетка:



TGLMesh = class
  // Массив вершин объекта - сетка
  Vertices : PGLVertexArray;
  // Массив граней
  Faces : PGLFacesArray;
  // Массив фасетных нормалей
  FasetNormals : PGLVertexArray;
  // Количество вершин
  VertexCount : Integer;
  // Количество граней
  FacesCount : Integer;
  // Коэффициент масштабирования
  fExtent : GLFloat;
  // Флаг масштабирования
  Extent : GLBoolean;
public
  // Загрузка
  procedure LoadFromFile(const FileName: string);
  // Расчет нормалей
  procedure CalcNormals;
  // Отрисовка
  procedure Draw;
  // Уничтожение с очисткой массивов
  destructor Destroy; override;
end;




Здесь пояснений практически не требуется. Можно лишь отметить, что Extent служит для того, чтобы объект загнать в размеры в пределах (-1, 1), я сделал это для того, чтобы объект любого размера не мог вылезти за пределы окна. Вообще говоря, в 3D Studio Max не сложно масштабировать объект так, чтобы координаты вершин попали в интервал (-1, 1), но на этапе создания модели думать об этом совсем не хочется.



// Загрузка файла
procedure TGLMesh.LoadFromFile;
var
  f : TextFile;
  S : string;
  i : Integer;
  Vertex : TGLVertex;
  Face : TGLFace;
  MaxVertex : GLFloat;
begin

  AssignFile(f,FileName);
  Reset(f);
  // Пропускаем строки, пока не попадется 'numverts numfaces'
  repeat
    ReadLn(f, S);
  until
    (S = 'numverts numfaces') or eof(f);

  // Читаем количество вершин и граней
  Readln(f,VertexCount,FacesCount);

  // Выделяем память для хранения сетки
  GetMem(Vertices,VertexCount*SizeOf(TGLVertex));
  GetMem(Faces,FacesCount*SizeOf(TGLFace));
  GetMem(FasetNormals,FacesCount*SizeOf(TGLVector));

  // Пропускаем строку "Mesh vertices"
  ReadLn(f, S);

  // Считываем вершины
  for i := 0 to VertexCount - 1 do
  begin
    Readln(f,Vertex.x,Vertex.y,Vertex.z);
    Vertices[i] := Vertex;
  end;

  // Пропускаем строку "end vertices"
  ReadLn(f, S);
  // Пропускаем строку "Mesh faces"
  ReadLn(f, S);

  // Считываем грани
  for i := 0 to FacesCount - 1 do
  begin
    Readln(f,Face[0],Face[1],Face[2]);
    Face[0] := Face[0] - 1;
    Face[1] := Face[1] - 1;
    Face[2] := Face[2] - 1;
    Faces[i] := Face;
  end;

  CloseFile(f);

  // Рассчитываем масштаб
  MaxVertex := 0;

  for i := 0 to VertexCount - 1 do
  begin
    MaxVertex := Max(MaxVertex,Vertices[i].x);
    MaxVertex := Max(MaxVertex,Vertices[i].y);
    MaxVertex := Max(MaxVertex,Vertices[i].z);
  end;

  fExtent := 1/MaxVertex;
  CalcNormals;
end;




Здесь могут быть непонятны следующие моменты: В блоке считывания граней я вычитаю единицу из каждого индекса вершины, считанного из файла. Делается это потому, что в программе индексы нумеруются, начиная с нуля, а в файле GMS - начиная с единицы. Процедура CalcNormals служит для расчета нормалей и взята из книги "OpenGL графика в проектах Delphi" Михаила Краснова. О том, что такое нормали и зачем они нужны я расскажу в разделах "Фасетные нормали" и "Сглаживающие нормали".



procedure TGLMesh.Draw;
var
  i : Integer;
  Face : TGLFace;
begin
  if Extent then
    glScalef(fExtent,fExtent,fExtent);

  for i := 0 to FacesCount - 1 do
  begin
    glBegin(GL_TRIANGLES);
    Face := Faces[i];
    glNormal3fv(@FasetNormals[i]);
    glVertex3fv(@Vertices[Face[0]]);
    glVertex3fv(@Vertices[Face[1]]);
    glVertex3fv(@Vertices[Face[2]]);
    glEnd;
  end;
end;




Здесь все понятно. Сначала, если установлен флаг масштабирования, устанавливается масштаб одинаковый по всем осям, затем в цикле рисуются треугольники. Перед началом рисования треугольника объявляется нормаль к нему. В качестве параметров передаются не конкретные значения, а указатели на них.



destructor TGLMesh.Destroy;
begin
  FreeMem(Vertices,VertexCount*SizeOf(TGLVertex));
  FreeMem(Faces,FacesCount*SizeOf(TGLFace));
  FreeMem(FasetNormals,FacesCount*SizeOf(TGLVector));
end;




Здесь тоже все понятно, просто освобождается память, занятая объектом. Вызовы процедур загрузки и отрисовки объекта находятся в модуле frmMain и не представляют ничего интересного.

Создание анимированного персонажа и вывод на экран

Специально для тех, кто не владеет навыками работы с 3D Studio Max и Character Studio, я создал модель бегающего человечка. Она находится в папке MAX, и файл называется BodyRun.max. Если у Вас вообще нет пакета 3D Studio Max, то файл GMS с сетками этого человечка находится в папке GMS и называется ManRun.gms.

Итак, запустите среду 3D Studio Max и создайте анимированного персонажа или загрузите его из файла BodyRun.max. Запустите утилиту MEGA, как это делалось в разделе Знакомство с утилитой MEGA V1.0. Установите значение поля From =0, значение поля To установите в кадр, на котором заканчивается анимация, в случае с файлом BodyRun.max это значение нужно установить в 11. Значение поля Step установите в еденицу. Выделите сетку персонажа.

Внимание:

убедитесь, что Вы выделили именно сетку персонажа и только ее. Пометьте флажок Selected Only. Для анимации сетки используется скелет. Он создается и подгоняется под размеры и форму тела, затем вершины сетки связываются с костями скелета. При анимации изменяются параметры положения частей скелета, а сетка лишь следует за ними. Поэтому, всегда, когда используется этот подход, в сцене помимо сетки присутствует скелет. Вот почему необходимо выделить только сетку и пометить флажок Selected Only.

После того, как Вы выполнили все операции укзанные выше, экспортируйте объект в файл GMS. В процессе экспорта Вы должны увидеть, как последовательно перемещается ползунок расположенный внизу экрана, отсчитывая кадры анимации, и как меняются кадры в проекционных окнах 3D Studio Max. Процесс экспорта завершится, когда ползунок достигнет конечного значения.

Готовый проект лежит в папке Ch02. Откомпилируйте его и запустите на выполнение. Нажатием кнопки "Анимировать" можно запускать или останавливать анимацию. Если Ваш компьютер оснащен 3D ускорителем, то лучше развернуть окно на весь экран - так медленнее. Теперь разберем исходный код программы. Он дополнился новым объектом TGLMultyMesh, который создан для загрузки и последовательной отрисовки нескольких сетчатых объектов.



TGLMultyMesh = class
    Meshes : TList;
    CurrentFrame : Integer;
    Action : Boolean;
    fExtent : GLFloat;
    Extent : Boolean;
  public
    procedure LoadFromFile(const FileName: string);
    procedure Draw;
    constructor Create;
    destructor Destroy; override;
  published
end;




Список Meshes хранит все сетки загруженные из файла. Переменная Action указывает выполняется анимация или нет, а CurrentFrame содержит номер текущего кадра анимации.



procedure TGLMultyMesh.LoadFromFile;
var
  f : TextFile;
  S : string;

  procedure ReadNextMesh;
  var
    i : Integer;
    Vertex : TGLVertex;
    Face : TGLFace;
    MaxVertex : GLFloat;
    NextMesh : TGLMesh;
  begin
    NextMesh := TGLMesh.Create;
    repeat
      ReadLn(f, S);
    until
      (S = 'numverts numfaces') or eof(f);
    // Читаем количество вершин и граней
    Readln(f,NextMesh.VertexCount,NextMesh.FacesCount);
    // Выделяем память для хранения сетки
    GetMem(NextMesh.Vertices,NextMesh.VertexCount*SizeOf(TGLVertex));
    GetMem(NextMesh.Faces,NextMesh.FacesCount*SizeOf(TGLFace));
    GetMem(NextMesh.FasetNormals,NextMesh.FacesCount*SizeOf(TGLVector));
    ReadLn(f,S); // Пропускаем строку Mesh vertices:
    // Считываем вершины
    for i := 0 to NextMesh.VertexCount - 1 do
    begin
      Readln(f,Vertex.x,Vertex.y,Vertex.z);
      NextMesh.Vertices[i] := Vertex;
    end;
    ReadLn(f,S); // Пропускаем строку end vertices
    ReadLn(f,S); // Пропускаем строку Mesh faces:
    // Считываем грани
    for i := 0 to NextMesh.FacesCount - 1 do
    begin
      Readln(f,Face[0],Face[1],Face[2]);
      Face[0] := Face[0] - 1;
      Face[1] := Face[1] - 1;
      Face[2] := Face[2] - 1;
      NextMesh.Faces[i] := Face;
    end;
    // Рассчитываем масштаб
    MaxVertex := 0;
    for i := 0 to NextMesh.VertexCount - 1 do
    begin
      MaxVertex := Max(MaxVertex,NextMesh.Vertices[i].x);
      MaxVertex := Max(MaxVertex,NextMesh.Vertices[i].y);
      MaxVertex := Max(MaxVertex,NextMesh.Vertices[i].z);
    end;
    NextMesh.fExtent := 1/MaxVertex;
    NextMesh.CalcNormals;
    Meshes.Add(NextMesh);
  end;

begin
  Meshes := TList.Create;
  AssignFile(f,FileName);
  Reset(f);
  while not Eof(f) do
  begin
    Readln(f,S);
    if S = 'New object' then
      ReadNextMesh;
  end;
  CloseFile(f);
end;




Код загрузки объекта TGLMultyMesh практически идентичен коду загрузки объекта TGLMesh. Небольшое отличие состоит в том, что объект TGLMultyMesh предполагает, что файл содержит несколько сеток. Поэтому при загрузке проиходит поиск строки "New Object", создается объект TGLMesh, который помещается в список Meshes и в него считывается информация из файла. Затем весь цикл повторяется до тех пор, пока не кончится файл. Процедуры создания, уничтожения и отрисовки объекта тоже почти не изменились:



procedure TGLMultyMesh.Draw;
begin
  if Extent then
  begin
    fExtent := TGLMesh(Meshes.Items[CurrentFrame]).fExtent;
    glScalef(fExtent,fExtent,fExtent);
  end;
  // Рисование текущего кадра
  TGLMesh(Meshes.Items[CurrentFrame]).Draw;
  // Если включена анимация увеличить значение текущего кадра
  if Action then
  begin
    inc(CurrentFrame);
    if CurrentFrame > (Meshes.Count - 1) then
      CurrentFrame := 0;
  end;
end;

constructor TGLMultyMesh.Create;
begin
  Action := False;
  CurrentFrame := 0;
end;

destructor TGLMultyMesh.Destroy;
var
  i : Integer;
begin
  for i := 0 to Meshes.Count - 1 do
    TGLMesh(Meshes.Items[i]).Destroy;
  Meshes.Free;
end;




Немного изменился и вызов функции загрузки в модуле frmMain.pas.



procedure TfrmGL.N1Click(Sender: TObject);
begin
  if OpenDialog.Execute then
  begin
    MyMesh.Destroy;
    Mymesh := TGLMultyMesh.Create;
    MyMesh.LoadFromFile( OpenDialog.FileName );
    MyMesh.Extent := true;
    // Проверяем сколько сеток загружено и возможна ли анимация
    if MyMesh.Meshes.Count <= 1 then
      N2.Enabled := False
    else
      N2.Enabled := True;
  end;
end;

// Включение анимации
procedure TfrmGL.N2Click(Sender: TObject);
begin
  MyMesh.Action := not MyMesh.Action;
  N2.Checked := not N2.Checked;
end;




Здесь все должно быть предельно ясно, не будем акцентировать на этом внимание, и так статья длиннее получается, чем я расчитывал.

Да, конечно, человечек убогий. Мало того, что он кривой, так еще и прихрамывает. Что делать, чтобы создавать красивых человечков с минимальным количеством граней нужно быть профессионалом 3D моделирования. Все же, мы еще попытаемся его улучшить.

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

Что такое нормали

Нормалью называется перпендикуляр к чему-либо. В нашем случае это перпендикуляр к грани. Хотелось бы, но, к сожалению, без нормалей никак не обойтись. Дело в том, что по нормалям расчитывается освещение объекта. Так, например, если нормаль грани направлена на источник света, то грань будет освещена максимально. Чем больше нормаль отвернется от источника света, тем менее грань будет освещена. В случае с OpenGL, если нормаль отвернется от экрана более чем на 90 градусов, мы вообще не увидим грань, она не будет отрисовываться. Если бы мы не использовали нормали, то наш объект был бы закрашен одним цветом, то есть мы бы увидели только силует объекта. Трехмерный эффект достигается окрашиванием граней объекта в разные по яркости цвета, или наложением теней, кому как больше нравится это называть. Кроме того, степень освещенности зависит также от длины вектора нормали, но, как правило, длина вектора нормали должна находится в пределах (0; 1).

Теперь я думаю, стало ясно, что такое нормали и зачем они нужны.

Загрузка фасетных нормалей из файла GMS

Что такое фасетная нормаль? Фасетная нормаль, это самая обычная нормаль к грани, а называется она так по производимому воздействию на изображаемый объект. После применения фасетных нормалей грани объекты хоть и освещены по-разному, но каждая грань освещена равномерно и соответственно закрашена одним цветом, что приводит к тому, что объект выглядит граненым. Отсюда и название. По-нашему "фасетная нормаль" это "граненая нормaль". В предыдущих примерах фасетные нормали рассчитывались по математическому алгоритму (процедура CalcNormals), но по всей видимости он иногда дает сбои. Не все то хорошо для программиста, что хорошо для математика. В результате и появляются черные треугольники там где их не должно быть.

К счастью, внутренний язык 3D Studio Max позволил мне найти фасетные нормали, которые он использовал для отображения объекта, а отображались объекты в 3D Studio Max правильно. Приложение, использующее нормали, взятые из 3D Studio Max, находится в папке Ch03. А какая при этом получается разница, Вы можете увидеть на картинках ниже:

Теперь наша баранка выглядит правильно. В процедуре загрузки сетки добавился блок считывания фасетных нормалей из файла GMS. Процедуру CalcNormals я оставил в исходном тексте, но закоментировал.



ReadLn(f, S); //Пропускаем строку "end faces"
ReadLn(f, S); // Пропускаем строку "Faset normals"

// фасетные нормали
for i := 0 to FacesCount - 1 do
begin
  Readln(f,Normal.x,Normal.y,Normal.z);
  FasetNormals[i] := Normal;
end;




Естественно, что количество фасетных нормалей равняется количеству граней.

Загрузка сглаживающих нормалей из файла GMS

Все-таки, несмотря на то, что объект теперь отображается правильно, хочется чего-то еще. Ну кому понравится граненая баранка? Или футбольный мяч такой, будто его вытесали из гранита? И, несмотря на то, что уровень детализации в данном примере не высок, можно еще улучшить внешний вид объекта. На помощь приходят сглаживающие нормали. Об этом стоит рассказать подробнее.

Когда я понял, что, используя команду glShadeModel, мне не удастся сгладить мой объект (и у Вас не получится тоже), я затосковал. Нужно было что-то делать, и я решил заняться этим вопросом вплотную. Вот что мне удалось выяснить. Оказывается к одной грани можно построить не одну нормаль, а столько, сколько душа пожелает. Но это еще ничего не дает. А вот если мы нормаль отклоним в сторону, так что она станет, не перпендикулярна грани, то грань окрасится неравномерно. Конечно, слова о том, что "нормаль не перпендикулярна", могут показаться немного странными для математика, но программиста это смущать не должно :). Я попробую пояснить подробнее, что же получается в этом случае.

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

Это можно применять следующим образом. Чтобы добиться эффекта сглаживания, строить нормали нужно к вершинам грани, на каждую вершину по одной нормали. Для построения нормали, необходимо узнать к каким граням принадлежит вершина (теоретически вершина может принадлежать бесконечному числу граней - на практике не больше 12), взять фасетные нормали от этих граней, расчитать от них среднюю нормаль и построить ее к вершине. Как это сделать? Какими формулами это считается? Честно говоря, я понятия не имею. Есть такой сайт: http://www.pobox.com/~nate Ната Робинсона, там лежит пример на сглаживание и не только. Правда, написан он на Сях. Мне бы не составило труда переписать его на Дельфи, но... Зачем утруждать себя, если есть Баунти? Снова берем 3D Studio Max, лезем внутрь, хватаем сглаживающие нормали и... Вуаля!

Проект находится в папке Ch04. Скомпилируйте его и запустите на выполнение. Теперь Вы можете наслаждаться внешним видом сглаженного бублика нажав на кнопку Фасеты/Сгладить. Выглядит это примерно так:

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



ReadLn(f,S); // Пропускаем строку end faset normals
ReadLn(f,S); // Пропускаем строку SmoothNormals:

// Считываем сглаживающие нормали
for i := 0 to NextMesh.VertexCount - 1 do
begin
  Readln(f,Normal.x,Normal.y,Normal.z);
  NextMesh.SmoothNormals[i] := Normal;
end;




Процедура отрисовки претерпела "существенные" изменения:



procedure TGLMesh.Draw(Smooth: Boolean);
var
  i : Integer;
  Face : TGLFace;
begin
  for i := 0 to FacesCount - 1 do
  begin
    glBegin(GL_TRIANGLES);
    Face := Faces[i];
    if Smooth then
    begin
      // Если сглаживать тогда перед каждой
      glNormal3fv(@SmoothNormals[Face[0]]);
      // вершиной рисуем сглаживающую нормаль
      glVertex3fv(@Vertices[Face[0]]);
      glNormal3fv(@SmoothNormals[Face[1]]);
      glVertex3fv(@Vertices[Face[1]]);
      glNormal3fv(@SmoothNormals[Face[2]]);
      glVertex3fv(@Vertices[Face[2]]);
    end
    else
    // Если не сглаживать один раз рисуем фасетную нормаль
    begin
      glNormal3fv(@FasetNormals[i]);
      glVertex3fv(@Vertices[Face[0]]);
      glVertex3fv(@Vertices[Face[1]]);
      glVertex3fv(@Vertices[Face[2]]);
    end;
    glEnd;
  end;
end;

procedure TGLMultyMesh.Draw;
begin
  if Extent then
  begin
    fExtent := TGLMesh(Meshes.Items[CurrentFrame]).fExtent;
    glScalef(fExtent,fExtent,fExtent);
  end;
  TGLMesh(Meshes.Items[CurrentFrame]).Draw(fSmooth);
  if Action then
  begin
    inc(CurrentFrame);
    if CurrentFrame > (Meshes.Count - 1) then
      CurrentFrame := 0;
  end;
end;




Сам объект TGLMesh дополнился массивом для сглаживающих нормалей, а TGLMultyMesh - флагом указывающим следует ли сглаживать или нет. Этот флаг передается в процедуру отрисовки объекта TGLMesh. Деструктор пополнился строкой уничтожающей массив сглаживающих нормалей. В модуле frmMain появился обработчик нажатия пункта меню Фасеты/Сгладить.

Вот, пожалуй, и все. Могу только добавить, что не всегда удобно пользоваться сглаживающими нормалями из файла GMS, хотя в большинстве случаев они подходят. Загрузите, к примеру, объект Zban.gms и установите сглаживающий режим. Видите, все сглажено, а в 3D Studio Max он выглядел по-другому. Сверху и снизу у него были полукруглые крышки, но посередине был четкий цилиндр, с резкой границей в местах состыковки с полукруглыми крышками. Это побочный эффект сглаживания. Если Вы хотите добится исчезновения этого эффекта, Вам придется написать приложение для ручной корректировки нормалей, или программно отслеживать ситуацию, когда излом достиг критического угла и следует воспользоваться фасетной нормалью. Теперь, пожалуй, действительно все.

Взято с

Экспорт из TDBGrid в Excel без OLE

Экспорт из TDBGrid в Excel без OLE

{ 
  Exporting a DBGrid to excel without OLE 

  I develop software and about 95% of my work deals with databases. 
  I enjoied the advantages of using Microsoft Excel in my projects 
  in order to make reports but recently I decided to convert myself 
  to the free OpenOffice suite. 
  I faced with the problem of exporting data to Excel without having 
  Office installed on my computer. 
  The first solution was to create directly an Excel format compatible file: 
  this solution is about 50 times faster than the OLE solution but there 
  is a problem: the output file is not compatible with OpenOffice. 
  I wanted a solution which was compatible with each "DataSet"; 
  at the same time I wanted to export only the dataset data present in 
  a DBGrid and not all the "DataSet". 
  Finally I obtained this solution which satisfied my requirements. 
  I hope that it will be usefull for you too. 

  First of all you must import the ADOX type library 
  which will be used to create the Excel file and its 
  internal structure: in the Delphi IDE: 

  1)Project->Import Type Library: 
  2)Select "Microsoft ADO Ext. for DDL and Security" 
  3)Uncheck "Generate component wrapper" at the bottom 
  4)Rename the class names (TTable, TColumn, TIndex, TKey, TGroup, TUser, TCatalog) in 
    (TXTable, TXColumn, TXIndex, TXKey, TXGroup, TXUser, TXCatalog) 
    in order to avoid conflicts with the already present TTable component. 
  5)Select the Unit dir name and press "Create Unit". 
    It will be created a file named AOX_TLB. 
    Include ADOX_TLB in the "uses" directive inside the file in which you want 
    to use ADOX functionality. 

  That is all. Let's go now with the implementation: 
} 

unit DBGridExportToExcel; 

interface 

uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  ExtCtrls, StdCtrls, ComCtrls, DB, IniFiles, Buttons, dbgrids, ADOX_TLB, ADODB; 


type TScrollEvents = class 
       BeforeScroll_Event: TDataSetNotifyEvent; 
       AfterScroll_Event: TDataSetNotifyEvent; 
       AutoCalcFields_Property: Boolean; 
  end; 

procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents); 
procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents); 
procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string); 


implementation 

//Support procedures: I made that in order to increase speed in 
//the process of scanning large amounts 
//of records in a dataset 

//we make a call to the "DisableControls" procedure and then disable the "BeforeScroll" and 
//"AfterScroll" events and the "AutoCalcFields" property. 
procedure DisableDependencies(DataSet: TDataSet; var ScrollEvents: TScrollEvents);
begin
  with DataSet do
    begin
      DisableControls;
      ScrollEvents := TScrollEvents.Create();
      with ScrollEvents do
        begin
          BeforeScroll_Event := BeforeScroll;
          AfterScroll_Event := AfterScroll;
          AutoCalcFields_Property := AutoCalcFields;
          BeforeScroll := nil;
          AfterScroll := nil;
          AutoCalcFields := False;
        end;
    end;
end;

//we make a call to the "EnableControls" procedure and then restore
// the "BeforeScroll" and "AfterScroll" events and the "AutoCalcFields" property.

procedure EnableDependencies(DataSet: TDataSet; ScrollEvents: TScrollEvents);
begin
  with DataSet do
    begin
      EnableControls;
      with ScrollEvents do
        begin
          BeforeScroll := BeforeScroll_Event;
          AfterScroll := AfterScroll_Event;
          AutoCalcFields := AutoCalcFields_Property;
        end;
    end;
end;

//This is the procedure which make the work: 

procedure DBGridToExcelADO(DBGrid: TDBGrid; FileName: string; SheetName: string); 
var 
  cat: _Catalog; 
  tbl: _Table; 
  col: _Column; 
  i: integer; 
  ADOConnection: TADOConnection; 
  ADOQuery: TADOQuery; 
  ScrollEvents: TScrollEvents; 
  SavePlace: TBookmark; 
begin 
  // 
  //WorkBook creation (database) 
  cat := CoCatalog.Create; 
  cat._Set_ActiveConnection('Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0'); 
  //WorkSheet creation (table) 
  tbl := CoTable.Create; 
  tbl.Set_Name(SheetName); 
  //Columns creation (fields) 
  DBGrid.DataSource.DataSet.First; 
  with DBGrid.Columns do 
    begin 
      for i := 0 to Count - 1 do 
        if Items[i].Visible then 
        begin 
          col := nil; 
          col := CoColumn.Create; 
          with col do 
            begin 
              Set_Name(Items[i].Title.Caption); 
              Set_Type_(adVarWChar); 
            end; 
          //add column to table 
          tbl.Columns.Append(col, adVarWChar, 20); 
        end; 
    end; 
  //add table to database 
  cat.Tables.Append(tbl); 

  col := nil; 
  tbl := nil; 
  cat := nil; 

  //exporting 
  ADOConnection := TADOConnection.Create(nil); 
  ADOConnection.LoginPrompt := False; 
  ADOConnection.ConnectionString := 'Provider=Microsoft.Jet.OLEDB.4.0; Data Source=' + FileName + ';Extended Properties=Excel 8.0'; 
  ADOQuery := TADOQuery.Create(nil); 
  ADOQuery.Connection := ADOConnection; 
  ADOQuery.SQL.Text := 'Select * from [' + SheetName + '$]'; 
  ADOQuery.Open; 


  DisableDependencies(DBGrid.DataSource.DataSet, ScrollEvents); 
  SavePlace := DBGrid.DataSource.DataSet.GetBookmark; 
  try 
  with DBGrid.DataSource.DataSet do 
    begin 
      First; 
      while not Eof do 
        begin 
          ADOQuery.Append; 
          with DBGrid.Columns do 
            begin 
              ADOQuery.Edit; 
              for i := 0 to Count - 1 do 
                if Items[i].Visible then 
                  begin 
                    ADOQuery.FieldByName(Items[i].Title.Caption).AsString := FieldByName(Items[i].FieldName).AsString; 
                  end; 
              ADOQuery.Post; 
            end; 
          Next; 
        end; 
    end; 

  finally 
  DBGrid.DataSource.DataSet.GotoBookmark(SavePlace); 
  DBGrid.DataSource.DataSet.FreeBookmark(SavePlace); 
  EnableDependencies(DBGrid.DataSource.DataSet, ScrollEvents); 

  ADOQuery.Close; 
  ADOConnection.Close; 

  ADOQuery.Free; 
  ADOConnection.Free; 

  end; 

end; 

end. 


Взято с сайта

Элемент управления Edit, реагирующий на событие OnTimer.

Элемент управления Edit, реагирующий на событие OnTimer.

Как-то раз встала такая проблема: если пользователь какое-то время ничего не вводит в элемент управления Edit, то предупредить его об этом.

unit EditOnTime; 

interface 

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

type 
TEditOnTime = class(TEdit) 
private 
  FInterval: integer; 
  FTimer: TTimer; 
  FOnTimer: TNotifyEvent; 
  procedure SetInterval(Interval: integer); 
  procedure Timer(Sender: TObject); 
protected 
  procedure KeyPress(var Key: char); override; 
public 
  constructor Create(AOwner: TComponent); override; 
  destructor Destroy; override; 
published 
  property Interval: integer read FInterval write SetInterval default 750; 
property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;   
end; 

procedure Register; 

implementation 

//******************* RegisterComponent 
// Здесь мы регистрируем компонент в IDE 
procedure Register; 
begin 
RegisterComponents('MPS', [TEditOnTime]);   
end; 

//******************* TEditOnTime.SetInterval 
// устанавливаем интервал таймера 
procedure TEditOnTime.SetInterval(Interval: integer); 
begin 
FInterval := Interval;   
if Assigned(FTimer) then   
  FTimer.Interval := FInterval;   
end; 

//******************* TEditOnTime.Create 
constructor TEditOnTime.Create(AOwner: TComponent); 
begin 
FInterval := 750;   
inherited Create(AOwner);   
if not (csDesigning in ComponentState) then   
  try   
   FTimer := TTimer.Create(self);   
   FTimer.Enabled := false;   
   FTimer.Interval := FInterval;   
   FTimer.OnTimer := Timer;   
  except   
   FreeAndNil(FTimer);   
  end;   
end; 

//******************* TEditOnTime.Destroy 
destructor TEditOnTime.Destroy; 
begin 
if Assigned(FTimer) then FreeAndNil(FTimer);   
inherited Destroy;   
end; 

//******************* TEditOnTime.OnTimer 
procedure TEditOnTime.Timer(Sender: TObject); 
begin 
FTimer.Enabled := false;   
if Assigned(FOnTimer) then FOnTimer(self);   
end; 

//******************* TEditOnTime.KeyPress 
procedure TEditOnTime.KeyPress(var Key: char); 
begin 
FTimer.Enabled := false;   
inherited KeyPress(Key);   
FTimer.Enabled := (Text <> '') and Assigned(FTimer) and Assigned(FOnTimer);   
end; 

end.

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

Элементы спектрального анализа (Фурье, Хартман etc.)

Элементы спектрального анализа (Фурье, Хартман etc.)

{$A+,B-,C+,D+,E-,F-,G+,H+,I+,J+,K-,L+,M-,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}
{$MINSTACKSIZE$00004000}
{$MAXSTACKSIZE $00100000}
{$IMAGEBASE $00400000}
{$APPTYPE GUI}

unit Main;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, ExtCtrls, ComCtrls, Menus;

type

  TfmMain = class(TForm)
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    StatusBar1: TStatusBar;
    N3: TMenuItem;
    imgInfo: TImage;
    Panel1: TPanel;
    btnStart: TSpeedButton;
    procedure btnStartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  end;

var

  fmMain: TfmMain;

implementation

uses PFiles;

{$R *.DFM}

function Power2(lPower: Byte): LongInt;

begin
  Result := 1 shl lPower;
end;

procedure ClassicDirect(var aSignal, aSpR, aSpI: array of Double; N:
  LongInt);

var lSrch: LongInt;
var lGarm: LongInt;
var dSumR: Double;
var dSumI: Double;
begin
  for lGarm := 0 to N div 2 - 1 do
    begin
      dSumR := 0;
      dSumI := 0;
      for lSrch := 0 to N - 1 do
        begin
          dSumR := dSumR + aSignal[lSrch] * Cos(lGarm * lSrch / N * 2 * PI);
          dSumI := dSumI + aSignal[lSrch] * Sin(lGarm * lSrch / N * 2 * PI);
        end;
      aSpR[lGarm] := dSumR;
      aSpI[lGarm] := dSumI;
    end;
end;

procedure ClassicInverce(var aSpR, aSpI, aSignal: array of Double; N:
  LongInt);

var lSrch: LongInt;
var lGarm: LongInt;
var dSum: Double;
begin
  for lSrch := 0 to N - 1 do
    begin
      dSum := 0;
      for lGarm := 0 to N div 2 - 1 do
        dSum := dSum
          + aSpR[lGarm] * Cos(lSrch * lGarm * 2 * Pi / N)
          + aSpI[lGarm] * Sin(lSrch * lGarm * 2 * Pi / N);
      aSignal[lSrch] := dSum * 2;
    end;
end;

function InvertBits(BF, DataSize, Power: Word): Word;

var BR: Word;
var NN: Word;
var L: Word;
begin
  br := 0;
  nn := DataSize;
  for l := 1 to Power do
    begin
      NN := NN div 2;
      if (BF >= NN) then
        begin
          BR := BR + Power2(l - 1);
          BF := BF - NN
        end;
    end;
  InvertBits := BR;
end;

procedure FourierDirect(var RealData, VirtData, ResultR, ResultV: array of
  Double; DataSize: LongInt);

var A1: Real;
var A2: Real;
var B1: Real;
var B2: Real;
var D2: Word;
var C2: Word;
var C1: Word;
var D1: Word;
var I: Word;
var J: Word;
var K: Word;
var Cosin: Real;
var Sinus: Real;
var wIndex: Word;
var Power: Word;
begin
  C1 := DataSize shr 1;
  C2 := 1;
  for Power := 0 to 15 //hope it will be faster then
    round(ln(DataSize) / ln(2)) do
    if Power2(Power) = DataSize then Break;
  for I := 1 to Power do
    begin
      D1 := 0;
      D2 := C1;
      for J := 1 to C2 do
        begin
          wIndex := InvertBits(D1 div C1, DataSize, Power);
          Cosin := +(Cos((2 * Pi / DataSize) * wIndex));
          Sinus := -(Sin((2 * Pi / DataSize) * wIndex));
          for K := D1 to D2 - 1 do
            begin
              A1 := RealData[K];
              A2 := VirtData[K];
              B1 := ((Cosin * RealData[K + C1] - Sinus * VirtData[K + C1]));
              B2 := ((Sinus * RealData[K + C1] + Cosin * VirtData[K + C1]));
              RealData[K] := A1 + B1;
              VirtData[K] := A2 + B2;
              RealData[K + C1] := A1 - B1;
              VirtData[K + C1] := A2 - B2;
            end;
          Inc(D1, C1 * 2);
          Inc(D2, C1 * 2);
        end;
      C1 := C1 div 2;
      C2 := C2 * 2;
    end;
  for I := 0 to DataSize div 2 - 1 do
    begin
      ResultR[I] := +RealData[InvertBits(I, DataSize, Power)];
      ResultV[I] := -VirtData[InvertBits(I, DataSize, Power)];
    end;
end;

procedure Hartley(iSize: LongInt; var aData: array of Double);

type taDouble = array[0..MaxLongInt div SizeOf(Double) - 1] of Double;
var prFI, prFN, prGI: ^taDouble;
var rCos, rSin: Double;
var rA, rB, rTemp: Double;
var rC1, rC2, rC3, rC4: Double;
var rS1, rS2, rS3, rS4: Double;
var rF0, rF1, rF2, rF3: Double;
var rG0, rG1, rG2, rG3: Double;
var iK1, iK2, iK3, iK4: LongInt;
var iSrch, iK, iKX: LongInt;
begin
  iK2 := 0;
  for iK1 := 1 to iSize - 1 do
    begin
      iK := iSize shr 1;
      repeat
        iK2 := iK2 xor iK;
        if (iK2 and iK) <> 0 then Break;
        iK := iK shr 1;
      until False;
      if iK1 > iK2 then
        begin
          rTemp := aData[iK1];
          aData[iK1] := aData[iK2];
          aData[iK2] := rTemp;
        end;
    end;
  iK := 0;
  while (1 shl iK) < iSize do
    Inc(iK);
  iK := iK and 1;
  if iK = 0 then
    begin
      prFI := @aData;
      prFN := @aData;
      prFN := @prFN[iSize];
      while Word(prFI) < Word(prFN) do
        begin
          rF1 := prFI^[0] - prFI^[1];
          rF0 := prFI^[0] + prFI^[1];
          rF3 := prFI^[2] - prFI^[3];
          rF2 := prFI^[2] + prFI^[3];
          prFI^[2] := rF0 - rF2;
          prFI^[0] := rF0 + rF2;
          prFI^[3] := rF1 - rF3;
          prFI^[1] := rF1 + rF3;
          prFI := @prFI[4];
        end;
    end
  else
    begin
      prFI := @aData;
      prFN := @aData;
      prFN := @prFN[iSize];
      prGI := prFI;
      prGI := @prGI[1];
      while Word(prFI) < Word(prFN) do
        begin
          rC1 := prFI^[0] - prGI^[0];
          rS1 := prFI^[0] + prGI^[0];
          rC2 := prFI^[2] - prGI^[2];
          rS2 := prFI^[2] + prGI^[2];
          rC3 := prFI^[4] - prGI^[4];
          rS3 := prFI^[4] + prGI^[4];
          rC4 := prFI^[6] - prGI^[6];
          rS4 := prFI^[6] + prGI^[6];
          rF1 := rS1 - rS2;
          rF0 := rS1 + rS2;
          rG1 := rC1 - rC2;
          rG0 := rC1 + rC2;
          rF3 := rS3 - rS4;
          rF2 := rS3 + rS4;
          rG3 := Sqrt(2) * rC4;
          rG2 := Sqrt(2) * rC3;
          prFI^[4] := rF0 - rF2;
          prFI^[0] := rF0 + rF2;
          prFI^[6] := rF1 - rF3;
          prFI^[2] := rF1 + rF3;
          prGI^[4] := rG0 - rG2;
          prGI^[0] := rG0 + rG2;
          prGI^[6] := rG1 - rG3;
          prGI^[2] := rG1 + rG3;
          prFI := @prFI[8];
          prGI := @prGI[8];
        end;
    end;
  if iSize < 16 then Exit;
  repeat
    Inc(iK, 2);
    iK1 := 1 shl iK;
    iK2 := iK1 shl 1;
    iK4 := iK2 shl 1;
    iK3 := iK2 + iK1;
    iKX := iK1 shr 1;
    prFI := @aData;
    prGI := prFI;
    prGI := @prGI[iKX];
    prFN := @aData;
    prFN := @prFN[iSize];
    repeat
      rF1 := prFI^[000] - prFI^[iK1];
      rF0 := prFI^[000] + prFI^[iK1];
      rF3 := prFI^[iK2] - prFI^[iK3];
      rF2 := prFI^[iK2] + prFI^[iK3];
      prFI^[iK2] := rF0 - rF2;
      prFI^[000] := rF0 + rF2;
      prFI^[iK3] := rF1 - rF3;
      prFI^[iK1] := rF1 + rF3;
      rG1 := prGI^[0] - prGI^[iK1];
      rG0 := prGI^[0] + prGI^[iK1];
      rG3 := Sqrt(2) * prGI^[iK3];
      rG2 := Sqrt(2) * prGI^[iK2];
      prGI^[iK2] := rG0 - rG2;
      prGI^[000] := rG0 + rG2;
      prGI^[iK3] := rG1 - rG3;
      prGI^[iK1] := rG1 + rG3;
      prGI := @prGI[iK4];
      prFI := @prFI[iK4];
    until not (Word(prFI) < Word(prFN));
    rCos := Cos(Pi / 2 / Power2(iK));
    rSin := Sin(Pi / 2 / Power2(iK));
    rC1 := 1;
    rS1 := 0;
    for iSrch := 1 to iKX - 1 do
      begin
        rTemp := rC1;
        rC1 := (rTemp * rCos - rS1 * rSin);
        rS1 := (rTemp * rSin + rS1 * rCos);
        rC2 := (rC1 * rC1 - rS1 * rS1);
        rS2 := (2 * (rC1 * rS1));
        prFN := @aData;
        prFN := @prFN[iSize];
        prFI := @aData;
        prFI := @prFI[iSrch];
        prGI := @aData;
        prGI := @prGI[iK1 - iSrch];
        repeat
          rB := (rS2 * prFI^[iK1] - rC2 * prGI^[iK1]);
          rA := (rC2 * prFI^[iK1] + rS2 * prGI^[iK1]);
          rF1 := prFI^[0] - rA;
          rF0 := prFI^[0] + rA;
          rG1 := prGI^[0] - rB;
          rG0 := prGI^[0] + rB;
          rB := (rS2 * prFI^[iK3] - rC2 * prGI^[iK3]);
          rA := (rC2 * prFI^[iK3] + rS2 * prGI^[iK3]);
          rF3 := prFI^[iK2] - rA;
          rF2 := prFI^[iK2] + rA;
          rG3 := prGI^[iK2] - rB;
          rG2 := prGI^[iK2] + rB;
          rB := (rS1 * rF2 - rC1 * rG3);
          rA := (rC1 * rF2 + rS1 * rG3);
          prFI^[iK2] := rF0 - rA;
          prFI^[0] := rF0 + rA;
          prGI^[iK3] := rG1 - rB;
          prGI^[iK1] := rG1 + rB;
          rB := (rC1 * rG2 - rS1 * rF3);
          rA := (rS1 * rG2 + rC1 * rF3);
          prGI^[iK2] := rG0 - rA;
          prGI^[0] := rG0 + rA;
          prFI^[iK3] := rF1 - rB;
          prFI^[iK1] := rF1 + rB;
          prGI := @prGI[iK4];
          prFI := @prFI[iK4];
        until not (LongInt(prFI) < LongInt(prFN));
      end;
  until not (iK4 < iSize);
end;

procedure HartleyDirect(
  var aData: array of Double;

  iSize: LongInt);
var rA, rB: Double;
var iI, iJ, iK: LongInt;
begin
  Hartley(iSize, aData);
  iJ := iSize - 1;
  iK := iSize div 2;
  for iI := 1 to iK - 1 do
    begin
      rA := aData[ii];
      rB := aData[ij];
      aData[iJ] := (rA - rB) / 2;
      aData[iI] := (rA + rB) / 2;
      Dec(iJ);
    end;
end;

procedure HartleyInverce(
  var aData: array of Double;

  iSize: LongInt);

var rA, rB: Double;
var iI, iJ, iK: LongInt;
begin
  iJ := iSize - 1;
  iK := iSize div 2;
  for iI := 1 to iK - 1 do
    begin
      rA := aData[iI];
      rB := aData[iJ];
      aData[iJ] := rA - rB;
      aData[iI] := rA + rB;
      Dec(iJ);
    end;
  Hartley(iSize, aData);
end;

//not tested

procedure HartleyDirectComplex(real, imag: array of Double; n: LongInt);
var a, b, c, d: double;

  q, r, s, t: double;
  i, j, k: LongInt;
begin

  j := n - 1;
  k := n div 2;
  for i := 1 to k - 1 do
    begin
      a := real[i]; b := real[j]; q := a + b; r := a - b;
      c := imag[i]; d := imag[j]; s := c + d; t := c - d;
      real[i] := (q + t) * 0.5; real[j] := (q - t) * 0.5;
      imag[i] := (s - r) * 0.5; imag[j] := (s + r) * 0.5;
      dec(j);
    end;
  Hartley(N, Real);
  Hartley(N, Imag);
end;

//not tested

procedure HartleyInverceComplex(real, imag: array of Double; N: LongInt);
var a, b, c, d: double;

  q, r, s, t: double;
  i, j, k: longInt;
begin
  Hartley(N, real);
  Hartley(N, imag);
  j := n - 1;
  k := n div 2;
  for i := 1 to k - 1 do
    begin
      a := real[i]; b := real[j]; q := a + b; r := a - b;
      c := imag[i]; d := imag[j]; s := c + d; t := c - d;
      imag[i] := (s + r) * 0.5; imag[j] := (s - r) * 0.5;
      real[i] := (q - t) * 0.5; real[j] := (q + t) * 0.5;
      dec(j);
    end;
end;

procedure DrawSignal(var aSignal: array of Double; N, lColor: LongInt);

var lSrch: LongInt;
var lHalfHeight: LongInt;
begin
  with fmMain do
    begin
      lHalfHeight := imgInfo.Height div 2;
      imgInfo.Canvas.MoveTo(0, lHalfHeight);
      imgInfo.Canvas.Pen.Color := lColor;
      for lSrch := 0 to N - 1 do
        begin
          imgInfo.Canvas.LineTo(lSrch, Round(aSignal[lSrch]) + lHalfHeight);
        end;
      imgInfo.Repaint;
    end;
end;

procedure DrawSpector(var aSpR, aSpI: array of Double; N, lColR, lColI:
  LongInt);

var lSrch: LongInt;
var lHalfHeight: LongInt;
begin
  with fmMain do
    begin
      lHalfHeight := imgInfo.Height div 2;
      for lSrch := 0 to N div 2 do
        begin
          imgInfo.Canvas.Pixels[lSrch, Round(aSpR[lSrch] / N) + lHalfHeight] :=
            lColR;

          imgInfo.Canvas.Pixels[lSrch + N div 2, Round(aSpI[lSrch] / N) +
            lHalfHeight] := lColI;

        end;
      imgInfo.Repaint;
    end;
end;

const N = 512;
var aSignalR: array[0..N - 1] of Double; //
var aSignalI: array[0..N - 1] of Double; //
var aSpR, aSpI: array[0..N div 2 - 1] of Double; //
var lFH: LongInt;

procedure TfmMain.btnStartClick(Sender: TObject);

const Epsilon = 0.00001;
var lSrch: LongInt;
var aBuff: array[0..N - 1] of ShortInt;
begin
  if lFH > 0 then
    begin
//   Repeat

      if F.Read(lFH, @aBuff, N) <> N then
        begin
          Exit;
        end;
      for lSrch := 0 to N - 1 do
        begin
          aSignalR[lSrch] := ShortInt(aBuff[lSrch] + $80);
          aSignalI[lSrch] := 0;
        end;

      imgInfo.Canvas.Rectangle(0, 0, imgInfo.Width, imgInfo.Height);
      DrawSignal(aSignalR, N, $D0D0D0);

//    ClassicDirect(aSignalR, aSpR, aSpI, N);                 //result in aSpR & aSpI,
      aSignal unchanged
//    FourierDirect(aSignalR, aSignalI, aSpR, aSpI, N);       //result in aSpR &
      aSpI, aSiggnalR & aSignalI modified

      HartleyDirect(aSignalR, N); //result in source aSignal ;-)

      DrawSpector(aSignalR, aSignalR[N div 2 - 1], N, $80, $8000);
      DrawSpector(aSpR, aSpI, N, $80, $8000);

{    for lSrch := 0 to N div 2 -1 do begin                    //comparing classic & Hartley

if (Abs(aSpR[lSrch] - aSignal[lSrch]) > Epsilon)
or ((lSrch > 0) And (Abs(aSpI[lSrch] - aSignal[N - lSrch]) > Epsilon))
then MessageDlg('Error comparing',mtError,[mbOK],-1);
end;}

      HartleyInverce(aSignalR, N); //to restore original signal with
      HartleyDirect
//    ClassicInverce(aSpR, aSpI, aSignalR, N);                //to restore original
      signal with ClassicDirect or FourierDirect

      for lSrch := 0 to N - 1 do
        aSignalR[lSrch] := aSignalR[lSrch] / N; //scaling

      DrawSignal(aSignalR, N, $D00000);
      Application.ProcessMessages;
//   Until False;

    end;
end;

procedure TfmMain.FormCreate(Sender: TObject);

begin
  lFH := F.Open('input.pcm', ForRead);
end;

procedure TfmMain.FormClose(Sender: TObject; var Action: TCloseAction);

begin
  F.Close(lFH);
end;

end.

Denis Furman [000705

Взято из

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

Сборник Kuliba

Привожу FFT-алгоритм, позволяющий оперировать 256 точками данных примерно за 0.008 секунд на P66 (с 72MB, YMMV). Создан на Delphi.

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

Но я не думаю что алгоритм слишком плох, в нем заложено немало математических трюков. Имеется некоторое количество рекурсий, но они занимается не копированием данных, а манипуляциями с указателями, если у нас есть массив размером N = 2^d, то глубина рекурсии составит всего d. Возможно имело бы смысл применить развертывающуюся рекурсию, но не пока не ясно, поможет ли ее применение в данном алгоритме. (Но вероятно мы смогли бы достаточно легко получить надежную математическую модель, развертывая в рекурсии один или два нижних слоя, то есть проще говоря:



if Depth < 2 then
{производим какие-либо действия}




вместо текущего 'if Depth = 0 then...' Это должно устранить непродуктивные вызовы функций, что несомненно хорошо в то время, пока развертывающая рекурсия работает с ресурсами.)

Имеется поиск с применением таблиц синусов и косинусов; здесь использован метод золотой середины: данный алгоритм весьма трудоемок, но дает отличные результаты при использовании малых и средних массивов.

Вероятно в машине с большим объемом оперативной памяти следует использовать VirtualAlloc(... PAGE_NOCACHE) для Src, Dest и таблиц поиска.

Если кто-либо обнаружит неверную на ваш взгляд или просто непонятную в данном совете функцию пожалуйста сообщите мне об этом.

Что делает данная технология вкратце. Имеется несколько FFT, образующих 'комплексный FT', который понимает и о котором заботится моя технология. Это означает, что если N = 2^d, Src^ и Dest^ образуют массив из N TComplexes, происходит вызов



FFT(d, Src, Dest)




, далее заполняем Dest с применением 'комплексного FT' после того, как результат вызова Dest^[j] будет равен



1/sqrt(N) * Sum(k=0.. N - 1 ; EiT(2*Pi(j*k/N)) * Src^[k])




, где EiT(t) = cos(t) + i sin(t) . То есть, стандартное преобразование Фурье.

Публикую две версии: в первой версии я использую TComplex с функциями для работы с комплексными числами. Во второй версии все числа реальные - вместо массивов Src и Dest мы используем массивы реальных чисел SrcR, SrcI, DestR, DestI (в блоке вычислений реальных чисел), и вызовы всех функций осуществляются линейно. Первая версия достаточна легка в реализации, зато вторая - значительно быстрее. (Обе версии оперируют 'комплексными FFT'.) Технология работы была опробована на алгоритме Plancherel (также известным как Parseval). Обе версии работоспособны, btw: если это не работает у вас - значит я что-то выбросил вместе со своими глупыми коментариями :-) Итак, сложная версия:



unitcplx;

interface

type

  PReal = ^TReal;
  TReal = extended;

  PComplex = ^TComplex;
  TComplex = record
    r: TReal;
    i: TReal;
  end;

function MakeComplex(x, y: TReal): TComplex;
function Sum(x, y: TComplex): TComplex;
function Difference(x, y: TComplex): TComplex;
function Product(x, y: TComplex): TComplex;
function TimesReal(x: TComplex; y: TReal): TComplex;
function PlusReal(x: TComplex; y: TReal): TComplex;
function EiT(t: TReal): TComplex;
function ComplexToStr(x: TComplex): string;
function AbsSquared(x: TComplex): TReal;

implementation

uses SysUtils;

function MakeComplex(x, y: TReal): TComplex;
begin

  with result do
  begin
    r := x;
    i := y;
  end;
end;

function Sum(x, y: TComplex): TComplex;
begin
  with result do
  begin

    r := x.r + y.r;
    i := x.i + y.i;
  end;
end;

function Difference(x, y: TComplex): TComplex;
begin
  with result do
  begin

    r := x.r - y.r;
    i := x.i - y.i;
  end;
end;

function EiT(t: TReal): TComplex;
begin
  with result do
  begin

    r := cos(t);
    i := sin(t);
  end;
end;

function Product(x, y: TComplex): TComplex;
begin
  with result do
  begin

    r := x.r * y.r - x.i * y.i;
    i := x.r * y.i + x.i * y.r;
  end;
end;

function TimesReal(x: TComplex; y: TReal): TComplex;
begin
  with result do
  begin

    r := x.r * y;
    i := x.i * y;
  end;
end;

function PlusReal(x: TComplex; y: TReal): TComplex;
begin
  with result do
  begin

    r := x.r + y;
    i := x.i;
  end;
end;

function ComplexToStr(x: TComplex): string;
begin
  result := FloatToStr(x.r)
    + ' + '
    + FloatToStr(x.i)
    + 'i';
end;

function AbsSquared(x: TComplex): TReal;
begin
  result := x.r * x.r + x.i * x.i;
end;

end.





unit cplxfft1;

interface

uses Cplx;

type
  PScalar = ^TScalar;
  TScalar = TComplex; {Легко получаем преобразование в реальную величину}

  PScalars = ^TScalars;
  TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]
    of TScalar;

const
  TrigTableDepth: word = 0;
  TrigTable: PScalars = nil;

procedure InitTrigTable(Depth: word);

procedure FFT(Depth: word;
  Src: PScalars;
  Dest: PScalars);

{Перед вызовом Src и Dest ТРЕБУЕТСЯ распределение
(integer(1) shl Depth) * SizeOf(TScalar)
байт памяти!}

implementation

procedure DoFFT(Depth: word;
  Src: PScalars;
  SrcSpacing: word;
  Dest: PScalars);
{рекурсивная часть, вызываемая при готовности FFT}
var
  j, N: integer;
  Temp: TScalar;
  Shift: word;
begin
  if Depth = 0 then
  begin
    Dest^[0] := Src^[0];
    exit;
  end;

  N := integer(1) shl (Depth - 1);

  DoFFT(Depth - 1, Src, SrcSpacing * 2, Dest);
  DoFFT(Depth - 1, @Src^[SrcSpacing], SrcSpacing * 2, @Dest^[N]);

  Shift := TrigTableDepth - Depth;

  for j := 0 to N - 1 do
  begin
    Temp := Product(TrigTable^[j shl Shift],
      Dest^[j + N]);
    Dest^[j + N] := Difference(Dest^[j], Temp);
    Dest^[j] := Sum(Dest^[j], Temp);
  end;
end;

procedure FFT(Depth: word;
  Src: PScalars;
  Dest: PScalars);
var
  j, N: integer;
  Normalizer: extended;
begin
  N := integer(1) shl depth;
  if Depth TrigTableDepth then
    InitTrigTable(Depth);
  DoFFT(Depth, Src, 1, Dest);
  Normalizer := 1 / sqrt(N);
  for j := 0 to N - 1 do
    Dest^[j] := TimesReal(Dest^[j], Normalizer);
end;

procedure InitTrigTable(Depth: word);
var
  j, N: integer;
begin
  N := integer(1) shl depth;
  ReAllocMem(TrigTable, N * SizeOf(TScalar));
  for j := 0 to N - 1 do

    TrigTable^[j] := EiT(-(2 * Pi) * j / N);
  TrigTableDepth := Depth;
end;

initialization
  ;

finalization
  ReAllocMem(TrigTable, 0);

end.





unit DemoForm;

interface

uses

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

type

  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Edit1: TEdit;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

uses cplx, cplxfft1, MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var
  j: integer;
  s: string;

  src, dest: PScalars;
  norm: extended;
  d, N, count: integer;
  st, et: longint;
begin

  d := StrToIntDef(edit1.text, -1);
  if d < 1 then
    raise
      exception.Create('глубина рекурсии должны быть положительным целым числом');

  N := integer(1) shl d;

  GetMem(Src, N * Sizeof(TScalar));
  GetMem(Dest, N * SizeOf(TScalar));

  for j := 0 to N - 1 do
  begin
    src^[j] := MakeComplex(random, random);
  end;

  begin

    st := timeGetTime;
    FFT(d, Src, dest);
    et := timeGetTime;

  end;

  Memo1.Lines.Add('N = ' + IntToStr(N));
  Memo1.Lines.Add('норма ожидания: ' + #9 + FloatToStr(N * 2 / 3));

  norm := 0;
  for j := 0 to N - 1 do
    norm := norm + AbsSquared(src^[j]);
  Memo1.Lines.Add('Норма данных: ' + #9 + FloatToStr(norm));
  norm := 0;
  for j := 0 to N - 1 do
    norm := norm + AbsSquared(dest^[j]);
  Memo1.Lines.Add('Норма FT: ' + #9#9 + FloatToStr(norm));

  Memo1.Lines.Add('Время расчета FFT: ' + #9
    + inttostr(et - st)
    + ' мс.');
  Memo1.Lines.Add(' ');

  FreeMem(Src);
  FreeMem(DEst);
end;

end.




**** Версия для работы с реальными числами:



unit cplxfft2;

interface

type

  PScalar = ^TScalar;
  TScalar = extended;

  PScalars = ^TScalars;
  TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]
    of TScalar;

const

  TrigTableDepth: word = 0;
  CosTable: PScalars = nil;
  SinTable: PScalars = nil;

procedure InitTrigTables(Depth: word);

procedure FFT(Depth: word;

  SrcR, SrcI: PScalars;
  DestR, DestI: PScalars);

{Перед вызовом Src и Dest ТРЕБУЕТСЯ распределение

(integer(1) shl Depth) * SizeOf(TScalar)

байт памяти!}

implementation

procedure DoFFT(Depth: word;

  SrcR, SrcI: PScalars;
  SrcSpacing: word;
  DestR, DestI: PScalars);
{рекурсивная часть, вызываемая при готовности FFT}
var
  j, N: integer;

  TempR, TempI: TScalar;
  Shift: word;
  c, s: extended;
begin
  if Depth = 0 then

  begin
    DestR^[0] := SrcR^[0];
    DestI^[0] := SrcI^[0];
    exit;
  end;

  N := integer(1) shl (Depth - 1);

  DoFFT(Depth - 1, SrcR, SrcI, SrcSpacing * 2, DestR, DestI);
  DoFFT(Depth - 1,

    @SrcR^[srcSpacing],
    @SrcI^[SrcSpacing],
    SrcSpacing * 2,
    @DestR^[N],
    @DestI^[N]);

  Shift := TrigTableDepth - Depth;

  for j := 0 to N - 1 do
  begin

    c := CosTable^[j shl Shift];
    s := SinTable^[j shl Shift];

    TempR := c * DestR^[j + N] - s * DestI^[j + N];
    TempI := c * DestI^[j + N] + s * DestR^[j + N];

    DestR^[j + N] := DestR^[j] - TempR;
    DestI^[j + N] := DestI^[j] - TempI;

    DestR^[j] := DestR^[j] + TempR;
    DestI^[j] := DestI^[j] + TempI;
  end;

end;

procedure FFT(Depth: word;

  SrcR, SrcI: PScalars;
  DestR, DestI: PScalars);
var
  j, N: integer;
  Normalizer: extended;
begin

  N := integer(1) shl depth;

  if Depth TrigTableDepth then

    InitTrigTables(Depth);

  DoFFT(Depth, SrcR, SrcI, 1, DestR, DestI);

  Normalizer := 1 / sqrt(N);

  for j := 0 to N - 1 do

  begin
    DestR^[j] := DestR^[j] * Normalizer;
    DestI^[j] := DestI^[j] * Normalizer;
  end;

end;

procedure InitTrigTables(Depth: word);
var
  j, N: integer;
begin

  N := integer(1) shl depth;
  ReAllocMem(CosTable, N * SizeOf(TScalar));
  ReAllocMem(SinTable, N * SizeOf(TScalar));
  for j := 0 to N - 1 do

  begin
    CosTable^[j] := cos(-(2 * Pi) * j / N);
    SinTable^[j] := sin(-(2 * Pi) * j / N);
  end;
  TrigTableDepth := Depth;

end;

initialization

  ;

finalization

  ReAllocMem(CosTable, 0);
  ReAllocMem(SinTable, 0);

end.

 



unit demofrm;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, cplxfft2, StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Edit1: TEdit;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var

  Form1: TForm1;

implementation

{$R *.DFM}

uses MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var
  SR, SI, DR, DI: PScalars;
  j, d, N: integer;
  st, et: longint;
  norm: extended;
begin

  d := StrToIntDef(edit1.text, -1);
  if d < 1 then
    raise
      exception.Create('глубина рекурсии должны быть положительным целым числом');

  N := integer(1) shl d;

  GetMem(SR, N * SizeOf(TScalar));
  GetMem(SI, N * SizeOf(TScalar));
  GetMem(DR, N * SizeOf(TScalar));
  GetMem(DI, N * SizeOf(TScalar));

  for j := 0 to N - 1 do
  begin

    SR^[j] := random;
    SI^[j] := random;
  end;

  st := timeGetTime;
  FFT(d, SR, SI, DR, DI);

  et := timeGetTime;

  memo1.Lines.Add('N = ' + inttostr(N));
  memo1.Lines.Add('норма ожидания: ' + #9 + FloatToStr(N * 2 / 3));

  norm := 0;
  for j := 0 to N - 1 do

    norm := norm + SR^[j] * SR^[j] + SI^[j] * SI^[j];
  memo1.Lines.Add('норма данных: ' + #9 + FloatToStr(norm));

  norm := 0;
  for j := 0 to N - 1 do

    norm := norm + DR^[j] * DR^[j] + DI^[j] * DI^[j];
  memo1.Lines.Add('норма FT: ' + #9#9 + FloatToStr(norm));

  memo1.Lines.Add('Время расчета FFT: ' + #9 + inttostr(et - st));
  memo1.Lines.add('');
  (*for j:=0 to N - 1 do

  Memo1.Lines.Add(FloatToStr(SR^[j])
  + ' + '
  + FloatToStr(SI^[j])
  + 'i');

  for j:=0 to N - 1 do

  Memo1.Lines.Add(FloatToStr(DR^[j])
  + ' + '
  + FloatToStr(DI^[j])
  + 'i');*)

  FreeMem(SR, N * SizeOf(TScalar));
  FreeMem(SI, N * SizeOf(TScalar));
  FreeMem(DR, N * SizeOf(TScalar));
  FreeMem(DI, N * SizeOf(TScalar));
end;

end.

Взято с

JPG ---> BMP

JPG ---> BMP

uses 
  JPEG; 

procedure JPEGtoBMP(const FileName: TFileName); 
var 
  jpeg: TJPEGImage; 
  bmp:  TBitmap; 
begin 
  jpeg := TJPEGImage.Create; 
  try 
    jpeg.CompressionQuality := 100; {Default Value} 
    jpeg.LoadFromFile(FileName); 
    bmp := TBitmap.Create; 
    try 
      bmp.Assign(jpeg); 
      bmp.SaveTofile(ChangeFileExt(FileName, '.bmp')); 
    finally 
      bmp.Free 
    end; 
  finally 
    jpeg.Free 
  end; 
end; 


{ 
  CompressionQuality (default 100): 
  Set a value between 1..100, depending on your need of quality and 
  image file size. 1 = Smallest file size, 100 = Best quality. 

  Mit CompressionQuality konnen Sie die Qualitat der Komprimierung fur die 
  JPEG-Grafik festlegen (Default ist 100), wenn diese gespeichert wird. 
  Eine hohere Komprimierung ergibt eine etwas schlechtere Bildqualitat, 
  dafur aber eine kleinere Datei. 
  1 = kleinste Dateigrosse, 100 = beste Qualitat 
} 

Взято с сайта

Качественно уменьшить изображение

Качественно уменьшить изображение

В Delphi изменять размеры изображения очень просто, используя CopyRect:



procedureTForm1.Button1Click(Sender: TObject);
begin
  Form1.Canvas.Font.Size := 24;
  Form1.Canvas.TextOut(0, 0, 'Text');
  Form1.Canvas.CopyRect(Bounds(0, 50, 25, 10), Form1.Canvas,
  Bounds(0, 0, 100, 40));
end;




Но этот способ не очень хорош для уменьшения не маленьких картинок ? мелкие детали сливаются. Для частичного устранения этого недостатка при уменьшении изображения в четыре раза я беру средний цвет в каждом квадратике 4X4. К чему это приводит, посмотрите сами.



procedure TForm1.Button1Click(Sender: TObject);
var
  x, y: integer;
  i, j: integer;
  r, g, b: integer;
begin
  Form1.Canvas.Font.Size := 24;
  Form1.Canvas.TextOut(0, 0, 'Text');
  for y := 0 to 10 do
  begin
    for x := 0 to 25 do
    begin
      r := 0;
      for i := 0 to 3 do
        for j := 0 to 3 do
          r := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      r := round(r / 16);
      g := 0;
      for i := 0 to 3 do
        for j := 0 to 3 do
          g := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      g := round(g / 16);
      b := 0;
      for i := 0 to 3 do
        for j := 0 to 3 do
          b := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
      b := round(b / 16);
      Form1.Canvas.Pixels[x,y+50] := RGB(r, g, b)
    end;
    Application.ProcessMessages;
  end;
end;



unit ProjetoX_Screen;

interface

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

type
  TFormScreen = class(TForm)
    ImgFundo: TImage;
    procedure FormCreate(Sender: TObject);
  public
    MyRegion : HRGN;
    function BitmapToRegion(hBmp: TBitmap; TransColor: TColor): HRGN;
  end;

var
  FormScreen: TFormScreen;

implementation

{$R *.DFM}
function TFormScreen.BitmapToRegion(hBmp: TBitmap; TransColor: TColor): HRGN;

const
  ALLOC_UNIT = 100;

var
  MemDC, DC: HDC;
  BitmapInfo: TBitmapInfo;
  hbm32, holdBmp, holdMemBmp: HBitmap;
  pbits32 : Pointer;
  bm32 : BITMAP;
  maxRects: DWORD;
  hData: HGLOBAL;
  pData: PRgnData;
  b, CR, CG, CB : Byte;
  p32: pByte;
  x, x0, y: integer;
  p: pLongInt;
  pr: PRect;
  h: HRGN;

begin
  Result := 0;
  if hBmp <> nil then
  begin
    MemDC := CreateCompatibleDC(0);
    if MemDC <> 0 then
    begin
      with BitmapInfo.bmiHeader do
      begin
        biSize          := sizeof(TBitmapInfoHeader);
        biWidth         := hBmp.Width;
        biHeight        := hBmp.Height;
        biPlanes        := 1;
        biBitCount      := 32;
        biCompression   := BI_RGB;
        biSizeImage     := 0;
        biXPelsPerMeter := 0;
        biYPelsPerMeter := 0;
        biClrUsed       := 0;
        biClrImportant  := 0;
      end;
      hbm32 := CreateDIBSection(MemDC, BitmapInfo, DIB_RGB_COLORS, pbits32,0, 0);
      if hbm32 <> 0 then
      begin
        holdMemBmp := SelectObject(MemDC, hbm32);
        GetObject(hbm32, SizeOf(bm32), @bm32);
        while (bm32.bmWidthBytes mod 4) > 0 do
          inc(bm32.bmWidthBytes);
        DC := CreateCompatibleDC(MemDC);
        holdBmp := SelectObject(DC, hBmp.Handle);
        BitBlt(MemDC, 0, 0, hBmp.Width, hBmp.Height, DC, 0, 0, SRCCOPY);
        maxRects := ALLOC_UNIT;
        hData := GlobalAlloc(GMEM_MOVEABLE, sizeof(TRgnDataHeader) +
           SizeOf(TRect) * maxRects);
        pData := GlobalLock(hData);
        pData^.rdh.dwSize := SizeOf(TRgnDataHeader);
        pData^.rdh.iType := RDH_RECTANGLES;
        pData^.rdh.nCount := 0;
        pData^.rdh.nRgnSize := 0;
        SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0);
        CR := GetRValue(ColorToRGB(TransColor));
        CG := GetGValue(ColorToRGB(TransColor));
        CB := GetBValue(ColorToRGB(TransColor));
        p32 := bm32.bmBits;
        inc(PChar(p32), (bm32.bmHeight - 1) * bm32.bmWidthBytes);
        for y := 0 to hBmp.Height-1 do
        begin
          x := -1;
          while x+1 < hBmp.Width do
          begin
            inc(x);
            x0 := x;
            p := PLongInt(p32);
            inc(PChar(p), x * SizeOf(LongInt));
            while x < hBmp.Width do
            begin
              b := GetBValue(p^);
              if (b = CR) then
              begin
                b := GetGValue(p^);
                if (b = CG) then
                begin
                  b := GetRValue(p^);
                  if (b = CB) then
                    break;
                end;
              end;
              inc(PChar(p), SizeOf(LongInt));
              inc(x);
            end;
            if x > x0 then
            begin
              if pData^.rdh.nCount >= maxRects then
              begin
                GlobalUnlock(hData);
                inc(maxRects, ALLOC_UNIT);
                hData := GlobalReAlloc(hData, SizeOf(TRgnDataHeader) +
                   SizeOf(TRect) * maxRects, GMEM_MOVEABLE);
                pData := GlobalLock(hData);
                Assert(pData <> NIL);
              end;
              pr := @pData^.Buffer[pData^.rdh.nCount * SizeOf(TRect)];
              SetRect(pr^, x0, y, x, y+1);
              if x0 < pData^.rdh.rcBound.Left then
                pData^.rdh.rcBound.Left := x0;
              if y < pData^.rdh.rcBound.Top then
                pData^.rdh.rcBound.Top := y;
              if x > pData^.rdh.rcBound.Right then
                pData^.rdh.rcBound.Left := x;
              if y+1 > pData^.rdh.rcBound.Bottom then
                pData^.rdh.rcBound.Bottom := y+1;
              inc(pData^.rdh.nCount);
              if pData^.rdh.nCount = 2000 then
              begin
                h := ExtCreateRegion(NIL, SizeOf(TRgnDataHeader) +
                   (SizeOf(TRect) * maxRects), pData^);
                Assert(h <> 0);
                if Result <> 0 then
                begin
                  CombineRgn(Result, Result, h, RGN_OR);
                  DeleteObject(h);
                end else
                  Result := h;
                pData^.rdh.nCount := 0;
                SetRect(pData^.rdh.rcBound, MaxInt, MaxInt, 0, 0);
              end;
            end;
          end;
          Dec(PChar(p32), bm32.bmWidthBytes);
        end;
        h := ExtCreateRegion(NIL, SizeOf(TRgnDataHeader) +
           (SizeOf(TRect) * maxRects), pData^);
        Assert(h <> 0);
        if Result <> 0 then
        begin
          CombineRgn(Result, Result, h, RGN_OR);
          DeleteObject(h);
        end else
          Result := h;
        GlobalFree(hData);
        SelectObject(DC, holdBmp);
        DeleteDC(DC);
        DeleteObject(SelectObject(MemDC, holdMemBmp));
      end;
    end;
    DeleteDC(MemDC);
  end;
end;

procedure TFormScreen.FormCreate(Sender: TObject);
begin
        MyRegion := BitmapToRegion(imgFundo.Picture.Bitmap,imgFundo.Canvas.Pixels[0,0]);
        SetWindowRgn(Handle,MyRegion,True);
end;





procedure TFormXXXXXX.FormCreate(Sender: TObject);
begin
        FormScreen.MyRegion := FormScreen.BitmapToRegion(imgFundo.Picture.Bitmap,
          imgFundo.Canvas.Pixels[0,0]);
        SetWindowRgn(Handle,FormScreen.MyRegion,True);
end;

Взято из

Как активизировать предыдущий экземпляр вашей программы?

Как активизировать предыдущий экземпляр вашей программы?

Если внутренняя переменная hPrevInst не равна нулю, то она содержит дескриптор предыдущего запущенного экземпляра вашей программы. Вы просто находите открытое окно по его дескриптору и, при необходимости, выводите на передний план. Весь код расположен в файле .DPR file, НЕ в модуле. Строки, которые вам необходимо добавить к вашему .DPR-файлу, в приведенном ниже примере помечены {*}.


programOnce;

uses
{*}  WinTypes, WinProcs, SysUtils,

Forms,
Onceu in 'ONCEU.PAS' {Form1};

{$R *.RES}
{*}TYPE
{*}  PHWND = ^HWnd;

{*}  FUNCTION EnumWndProc(H : hWnd; P : PHWnd) : Integer; Export;
{*}  VAR ClassName : ARRAY[0..30] OF Char;
{*}  BEGIN
{*}    {Если это окно принадлежит предшествующему экземпляру...}
{*}    IF GetWindowWord(H, GWW_HINSTANCE) = hPrevInst THEN
{*}      BEGIN
{*}        {... проверяем КАКОЕ это окно.}
{*}        GetClassName(H, ClassName, 30);
{*}        {Если это главное окно приложения...}
{*}        IF StrIComp(ClassName, 'TApplication') = 0 THEN
{*}          BEGIN
{*}            {... ищем}
{*}{*}            P^ := H;
{*}            EnumWndProc := 0;
{*}          END;
{*}      END;
{*}  END;

{*}  PROCEDURE CheckPrevInst;
{*}  VAR PrevWnd : hWnd;
{*}  BEGIN
{*}    IF hPrevInst <> 0 THEN
{*}      {Предыдущий экземпляр запущен}
{*}      BEGIN
{*}        PrevWnd := 0;
{*}        EnumWindows(@EnumWndProc, LongInt(@PrevWnd));
{*}        {Ищем дескриптор окна предыдущего}
{*}        {экземпляра и активизируем его}
{*}        IF PrevWnd <> 0 THEN
{*}          IF IsIconic(PrevWnd) THEN
{*}            ShowWindow(PrevWnd, SW_SHOWNORMAL)
{*}          ELSE BringWindowToTop(PrevWnd);
{*}        Halt;
{*}      END;
{*}  END;
begin
{*}  CheckPrevInst;

Application.Title := 'Once';
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

Взято с

Как автоматически помещать курсор мышки в центр контрола получившего фокус?

Как автоматически помещать курсор мышки в центр контрола получившего фокус?

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

Вот пример вызова нашей функции:

procedure TForm1.Button1Enter(Sender: TObject);
begin
  MoveMouseOverControl(Sender);
end;

Сама функция:

procedure MoveMouseOverControl(Sender: TObject);
var x,y: integer;
    point: TPoint;
begin
  with TControl(Sender) do
  begin
    x:= left + (width div 2);
    y:= top + (height div 2);
    point:= Parent.ClientToScreen(point);
    SetCursorPos(point.x, point.y);
  end;
end;

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

Как автоматически расширить TEdit?

Как автоматически расширить TEdit?

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

unit ExpandingEdit; 

interface 

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

type 
  TExpandingEdit = class(TEdit) 
  private 
    FCanvas: TControlCanvas; 
  protected 
    procedure Change; override; 
  public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
  end; 

procedure Register; 

implementation 

constructor TExpandingEdit.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  FCanvas := TControlCanvas.Create; 
  FCanvas.Control := Self; 
end; 

destructor TExpandingEdit.Destroy; 
begin 
  FCanvas.Free; 
  inherited Destroy; 
end; 

procedure TExpandingEdit.Change; 
const 
  EditMargin = 8; 
var 
  W: Integer; 
begin 
  inherited Change; 
  if not HandleAllocated then Exit; 
  FCanvas.Font := Font; 
  W := FCanvas.TextWidth(Text) + (2 * EditMargin); 
  if (Width < W) then Width := W; 
end; 

procedure Register; 
begin 
  RegisterComponents('Samples', [TExpandingEdit]); 
end; 

end.

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

Как автоматически заполнить поля формы в IE?

Как автоматически заполнить поля формы в IE?

{ 
  This example shows how to automatically fill in a search string 
  in the "Search Tip" page and click the search button. 
} 

uses 
  MSHTML_TLB; 

// first navigate to tipspage 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Webbrowser1.Navigate('http://www.swissdelphicenter.ch/en/tipsuchen.php'); 
end; 

// Try to access IE instance and fill out the search field with 
// a text and click the search button 

procedure TForm1.Button3Click(Sender: TObject); 
var 
  hIE: HWND; 
  ShellWindow: IShellWindows; 
  WB: IWebbrowser2; 
  spDisp: IDispatch; 
  IDoc1: IHTMLDocument2; 
  Document: Variant; 
  k, m: Integer; 
  ovElements: OleVariant; 
  i: Integer; 
begin 
  ShellWindow := CoShellWindows.Create; 
  // get the running instance of Internet Explorer 
  for k := 0 to ShellWindow.Count do 
  begin 
    spDisp := ShellWindow.Item(k); 
    if spDisp = nil then Continue; 
    // QueryInterface determines if an interface can be used with an object 
    spDisp.QueryInterface(iWebBrowser2, WB); 

    if WB <> nil then 
    begin 
      WB.Document.QueryInterface(IHTMLDocument2, iDoc1); 
      if iDoc1 <> nil then 
      begin 
        WB := ShellWindow.Item(k) as IWebbrowser2; 
        begin 
          Document := WB.Document; 

          // count forms on document and iterate through its forms 
          for m := 0 to Document.forms.Length - 1 do 
          begin 
            ovElements := Document.forms.Item(m).elements; 
            // iterate through elements 
            for i := 0 to ovElements.Length - 1 do 
            begin 
              // when input fieldname is found, try to fill out 
              try 
                if (CompareText(ovElements.item(i).tagName, 'INPUT') = 0) and 
                  (CompareText(ovElements.item(i).type, 'text') = 0) then 
                begin 
                  ovElements.item(i).Value := 'FindWindow'; 
                end; 
              except 
              end; 
              // when Submit button is found, try to click 
              try 
                if (CompareText(ovElements.item(i).tagName, 'INPUT') = 0) and 
                  (CompareText(ovElements.item(i).type, 'SUBMIT') = 0) and 
                  (ovElements.item(i).Value = 'Search') then  // Suchen fьr German 
                begin 
                  ovElements.item(i).Click; 
                end; 
              except 
              end; 
            end; 
          end; 
        end; 
      end; 
    end; 
  end; 
end; 

Взято с сайта

Как бы мне создать эдакий trackbar

Как бы мне создать эдакий trackbar в котором вместо широкой белой полоски с ползунком была бы тонкая линия?

В примере создается компонент, унаследованный от TTrackbar который переопределяет метод CreateParams и убират флаг TBS_ENABLESELRANGE из Style. Константа TBS_ENABLESELRANGE обьявленна в модуле CommCtrl.

uses CommCtrl, ComCtrls;

type
  TMyTrackBar = class(TTrackBar)
    procedure CreateParams(var Params: TCreateParams); override;
  end;

procedure TMyTrackBar.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := Params.Style and not TBS_ENABLESELRANGE;
end;

var
  MyTrackbar: TMyTrackbar;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyTrackBar := TMyTrackbar.Create(Form1);
  MyTrackbar.Parent := Form1;
  MyTrackbar.Left := 100;
  MyTrackbar.Top := 100;
  MyTrackbar.Width := 150;
  MyTrackbar.Height := 45;
  MyTrackBar.Visible := true;
end;

Как быстро нарисовать тень в заданном регионе?

Как быстро нарисовать тень в заданном регионе?

procedure TForm2.DrawShadows(WDepth, HDepth : Integer); 
var 
  Dst, RgnBox  : TRect; 
  hOldDC         : HDC; 
  OffScreen      : TBitmap; 
  Pattern          : TBitmap; 
  Bits               : array[0..7] of WORD; 
begin 
  Bits[0]:=$0055; 
  Bits[1]:=$00aa; 
  Bits[2]:=$0055; 
  Bits[3]:=$00aa; 
  Bits[4]:=$0055; 
  Bits[5]:=$00aa; 
  Bits[6]:=$0055; 
  Bits[7]:=$00aa; 
 
  hOldDC:=Canvas.Handle; 
  Canvas.Handle:=GetWindowDC(Form1.Handle); 
 
 
  OffsetRgn(ShadeRgn, WDepth, HDepth); 
  GetRgnBox(ShadeRgn, RgnBox); 
 
  Pattern:=TBitmap.Create; 
  Pattern.ReleaseHandle; 
  Pattern.Handle:=CreateBitmap(8, 8, 1, 1, @(Bits[0])); 
  Canvas.Brush.Bitmap:=Pattern; 
 
  OffScreen:=TBitmap.Create; 
  OffScreen.Width:=RgnBox.Right-RgnBox.Left; 
  OffScreen.Height:=RgnBox.Bottom-RgnBox.Top; 
  Dst:=Rect(0, 0, OffScreen.Width, OffScreen.Height); 
 
  OffsetRgn(ShadeRgn, 0, -RgnBox.Top); 
  FillRgn(OffScreen.Canvas.Handle, ShadeRgn, Canvas.Brush.Handle); 
 
  OffsetRgn(ShadeRgn, 0, RgnBox.Top); 
 
//  BitBlt работает быстрее CopyRect 
  BitBlt(OffScreen.Canvas.Handle, 0, 0, OffScreen.Width, OffScreen.Height, 
         Canvas.Handle, RgnBox.Left, RgnBox.Top, SRCAND); 
 
  Canvas.Brush.Color:=clBlack; 
  FillRgn(Canvas.Handle, ShadeRgn, Canvas.Brush.Handle); 
 
  BitBlt(Canvas.Handle, RgnBox.Left, RgnBox.Top, OffScreen.Width, 
   OffScreen.Height, OffScreen.Canvas.Handle, 0, 0, SRCPAINT); 
 
  OffScreen.Free; 
  Pattern.Free; 
 
  OffsetRgn(ShadeRgn, -WDepth, -HDepth); 
 
  ReleaseDC(Form1.Handle, Canvas.Handle); 
  Canvas.Handle:=hOldDC; 
end; 

Комментарии :
Функция рисует тень сложной формы на форме Form2.
Для определения формы тени используется регион ShadeRgn, который был создан где-то раньше (например в OnCreate). Относительно регионов см. Win32 API.

Титов Игорь Евгеньевич
infos@obninsk.ru

Как быстро выводить графику?

Как быстро выводить графику?

Как быстро выводить графику (a то Canvas очень медленно работает)

Вот пример заполнения формы точками случайного цвета:

type
TRGB = record
    b, g, r: byte;
  end;
  ARGB = array[0..1] of TRGB;
  PARGB = ^ARGB;

var
  b: TBitMap;

procedure TForm1.FormCreate(sender: TObject);
begin
  b := TBitMap.Create;
  b.pixelformat := pf24bit;
  b.width := Clientwidth;
  b.height := Clientheight;
end;

procedure TForm1.Tim1OnTimer(sender: TObject);
var
  p: PARGB;
  x, y: integer;
begin
  for y := 0 to b.height - 1 do
  begin
    p := b.scanline[y];
    for x := 0 to b.width - 1 do
    begin
      p[x].r := random(256);
      p[x].g := random(256);
      p[x].b := random(256);
    end;
  end;
  canvas.draw(0, 0, b);
end;

procedure TForm1.FormDestroy(sender: TObject);
begin
  b.free;
end;

Взято из

Как читать/писать в I/O порты?

Как читать/писать в I/O порты?

В Delphi 1 записывать и считывать из портов можно через глобальный массив 'ports'. Однако данная возможность отсутствует в '32-битном' Delphi.

Следующие две функции можно использовать в любой версии delphi:


function InPort(PortAddr:word): byte; 
{$IFDEF WIN32} 
assembler; stdcall; 
asm 
        mov dx,PortAddr 
        in al,dx 
end; 
{$ELSE} 
begin 
  Result := Port[PortAddr]; 
end; 
{$ENDIF} 

procedure OutPort(PortAddr:   
          word; Databyte: byte); 
{$IFDEF WIN32} 
assembler; stdcall; 
asm 
   mov al,Databyte 
   mov dx,PortAddr 
   out dx,al 
end; 
{$ELSE} 
begin 
  Port[PortAddr] := DataByte; 
end; 
{$ENDIF} 

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

Как динамически прочитать информацию о классе

Как динамически прочитать информацию о классе

procedureTForm1.FormCreate(Sender: TObject);
begin
  {This only works for classes registered using RegisterClass}
  RegisterClasses([TButton, TForm]);
end;


procedure TForm1.Button1Click(Sender: TObject);
var
  CRef: TPersistentClass;
  PTI: PTypeInfo;
  AControl: TControl;
begin
  CRef := GetClass('TButton');
  if CRef <> nil then
  begin
    AControl := TControl(TControlClass(CRef).Create(Self));
    with AControl do
    begin
      Parent := Self;
      Width := 50;
      Height := 30;
    end;
    Inc(Id);
  end
  else
    MessageDlg('No such class', mtWarning, [mbOk], 0);
end;

Взято из

Как добавить Cookies?

Как добавить Cookies?

Пример демонстрирует создание cookie посредствам стандартного компонента Delphi

procedure TwebDispatcher.WebAction(Sender: TObject; Request: TWebRequest; 
  Response: TWebResponse; var Handled: Boolean); 
begin 
    with (Response.Cookies.Add) do begin 
      Name := 'TESTNAME'; 
      Value := 'TESTVALUE'; 
      Secure := False; 
      Expires := Now; 
      Response.Cookies.WebResponse.SendResponse; 
    end; 
end; 


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

Как добавить документ в меню Пуск -> Документы?

Как добавить документ в меню Пуск -> Документы?

Используйте функцию SHAddToRecentDocs.

uses ShlOBJ;

procedure TForm1.Button1Click(Sender: TObject);
var
   s : string;
begin
   s := 'C:\DownLoad\ntkfaq.html';
   SHAddToRecentDocs(SHARD_PATH, pChar(s));
end;


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

Как добавить горизонтальную полосу прокрутки (scrollbar) в TListBox?

Как добавить горизонтальную полосу прокрутки (scrollbar) в TListBox?

В Delphi компонент TListBox автоматически включает в себя вертикальный scrollbar. Полоска прокрутки появляется в том случае, если все элементы списка не помещаются в видимую область списка. Однако, list box не показывает горизонтального скролбара, когда ширина элементов превышает ширину списка. Конечно же существует способ добавить горизонтальную полосу прокрутки.

Добавьте следующий код в событие Вашей формы OnCreate.

procedure TForm1.FormCreate(Sender: TObject); 
var 
  i, MaxWidth: integer; 
begin 
  MaxWidth := 0; 
  for i := 0 to LB1.Items.Count - 1 do 
  if MaxWidth < LB1.Canvas.TextWidth(LB1.Items.Strings[i]) then 
    MaxWidth := LB1.Canvas.TextWidth(LB1.Items.Strings[i]); 
  SendMessage(LB1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0); 
end; 

Приведённый код определяет ширину в пикселях самой длинной строки списка. Затем он использует сообщение LB_SETHORIZONTALEXTENT, чтобы установить ширину горизонтального скролбара в пикселях. Два дополнительных пикселя добавленные к MaxWidth служат для стрелки в правом углу list box-а.

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

Как добавить кнопку?

Как добавить кнопку?

type
TConnType = (COM_OBJECT, EXPLORER_BAR, SCRIPT, EXECUTABLE);

function AddBandToolbarBtn(Visible: Boolean; ConnType: TConnType;
  BtnText, HotIcon, Icon, GuidOrPath: string): string;
var
  GUID: TGUID;
  Reg: TRegistry;
  ID: string;
begin
  CreateGuid(GUID);
  ID := GuidToString(GUID);
  Reg := TRegistry.Create;
  with Reg do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('\Software\Microsoft\Internet Explorer\Extensions\'
      + ID, True);
    if Visible then
      WriteString('Default Visible', 'Yes')
    else
      WriteString('Default Visible', 'No');
    WriteString('ButtonText', BtnText);
    WriteString('HotIcon', HotIcon);
    WriteString('Icon', Icon);
    case ConnType of
      COM_OBJECT:
        begin
          WriteString('CLSID', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
          WriteString('ClsidExtension', GuidOrPath);
        end;
      EXPLORER_BAR:
        begin
          WriteString('CLSID', '{E0DD6CAB-2D10-11D2-8F1A-0000F87ABD16}');
          WriteString('BandCLSID', GuidOrPath);
        end;
      EXECUTABLE:
        begin
          WriteString('CLSID', '{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');
          WriteString('Exec', GuidOrPath);
        end;
      SCRIPT:
        begin
          writeString('CLSID', '{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');
          WriteString('Script', GuidOrPath);
        end;
    end;
    CloseKey;
    OpenKey('\Software\IE5Tools\ToolBar Buttons\', True);
    WriteString(BtnText, ID);
    CloseKey;
  finally
    Free;
  end;
  Result := ID;
end;

Взято с

Delphi Knowledge Base

Как добавить кнопку в панель инструментов IE?

Как добавить кнопку в панель инструментов IE?

1. ButtonText = Всплывающая подсказка к кнопке
2. MenuText = Текст, который будет использован для пункта в меню "Сервис"
3. MenuStatusbar = *Ignore*
4. CLSID = Ваш уникальный classID. Для создания нового CLSID (для каждой кнопки) можно использовать GUIDTOSTRING.
5. Default Visible := Показать ей.
6. Exec := Путь к Вашей программе.
7. Hoticon := иконка из shell32.dll когда мышка находится над кнопкой
8. Icon := иконка из shell32.dll

procedure CreateExplorerButton;
const
  TagID = '\{10954C80-4F0F-11d3-B17C-00C0DFE39736}\';
var
  Reg: TRegistry;
   ProgramPath: string;
  RegKeyPath: string;
begin
 ProgramPath := 'c:\folder\exename.exe';
 Reg := TRegistry.Create;
 try
  with Reg do begin
   RootKey := HKEY_LOCAL_MACHINE;
   RegKeyPath := 'Software\Microsoft\Internet Explorer\Extensions';
   OpenKey(RegKeyPath + TagID, True);
   WriteString('ButtonText', 'Your program Button text');
   WriteString('MenuText', 'Your program Menu text');
   WriteString('MenuStatusBar', 'Run Script');
   WriteString('ClSid', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
   WriteString('Default Visible', 'Yes'); 
   WriteString('Exec', ProgramPath);
   WriteString('HotIcon', ',4');
   WriteString('Icon', ',4');
  end
 finally
  Reg.CloseKey;
  Reg.Free;
 end;
end;

После выполнения этого кода достаточно просто запустить IE.

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

Как добавить когерентный шум?

Как добавить когерентный шум?

{Coherentnoise function over 1, 2 or 3 dimensions by Ken Perlin}

unit perlin;

interface

function noise1(arg: double): double;
function noise2(vec0, vec1: double): double;
function noise3(vec0, vec1, vec2: double): double;
function PNoise1(x, alpha, beta: double; n: integer): double;
function PNoise2(x, y, alpha, beta: double; n: integer): double;
function PNoise3(x, y, z, alpha, beta: double; n: integer): double;

{High Alpha: smoother intensity change, lower contrast
Low Alpha: rapid intensity change, higher contrast
High Beta: coarse, big spots
Low Beta: fine, small spots}

implementation

uses
  SysUtils;

const
  defB = $100;
  defBM = $FF;
  defN = $1000;

var
  start: boolean = true;
  p: array[0..defB + defB + 2 - 1] of integer;
  g3: array[0..defB + defB + 2 - 1, 0..2] of double;
  g2: array[0..defB + defB + 2 - 1, 0..1] of double;
  g1: array[0..defB + defB + 2 - 1] of double;

function s_curve(t: double): double;
begin
  result := t * t * (3.0 - 2.0 * t);
end;

function lerp(t, a, b: double): double;
begin
  result := a + t * (b - a);
end;

procedure setup(veci: double; var b0, b1: integer; var r0, r1: double);
var
  t: double;
begin
  t := veci + defN;
  b0 := trunc(t) and defBM;
  b1 := (b0 + 1) and defBM;
  r0 := t - int(t);
  r1 := r0 - 1.0;
end;

procedure normalize2(var v0, v1: double);
var
  s: double;
begin
  s := sqrt(v0 * v0 + v1 * v1);
  v0 := v0 / s;
  v1 := v1 / s;
end;

procedure normalize3(var v0, v1, v2: double);
var
  s: double;
begin
  s := sqrt(v0 * v0 + v1 * v1 + v2 * v2);
  v0 := v0 / s;
  v1 := v1 / s;
  v2 := v2 / s;
end;

procedure init;
var
  i, j, k: integer;
begin
  for i := 0 to defB - 1 do
  begin
    p[i] := i;
    g1[i] := (random(defB + defB) - defB) / defB;
    for j := 0 to 1 do
      g2[i, j] := (random(defB + defB) - defB) / defB;
    normalize2(g2[i, 0], g2[i, 1]);
    for j := 0 to 2 do
      g3[i, j] := (random(defB + defB) - defB) / defB;
    normalize3(g3[i, 0], g3[i, 1], g3[i, 2]);
  end;
  i := defB;
  while i > 0 do
  begin
    k := p[i];
    j := random(defB);
    p[i] := p[j];
    p[j] := k;
    dec(i);
  end;
  for i := 0 to defB + 1 do
  begin
    p[defB + i] := p[i];
    g1[defB + i] := g1[i];
    for j := 0 to 1 do
      g2[defB + i, j] := g2[i, j];
    for j := 0 to 2 do
      g3[defB + i, j] := g3[i, j];
  end;
end;

function noise1(arg: double): double;
var
  bx0, bx1: integer;
  rx0, rx1, sx, u, v: double;
begin
  if start then
  begin
    init;
    start := false;
  end;
  bx0 := trunc(arg + defN) and defBM;
  bx1 := (bx0 + 1) and defBM;
  rx0 := frac(arg + defN);
  rx1 := rx0 - 1.0;
  sx := rx0 * rx0 * (3.0 - 2.0 * rx0);
  u := rx0 * g1[p[bx0]];
  v := rx1 * g1[p[bx1]];
  result := u + sx * (v - u);
end;

function noise2(vec0, vec1: double): double;
var
  i, j, bx0, bx1, by0, by1, b00, b10, b01, b11: integer;
  rx0, rx1, ry0, ry1, sx, sy, a, b, u, v: double;
begin
  if start then
  begin
    init;
    start := false;
  end;
  bx0 := trunc(vec0 + defN) and defBM;
  bx1 := (bx0 + 1) and defBM;
  rx0 := frac(vec0 + defN);
  rx1 := rx0 - 1.0;
  by0 := trunc(vec1 + defN) and defBM;
  by1 := (by0 + 1) and defBM;
  ry0 := frac(vec1 + defN);
  ry1 := ry0 - 1.0;
  i := p[bx0];
  j := p[bx1];
  b00 := p[i + by0];
  b10 := p[j + by0];
  b01 := p[i + by1];
  b11 := p[j + by1];
  sx := rx0 * rx0 * (3.0 - 2.0 * rx0);
  sy := ry0 * ry0 * (3.0 - 2.0 * ry0);
  u := rx0 * g2[b00, 0] + ry0 * g2[b00, 1];
  v := rx1 * g2[b10, 0] + ry0 * g2[b10, 1];
  a := u + sx * (v - u);
  u := rx0 * g2[b01, 0] + ry1 * g2[b01, 1];
  v := rx1 * g2[b11, 0] + ry1 * g2[b11, 1];
  b := u + sx * (v - u);
  result := a + sy * (b - a);
end;

function noise3orig(vec0, vec1, vec2: double): double;
var
  i, j, bx0, bx1, by0, by1, bz0, bz1, b00, b10, b01, b11: integer;
  rx0, rx1, ry0, ry1, rz0, rz1, sx, sy, sz, a, b, c, d, u, v: double;
begin
  if start then
  begin
    start := false;
    init;
  end;
  setup(vec0, bx0, bx1, rx0, rx1);
  setup(vec1, by0, by1, ry0, ry1);
  setup(vec2, bz0, bz1, rz0, rz1);
  i := p[bx0];
  j := p[bx1];
  b00 := p[i + by0];
  b10 := p[j + by0];
  b01 := p[i + by1];
  b11 := p[j + by1];
  sx := s_curve(rx0);
  sy := s_curve(ry0);
  sz := s_curve(rz0);
  u := rx0 * g3[b00 + bz0, 0] + ry0 * g3[b00 + bz0, 1] + rz0 * g3[b00 + bz0, 2];
  v := rx1 * g3[b10 + bz0, 0] + ry0 * g3[b10 + bz0, 1] + rz0 * g3[b10 + bz0, 2];
  a := lerp(sx, u, v);
  u := rx0 * g3[b01 + bz0, 0] + ry1 * g3[b01 + bz0, 1] + rz0 * g3[b01 + bz0, 2];
  v := rx1 * g3[b11 + bz0, 0] + ry1 * g3[b11 + bz0, 1] + rz0 * g3[b11 + bz0, 2];
  b := lerp(sx, u, v);
  c := lerp(sy, a, b);
  u := rx0 * g3[b00 + bz1, 0] + ry0 * g3[b00 + bz1, 1] + rz1 * g3[b00 + bz1, 2];
  v := rx1 * g3[b10 + bz1, 0] + ry0 * g3[b10 + bz1, 1] + rz1 * g3[b10 + bz1, 2];
  a := lerp(sx, u, v);
  u := rx0 * g3[b01 + bz1, 0] + ry1 * g3[b01 + bz1, 1] + rz1 * g3[b01 + bz1, 2];
  v := rx1 * g3[b11 + bz1, 0] + ry1 * g3[b11 + bz1, 1] + rz1 * g3[b11 + bz1, 2];
  b := lerp(sx, u, v);
  d := lerp(sy, a, b);
  result := lerp(sz, c, d);
end;

function noise3(vec0, vec1, vec2: double): double;
var
  i, j, bx0, bx1, by0, by1, bz0, bz1, b00, b10, b01, b11: integer;
  rx0, rx1, ry0, ry1, rz0, rz1, sx, sy, sz, a, b, c, d, u, v: double;
begin
  if start then
  begin
    start := false;
    init;
  end;
  bx0 := trunc(vec0 + defN) and defBM;
  bx1 := (bx0 + 1) and defBM;
  rx0 := frac(vec0 + defN);
  rx1 := rx0 - 1.0;
  by0 := trunc(vec1 + defN) and defBM;
  by1 := (by0 + 1) and defBM;
  ry0 := frac(vec1 + defN);
  ry1 := ry0 - 1.0;
  bz0 := trunc(vec2 + defN) and defBM;
  bz1 := (bz0 + 1) and defBM;
  rz0 := frac(vec2 + defN);
  rz1 := rz0 - 1.0;
  i := p[bx0];
  j := p[bx1];
  b00 := p[i + by0];
  b10 := p[j + by0];
  b01 := p[i + by1];
  b11 := p[j + by1];
  sx := rx0 * rx0 * (3.0 - 2.0 * rx0);
  sy := ry0 * ry0 * (3.0 - 2.0 * ry0);
  sz := rz0 * rz0 * (3.0 - 2.0 * rz0);
  u := rx0 * g3[b00 + bz0, 0] + ry0 * g3[b00 + bz0, 1] + rz0 * g3[b00 + bz0, 2];
  v := rx1 * g3[b10 + bz0, 0] + ry0 * g3[b10 + bz0, 1] + rz0 * g3[b10 + bz0, 2];
  a := u + sx * (v - u);
  u := rx0 * g3[b01 + bz0, 0] + ry1 * g3[b01 + bz0, 1] + rz0 * g3[b01 + bz0, 2];
  v := rx1 * g3[b11 + bz0, 0] + ry1 * g3[b11 + bz0, 1] + rz0 * g3[b11 + bz0, 2];
  b := u + sx * (v - u);
  c := a + sy * (b - a);
  u := rx0 * g3[b00 + bz1, 0] + ry0 * g3[b00 + bz1, 1] + rz1 * g3[b00 + bz1, 2];
  v := rx1 * g3[b10 + bz1, 0] + ry0 * g3[b10 + bz1, 1] + rz1 * g3[b10 + bz1, 2];
  a := u + sx * (v - u);
  u := rx0 * g3[b01 + bz1, 0] + ry1 * g3[b01 + bz1, 1] + rz1 * g3[b01 + bz1, 2];
  v := rx1 * g3[b11 + bz1, 0] + ry1 * g3[b11 + bz1, 1] + rz1 * g3[b11 + bz1, 2];
  b := u + sx * (v - u);
  d := a + sy * (b - a);
  result := c + sz * (d - c);
end;

{Harmonic summing functions}

{In what follows "alpha" is the weight when the sum is formed. Typically it is 2. As this
approaches 1 the function is noisier.
"beta" is the harmonic scaling/spacing, typically 2.
persistance = 1/alpha
beta = frequency
N = octaves}

function PNoise1(x, alpha, beta: double; n: integer): double;
var
  i: integer;
  val, sum, p, scale: double;
begin
  sum := 0;
  scale := 1;
  p := x;
  for i := 0 to n - 1 do
  begin
    val := noise1(p);
    sum := sum + val / scale;
    scale := scale * alpha;
    p := p * beta;
  end;
  result := sum;
end;

function PNoise2(x, y, alpha, beta: double; n: integer): double;
var
  i: integer;
  val, sum, px, py, scale: double;
begin
  sum := 0;
  scale := 1;
  px := x;
  py := y;
  for i := 0 to n - 1 do
  begin
    val := noise2(px, py);
    sum := sum + val / scale;
    scale := scale * alpha;
    px := px * beta;
    py := py * beta;
  end;
  result := sum;
end;

function PNoise3(x, y, z, alpha, beta: double; n: integer): double;
var
  i: integer;
  val, sum, px, py, pz, scale: double;
begin
  sum := 0;
  scale := 1;
  px := x;
  py := y;
  pz := z;
  for i := 0 to n - 1 do
  begin
    val := noise3(px, py, pz);
    sum := sum + val / scale;
    scale := scale * alpha;
    px := px * beta;
    py := py * beta;
    pz := pz * beta;
  end;
  result := sum;
end;

end.



Used like this:


unit Unit1;

interface

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

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

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  perlin;

procedure TForm1.Button1Click(Sender: TObject);
var
  x, y, z, c: integer;
begin
  image1.Canvas.Brush.Color := 0;
  image1.Canvas.FillRect(image1.Canvas.ClipRect);
  for x := 0 to 511 do
    for y := 0 to 511 do
    begin
      z := trunc(pnoise2(x / 100, y / 100, 2, 2, 10) * 128) + 128;
      c := z + (z shl 8) + (z shl 16);
      image1.Canvas.Pixels[x, y] := c;
    end;
  c := 0;
  repeat
    image1.Canvas.Pixels[519, c] := $FFFFFF;
    c := c + 10;
  until
    c > 510;
end;

end.

Взято с

Delphi Knowledge Base

Как добавить копию текущей записи?

Как добавить копию текущей записи?

Следующая функция добавит в конец данных точную копию текущей записи.

procedure AppendCurrent(Dataset:Tdataset); 
var 
  aField : Variant ; 
  i      : Integer ; 
begin 
  // Создаём массив
  aField := VarArrayCreate([0,DataSet.Fieldcount-1],VarVariant); 

  // считываем значения в массив
  for i := 0 to (DataSet.Fieldcount-1) do 
     aField[i] := DataSet.fields[i].Value ; 

  DataSet.Append ; 

  // помещаем значения массива в новую запись
  for i := 0 to (DataSet.Fieldcount-1) do 
     DataSet.fields[i].Value := aField[i] ; 
end;

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

Примечания Vit:
1) Если таблица имеет ключевые поля или уникальные индексы данный код приведёт к ошибке "Key violation"

Как добавить нужный язык в систему?

Как добавить нужный язык в систему?

Автор: Mekan Gara

Для этого необходимо изменить некоторые ключи в реестре. Например, необходимо добавить Туркменский язык. Конечно, Вам необходимо иметь файл KBD с раскладкой клавиатуры (Turkmen.kbd).

procedure TTMKBD.OkClick(Sender: TObject); 
var reg:TRegistry; 
     srs,dst:string; 
begin 
   Reg := TRegistry.Create; 
  with Reg do 
    try 
      RootKey :=HKEY_LOCAL_MACHINE; 
      OpenKey('\System\CurrentControlSet\Control\keyboard layouts\00000405', True); 
      WriteString('layout file','Turkmen.kbd'); 
      WriteString('layout text','Turkmen'); 
      OpenKey('\System\CurrentControlSet\Control\Nls\Locale', True); 
      WriteString('00000405','Turkmen'); 
      CloseKey; 
    finally 
      Free; 
    end; 
  srs:='Turkmen.kbd'; 
  dst:='c:\windows\system\Turkmen.kbd'; 
Filecopy(srs,dst); 
showmessage('Well Done it all'); 
close; 
end;

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

Как добавить пункт в контекстное меню IE?

Как добавить пункт в контекстное меню IE?

В реестре по адресу:

HKEY_CURRENT_USER
SOFTWARE
Microsoft
Internet Explorer
MenuExt


два параметра, посмотришь на другие-поймешь что они означают.

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

Как добавить собственную панель?

Как добавить собственную панель?

functionAddExplorerBar(BarTitle, Url: string; BarSize: Int64; Horizontal:
  Boolean): string;
const
  EXPLORERBAR_ID = '{4D5C8C2A-D075-11d0-B416-00C04FB90376}';
  VERTICAL_BAR = '{00021493-0000-0000-C000-000000000046}';
  HORIZONTAL_BAR = '{00021494-0000-0000-C000-000000000046}';
var
  GUID: TGUID;
  SysDir, ID: string;
  Reg: TRegistry;
begin
  CreateGuid(GUID);
  ID := GuidToString(GUID);
  Reg := TRegistry.Create;
  with Reg do
  try
    RootKey := HKEY_CLASSES_ROOT;
    OpenKey('\CLSID\' + ID, True);
    WriteString('', 'BarTitle');
    CloseKey;
    CreateKey('\CLSID\' + ID + '\Implemented Categories');
    if HORIZONTAL then
      CreateKey('\CLSID\' + ID + '\Implemented Categories\' +
        HORIZONTAL_BAR)
    else
      CreateKey('\CLSID\' + ID + '\Implemented Categories\' +
        VERTICAL_BAR);
    SetLength(SysDir, 255);
    GetSysDirectory(PChar(SysDir), 255);
    SysDir := PChar(SysDir) + '\SHDOCVW.DLL';
    OpenKey('\CLSID\' + ID + '\InProcServer32', True);
    Writestring('', SysDir);
    WriteString('Threadingmodel', 'Apartment');
    CloseKey;
    OpenKey('\CLSID\' + ID + '\Instance', True);
    WriteString('CLSID', EXPLORERBAR_ID);
    CloseKey;
    OpenKey('\CLSID\' + ID + '\Instance\InitPropertyBag', True);
    WriteString('Url', URL);
    CloseKey;
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('Software\Microsoft\Internet Explorer\Explorer Bars\'
      + ID, True);
    WriteBinaryData('BarSize', BarSize, SizeOf(BarSize));
    CloseKey;
    OpenKey('\Software\IE5Tools\Explorer Bars\', True);
    WriteString(BarTitle, ID);
    CloseKey;
    OpenKey('\Software\Microsoft\Internet Explorer\Toolbar', True)
      WriteString(ID, '');
    CloseKey;
  finally
    Free;
  end;
  result := ID;
end;

Взято с

Delphi Knowledge Base

Как добавить событие OnMouseLeave?

Как добавить событие OnMouseLeave?

Все потомки TComponent могут посылать сообщения CM_MOUSEENTER и CM_MOUSELEAVE во время вхождения и покидания курсора мыши области компонента. Если вам необходимо, чтобы ваши компоненты обладали реакцией на эти события, необходио написать для них соответствующие обработчики.

procedureCMMouseEnter(var msg:TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
..
..
..
procedure MyComponent.CMMouseEnter(var msg:TMessage);
begin

inherited;
{действия на вход мыши в область компонента}
end;

procedure MyComponent.CMMouseLeave(var msg: TMessage);
begin

inherited;
{действия на покидание мыши области компонента}
end; 

Дополнение

Часто приходится сталкиваться с ситуацией, когда необходимо обработать два важных события для визуальных компонентов:

MouseEnter - когда событие мыши входит в пределы визуального компонента;
MouseLeave - когда событие мыши оставляет его пределы.
Известно, что все Delphi объявляет эти сообщения в виде:
Cm_MouseEnter;
Cm_MouseLeave.
Т.е. все визуальные компоненты, которые порождены от TControl, могут отлавливать эти события. Следующий пример показывает как создать наследника от TLabel и добавить два необходимых события OnMouseLeave и OnMouseEnter.



(*///////////////////////////////////////////////////////*)
(*// Author: Briculski Serge
(*// E-Mail: bserge@airport.md
(*// Date: 26 Apr 2000
(*///////////////////////////////////////////////////////*)

unit BS_Label;

interface

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

type
  TBS_Label = class(TLabel)
  private
    { Private declarations }
    FOnMouseLeave: TNotifyEvent;
    FOnMouseEnter: TNotifyEvent;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    { Protected declarations }
  public
    { Public declarations }
  published
    { Published declarations }
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Custom', [TBS_Label]);
end;

{ TBS_Label }

procedure TBS_Label.CMMouseEnter(var Message: TMessage);
begin
  if Assigned(FOnMouseEnter) then
    FOnMouseEnter(Self);
end;

procedure TBS_Label.CMMouseLeave(var Message: TMessage);
begin
  if Assigned(FOnMouseLeave) then
    FOnMouseLeave(Self);
end;

end.

Взято с

Как добавить свой пункт меню?

Как добавить свой пункт меню?

functionAddMenuItem(ConnType: TconnType; MenuText, StatusBarText,
  GuidOrPath: string; HelpMenu: Boolean): string;
var
  GUID: TGUID;
  ID: string;
  Reg: TRegistry;
begin
  CreateGuid(GUID);
  ID := GuidToString(GUID);
  Reg := TRegistry.Create;
  with Reg do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('\Software\Microsoft\Internet Explorer\Extensions\'
      + ID, True);
    if HelpMenu then
      WriteString('MenuCostumize', 'help');
    WriteString('CLSID', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
    WriteString('MenuText', MenuText);
    WriteString('MenuStatusBar', StatusBarText);
    case ConnType of
      EXECUTABLE: WriteString('Exec', GuidOrPath);
      COM_OBJECT: WriteString('ClsidExtension', GuidOrPath);
      SCRIPT: WriteString('Script', GuidOrPath);
    end;
    CloseKey;
    OpenKey('\Software\IE5Tools\Menu Items\', True);
    WriteString(MenuText, ID);
    CloseKey;
    Free;
  end;
  Result := ID;
end;

Взято с

Delphi Knowledge Base

Как добавить TCheckBox в TStringGrid?

Как добавить TCheckBox в TStringGrid?

Компилятор: Delphi

Автор: Joel E. Cant.

Пример демонстрирует добавление любого количества чекбоксов в StringGrid.
В этом примере необходимо добавить TPanel, а в саму панель включить TstringGrid.
Так же необходимо добавить невидимый TcheckBox на форму. Затем добавьте
5 колонок и 4 строки в объект StringGrid.

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
ShowMessage('There it is!!');  
end;

// Заполняем заголовок StringGrid
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.Cells[0,0] := 'A Simple';  
StringGrid1.Cells[1,0] := 'Way';  
StringGrid1.Cells[2,0] := 'To';  
StringGrid1.Cells[3,0] := 'Do It';  
StringGrid1.Cells[4,0] := 'Check !!';  
AddCheckBoxes; // добавляем чекбоксы...  
end;

procedure TForm1.AddCheckBoxes;
var
i: Integer;  
NewCheckBox: TCheckBox;  
begin
clean_previus_buffer; // очищаем неиспользуемые чекбоксы...  
for i := 1 to 4 do  
begin  
StringGrid1.Cells[0,i] := 'a';  
StringGrid1.Cells[1,i] := 'b';  
StringGrid1.Cells[2,i] := 'c';  
StringGrid1.Cells[3,i] := 'd';  
NewCheckBox := TCheckBox.Create(Application);  
NewCheckBox.Width := 0;  
NewCheckBox.Visible := false;  
NewCheckBox.Caption := 'OK';  
NewCheckBox.Color := clWindow;  
NewCheckBox.Tag := i;  
NewCheckBox.OnClick := CheckBox1.OnClick; //Связываем предыдущее событие OnClick  
                                          // с существующим TCheckBox  
NewCheckBox.Parent := Panel1;  
StringGrid1.Objects[4,i] := NewCheckBox;  
StringGrid1.RowCount := i;  
end;  
set_checkbox_alignment; // расположение чекбоксов в ячейках таблицы...  
end;

Procedure TForm1.clean_previus_buffer;
var
NewCheckBox: TCheckBox;  
i: Integer;  
begin
for i := 1 to StringGrid1.RowCount do  
begin  
NewCheckBox := (StringGrid1.Objects[4,i] as TCheckBox);  
if NewCheckBox <> nil then  
begin  
NewCheckBox.Visible := false;  
StringGrid1.Objects[4,i] := nil;  
end;  
end;  
end;

Procedure TForm1.set_checkbox_alignment;
var
NewCheckBox: TCheckBox;  
Rect: TRect;  
i: Integer;  
begin
for i := 1 to StringGrid1.RowCount do  
begin  
NewCheckBox := (StringGrid1.Objects[4,i] as TCheckBox);  
if NewCheckBox <> nil then  
begin  
Rect := StringGrid1.CellRect(4,i); // получаем размер ячейки для чекбокса  
NewCheckBox.Left := StringGrid1.Left + Rect.Left+2;  
NewCheckBox.Top := StringGrid1.Top + Rect.Top+2;  
NewCheckBox.Width := Rect.Right - Rect.Left;  
NewCheckBox.Height := Rect.Bottom - Rect.Top;  
NewCheckBox.Visible := True;  
end;  
end;  
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
begin
if not (gdFixed in State) then set_checkbox_alignment;  
end;

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

Как добавить текст к закладке?

Как добавить текст к закладке?

uses
ComObj;

procedure TForm1.Button1Click(Sender: TObject);
const
  // Word Document to open
  YourWordDocument = 'c:\test\worddoc.doc';
var
  BookmarkName, Doc, R: OleVariant;
begin
  // Start a Word instance
  try
    WordApp := CreateOleObject('Word.Application');
  except
    ShowMessage('Could not start MS Word!');
  end;
  // Open your Word document
  WordApp.Documents.Open(YourWordDocument);
  Doc := WordApp.ActiveDocument;

  // name of your bookmark
  BookmarkName := 'MyBookMark';

  // Check if bookmark exists
  if Doc.Bookmarks.Exists(BookmarkName) then
  begin
    R := Doc.Bookmarks.Item(BookmarkName).Range;
    // Add text at our bookmark
    R.InsertAfter('Text in bookmark');
    // You make a text formatting like changing its color
    R.Font.Color := clRed;
  end;

  // Save your document and quit Word
  if not VarIsEmpty(WordApp) then
  begin
    WordApp.DisplayAlerts := 0;
    WordApp.Documents.Item(1).Save;
    WordApp.Quit;
    BookmarkName := Unassigned;
    R := Unassigned;
    WordApp := Unassigned;
  end;
end;

Взято с

Delphi Knowledge Base

Как добавить текст в footer документа?

Как добавить текст в footer документа?

Footer:

{... }
aDoc := WordApp.Documents.Add(EmptyParam, EmptyParam);
aDoc.Sections.Item(1).Footers.Item(wdHeaderFooterPrimary).Range.Text :=
  'This is a footer';
{ ... }

Взято с

Delphi Knowledge Base

Как добавить текст в header документа?

Как добавить текст в header документа?

{... }
aDoc := WordApp.Documents.Add(EmptyParam, EmptyParam);
aDoc.Sections.Item(1).Headers.Item(wdHeaderFooterPrimary).Range.Text :=
  'This is a header';
{ ... }

Взято с

Delphi Knowledge Base

Как добавить текущую страницу TWebbrowser в favorites?

Как добавить текущую страницу TWebbrowser в favorites?

// You need: 1 TEdit, 2 TButtons, 1 TWebbrowser 
// Du brauchst: 1 TEdit, 2 TButtons, 1 TWebbrowser 

const 
  NotAllowed: set of Char = ['"'] + ['/'] + ['\'] + ['?'] + [':'] + ['*'] + 
    ['<'] + ['>'] + ['|']; 

implementation 

{$R *.DFM} 

function Load(Path, Key: string): string; 
var 
  Reg: TRegistry; 
begin 
  Reg := TRegistry.Create; 
  try 
    Reg.RootKey := HKEY_CURRENT_USER; 
    Reg.OpenKey(Path, False); 
    try 
      Result := Reg.ReadString(Key); 
    except 
      Result := ''; 
    end; 
    Reg.CloseKey; 
  finally 
    Reg.Free; 
  end; 
end; 

function WinDir: string; 
var 
  WinDir: PChar; 
begin 
  WinDir := StrAlloc(MAX_PATH); 
  GetWindowsDirectory(WinDir, MAX_PATH); 
  Result := string(WinDir); 
  if Result[Length(Result)] <> '\' then 
    Result := Result + '\'; 
  StrDispose(WinDir); 
end; 

function GetSysDir: string; 
var 
  dir: array [0..MAX_PATH] of Char; 
begin 
  GetSystemDirectory(dir, MAX_PATH); 
  Result := StrPas(dir); 
end; 

// Navigate to a page 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Webbrowser1.Navigate(edit1.Text); 
end; 

// Add the current page to the favorites 

procedure TForm1.Button2Click(Sender: TObject); 
var 
  url: TStringList; 
  fav: string; 
  title, b: string; 
  i: Integer; 
  c: Char; 
begin 
  fav := Load('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders','Favorites'); 
  url := TStringList.Create; 
  try 
    url.Add('[InternetShortcut]'); 
    url.Add('URL=' + webbrowser1.LocationURL); 
    url.Add('WorkingDirectory=' + WinDir()); 
    url.Add('IconIndex=0'); 
    url.Add('ShowCommand=7'); 
    url.Add('IconFile=' + GetSysDir() + '\url.dll'); 
    title := Webbrowser1.LocationName; 
    b := ''; 
    for i := 1 to Length(title) do 
    begin 
      c := title[i]; 
      if not (c in NotAllowed) then 
      begin 
        b := b + Webbrowser1.LocationName[i]; 
      end; 
    end; 
    url.SaveToFile(fav + '\' + b + '.url'); 
  finally 
    url.Free; 
  end; 
end; 

end.
Взято с сайта

Как добавить True Type шрифт в систему?

Как добавить True Type шрифт в систему?

Чтобы установить шрифт в систему, необходимо скопировать файл шрифта в 'Windows\Fonts' и добавить ключ в реестр:

'Software\Microsoft\Windows\CurrentVersion\Fonts'

Этот ключ указывает на файл шрифта. Далее запускаем API функцию 'AddFontRecource'. В заключении нужно уведомить систему широковещательным сообщением.


uses Registry; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
  hReg: TRegistry; 
  hBool : bool; 
begin 
  CopyFile('C:\DOWNLOAD\FP000100.TTF', 
           'C:\WINDOWS\FONTS\FP000100.TTF', hBool); 
  hReg := TRegistry.Create; 
  hReg.RootKey := HKEY_LOCAL_MACHINE; 
  hReg.LazyWrite := false; 
  hReg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', 
               false); 
  hReg.WriteString('TESTMICR (TrueType)','FP000100.TTF'); 
  hReg.CloseKey; 
  hReg.free; 
  //Добавляем ресурс шрифта
  AddFontResource('c:\windows\fonts\FP000100.TTF'); 
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); 
  //Убираем блокировку ресурса
  RemoveFontResource('c:\windows\fonts\FP000100.TTF'); 
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); 
end;

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

Как добавить True Type шрифт в систему?

Чтобы установить шрифт в систему, необходимо скопировать файл шрифта в 'Windows\Fonts' и добавить ключ в реестр:

'Software\Microsoft\Windows\CurrentVersion\Fonts'

Этот ключ указывает на файл шрифта. Далее запускаем API функцию 'AddFontRecource'. В заключении нужно уведомить систему широковещательным сообщением.

uses Registry; 

procedure TForm1.Button1Click(Sender: TObject); 
var 
  hReg: TRegistry; 
  hBool : bool; 
begin 
  CopyFile('C:\DOWNLOAD\FP000100.TTF', 
           'C:\WINDOWS\FONTS\FP000100.TTF', hBool); 
  hReg := TRegistry.Create; 
  hReg.RootKey := HKEY_LOCAL_MACHINE; 
  hReg.LazyWrite := false; 
  hReg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', 
               false); 
  hReg.WriteString('TESTMICR (TrueType)','FP000100.TTF'); 
  hReg.CloseKey; 
  hReg.free; 
  //Добавляем ресурс шрифта
  AddFontResource('c:\windows\fonts\FP000100.TTF'); 
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); 
  //Убираем блокировку ресурса
  RemoveFontResource('c:\windows\fonts\FP000100.TTF'); 
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); 
end;

Взято из

Как добавлять колонки в обычный Listbox (TListbox)?

Как добавлять колонки в обычный Listbox (TListbox)?

Класс TListbox содержит свойство TabWith:

ListBox1.TabWith := 50; 
ListBox1.Items.Add('Column1'^I'Column2');  // ^I это символ Tab

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

Как добиться верной работы фильтра на запросах и на неиндексированных таблицах

Как добиться верной работы фильтра на запросах и на неиндексированных таблицах

Автор: Nomadic

(Т.е. при работе программы наблюдалась следующая картина: в результате очередной фильтрации оставалось видно 4 записи из восьми. Добавляем букву к фильтру, остается, допустим, две. Убираем букву, которую только что добавили, в гриде все равно видно только две записи)

Эта проблема была в Delphi 3.0 только на TQuery, а в Delphi 3.01 появилась и в TTable. Лечится так (простой пример):



procedureTMainForm.Edit1Change(Sender: TObject);
begin
  if length(Edit1.Text) > 0 then
  begin
    Table1.Filtered := TRUE;
    UpdateFilter(Table1);
  end
  else
    Table1.Filtered := FALSE;
end;

procedure TMainForm.UpdateFilter(DataSet: TDataSet);
var
  FR: TFilterRecordEvent;
begin
  with DataSet do
  begin
    FR := OnFilterRecord;
    if Assigned(FR) and Active then
    begin
      DisableControls;
      try
        OnFilterRecord := nil;
        OnFilterRecord := FR;
      finally
        EnableControls;
      end;
    end;
  end;
end;

Взято из

Как добраться до конкретного фрейма?

Как добраться до конкретного фрейма?

var

  HTML_Doc: IHTMLDocument2;
  Window: IHTMLWindow2;
  oRange1: variant;
  name_frame: OleVariant;

  HTML_Doc := WebBrowser1.Document as IHTMLDocument2;
  Window := HTML_Doc.parentWindow as IHTMLWindow2;
  name_frame := 'mainFrame';
  oRange1 := Window.frames.item(name_frame).document.body.createTextRange;

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

Как долго запущена Windows?

Как долго запущена Windows?

Ниже приведён код обработчика события OnClick для Button1. Он показывает диалоговое окошко с текстом в следующем формате

Windows started on Thursday, February 10, 2000 at 11:42:46 AM
Its been up for 0 days, 3 hours, 22 minutes, 54 seconds

procedure TForm1.Button1Click(Sender: TObject); 
var 
  ndays: double; 
  ticks: LongInt; 
  btime: TDateTime; 
begin 
 {Функция GetTickCount получает количество миллисекунд, прошедших с момента старта Windows}
  ticks := GetTickCount; 

  {Чтобы получить дни, необходимо разделить на количество миллисекунд в дне, 24*60*60*1000=86400000} 
  ndays := ticks/86400000; 

  {теперь вычитаем из текущей даты полученное количество дней работы Windows}
  bTime := now-ndays; 

  {показываем диалоговое окошко с сообщением}
  ShowMessage( 
   FormatDateTime('"Windows started on" dddd, mmmm d, yyyy, ' + 
                  '"at" hh:nn:ss AM/PM', bTime) + #10#13 + 
   'Its been up for ' + IntToStr(Trunc(nDays)) + ' days,' + 
   FormatDateTime(' h "hours," n "minutes," s "seconds"',ndays)); 
end;

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

Как форматировать диск?

Как форматировать диск?

unit Unit1;
interface

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

type
  TUndocSHFormat = class(TForm)
    Label1: TLabel;
    Combo1: TComboBox;
    cmdSHFormat: TButton;
    cmdEnd: TButton;
    lbMessage: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure cmdSHFormatClick(Sender: TObject);
    procedure cmdEndClick(Sender: TObject);
  private
    procedure LoadAvailableDrives;
  public
  end;

var
  UndocSHFormat: TUndocSHFormat;

implementation

{$R *.DFM}

type POSVERSIONINFO = ^TOSVERSIONINFO;
  TOSVERSIONINFO = record
    dwOSVersionInfoSize: Longint;
    dwMajorVersion: Longint;
    dwMinorVersion: Longint;
    dwBuildNumber: Longint;
    dwPlatformId: Longint;
    szCSDVersion: PChar;
  end;

function GetVersionEx(lpVersionInformation: POSVERSIONINFO): Longint; stdcall; external 'kernel32.dll' name 'GetVersionExA';

const VER_PLATFORM_WIN32s = 0;
const VER_PLATFORM_WIN32_WINDOWS = 1;
const VER_PLATFORM_WIN32_NT = 2;


function SHFormatDrive(hwndOwner: longint; iDrive: Longint; iCapacity: LongInt;
  iFormatType: LongInt): Longint;
  stdcall; external 'shell32.dll';

const SHFD_CAPACITY_DEFAULT = 0;
const SHFD_CAPACITY_360 = 3;
const SHFD_CAPACITY_720 = 5;

//Win95
//Const SHFD_FORMAT_QUICK = 0;
//Const SHFD_FORMAT_FULL = 1;
//Const SHFD_FORMAT_SYSONLY = 2;

//WinNT
//Public Const SHFD_FORMAT_FULL = 0
//Public Const SHFD_FORMAT_QUICK = 1

const SHFD_FORMAT_QUICK: LongInt = 0;
const SHFD_FORMAT_FULL: LongInt = 1;
const SHFD_FORMAT_SYSONLY: LongInt = 2;

function GetLogicalDriveStrings(nBufferLength: LongInt; lpBuffer: PChar): LongInt;
  stdcall; external 'kernel32.dll' name 'GetLogicalDriveStringsA';

function GetDriveType(nDrive: PChar): LongInt;
  stdcall; external 'kernel32.dll' name 'GetDriveTypeA';

const DRIVE_REMOVABLE = 2;
const DRIVE_FIXED = 3;
const DRIVE_REMOTE = 4;
const DRIVE_CDROM = 5;
const DRIVE_RAMDISK = 6;

function IsWinNT: Boolean;
var osvi: TOSVERSIONINFO;
begin
  osvi.dwOSVersionInfoSize := SizeOf(osvi);
  GetVersionEx(@osvi);
  IsWinNT := (osvi.dwPlatformId = VER_PLATFORM_WIN32_NT);
end;


function GetDriveDisplayString(currDrive: PChar): pchar;
begin
  GetDriveDisplayString := nil;
  case GetDriveType(currDrive) of
    0, 1: GetDriveDisplayString := ' - Undetermined Drive Type -';
    DRIVE_REMOVABLE:
      case currDrive[1] of
        'A', 'B': GetDriveDisplayString := 'Floppy drive';
      else
        GetDriveDisplayString := 'Removable drive';
      end;
    DRIVE_FIXED: GetDriveDisplayString := 'Fixed (Hard) drive';
    DRIVE_REMOTE: GetDriveDisplayString := 'Remote drive';
    DRIVE_CDROM: GetDriveDisplayString := 'CD ROM';
    DRIVE_RAMDISK: GetDriveDisplayString := 'Ram disk';
  end;
end;

procedure TUndocSHFormat.LoadAvailableDrives;
var
  a, r: LongInt;
  lpBuffer: array[0..256] of char;
  currDrive: array[0..256] of char;
  lpDrives: pchar;

begin
  getmem(lpDrives, 256);
  fillchar(lpBuffer, 64, #32);

  r := GetLogicalDriveStrings(255, lpBuffer);

  if r <> 0 then
    begin
      strlcopy(lpBuffer, lpBuffer, r);
      for a := 0 to r do
        lpDrives[a] := lpBuffer[a];
      lpBuffer[r + 1] := #0;
      repeat
        strlcopy(currDrive, lpDrives, 3);
        lpDrives := @lpDrives[4];
        Combo1.Items.Add(strpas(currDrive) + ' ' + GetDriveDisplayString(currDrive));
      until lpDrives[0] = #0;
    end;
end;


procedure TUndocSHFormat.FormCreate(Sender: TObject);
begin
  lbMessage.caption := '';
  LoadAvailableDrives;
  Combo1.ItemIndex := 0;
  if IsWinNT then
    begin
      SHFD_FORMAT_FULL := 0;
      SHFD_FORMAT_QUICK := 1;
    end
  else //it's Win95
    begin
      SHFD_FORMAT_QUICK := 0;
      SHFD_FORMAT_FULL := 1;
      SHFD_FORMAT_SYSONLY := 2;
    end;
end;

procedure TUndocSHFormat.cmdSHFormatClick(Sender: TObject);
var
  resp: Integer;
  drvToFormat: Integer;
  prompt: string;
begin
  drvToFormat := Combo1.ItemIndex;
  prompt := 'Are you sure you want to run the Format dialog against ' + Combo1.Text;

  if drvToFormat > 0 then
    resp := MessageDLG(prompt, mtConfirmation, [mbYes, mbNo], 0)
  else
    resp := mrYes;

  if resp = mrYes then
    begin
      lbMessage.Caption := 'Checking drive for disk...';
      Application.ProcessMessages;
      SHFormatDrive(handle, drvToFormat, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK);
      lbMessage.caption := '';
    end;
end;

procedure TUndocSHFormat.cmdEndClick(Sender: TObject);
begin
  close;
end;

end.

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

---

---