Как изменить оконную процедуру для TForm?

  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WndProc(var Message: TMessage);
begin
  if Message.Msg = WM_CANCELMODE then
    begin
      Form1.Caption := 'A dialog or message box has popped up';
    end
  else
    inherited // <- остальное сделает родительская процедура
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('Test Message');
end;

Как изменить порт для принтера?

uses
WinSpool;

{ Function SetPrinterToPort
  Parameters :
    hPrinter: handle of printer to change, obtained from OpenPrinter
    port: port name to use, e.g. LPT1:, COM1:, FILE:
  Returns:
    The name of the previous port the printer was attached to.
  Description:
    Changes the port a printer is attached to using Win32 API functions.
      The changes made are NOT local to this process, they will affect all
      other processes that try to use this printer! It is recommended to set the
      port back to the old port returned by this function after
      the end of the print job.
  Error Conditions:
   Will raise EWin32Error exceptions if SetPrinter or GetPrinter fail.
  Created:
    21.10.99 by P. Below}

function SetPrinterToPort(hPrinter: THandle; const port: string): string;
var
  pInfo: PPrinterInfo2;
  bytesNeeded: DWORD;
begin
  {Figure out how much memory we need for the data buffer. Note that GetPrinter is
  supposed to fail with a specific error code here. The amount of memory will
   be larger than Sizeof(TPrinterInfo2) since variable amounts of data are appended
   to the record}
  SetLastError(NO_ERROR);
  GetPrinter(hPrinter, 2, nil, 0, @bytesNeeded);
  if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
    RaiseLastWin32Error;
  pInfo := AllocMem(bytesNeeded);
  try
    if not GetPrinter(hPrinter, 2, pInfo, bytesNeeded, @bytesNeeded) then
      RaiseLastWin32Error;
    with pInfo^ do
    begin
      Result := pPortname;
      pPortname := @port[1];
    end;
    if not SetPrinter(hPrinter, 2, pInfo, 0) then
      RaiseLastWin32Error;
  finally
    FreeMem(pInfo);
  end;
end;

function GetCurrentPrinterHandle: THandle;
var
  Device, Driver, Port: array[0..255] of char;
  hDeviceMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
  if not OpenPrinter(@Device, Result, nil) then
    RaiseLastWin32Error;
end;

Взято с

Delphi Knowledge Base

Как изменить размеры полигона?

{... }
type
  TPolygon = array of TPoint;

procedure ZoomPolygon(var Polygon: TPolygon; const Center: TPoint; const Scale: Double);
var
  I: Integer;
begin
  for I := 0 to High(Polygon) do
  begin
    Polygon[I].X := Round(Scale * (Polygon[I].X - Center.X) + Center.X);
    Polygon[I].Y := Round(Scale * (Polygon[I].Y - Center.Y) + Center.Y);
  end;
end;

Взято с

Delphi Knowledge Base

Как изменить шрифт hint?

{
  When the application displays a Help Hint,
  it creates an instance of HintWindowClass to represent
  the window used for displaying the hint.
  Applications can customize this window by creating a
  descendant of THintWindow and assigning it to the
  HintWindowClass variable at application startup.
}

type
  TMyHintWindow = class(THintWindow)
    constructor Create(AOwner: TComponent); override;
  end;

implementation

{....}

constructor TMyHintWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  with Canvas.Font do
  begin
    Name := 'Arial';
    Size := Size + 5;
    Style := [fsBold];
  end;
end;

procedure TForm2.FormCreate(Sender: TObject);
begin
  HintWindowClass := TMyHintWindow;
  Application.ShowHint := False;
  Application.ShowHint := True;
end;

Взято с сайта

Как изменить шрифт и выравнивание в заголовке формы?

Note: The formDeactivate never gets called so when the form isn't active, sometimes the FormPaint isn't called. If anything causes the form to be repainted while in inactive, it draws correctly.

unitUnit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormDeactivate(Sender: TObject);
    procedure FormActivate(Sender: TObject);
  private
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormPaint(Sender: TObject);
var
  LabelHeight, LabelWidth, LabelTop: Integer;
  caption_height, border3d_y, button_width, border_thickness: Integer;
  MyCanvas: TCanvas;
  CaptionBarRect: TRect;
begin
  CaptionBarRect := Rect(0, 0, 0, 0);
  MyCanvas := TCanvas.Create;
  MyCanvas.Handle := GetWindowDC(Form1.Handle);
  border3d_y := GetSystemMetrics(SM_CYEDGE);
  button_width := GetSystemMetrics(SM_CXSIZE);
  border_thickness := GetSystemMetrics(SM_CYSIZEFRAME);
  caption_height := GetSystemMetrics(SM_CYCAPTION);
  LabelWidth := Form1.Canvas.TextWidth(Form1.Caption);
  LabelHeight := Form1.Canvas.TextHeight(Form1.Caption);
  LabelTop := LabelHeight - (caption_height div 2);
  CaptionBarRect.Left := border_thickness + border3d_y + button_width;
  CaptionBarRect.Right := Form1.Width - (border_thickness + border3d_y)
      - (button_width * 4);
  CaptionBarRect.Top := border_thickness + border3d_y;
  CaptionBarRect.Bottom := caption_height;
  if Form1.Active then
    MyCanvas.Brush.Color := clActiveCaption
  else
    MyCanvas.Brush.Color := clInActiveCaption;
  MyCanvas.Brush.Style := bsSolid;
  MyCanvas.FillRect(CaptionBarRect);
  MyCanvas.Brush.Style := bsClear;
  MyCanvas.Font.Color := clCaptionText;
  MyCanvas.Font.Name := 'MS Sans Serif';
  MyCanvas.Font.Style := MyCanvas.Font.Style + [fsBold];
  DrawText(MyCanvas.Handle, PChar(' ' + Form1.Caption), Length(Form1.Caption) + 1,
    CaptionBarRect, DT_CENTER or DT_SINGLELINE or DT_VCENTER);
  MyCanvas.Free;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Form1.Paint;
end;

procedure TForm1.FormDeactivate(Sender: TObject);
begin
  Form1.Paint;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  Form1.Paint;
end;

end.

{ ... }
type
  TForm1 = class(TForm)
  private
    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
  ACanvas: TCanvas;
begin
  inherited;
  ACanvas := TCanvas.Create;
  try
    ACanvas.Handle := GetWindowDC(Form1.Handle);
    with ACanvas do
    begin
      Brush.Color := clActiveCaption;
      Font.Name := 'Tahoma';
      Font.Size := 8;
      Font.Color := clred;
      Font.Style := [fsItalic, fsBold];
      TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER),
        Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height)) / 2) + 1,
          ' Some Text');
    end;
  finally
    ReleaseDC(Form1.Handle, ACanvas.Handle);
    ACanvas.Free;
  end;
end;

Взято с

Delphi Knowledge Base

Как изменить шрифт определённой строки в DBGrid?

Для этого надо воспользоваться событием OnDrawDataCell в dbgrid.

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  // If the record's CustNo is 4711 draw the entire row with a
  // line through it. (set the font style to strike out)
  if (Sender as TDBGrid).DataSource.DataSet.FieldByName('CustNo').AsString =
    '4711' then
    with (Sender as TDBGrid).Canvas do
      begin
        FillRect(Rect);
       // Set the font style to StrikeOut
        Font.Style := Font.Style + [fsStrikeOut];
       // Draw the cell right aligned for floats + offset
        if (Field.DataType = ftFloat) then
          TextOut(Rect.Right - TextWidth(Field.AsString) - 3,
            Rect.Top + 3, Field.AsString)
       // Otherwise draw the cell left aligned + offset
        else
          TextOut(Rect.Left + 2, Rect.Top + 3, Field.AsString);
      end;
end;

Замечание: Вышеприведённый код использует таблицу "CUSTOMER.DB", TDBGrid, TDataSource
и TTable

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

Как изменить системное время?

Функция SetSystemTime.
Обрати внимание на привилегии.

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

1) Вариант №1
//**********************************************************
// Функция (раздел Public) SetPCSystemTime изменяет системную дату и время.
// Параметр(ы) : tDati Новая дата и время
// Возвращаемые значения: True - успешное завершение
// False - метод несработал
//************************************************************
function SetPCSystemTime(tDati: TDateTime): Boolean;
var
tSetDati: TDateTime;
vDatiBias: Variant;
tTZI: TTimeZoneInformation;
tST: TSystemTime;
begin
GetTimeZoneInformation(tTZI);
vDatiBias := tTZI.Bias / 1440;
tSetDati := tDati + vDatiBias;
with tST do
begin
wYear := StrToInt(FormatDateTime('yyyy', tSetDati));
wMonth := StrToInt(FormatDateTime('mm', tSetDati));
wDay := StrToInt(FormatDateTime('dd', tSetDati));
wHour := StrToInt(FormatDateTime('hh', tSetDati));
wMinute := StrToInt(FormatDateTime('nn', tSetDati));
wSecond := StrToInt(FormatDateTime('ss', tSetDati));
wMilliseconds := 0;
end;
SetPCSystemTime := SetSystemTime(tST);
end;

2) Вариант №2
***************************************************
Для изменения системного времени используется сложный спобой (через строки).
DateTimeToSystemTime(tSetDati,Tst); - работает быстрее и код короче

3) третий способ:
/////////////////////////////////////////////////////////////
Procedure settime(hour, min, sec, hundreths : byte); assembler;
asm
mov ch, hour
mov cl, min
mov dh, sec
mov dl, hundreths
mov ah, $2d
int $21
end;

////////////////////////////////////////////////////////////////////////
Procedure setdate(Year : word; Month, Day : byte); assembler;
asm
mov cx, year
mov dh, month
mov dl, day
mov ah, $2b
int $21
end;

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

Следующие несколько строк кода позволяют установить системную дату и время без использования панели управления. Дата и время устанавливаются двумя раздельными компонентами TDateTimePicker. Дата и время декодируются и передаются в API функцию.
Из значения часа вычитается 2 для установки правильного времени. (Примечание Vit: вычитается не 2 часа а разница с Гринвичем)

procedure TfmTime.btnTimeClick(Sender: TObject);
var vsys : _SYSTEMTIME;
vYear, vMonth, vDay, vHour, vMin, vSec, vMm : Word;
begin
DecodeDate( Trunc(dtpDate.Date), vYear, vMonth, vDay );
DecodeTime( dtpTime.Time, vHour, vMin, vSec, vMm );
vMm := 0;
vsys.wYear := vYear;
vsys.wMonth := vMonth;
vsys.wDay := vDay;
vsys.wHour := ( vHour - 2 );
vsys.wMinute := vMin;
vsys.wSecond := vSec;
vsys.wMilliseconds := vMm;
vsys.wDayOfWeek := DayOfWeek( Trunc(dtpDate.Date) );
SetSystemTime( vsys );
end;

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

Как изменить стандартный цвет ProgressBar?

Самый простой способ, это изменить цветовую схему в свойствах экрана...

А вот при помощи следующей команды можно разукрасить ProgressBar не изменяя системных настроек:

PostMessage(ProgressBar1.Handle, $0409, 0, clGreen);

Вуаля! Теперь Progress Bar зелёный. Это всего лишь простой пример чёрной магии ;)

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

Как изменить уровень громкости микрофона?

uses
  MMSystem;

// Setzt die Lautstarke fur das Mikrofon
// Set the volume for the microphone

function SetMicrophoneVolume(bValue: Word): Boolean;
var                          {0..65535}
  hMix: HMIXER;
  mxlc: MIXERLINECONTROLS;
  mxcd: TMIXERCONTROLDETAILS;
  vol: TMIXERCONTROLDETAILS_UNSIGNED;
  mxc: MIXERCONTROL;
  mxl: TMixerLine;
  intRet: Integer;
  nMixerDevs: Integer;
begin
  // Check if Mixer is available
  // Uberprufen, ob ein Mixer vorhanden
  nMixerDevs := mixerGetNumDevs();
  if (nMixerDevs < 1) then
  begin
    Exit;
  end;

  // open the mixer
  intRet := mixerOpen(@hMix, 0, 0, 0, 0);
  if intRet = MMSYSERR_NOERROR then
  begin
    mxl.dwComponentType := MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE;
    mxl.cbStruct := SizeOf(mxl);

    // get line info
    intRet := mixerGetLineInfo(hMix, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);

    if intRet = MMSYSERR_NOERROR then
    begin
      ZeroMemory(@mxlc, SizeOf(mxlc));
      mxlc.cbStruct := SizeOf(mxlc);
      mxlc.dwLineID := mxl.dwLineID;
      mxlc.dwControlType := MIXERCONTROL_CONTROLTYPE_VOLUME;
      mxlc.cControls := 1;
      mxlc.cbmxctrl := SizeOf(mxc);

      mxlc.pamxctrl := @mxc;
      intRet := mixerGetLineControls(hMix, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);

      if intRet = MMSYSERR_NOERROR then
      begin
      {
       // Microphone Name
          Label1.Caption := mxlc.pamxctrl.szName;

        // Min/Max Volume
        Label2.Caption := IntToStr(mxc.Bounds.dwMinimum) + '->' + IntToStr(mxc.Bounds.dwMaximum);
      }
        ZeroMemory(@mxcd, SizeOf(mxcd));
        mxcd.dwControlID := mxc.dwControlID;
        mxcd.cbStruct := SizeOf(mxcd);
        mxcd.cMultipleItems := 0;
        mxcd.cbDetails := SizeOf(Vol);
        mxcd.paDetails := @vol;
        mxcd.cChannels := 1;

        // vol.dwValue := mxlc.pamxctrl.Bounds.lMinimum; Set min. Volume / Minimum setzen
        // vol.dwValue := mxlc.pamxctrl.Bounds.lMaximum; Set max. Volume / Maximum setzen
        vol.dwValue := bValue;

        intRet := mixerSetControlDetails(hMix, @mxcd,
          MIXER_SETCONTROLDETAILSF_VALUE);
        if intRet <> MMSYSERR_NOERROR then
          ShowMessage('SetControlDetails Error');
      end
      else
        ShowMessage('GetLineInfo Error');
    end;
    intRet := mixerClose(hMix);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetMicrophoneVolume(30000);
end;

{********************************************************}

// Enable/disable "Mute Microphone Volume"
// Ton fur Mikrofon ein/ausschalten

function SetMicrophoneVolumeMute(bMute: Boolean): Boolean;
var
  hMix: HMIXER;
  mxlc: MIXERLINECONTROLS;
  mxcd: TMIXERCONTROLDETAILS;
  vol: TMIXERCONTROLDETAILS_UNSIGNED;
  mxc: MIXERCONTROL;
  mxl: TMixerLine;
  intRet: Integer;
  nMixerDevs: Integer;
  mcdMute: MIXERCONTROLDETAILS_BOOLEAN;
begin
  // Check if Mixer is available
  // Uberprufen, ob ein Mixer vorhanden ist
  nMixerDevs := mixerGetNumDevs();
  if (nMixerDevs < 1) then
  begin
    Exit;
  end;

  // open the mixer
  // Mixer offnen
  intRet := mixerOpen(@hMix, 0, 0, 0, 0);
  if intRet = MMSYSERR_NOERROR then
  begin
    mxl.dwComponentType := MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE;
    mxl.cbStruct        := SizeOf(mxl);

    // mixerline info
    intRet := mixerGetLineInfo(hMix, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);

    if intRet = MMSYSERR_NOERROR then
    begin
      ZeroMemory(@mxlc, SizeOf(mxlc));
      mxlc.cbStruct := SizeOf(mxlc);
      mxlc.dwLineID := mxl.dwLineID;
      mxlc.dwControlType := MIXERCONTROL_CONTROLTYPE_MUTE;
      mxlc.cControls := 1;
      mxlc.cbmxctrl := SizeOf(mxc);
      mxlc.pamxctrl := @mxc;

      // Get the mute control
      // Mute control ermitteln
      intRet := mixerGetLineControls(hMix, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);

      if intRet = MMSYSERR_NOERROR then
      begin
        ZeroMemory(@mxcd, SizeOf(mxcd));
        mxcd.cbStruct := SizeOf(TMIXERCONTROLDETAILS);
        mxcd.dwControlID := mxc.dwControlID;
        mxcd.cChannels := 1;
        mxcd.cbDetails := SizeOf(MIXERCONTROLDETAILS_BOOLEAN);
        mxcd.paDetails := @mcdMute;

        mcdMute.fValue := Ord(bMute);

        // set, unset mute
        // Stumsschalten ein/aus
        intRet := mixerSetControlDetails(hMix, @mxcd,
          MIXER_SETCONTROLDETAILSF_VALUE);
          {
          mixerGetControlDetails(hMix, @mxcd,
                                 MIXER_GETCONTROLDETAILSF_VALUE);
          Result := Boolean(mcdMute.fValue);
          }
        Result := intRet = MMSYSERR_NOERROR;

        if intRet <> MMSYSERR_NOERROR then
          ShowMessage('SetControlDetails Error');
      end
      else
        ShowMessage('GetLineInfo Error');
    end;

    intRet := mixerClose(hMix);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetMicrophoneVolumeMute(False);
end;

{********************************************************}

// Enable/disable "Mute" for several mixer line sources.

uses
  MMSystem;

type
TMixerLineSourceType = (lsDigital, lsLine, lsMicrophone, lsCompactDisk, lsTelephone,
                         lsWaveOut, lsAuxiliary, lsAnalog, lsLast);

function SetMixerLineSourceMute(AMixerLineSourceType: TMixerLineSourceType; bMute: Boolean): Boolean;
var
  hMix: HMIXER;
  mxlc: MIXERLINECONTROLS;
  mxcd: TMIXERCONTROLDETAILS;
  vol: TMIXERCONTROLDETAILS_UNSIGNED;
  mxc: MIXERCONTROL;
  mxl: TMixerLine;
  intRet: Integer;
  nMixerDevs: Integer;
  mcdMute: MIXERCONTROLDETAILS_BOOLEAN;
begin
  Result := False;
  // Check if Mixer is available
  // Uberprufen, ob ein Mixer vorhanden ist
  nMixerDevs := mixerGetNumDevs();
  if (nMixerDevs < 1) then
  begin
    Exit;
  end;

  // open the mixer
  // Mixer offnen
  intRet := mixerOpen(@hMix, 0, 0, 0, 0);
  if intRet = MMSYSERR_NOERROR then
  begin
    ZeroMemory(@mxl, SizeOf(mxl));
    case AMixerLineSourceType of
      lsDigital: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_DIGITAL;
      lsLine: mxl.dwComponentType := MIXERLINE_COMPONENTTYPE_SRC_LINE;
      lsMicrophone: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE;
      lsCompactDisk: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_COMPACTDISC;
      lsTelephone: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_TELEPHONE;
      lsWaveOut: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_WAVEOUT;
      lsAuxiliary: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_AUXILIARY;
      lsAnalog : mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_ANALOG;
      lsLast: mxl.dwComponentType :=MIXERLINE_COMPONENTTYPE_SRC_LAST;
    end;

    // mixerline info
    mxl.cbStruct := SizeOf(mxl);
    intRet := mixerGetLineInfo(hMix, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);

    if intRet = MMSYSERR_NOERROR then
    begin
      ZeroMemory(@mxlc, SizeOf(mxlc));
      mxlc.cbStruct := SizeOf(mxlc);
      mxlc.dwLineID := mxl.dwLineID;
      mxlc.dwControlType := MIXERCONTROL_CONTROLTYPE_MUTE;
      mxlc.cControls := 1;
      mxlc.cbmxctrl := SizeOf(mxc);
      mxlc.pamxctrl := @mxc;

      // Get the mute control
      // Mute control ermitteln
      intRet := mixerGetLineControls(hMix, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);

      if intRet = MMSYSERR_NOERROR then
      begin
        ZeroMemory(@mxcd, SizeOf(mxcd));
        mxcd.cbStruct := SizeOf(TMIXERCONTROLDETAILS);
        mxcd.dwControlID := mxc.dwControlID;
        mxcd.cChannels := 1;
        mxcd.cbDetails := SizeOf(MIXERCONTROLDETAILS_BOOLEAN);
        mxcd.paDetails := @mcdMute;

        mcdMute.fValue := Ord(bMute);

        // set, unset mute
        // Stumsschalten ein/aus
        intRet := mixerSetControlDetails(hMix, @mxcd, MIXER_SETCONTROLDETAILSF_VALUE);
        {
        mixerGetControlDetails(hMix, @mxcd, IXER_GETCONTROLDETAILSF_VALUE);
        Result := Boolean(mcdMute.fValue);
        }
        Result := intRet = MMSYSERR_NOERROR;

        if intRet <> MMSYSERR_NOERROR then
          ShowMessage('SetControlDetails Error');
      end
      else
        ShowMessage('GetLineInfo Error');
    end;
    intRet := mixerClose(hMix);
  end;
end;

// Example Call; Beispielaufruf:

procedure TForm1.Button1Click(Sender: TObject);
begin
  // Ton ausschalten
  SetMixerLineSourceMute(lsLine, True);
end;

Взято с сайта

Как изменить заголовок чужого окна?

SetWindowText(FindWindow(nil,'Текущий заголовок'), 'Желаемый');

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

Как изменить значение свойства компонента по имени?

functionGetProperty(AControl: TPersistent; AProperty: String): PPropInfo;
var
  i: Integer;
  props: PPropList;
  typeData: PTypeData;
begin
  Result := nil;
  if (AControl = nil) or (AControl.ClassInfo = nil) then
    Exit;
  typeData := GetTypeData(AControl.ClassInfo);
  if (typeData = nil) or (typeData^.PropCount = 0) then
    Exit;
  GetMem(props, typeData^.PropCount * SizeOf(Pointer));
  try
    GetPropInfos(AControl.ClassInfo, props);
    for i := 0 to typeData^.PropCount - 1 do
    begin
      with Props^[i]^ do
        if (Name = AProperty) then
          result := Props^[i];
    end;
  finally
    FreeMem(props);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  propInfo: PPropInfo;
begin
  PropInfo := GetProperty(Button1.Font, 'Name');
  if PropInfo <> nil then
    SetStrProp(Button1.Font, PropInfo, 'Arial');
end;

Взято из

You can use RTTI to do this. Here is how to change a particular component:

procedure TForm1.BtnClick(Sender: TObject);
var
  p: PPropInfo;
  f: TFont;
begin
  f := TFont.Create;
  {Setup the font properties}
  f.Name := 'Arial';
  p := GetPropInfo(Sender.ClassInfo, 'Font');
  if Assigned(p) then
    SetOrdProp(Sender, p, Integer(f));
  f.Free;
end;

To get at all the forms loop through the Screen global variable. For each form loop through its Components list calling the above procedure (or something close). If you only create your components at design time that is it. If you create some at runtime and the owner is not the form, then for each component loop through its Components list recursively to get at all the owned components.

Tip by Jeff Overcash

Взято из

I am building a routine that checks our forms for validity before deploying them. I would like to use some kind of structure that tests if a component type has access to a certain property, something like: " if (self.Controls[b] has Tag) then ...". Can anyone offer suggestions?
Here's an example of setting a string property for a component if it exists and another for an integer property:

procedureSetStringPropertyIfExists(AComp: TComponent; APropName: String;
AValue: String);
var
  PropInfo: PPropInfo;
  TK: TTypeKind;
begin
  PropInfo := GetPropInfo(AComp.ClassInfo, APropName);
  if PropInfo <> nil then
  begin
    TK := PropInfo^.PropType^.Kind;
    if (TK = tkString) or (TK = tkLString) or (TK = tkWString) then
      SetStrProp(AComp, PropInfo, AValue);
  end;
end;

procedure SetIntegerPropertyIfExists(AComp: TComponent; APropName: String;
AValue: Integer);
var
  PropInfo: PPropInfo;
begin
  PropInfo := GetPropInfo(AComp.ClassInfo, APropName);
  if PropInfo <> nil then
  begin
    if PropInfo^.PropType^.Kind = tkInteger then
      SetOrdProp(AComp, PropInfo, AValue);
  end;
end;

Tip by Xavier Pacheco

Взято из

Как извлечь иконку из EXE или DLL?

Такой вот совет пришел ко мне с рассылкой "Ежедневная рассылка сайта Мастера DELPHI", думаю многим будет интересно.

Решить эту задачу нам поможет функция function ExtractIcon(hInstance, filename, iconindex):integer
где hinstance - глобальная переменная приложения, ее изменять не надо. Тип integer.
filename - имя программы или DLL из которой надо извлекать иконки. Тип pchar.
iconindex - порядковый номер иконки в файле (начинается с 0). В одном файле может находится несколько иконок. Тип integer.
Функция находится в модуле ShellApi, так что не забудьте подключить его в uses. Если эта функция возвратит ноль, значит иконок в файле нет.
Данная функция возвращает handle иконки, поэтому применять ее нужно так:
Image1.Picture.Icon.Handle:=ExtractIcon(hInstance, pchar(paramstr(0)), 0);
данное объявление нарисует в Image'e картинку вашего приложения.

Автор: Михаил Христосенко

Взято с Vingrad.ru

Как я могу работать с IB с клиентского компьютера?

Можно использовать IB API (либо наборы компонт FreeIBComponents, IBObjects, IBX или FIBPlus, работающие напрямую с IB API), BDE+SQL Links, либо ODBC-драйвер.
Схема обмена данными между этими компонентами следующая

GDS32.DLL->IB прямое обращение к IB API
ODBC->GDS32.DLL-> IB работа через ODBC
BDE->SQL Link->GDS32.DLL->IB работа через BDE
BDE->ODBC->GDS32.DLL->IB работа через BDE, ODBC вместо SQL Link.

Практически во всех случаях вам не требуется производить какие-либо специфические настройки.

Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко

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

Проблема в следующем. Допустим, есть иерархия классов, у которых перекрывается один и тот же виртуальный (или динамический - не важно) метод и в одной из реализаций этого метода вы хотите вызвать виртуальный метод предка своего предка. Новая объектная модель Delphi допускает только вызов методов предка (с помощью ключевого слова inherited) либо вызов методов класса с префиксом - типом класса (например, TLevel1.ClassName).

Эта проблема стандартными средствами не решается. Но сделать требуемый вызов можно. Причем способом, показанным ниже, можно вызвать любой метод для любого класса, однако, в этом случае вся ответственность за правильность работы с методами и полями ложится на программиста. Ниже в методе VirtualFunction класса TLevel3 вызывается метод класса TLevel1, а в функции Level1Always всегда вызывается метод класса TLevel1 для любого его наследника.

TLevel1= class(TComponent)
   public
     function VirtualFunction: string; virtual;
   end;

   TLevel2 = class(TLevel1)
   public
     function VirtualFunction: string; override;
   end;

   TLevel3 = class(TLevel2)
   public
     function VirtualFunction: string; override;
   end;

   function Level1Always(MyLevel: TLevel1): string;

implementation

   type
     PClass = ^TClass;

   function TLevel1.VirtualFunction: string;
   begin
     Result := 'Level1';
   end;

   function TLevel2.VirtualFunction: string;
   begin
     Result := inherited VirtualFunction+' Level2';
   end;

   function TLevel3.VirtualFunction: string;
   var
     ClassOld: TClass;
   begin
         ClassOld := PClass(Self)^;
     PClass(Self)^ := TLevel1;
     Result := VirtualFunction + ' Level3';
     PClass(Self)^ := ClassOld;
   end;

   function Level1Always(MyObject: TObject): string;
   var
     ClassOld: TClass;
   begin
     ClassOld := PClass(MyObject)^;
     PClass(MyObject)^ := TLevel1;
     Result := (MyObject as TLevel1).VirtualFunction;
     PClass(MyObject)^ := ClassOld;
   end;

Как же это работает? Стандартные так называемые объектные типы (object types - class of ...) на самом деле представляют из себя указатель на VMT (Virtual Method Table) - таблицу виртуальных методов, который (указатель) лежит по смещению 0 в экземпляре класса. Воспользовавшись этим, мы сначала сохраняем 'старый тип класса' - указатель на VMT, присваиваем ему указатель на VMT нужного класса, делаем вызов и восстанавливаем все как было. Причем нигде не требуется, чтобы один из этих классов был бы порожден от другого, т.е. функция Level1Always вызовет требуемый метод вообще для любого экземпляра любого класса.

Если в функции Level1Always сделать попробовать вызов

  Result := MyObject.VirtualFunction;

то будет ошибка на стации компиляции, так как у класса TObject нет метода VirtualFunction. Другой вызов

  Result := (MyObject as TLevel3).VirtualFunction;

будет пропущен компилятором, но вызовет Run-time ошибку, даже если передается экземпляр класса TLevel3 или один из его потомком, так как информация о типе объекта меняется. Динамически распределяемые (dynamic) методы можно вызывать точно таким же образом, т.к. информация о них тоже хранится в VMT. Статические методы объектов вызываются гораздо более простым способом, например

var
     MyLevel3: TLevel3;
   ...
     (MyLevel3 as TLevel1).SomeMethode;

вызовет метод класса TLevel1 даже если у MyLevel3 есть свой такой же метод.

Copyright © 1996 Epsylon Technologies

Взято из

FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349

Как экспортировать процедуру в EXE файле

В DPR файле совершенно обычного проэкта дельфи можно указать функцию (процедуру) и объявить ее как экспортируемую - синтаксис точно такой-же как при создании стандартной DLL. С таким довеском EXE совершенно нормально компиллируется и работает и как EXE и как DLL (т.е. из нее можно импортировать описанные функции). Зачем это нужно? Была одна задача - делал консоль которая связывала воедино несколько приложений, так экспортные функции позволяли существенно расширять функциональность комплекса. Правда такой EXE все же имеет недостаток - EXE упаковщики сохраняют исполняемую часть и неправильно упаковывают экспортированную... Кроме того могут быть проблемы передачи строковых параметров.

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

Как экспортировать содержимое DBGrid в Excel или ClipBoard?

Пример dbgrid (DBGrid1) имеет всплывающее меню, которое позволяет две опции "Send to Excel" и "Copy"

// ЗАМЕЧАНИЕ: этот метод должен включать COMObj, Excel97 units

// ОБНОВЛЕНИЕ: если Вы используете Delphi 4, то замените xlWBatWorkSheet на 1 (один)

//-----------------------------------------------------------
// если toExcel = false, то экспортируем содержимое dbgrid в Clipboard
// если toExcel = true, то экспортируем содержимое dbgrid в Microsoft Excel
procedure ExportDBGrid(toExcel: Boolean);
var
  bm: TBookmark;
  col, row: Integer;
  sline: String;
  mem: TMemo;
  ExcelApp: Variant;
begin
  Screen.Cursor := crHourglass;
  DBGrid1.DataSource.DataSet.DisableControls;
  bm := DBGrid1.DataSource.DataSet.GetBookmark;
  DBGrid1.DataSource.DataSet.First;

  // создаём объект Excel
  if toExcel then
  begin
    ExcelApp := CreateOleObject('Excel.Application');
    ExcelApp.WorkBooks.Add(xlWBatWorkSheet);
    ExcelApp.WorkBooks[1].WorkSheets[1].Name := 'Grid Data';
  end;

  // Сперва отправляем данные в memo
  // работает быстрее, чем отправлять их напрямую в Excel
  mem := TMemo.Create(Self);
  mem.Visible := false;
  mem.Parent := MainForm;
  mem.Clear;
  sline := '';

  // добавляем информацию для имён колонок
  for col := 0 to DBGrid1.FieldCount-1 do
    sline := sline + DBGrid1.Fields[col].DisplayLabel + #9;
  mem.Lines.Add(sline);

  // получаем данные из memo
  for row := 0 to DBGrid1.DataSource.DataSet.RecordCount-1 do
  begin
    sline := '';
    for col := 0 to DBGrid1.FieldCount-1 do
      sline := sline + DBGrid1.Fields[col].AsString + #9;
    mem.Lines.Add(sline);
    DBGrid1.DataSource.DataSet.Next;
  end;

  // копируем данные в clipboard
  mem.SelectAll;
  mem.CopyToClipboard;

  // если необходимо, то отправляем их в Excel
  // если нет, то они уже в буфере обмена
  if toExcel then
  begin
    ExcelApp.Workbooks[1].WorkSheets['Grid Data'].Paste;
    ExcelApp.Visible := true;
  end;

  FreeAndNil(ExcelApp);
  DBGrid1.DataSource.DataSet.GotoBookmark(bm);
  DBGrid1.DataSource.DataSet.FreeBookmark(bm);
  DBGrid1.DataSource.DataSet.EnableControls;
  Screen.Cursor := crDefault;
end;

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

Как экспортировать StringGrid в MS Word таблицу?

uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  WordApp, NewDoc, WordTable: OLEVariant;
  iRows, iCols, iGridRows, jGridCols: Integer;
begin
  try
    // Create a Word Instance
    // Word Instanz erzeugen
    WordApp := CreateOleObject('Word.Application');
  except
    // Error...
    // Fehler....
    Exit;
  end;

  // Show Word
  // Word anzeigen
  WordApp.Visible := True;

  // Add a new Doc
  // Neues Dok einfugen
  NewDoc := WordApp.Documents.Add;

  // Get number of columns, rows
  // Spalten, Reihen ermitteln
  iCols := StringGrid1.ColCount;
  iRows := StringGrid1.RowCount;

  // Add a Table
  // Tabelle einfugen
  WordTable := NewDoc.Tables.Add(WordApp.Selection.Range, iCols, iRows);

  // Fill up the word table with the Stringgrid contents
  // Tabelle ausfullen mit Stringgrid Daten
  for iGridRows := 1 to iRows do
    for jGridCols := 1 to iCols do
      WordTable.Cell(iGridRows, jGridCols).Range.Text :=
        StringGrid1.Cells[jGridCols - 1, iGridRows - 1];

  // Here you might want to Save the Doc, quit Word...
  // Hier evtl Word Doc speichern, beenden...

  // ...

  // Cleanup...
  WordApp := Unassigned;
  NewDoc := Unassigned;
  WordTable := Unassigned;
end;

Взято с сайта

Как экспортировать таблицу базы данных в ASCII-файл?

procedure TMyTable.ExportToASCII;

var
  I: Integer;
  Dlg: TSaveDialog;
  ASCIIFile: TextFile;
  Res: Boolean;

begin
  if Active then
    if (FieldCount > 0) and (RecordCount > 0) then
      begin
        Dlg := TSaveDialog.Create(Application);
        Dlg.FileName := FASCIIFileName;
        Dlg.Filter := 'ASCII-Fiels (*.asc)|*.asc';
        Dlg.Options := Dlg.Options+[ofPathMustExist,
          ofOverwritePrompt, ofHideReadOnly];
        Dlg.Title := 'Экспоритровать данные в ASCII-файл';
        try
          Res := Dlg.Execute;
          if Res then
            FASCIIFileName := Dlg.FileName;
        finally
          Dlg.Free;
        end;
        if Res then
          begin
            AssignFile(ASCIIFile, FASCIIFileName);
            Rewrite(ASCIIFile);
            First;
            if FASCIIFieldNames then
              begin
                for I := 0 to FieldCount-1 do
                  begin
                    Write(ASCIIFile, Fields[I].FieldName);
                    if I <> FieldCount-1 then
                      Write(ASCIIFile, FASCIISeparator);
                  end;
                Write(ASCIIFile, #13#10);
              end;
            while not EOF do
              begin
                for I := 0 to FieldCount-1 do
                  begin
                    Write(ASCIIFile, Fields[I].Text);
                    if I <> FieldCount-1 then
                      Write(ASCIIFile, FASCIISeparator);
                  end;
                Next;
                if not EOF then
                  Write(ASCIIFile, #13#10);
              end;
            CloseFile(ASCIIFile);
            if IOResult <> 0 then
              MessageDlg('Ошибка при создании или переписывании '+
                'в ASCII-файл', mtError, [mbOK], 0);
          end;
      end
    else
      MessageDlg('Нет данных для экспортирования.',
        mtInformation, [mbOK], 0)
  else
    MessageDlg('Таблица должна быть открытой, чтобы данные '+
      'можно было экспортировать в ASCII-формат.', mtError,
      [mbOK], 0);
  end;

Как экспортировать таблицу в MS Word в TStringGrid?

uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
const
  AWordDoc = 'C:\xyz\testTable.doc';
var
  MSWord, Table: OLEVariant;
  iRows, iCols, iGridRows, jGridCols, iNumTables, iTableChosen: Integer;
  CellText: string;
  InputString: string;
begin
  try
    MSWord := CreateOleObject('Word.Application');
  except
    // Error....
    Exit;
  end;

  try
    MSWord.Visible := False;
    MSWord.Documents.Open(AWordDoc);

    // Get number of tables in document
    iNumTables := MSWord.ActiveDocument.Tables.Count;

    InputString := InputBox(IntToStr(iNumTables) +
      ' Tables in Word Document', 'Please Enter Table Number', '1');
    // Todo: Validate string for integer, range...
    iTableChosen := StrToInt(InputString);

    // access table
    Table := MSWord.ActiveDocument.Tables.Item(iTableChosen);
    // get dimensions of table
    iCols := Table.Rows.Count;
    iRows := Table.Columns.Count;
    // adjust stringgrid columns
    StringGrid1.RowCount := iCols;
    StringGrid1.ColCount := iRows + 1;

    // loop through cells
    for iGridRows := 1 to iRows do
      for jGridCols := 1 to iCols do
      begin
        CellText := Table.Cell(jGridCols, iGridRows).Range.FormattedText;
        if not VarisEmpty(CellText) then
        begin
          // Remove Tabs
          CellText := StringReplace(CellText,
            #$D, '', [rfReplaceAll]);
          // Remove linebreaks
          CellText := StringReplace(CellText, #$7, '', [rfReplaceAll]);

          // fill Stringgrid
          Stringgrid1.Cells[iGridRows, jGridCols] := CellText;
        end;
      end;
    //..
  finally
    MSWord.Quit;
  end;
end;

Взято с сайта

Как экспортировать все таблицы в CSV файл?

procedureTMainForm.SaveAllTablesToCSV(DBFileName: string);
var
  InfoStr,
    FileName,
    RecString,
    WorkingDirectory: string;
  OutFileList,
    TableNameList: TStringList;
  TableNum,
    FieldNum: integer;
  VT: TVarType;
begin
  ADOTable1.Active := false;
  WorkingDirectory := ExtractFileDir(DBFileName);
  TableNameList := TStringList.Create;
  OutFileList := TStringList.Create;
  InfoStr := 'The following files were created' + #13#13;

  ADOConnection1.GetTableNames(TableNameList, false);
  for TableNum := 0 to TableNameList.Count - 1 do
  begin
    FileName := WorkingDirectory + '\' +
      TableNameList.Strings[TableNum] + '.CSV';
    Caption := 'Saving "' + ExtractFileName(FileName) + '"';
    ADOTable1.TableName := TableNameList.Strings[TableNum];
    ADOTable1.Active := true;
    OutFileList.Clear;

    ADOTable1.First;
    while not ADOTable1.Eof do
    begin

      RecString := '';
      for FieldNum := 0 to ADOTable1.FieldCount - 1 do
      begin
        VT := VarType(ADOTable1.Fields[FieldNum].Value);
        case VT of
          // just write the field if not a string
          vtInteger, vtExtended, vtCurrency, vtInt64:
            RecString := RecString + ADOTable1.Fields[FieldNum].AsString
        else
          // it IS a string so put quotes around it
          RecString := RecString + '"' +
            ADOTable1.Fields[FieldNum].AsString + '"';
        end; { case }

        // if not the last field then use a field separator
        if FieldNum < (ADOTable1.FieldCount - 1) then
          RecString := RecString + ',';
      end; { for FieldNum }
      OutFileList.Add(RecString);

      ADOTable1.Next;
    end; { while }

    OutFileList.SaveToFile(FileName);
    InfoStr := InfoStr + FileName + #13;
    ADOTable1.Active := false;

  end; { for  TableNum }
  TableNameList.Free;
  OutFileList.Free;
  Caption := 'Done';
  ShowMessage(InfoStr);
end;

procedure TMainForm.Button1Click(Sender: TObject);
const
  ConnStrA = 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=';
  ConnStrC = ';Persist Security Info=False';
  ProvStr = 'Microsoft.Jet.OLEDB.4.0';
begin
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
  if OpenDialog1.Execute then

  try
    ADOConnection1.ConnectionString :=
      ConnStrA + OpenDialog1.FileName + ConnStrC;
    ADOConnection1.Provider := ProvStr;
    ADOConnection1.Connected := true;
    ADOTable1.Connection := ADOConnection1;
    SaveAllTablesToCSV(OpenDialog1.FileName);
  except
    ShowMessage('Could not Connect to ' + #13 +
      '"' + OpenDialog1.FileName + '"');
    Close;
  end;

end;

Взято с

Delphi Knowledge Base

Как экстрагировать аудиодорожку из AVI файла?

uses
{...}, vfw;

var
  abort: Boolean;

  {$R *.DFM}

{Vielen Dank an Jailbird, der einen groЯen Teil dieses Codes entwickelt hat
Special thanks to Jailbird, who developed a big part of this Code}

{Bitte zuerst die vfw.pas downloaden
Please download th vfw.pas first }

{Die 'SaveCallback' Funktion erlaubt es dem Benutzer den
aktuellen Prozess Status zu erfahren und den Speichervorgang
vorzeitig abzubrechen. Diese Funktion muss NICHT vom Benutzer
aufgerufen werden.

The 'SaveCallback' function allows the user to get the
process status and abort the save progress. This function
needn't to call by the user.}

function SaveCallback(nPercent: Int): Bool; pascal;
begin
  Application.ProcessMessages;

  Form1.Progressbar1.Position := nPercent; //Speicher Status in Prozent
  //Save Status in Percent
  if abort = True then
    Result := True    //Wenn die Funktion "True" zurьckgibt, wird der Speichervorgang fortgesetzt.
  else                //If then function returns "True", the Process will continue
    Result := False;  //Gibt sie "False" zurьck wird der Vorgang abgebrochen
end;                  //If it returns "False" the process will abort

{Die folgende Funktion erwartet zwei Parameter:

Inputfile: PChar
  Geben Sie hier die die AVI Datei an aus welche Sie
  die Audiospur extrahieren mцchten.

Outputfile: PChar
  Geben Sie einen Pfad + Dateinamen einer WAVE Datei an.
  In diese Datei wird die AudioSpur gespeichert.

  HINWEIS:
  Geben Sie nur eine WAVE Datei als Ausgabedatei an wenn
  die Audiodaten in der AVI Datei unkomprimiert (als PCM WAVE)
  vorliegen.

####################################################

The following function needs two parameters:

InputFile: PChar
  Enter a Dir + Filename of a AVI File.

OutputFile: PChar
  Enter a Dir + Filename of a WAVE File where do you want to
  put the audiodata of the movie.

  TIP:
  Enter jus a Filename of a WAVE File if the audiodata of the
  movie is in uncompressed PCM Format.

###########################################################

WICHTIG:
  Stellen Sie vor dem aufrufen der Funktion 'ExtractAVISound' sicher
  das die Eingabedatei (Inputfile) ьber eine AudioSpur verfьgt.

IMPORTANT:
  Before calling the 'ExtractAVISound' function be sure that the
  Inputfile has a audiotrace.
}

function TForm1.ExtractAVISound(InputFile, Outputfile: PChar): Boolean;
var
  PFile: IAviFile;
  PAvi: IAviStream;
  plpOptions: PAviCompressOptions;
begin
  Abort := False;

  if Fileexists(StrPas(Outputfile)) then
  begin
    case MessageDlg('Ausgabedatei existiert bereits. Ьberschreiben?',
      mtWarning, [mbYes, mbNo], 0) of
      mrYes:
        begin
          DeleteFile(StrPas(Outputfile)); //Wichtig, da die Funktion sonst nur so viel der
        end;                             //Datei ьberschreibt wie gebraucht wird.
      //Important because the function overwrite just
      //the part of the file which is needed.
      mrNo:
        begin
          Exit;
        end;
    end;
  end;

  try            //Initialisiert die API
    AviFileInit;  //Init the API
    if AviFileOpen(PFile, Inputfile, 0, nil) <> 0 then  //Цffnet eine AVI Datei
    begin                                               //Opens a AVI File
      MessageDlg('Fehler beim laden des Videos.
      Mцglicherweise wird die Datei von einem anderen Prozess verwendet.'
        + #13#10 +
        'SchlieЯen Sie alle in Frage kommenden Anwendungen und versuchen Sie es erneut.',
        mtError, [mbOK], 0);
      Result := False;
      Exit;
    end;
    if AviFileGetStream(PFile, PAvi, StreamTypeAudio, 0) <> 0 then
    begin
      MessageDlg(
        'Fehler beim laden des AudioStreams. Bitte ьberprьfen Sie, ob dieses Video ьber einen AudioStream verfьgt.',
        mtError, [mbOK], 0);
      AviFileExit;
      Result := False;
      Exit;
    end;
    //Speichert den AudioStream
    //Saves the AudioStream
    if AviSaveV(Outputfile, nil, @SaveCallback, 1, PAvi, plpOptions) <> 0 then
    begin
      MessageDlg('Fehler beim Speichern des AudioStreams oder Sie haben den Speichervorgang abgebrochen.',
        mtError, [mbOK], 0);
      AviStreamRelease(PAvi);
      AviFileExit;
      Result := False;
      Exit;
    end;
  finally
    AviStreamRelease(PAvi);
    AviFileExit;
  end;
  Result := True;  //'TRUE' zurьckgeben wenn alles geklappt hat
  //return 'TRUE' if all right
end;

//Beispiel zu aufrufen der Funktion:
//Example how to call the function:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if ExtractAVISound(PChar('D:\test.avi'), PChar('D:\test.wav')) = True then
    ShowMessage('Audiospur erfolgreich gespeichert!'); // Audio sucessfully saved
  else
    ShowMessage('Fehler beim Speichern der Audiospur.'); // Error while saving...
end;

Взято с сайта

Как экстрагировать фрейм из AVI?

uses
VfW { from download };

function GrabAVIFrame(avifn: string; iFrameNumber: Integer; ToFileName: TFileName): Boolean;
var
  Error: Integer;
  pFile: PAVIFile;
  AVIStream: PAVIStream;
  gapgf: PGETFRAME;
  lpbi: PBITMAPINFOHEADER;
  bits: PChar;
  hBmp: HBITMAP;
  AviInfo: TAVIFILEINFOW;
  sError: string;
  TmpBmp: TBitmap;
  DC_Handle: HDC;
begin
  Result := False;
  // Initialize the AVIFile library.
  AVIFileInit;

  // The AVIFileOpen function opens an AVI file
  Error := AVIFileOpen(pFile, PChar(avifn), 0, nil);
  if Error <> 0 then
  begin
    AVIFileExit;
    case Error of
      AVIERR_BADFORMAT: sError := 'The file couldnot be read';
      AVIERR_MEMORY: sError := 'The file could not be opened because of insufficient memory.';
      AVIERR_FILEREAD: sError := 'A disk error occurred while reading the file.';
      AVIERR_FILEOPEN: sError := 'A disk error occurred while opening the file.';
    end;
    ShowMessage(sError);
    Exit;
  end;

  // AVIFileInfo obtains information about an AVI file
  if AVIFileInfo(pFile, @AVIINFO, SizeOf(AVIINFO)) <> AVIERR_OK then
  begin
    // Clean up and exit
    AVIFileRelease(pFile);
    AVIFileExit;
    Exit;
  end;

  // Show some information about the AVI
  Form1.Memo1.Lines.Add('AVI Width : ' + IntToStr(AVIINFO.dwWidth));
  Form1.Memo1.Lines.Add('AVI Height : ' + IntToStr(AVIINFO.dwHeight));
  Form1.Memo1.Lines.Add('AVI Length : ' + IntToStr(AVIINFO.dwLength));

  // Open a Stream from the file
  Error := AVIFileGetStream(pFile, AVIStream, streamtypeVIDEO, 0);
  if Error <> AVIERR_OK then
  begin
    // Clean up and exit
    AVIFileRelease(pFile);
    AVIFileExit;
    Exit;
  end;

  // Prepares to decompress video frames
  gapgf := AVIStreamGetFrameOpen(AVIStream, nil);
  if gapgf = nil then
  begin
    AVIStreamRelease(AVIStream);
    AVIFileRelease(pFile);
    AVIFileExit;
    Exit;
  end;

  // Read current Frame
  // AVIStreamGetFrame Returns the address of a decompressed video frame
  lpbi := AVIStreamGetFrame(gapgf, iFrameNumber);
  if lpbi = nil then
  begin
    AVIStreamGetFrameClose(gapgf);
    AVIStreamRelease(AVIStream);
    AVIFileRelease(pFile);
    AVIFileExit;
    Exit;
  end;

  // Show number of frames:
  Form1.Memo1.Lines.Add(Format('Framstart: %d FrameEnd: %d',
    [AVIStreamStart(AVIStream), AVIStreamEnd(AVIStream)]));

  TmpBmp := TBitmap.Create;
  try
    TmpBmp.Height := lpbi.biHeight;
    TmpBmp.Width  := lpbi.biWidth;
    bits := Pointer(Integer(lpbi) + SizeOf(TBITMAPINFOHEADER));

    DC_Handle := CreateDC('Display', nil, nil, nil);
    try
      hBmp := CreateDIBitmap(DC_Handle, // handle of device context
        lpbi^, // address of bitmap size and format data
        CBM_INIT, // initialization flag
        bits, // address of initialization data
        PBITMAPINFO(lpbi)^, // address of bitmap color-format data
        DIB_RGB_COLORS); // color-data usage
    finally
      DeleteDC(DC_Handle);
    end;

    TmpBmp.Handle := hBmp;
    AVIStreamGetFrameClose(gapgf);
    AVIStreamRelease(AVIStream);
    AVIFileRelease(pfile);
    AVIFileExit;
    try
      TmpBmp.SaveToFile(ToFileName);
      Result := True;
    except
    end;
  finally
    TmpBmp.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // Extract Frame 3 from AVI file
  GrabAVIFrame('C:\Test.avi', 3, 'c:\avifram.bmp');
end;

Взято с сайта

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

Как эмулировать нажатия клавиш в другой программе
http://delfaq.wallst.ru/faq/emul.html
Этот модуль является почти полным аналогом мотоду SendKeys из VB.
(Автор: Ken Henderson, email:khen@compuserve.com)
================================================================

(*
SendKeys routine for 32-bit Delphi.

Written by Ken Henderson
Copyright (c) 1995 Ken Henderson email:khen@compuserve.com

This unit includes two routines that simulate popular Visual Basic
routines: Sendkeys and AppActivate. SendKeys takes a PChar
as its first parameter and a boolean as its second, like so:

SendKeys('KeyString', Wait);

where KeyString is a string of key names and modifiers that you want
to send to the current input focus and Wait is a boolean variable or value
that indicates whether SendKeys should wait for each key message to be
processed before proceeding. See the table below for more information.

AppActivate also takes a PChar as its only parameter, like so:

AppActivate('WindowName');

where WindowName is the name of the window that you want to make the
current input focus.

SendKeys supports the Visual Basic SendKeys syntax, as documented below.

Supported modifiers:

+ = Shift
^ = Control
% = Alt

Surround sequences of characters or key names with parentheses in order to
modify them as a group. For example, '+abc' shifts only 'a', while '+(abc)' shifts
all three characters.

Supported special characters

~ = Enter
( = Begin modifier group (see above)
) = End modifier group (see above)
{ = Begin key name text (see below)
} = End key name text (see below)

Supported characters:

Any character that can be typed is supported. Surround the modifier keys
listed above with braces in order to send as normal text.

Supported key names (surround these with braces):

BKSP, BS, BACKSPACE
BREAK
CAPSLOCK
CLEAR
DEL
DELETE
DOWN
END
ENTER
ESC
ESCAPE
F1
F2
F3
F4
F5
F6
F7
F8
F9
F10
F11
F12
F13
F14
F15
F16
HELP
HOME
INS
LEFT
NUMLOCK
PGDN
PGUP
PRTSC
RIGHT
SCROLLLOCK
TAB
UP

Follow the keyname with a space and a number to send the specified key a
given number of times (e.g., {left 6}).
*)

unit sndkey32;

interface

Uses SysUtils, Windows, Messages;

function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
function AppActivate(WindowName : PChar) : boolean;

{Buffer for working with PChar's}

const
  WorkBufLen = 40;
var
  WorkBuf : array[0..WorkBufLen] of Char;

implementation
type
  THKeys = array[0..pred(MaxLongInt)] of byte;
var
  AllocationSize : integer;

(*
Converts a string of characters and key names to keyboard events and
passes them to Windows.

Example syntax:

SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);

*)

function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
type
  WBytes = array[0..pred(SizeOf(Word))] of Byte;

  TSendKey = record
    Name : ShortString;
    VKey : Byte;
  end;

const

{Array of keys that SendKeys recognizes.

  if you add to this list, you must be sure to keep it sorted alphabetically
  by Name because a binary search routine is used to scan it.}

  MaxSendKeyRecs = 41;
  SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey =
  (
   (Name:'BKSP'; VKey:VK_BACK),
   (Name:'BS'; VKey:VK_BACK),
   (Name:'BACKSPACE'; VKey:VK_BACK),
   (Name:'BREAK'; VKey:VK_CANCEL),
   (Name:'CAPSLOCK'; VKey:VK_CAPITAL),
   (Name:'CLEAR'; VKey:VK_CLEAR),
   (Name:'DEL'; VKey:VK_DELETE),
   (Name:'DELETE'; VKey:VK_DELETE),
   (Name:'DOWN'; VKey:VK_DOWN),
   (Name:'END'; VKey:VK_END),
   (Name:'ENTER'; VKey:VK_RETURN),
   (Name:'ESC'; VKey:VK_ESCAPE),
   (Name:'ESCAPE'; VKey:VK_ESCAPE),
   (Name:'F1'; VKey:VK_F1),
   (Name:'F10'; VKey:VK_F10),
   (Name:'F11'; VKey:VK_F11),
   (Name:'F12'; VKey:VK_F12),
   (Name:'F13'; VKey:VK_F13),
   (Name:'F14'; VKey:VK_F14),
   (Name:'F15'; VKey:VK_F15),
   (Name:'F16'; VKey:VK_F16),
   (Name:'F2'; VKey:VK_F2),
   (Name:'F3'; VKey:VK_F3),
   (Name:'F4'; VKey:VK_F4),
   (Name:'F5'; VKey:VK_F5),
   (Name:'F6'; VKey:VK_F6),
   (Name:'F7'; VKey:VK_F7),
   (Name:'F8'; VKey:VK_F8),
   (Name:'F9'; VKey:VK_F9),
   (Name:'HELP'; VKey:VK_HELP),
   (Name:'HOME'; VKey:VK_HOME),
   (Name:'INS'; VKey:VK_INSERT),
   (Name:'LEFT'; VKey:VK_LEFT),
   (Name:'NUMLOCK'; VKey:VK_NUMLOCK),
   (Name:'PGDN'; VKey:VK_NEXT),
   (Name:'PGUP'; VKey:VK_PRIOR),
   (Name:'PRTSC'; VKey:VK_PRINT),
   (Name:'RIGHT'; VKey:VK_RIGHT),
   (Name:'SCROLLLOCK'; VKey:VK_SCROLL),
   (Name:'TAB'; VKey:VK_TAB),
   (Name:'UP'; VKey:VK_UP)
  );
{Extra VK constants missing from Delphi's Windows API interface}
  VK_NULL=0;
  VK_SemiColon=186;
  VK_Equal=187;
  VK_Comma=188;
  VK_Minus=189;
  VK_Period=190;
  VK_Slash=191;
  VK_BackQuote=192;
  VK_LeftBracket=219;
  VK_BackSlash=220;
  VK_RightBracket=221;
  VK_Quote=222;
  VK_Last=VK_Quote;

  ExtendedVKeys : set of byte =
  [VK_Up,
   VK_Down,
   VK_Left,
   VK_Right,
   VK_Home,
   VK_End,
   VK_Prior, {PgUp}
   VK_Next, {PgDn}
   VK_Insert,
   VK_Delete];

const
  INVALIDKEY = $FFFF;
  VKKEYSCANSHIFTON = $01;
  VKKEYSCANCTRLON = $02;
  VKKEYSCANALTON = $04;
  UNITNAME = 'SendKeys';
var
  UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean;
  PosSpace : Byte;
  I, L : Integer;
  NumTimes, MKey : Word;
  KeyString : String[20];

procedure DisplayMessage(Message : PChar);
begin
  MessageBox(0,Message,UNITNAME,0);
end;

function BitSet(BitTable, BitMask : Byte) : Boolean;
begin
  Result:=ByteBool(BitTable and BitMask);
end;

procedure SetBit(var BitTable : Byte; BitMask : Byte);
begin
  BitTable:=BitTable or Bitmask;
end;

procedure KeyboardEvent(VKey, ScanCode : Byte; Flags : Longint);
var
  KeyboardMsg : TMsg;
begin
  keybd_event(VKey, ScanCode, Flags,0);
  if (Wait) then While (PeekMessage(KeyboardMsg,0,WM_KEYFIRST, WM_KEYLAST, PM_REMOVE)) do begin
    TranslateMessage(KeyboardMsg);
    DispatchMessage(KeyboardMsg);
  end;
end;

procedure SendKeyDown(VKey: Byte; NumTimes : Word; GenUpMsg : Boolean);
var
  Cnt : Word;
  ScanCode : Byte;
  NumState : Boolean;
  KeyBoardState : TKeyboardState;
begin
  if (VKey=VK_NUMLOCK) then begin
    NumState:=ByteBool(GetKeyState(VK_NUMLOCK) and 1);
    GetKeyBoardState(KeyBoardState);
    if NumState then KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] and not 1)
    else KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] or 1);
    SetKeyBoardState(KeyBoardState);
    exit;
  end;

  ScanCode:=Lo(MapVirtualKey(VKey,0));
  For Cnt:=1 to NumTimes do
    if (VKey in ExtendedVKeys)then begin
      KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
      if (GenUpMsg) then
        KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
    end else begin
      KeyboardEvent(VKey, ScanCode, 0);
      if (GenUpMsg) then KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
    end;
end;

procedure SendKeyUp(VKey: Byte);
var
  ScanCode : Byte;
begin
  ScanCode:=Lo(MapVirtualKey(VKey,0));
  if (VKey in ExtendedVKeys)then
    KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)
  else KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;

procedure SendKey(MKey: Word; NumTimes : Word; GenDownMsg : Boolean);
begin
  if (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyDown(VK_SHIFT,1,False);
  if (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyDown(VK_CONTROL,1,False);
  if (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyDown(VK_MENU,1,False);
  SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
  if (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyUp(VK_SHIFT);
  if (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyUp(VK_CONTROL);
  if (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyUp(VK_MENU);
end;

{Implements a simple binary search to locate special key name strings}
function StringToVKey(KeyString : ShortString) : Word;
var
  Found, Collided : Boolean;
  Bottom, Top, Middle : Byte;
begin
  Result:=INVALIDKEY;
  Bottom:=1;
  Top:=MaxSendKeyRecs;
  Found:=false;
  Middle:=(Bottom+Top) div 2;
  Repeat
    Collided:=((Bottom=Middle) or (Top=Middle));
    if (KeyString=SendKeyRecs[Middle].Name) then begin
       Found:=true;
       Result:=SendKeyRecs[Middle].VKey;
           if (KeyString>SendKeyRecs[Middle].Name) then Bottom:=Middle
       else Top:=Middle;
       Middle:=(Succ(Bottom+Top)) div 2;
    end;
  Until (Found or Collided);
  if (Result=INVALIDKEY) then DisplayMessage('Invalid Key Name');
end;

procedure PopUpShiftKeys;
begin
  if (not UsingParens) then begin
    if ShiftDown then SendKeyUp(VK_SHIFT);
    if ControlDown then SendKeyUp(VK_CONTROL);
    if AltDown then SendKeyUp(VK_MENU);
    ShiftDown:=false;
    ControlDown:=false;
    AltDown:=false;
  end;
end;

begin
  AllocationSize:=MaxInt;
  Result:=false;
  UsingParens:=false;
  ShiftDown:=false;
  ControlDown:=false;
  AltDown:=false;
  I:=0;
  L:=StrLen(SendKeysString);
  if (L>AllocationSize) then L:=AllocationSize;
  if (L=0) then Exit;

  While (I
    case SendKeysString[I] of
    '(' : begin
            UsingParens:=true;
            Inc(I);
          end;
    ')' : begin
            UsingParens:=false;
            PopUpShiftKeys;
            Inc(I);
          end;
    '%' : begin
             AltDown:=true;
             SendKeyDown(VK_MENU,1,False);
             Inc(I);
          end;
    '+' : begin
             ShiftDown:=true;
             SendKeyDown(VK_SHIFT,1,False);
             Inc(I);
           end;
    '^' : begin
             ControlDown:=true;
             SendKeyDown(VK_CONTROL,1,False);
             Inc(I);
           end;
    '{' : begin
            NumTimes:=1;
            if (SendKeysString[Succ(I)]='{') then begin
              MKey:=VK_LEFTBRACKET;
              SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
              SendKey(MKey,1,True);
              PopUpShiftKeys;
              Inc(I,3);
              Continue;
            end;
            KeyString:='';
            FoundClose:=false;
            While (I<=L) do begin
              Inc(I);
              if (SendKeysString[I]='}') then begin
                FoundClose:=true;
                Inc(I);
                Break;
              end;
              KeyString:=KeyString+Upcase(SendKeysString[I]);
            end;
            if (Not FoundClose) then begin
               DisplayMessage('No Close');
               Exit;
            end;
            if (SendKeysString[I]='}') then begin
              MKey:=VK_RIGHTBRACKET;
              SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
              SendKey(MKey,1,True);
              PopUpShiftKeys;
              Inc(I);
              Continue;
            end;
            PosSpace:=Pos(' ',KeyString);
            if (PosSpace<>0) then begin
               NumTimes:=StrToInt(Copy(KeyString,Succ(PosSpace),Length(KeyString)-PosSpace));
               KeyString:=Copy(KeyString,1,Pred(PosSpace));
            end;
            if (Length(KeyString)=1) then MKey:=vkKeyScan(KeyString[1])
            else MKey:=StringToVKey(KeyString);
            if (MKey<>INVALIDKEY) then begin
              SendKey(MKey,NumTimes,True);
              PopUpShiftKeys;
              Continue;
            end;
          end;
    '~' : begin
            SendKeyDown(VK_RETURN,1,True);
            PopUpShiftKeys;
            Inc(I);
          end;
    else begin
             MKey:=vkKeyScan(SendKeysString[I]);
             if (MKey<>INVALIDKEY) then begin
               SendKey(MKey,1,True);
               PopUpShiftKeys;
             end else DisplayMessage('Invalid KeyName');
             Inc(I);
          end;
    end;
  end;
  Result:=true;
  PopUpShiftKeys;
end;

{AppActivate

This is used to set the current input focus to a given window using its
name. This is especially useful for ensuring a window is active before
sending it input messages using the SendKeys function. You can specify
a window's name in its entirety, or only portion of it, beginning from
the left.

}

var
  WindowHandle : HWND;

function EnumWindowsProc(WHandle: HWND; lParam: LPARAM): BOOL; export; stdcall;
const
  MAX_WINDOW_NAME_LEN = 80;
var
  WindowName : array[0..MAX_WINDOW_NAME_LEN] of char;
begin
  {Can't test GetWindowText's return value since some windows don't have a title}
  GetWindowText(WHandle,WindowName,MAX_WINDOW_NAME_LEN);
  Result := (StrLIComp(WindowName,PChar(lParam), StrLen(PChar(lParam))) <> 0);
  if (not Result) then WindowHandle:=WHandle;
end;

function AppActivate(WindowName : PChar) : boolean;
begin
  try
    Result:=true;
    WindowHandle:=FindWindow(nil,WindowName);
    if (WindowHandle=0) then EnumWindows(@EnumWindowsProc,Intege (PChar(WindowName)));
    if (WindowHandle<>0) then begin
      SendMessage(WindowHandle, WM_SYSCOMMAND, SC_HOTKEY, WindowHandle);
      SendMessage(WindowHandle, WM_SYSCOMMAND, SC_RESTORE, WindowHandle);
    end else Result:=false;
  except
    on Exception do Result:=false;
  end;
end;

end.

Взято с сайта

Как качественно увеличить изображение при помощи билинейной интерполяции

При увеличении изображения нужно находить цвет точек, находящимися между
точками исходного изображения. Функция CopyRect, встроенная в Delphi берет
для этого цвет ближайшей точки. Увеличенное изображение получается некрасивым.
Чтобы избежать этого, используют интерполяцию.
Существует несколько видов интерполяции изображения. Наиболее простой из них - билинейный.

Изображение рассматривается как поверхность, цвет - третье измерение.
Если изображение цветное, то интерполяция проводится отдельно для трех цветов.
Для каждой точки нового изображения с координатами (xo,yo)
нужно найти четыре ближайшие точки исходного изображения.
Эти точки образуют квадрат. Через две верхние точки проводится прямая f1(x),
через две нижние - f2(x). Дальше находятся координаты для точек f1(xo) и f2(xo),
через которые проводится третья прямая f3(y). Цвет искомой точки - это f3(yo).

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

procedure Interpolate(var bm: TBitMap; dx, dy: single);
var
  bm1: TBitMap;
  z1, z2: single;
  k, k1, k2: single;
  x1, y1: integer;
  c: array [0..1, 0..1, 0..2] of byte;
  res: array [0..2] of byte;
  x, y: integer;
  xp, yp: integer;
  xo, yo: integer;
  col: integer;
  pix: TColor;
begin
  bm1 := TBitMap.Create;
  bm1.Width := round(bm.Width * dx);
  bm1.Height := round(bm.Height * dy);
  for y := 0 to bm1.Height - 1 do begin
    for x := 0 to bm1.Width - 1 do begin
      xo := trunc(x / dx);
      yo := trunc(y / dy);
      x1 := round(xo * dx);
      y1 := round(yo * dy);

      for yp := 0 to 1 do
        for xp := 0 to 1 do begin
          pix := bm.Canvas.Pixels[xo + xp, yo + yp];
          c[xp, yp, 0] := GetRValue(pix);
          c[xp, yp, 1] := GetGValue(pix);
          c[xp, yp, 2] := GetBValue(pix);
        end;

      for col := 0 to 2 do begin
        k1 := (c[1,0,col] - c[0,0,col]) / dx;
        z1 := x * k1 + c[0,0,col] - x1 * k1;
        k2 := (c[1,1,col] - c[0,1,col]) / dx;
        z2 := x * k2 + c[0,1,col] - x1 * k2;
        k := (z2 - z1) / dy;
        res[col] := round(y * k + z1 - y1 * k);
      end;
      bm1.Canvas.Pixels[x,y] := RGB(res[0], res[1], res[2]);
    end;
    Form1.Caption := IntToStr(round(100 * y / bm1.Height)) + '%';
    Application.ProcessMessages;
    if Application.Terminated then Exit;
  end;
  bm := bm1;
end;

const
  dx = 5.5;
  dy = 5.5;

procedure TForm1.Button1Click(Sender: TObject);
const
  w = 50;
  h = 50;
var
  bm: TBitMap;
  can: TCanvas;
begin
  bm := TBitMap.Create;
  can := TCanvas.Create;
  can.Handle := GetDC(0);
  bm.Width := w;
  bm.Height := h;
  bm.Canvas.CopyRect(Bounds(0, 0, w, h), can, Bounds(0, 0, w, h));
  ReleaseDC(0, can.Handle);
  Interpolate(bm, dx, dy);
  Form1.Canvas.Draw(0, 0, bm);
  Form1.Caption := 'x: ' + FloatToStr(dx) +
    ' y: ' + FloatToStr(dy) +
    ' width: ' + IntToStr(w) +
    ' height: ' + IntToStr(h);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  bm: TBitMap;
begin
  if OpenDialog1.Execute then
    bm.LoadFromFile(OpenDialog1.FileName);
  Interpolate(bm, dx, dy);
  Form1.Canvas.Draw(0, 0, bm);
  Form1.Caption := 'x: ' + FloatToStr(dx) +
    ' y: ' + FloatToStr(dy) +
    ' width: ' + IntToStr(bm.Width) +
    ' height: ' + IntToStr(bm.Height);
end;

Эта программа строит заданные графики, используя модуль Recognition.
От констант left и right зависит диапазон x, от YScale зависит масштаб по y, а от k зависит качество прорисовки.
uses Recognition;

procedure TForm1.Button1Click(Sender: TObject);
const
  left = -10;
  right = 10;
  YScale = 50;
  k = 10;
var
  i: integer;
  Num: extended;
  s: String;
  XScale: single;
  col: TColor;
begin
  s := Edit1.Text;
  preparation(s, ['x']);
  XScale := PaintBox1.Width / (right - left);
  randomize;
  col := RGB(random(100), random(100), random(100));
  for i := round(left * XScale * k) to round(right * XScale * k) do
    if recogn(ChangeVar(s, 'x', i / XScale / k), Num) then
      PaintBox1.Canvas.Pixels[round(i / k - left * XScale),
        round(PaintBox1.Height / 2 - Num * YScale)] := col;
end;

Взято с сайта

Как клонировать процесс?

{
  In Linux it is possible to duplicate a process with fork. In the original
  process, fork will return the handle to the duplicated process. The
  duplicated process will return zero.
}

program TestFork;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Libc;

var
  ForkedProcessHandle: __pid_t;
  bForked: Boolean;

procedure ForkNow;
begin
  bForked := true;
  ForkedProcessHandle := fork;
end;

function IsForked: Boolean;
begin
  Result := (ForkedProcessHandle = 0) and bForked;
end;

var
  Lf: Integer;

begin
  sigignore(SIGCHLD);
  bForked := false;

  WriteLn('do some stuff');

  WriteLn('before fork');
  ForkNow;
  WriteLn('after fork - we have dublicated the process');

  if IsForked then begin
    WriteLn('do some stuff in forked process (wait 5s)');
    for Lf := 0 to 50 do begin
      Write('f');
      sleep(100);
    end;
  end else begin
    WriteLn('do stuff in original process (wait 10)');
    for Lf := 0 to 100 do begin
      Write('o');
      sleep(100);
    end;
  end;

  WriteLn;

  if IsForked then
    WriteLn('forked process end')
  else
    WriteLn('original process end');
end.

{
Output of this demo app:

do some stuff
before fork
after fork - we have dublicated the process
after fork - we have dublicated the process
do some stuff in forked process (wait 5s)
fdo stuff in original process (wait 10)
ooffooffooffooffooffooffooffooffooffooffooffooffooffooffooffooffooffooff
ooffooffooffooffooffooffooffoo
forked process end
ooooooooooooooooooooooooooooooooooooooooooooooooo
original process end
}

Взято с сайта

Как консольное приложение может узнать, что Винды завершаются?

Автор: Nomadic

Все процессы получают сигналы CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT и CTRL_SHUTDOWN_EVENT. А делается это (грубо говоря :) так:

BOOLCtrl_Handler( DWORD Ctrl )
{
  if( (Ctrl == CTRL_SHUTDOWN_EVENT)  (Ctrl == CTRL_LOGOFF_EVENT) )
  {
    // Вау! Юзер обламывает!
  }
  else
  {
    // Тут что-от другое можно творить. А можно и не творить :-)
  }
  return TRUE;
}

function Ctrl_Handler(Ctrl: Longint): LongBool;
begin
  if Ctrl in [CTRL_SHUTDOWN_EVENT, CTRL_LOGOFF_EVENT] then
  begin
    // Вау, вау
  end
  else
  begin
    // Am I creator?
  end;
  Result := true;
end;

А где-то в программе:

SetConsoleCtrlHandler( Ctrl_Handler, TRUE );

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

Короче, смотри описание SetConsoleCtrlHandler -- там всё есть.

Взято с

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

All Systems (Win 95+ and WinNT4+) with MS Internet Explorer 4 and newer have a library named mlang.dll in the Winnt\System32 directory. Usually you can tell Delphi to simply import these COM Libraries. This one however, Delphi did not. I started to convert the "most wanted" interface for myself. The results I present you here.

First I give you the code for the conversion unit, that allows you simply convert any text from code page interpretation into another one. Following I will shortly discuss the code and give you a sample of how to use it.

uCodePageConverter

{** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
* Unit Name : uCodePageConverter
* Autor     : Daniel Wischnewski
* Copyright : Copyright © 2002 by gate(n)etwork. All Right Reserved.
* Urheber   : Daniel Wischnewski
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit uCodePageConverter;

interface

uses
  Windows;

const
  IID_MLangConvertCharset: TGUID = '{D66D6F98-CDAA-11D0-B822-00C04FC9B31F}';
  CLASS_MLangConvertCharset: TGUID = '{D66D6F99-CDAA-11D0-B822-00C04FC9B31F}';

type
  tagMLCONVCHARF = DWORD;

const
  MLCONVCHARF_AUTODETECT: tagMLCONVCHARF = 1;
  MLCONVCHARF_ENTITIZE: tagMLCONVCHARF = 2;

type
  tagCODEPAGE = UINT;

const
  CODEPAGE_Thai: tagCODEPAGE = 0874;
  CODEPAGE_Japanese: tagCODEPAGE = 0932;
  CODEPAGE_Chinese_PRC: tagCODEPAGE = 0936;
  CODEPAGE_Korean: tagCODEPAGE = 0949;
  CODEPAGE_Chinese_Taiwan: tagCODEPAGE = 0950;
  CODEPAGE_UniCode: tagCODEPAGE = 1200;
  CODEPAGE_Windows_31_EastEurope: tagCODEPAGE = 1250;
  CODEPAGE_Windows_31_Cyrillic: tagCODEPAGE = 1251;
  CODEPAGE_Windows_31_Latin1: tagCODEPAGE = 1252;
  CODEPAGE_Windows_31_Greek: tagCODEPAGE = 1253;
  CODEPAGE_Windows_31_Turkish: tagCODEPAGE = 1254;
  CODEPAGE_Hebrew: tagCODEPAGE = 1255;
  CODEPAGE_Arabic: tagCODEPAGE = 1256;
  CODEPAGE_Baltic: tagCODEPAGE = 1257;

type
  IMLangConvertCharset = interface
    ['{D66D6F98-CDAA-11D0-B822-00C04FC9B31F}']
    function Initialize(
      uiSrcCodePage: tagCODEPAGE; uiDstCodePage: tagCODEPAGE;
      dwProperty: tagMLCONVCHARF
      ): HResult; stdcall;
    function GetSourceCodePage(
      out puiSrcCodePage: tagCODEPAGE
      ): HResult; stdcall;
    function GetDestinationCodePage(
      out puiDstCodePage: tagCODEPAGE
      ): HResult; stdcall;
    function GetProperty(out pdwProperty: tagMLCONVCHARF): HResult; stdcall;
    function DoConversion(
      pSrcStr: PChar; pcSrcSize: PUINT; pDstStr: PChar; pcDstSize: PUINT
      ): HResult; stdcall;
    function DoConversionToUnicode(
      pSrcStr: PChar; pcSrcSize: PUINT; pDstStr: PWChar; pcDstSize: PUINT
      ): HResult; stdcall;
    function DoConversionFromUnicode(
      pSrcStr: PWChar; pcSrcSize: PUINT; pDstStr: PChar; pcDstSize: PUINT
      ): HResult; stdcall;
  end;

  CoMLangConvertCharset = class
    class function Create: IMLangConvertCharset;
    class function CreateRemote(const MachineName: string): IMLangConvertCharset;
  end;

implementation

uses
  ComObj;

{ CoMLangConvertCharset }

class function CoMLangConvertCharset.Create: IMLangConvertCharset;
begin
  Result := CreateComObject(CLASS_MLangConvertCharset) as IMLangConvertCharset;
end;

class function CoMLangConvertCharset.CreateRemote(
  const MachineName: string
  ): IMLangConvertCharset;
begin
  Result := CreateRemoteComObject(
    MachineName, CLASS_MLangConvertCharset
    ) as IMLangConvertCharset;
end;

end.

As you can see, I did translate only one of the many interfaces, however this one is the most efficient (according to Microsoft) and will do the job. Further I added some constants to simplify the task of finding the most important values.

When using this unit to do any code page conersions you must not forget, that the both code pages (source and destination) must be installed and supported on the computer that does the translation. OIn the computer that is going to show the result only the destination code page must be installed and supported.

To test the unit simple create a form with a memo and a button. Add the following code to the buttons OnClick event. (Do not forget to add the conversion unit to the uses clause!)

SAMPLE

procedure TForm1.Button1Click(Sender: TObject);
var
  Conv: IMLangConvertCharset;
  Source: PWChar;
  Dest: PChar;
  SourceSize, DestSize: UINT;
begin
  // connect to MS multi-language lib
  Conv := CoMLangConvertCharset.Create;
  // initialize UniCode Translation to Japanese
  Conv.Initialize(CODEPAGE_UniCode, CODEPAGE_Japanese, MLCONVCHARF_ENTITIZE);
  // load source (from memo)
  Source := PWChar(WideString(Memo1.Text));
  SourceSize := Succ(Length(Memo1.Text));
  // prepare destination
  DestSize := 0;
  // lets calculate size needed
  Conv.DoConversionFromUnicode(Source, @SourceSize, nil, @DestSize);
  // reserve memory
  GetMem(Dest, DestSize);
  try
    // convert
    Conv.DoConversionFromUnicode(Source, @SourceSize, Dest, @DestSize);
    // show
    Memo1.Text := Dest;
  finally
    // free memory
    FreeMem(Dest);
  end;
end;

Взято с

Delphi Knowledge Base

Как конвертировать RFC дату и обратно?

functionDateTimeToRfcTime(
  dt: TDateTime;
  iDiff: integer;
  blnGMT: boolean = false): string;
{*
Explanation:
iDiff is the local offset to GMT in minutes
if blnGMT then Result is UNC time else local time
e.g. local time zone: ET = GMT - 5hr = -300 minutes
    dt is TDateTime of 3 Jan 2001 5:45am
      blnGMT = true  -> Result = 'Wed, 03 Jan 2001 05:45:00 GMT'
      blnGMT = false -> Result = 'Wed, 03 Jan 2001 05:45:00 -0500'
*}
const
  Weekday: array[1..7] of string =
  ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
  Month: array[1..12] of string = (
    'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
    'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
var
  iDummy: Word;
  iYear: Word;
  iMonth: Word;
  iDay: Word;
  iHour: Word;
  iMinute: Word;
  iSecond: Word;
  strZone: string;
begin
  if blnGMT then
  begin
    dt := dt - iDiff / 1440;
    strZone := 'GMT';
  end
  else
  begin
    iDiff := (iDiff div 60) * 100 + (iDiff mod 60);
    if iDiff < 0 then
      strZone := Format('-%.4d', [-iDiff])
    else
      strZone := Format('+%.4d', [iDiff]);
  end;
  DecodeDate(dt, iYear, iMonth, iDay);
  DecodeTime(dt, iHour, iMinute, iSecond, iDummy);
  Result := Format('%s, %.2d %s %4d %.2d:%.2d:%.2d %s', [
    Weekday[DayOfWeek(dt)], iDay, Month[iMonth], iYear,
      iHour, iMinute, iSecond, strZone]);
end;

function RfcTimeToDateTime(
  strTime: string;
  blnGMT: boolean = true): TDateTime;
{*
Explanation:
if blnGMT then Result is UNC time else local time
e.g. local time zone: ET = GMT - 5hr = -0500
    strTime = 'Wed, 03 Jan 2001 05:45:00 -0500'
      blnGMT = true  -> FormatDateTime('...', Result) = '03.01.2001 10:45:00'
      blnGMT = false -> FormatDateTime('...', Result) = '03.01.2001 05:45:00'
*}
const
  wd = 'sun#mon#tue#wed#thu#fri#sat';
  month = 'janfebmaraprmayjunjulaugsepoctnovdec';
var
  s: string;
  dd: Word;
  mm: Word;
  yy: Word;
  hh: Word;
  nn: Word;
  ss: Word;
begin
  s := LowerCase(Copy(strTime, 1, 3));
  if Pos(s, wd) > 0 then
    Delete(strTime, 1, Pos(' ', strTime));
  s := Trim(Copy(strTime, 1, Pos(' ', strTime)));
  Delete(strTime, 1, Length(s) + 1);
  dd := StrToIntDef(s, 0);
  s := LowerCase(Copy(strTime, 1, 3));
  Delete(strTime, 1, 4);
  mm := (Pos(s, month) div 3) + 1;
  s := Copy(strTime, 1, 4);
  Delete(strTime, 1, 5);
  yy := StrToIntDef(s, 0);
  Result := EncodeDate(yy, mm, dd);
  s := strTime[1] + strTime[2];
  hh := StrToIntDef(strTime[1] + strTime[2], 0);
  nn := StrToIntDef(strTime[4] + strTime[5], 0);
  ss := StrToIntDef(strTime[7] + strTime[8], 0);
  Delete(strTime, 1, 9);
  Result := Result + EncodeTime(hh, nn, ss, 0);
  if (CompareText(strTime, 'gmt') <> 0) and blnGMT then
  begin
    hh := StrToIntDef(strTime[2] + strTime[3], 0);
    nn := StrToIntDef(strTime[4] + strTime[5], 0);
    if strTime[1] = '+' then
      Result := Result - EncodeTime(hh, nn, 0, 0)
    else
      Result := Result + EncodeTime(hh, nn, 0, 0);
  end;
end;

Взято с

Delphi Knowledge Base

function RFC1123ToDateTime(Date: string): TDateTime;
var
  day, month, year: Integer;
  strMonth: string;
  Hour, Minute, Second: Integer;
begin
  try
    day      := StrToInt(Copy(Date, 6, 2));
    strMonth := Copy(Date, 9, 3);
    if strMonth = 'Jan' then month := 1
    else if strMonth = 'Feb' then month := 2
    else if strMonth = 'Mar' then month := 3
    else if strMonth = 'Apr' then month := 4
    else if strMonth = 'May' then month := 5
    else if strMonth = 'Jun' then month := 6
    else if strMonth = 'Jul' then month := 7
    else if strMonth = 'Aug' then month := 8
    else if strMonth = 'Sep' then month := 9
    else if strMonth = 'Oct' then month := 10
    else if strMonth = 'Nov' then month := 11
    else if strMonth = 'Dec' then month := 12;
    year   := StrToInt(Copy(Date, 13, 4));
    hour   := StrToInt(Copy(Date, 18, 2));
    minute := StrToInt(Copy(Date, 21, 2));
    second := StrToInt(Copy(Date, 24, 2));
    Result := 0;
    Result := EncodeTime(hour, minute, second, 0);
    Result := Result + EncodeDate(year, month, day);
  except
    Result := now;
  end;
end;

function DateTimeToRFC1123(aDate: TDateTime): string;
const
  StrWeekDay: string = 'MonTueWedThuFriSatSun';
  StrMonth: string = 'JanFebMarAprMayJunJulAugSepOctNovDec';
var
  Year, Month, Day: Word;
  Hour, Min, Sec, MSec: Word;
  DayOfWeek: Word;
begin
  DecodeDate(aDate, Year, Month, Day);
  DecodeTime(aDate, Hour, Min, Sec, MSec);
  DayOfWeek := ((Trunc(aDate) - 2) mod 7);
  Result    := Copy(StrWeekDay, 1 + DayOfWeek * 3, 3) + ', ' +
    Format('%2.2d %s %4.4d %2.2d:%2.2d:%2.2d',
    [Day, Copy(StrMonth, 1 + 3 * (Month - 1), 3),
    Year, Hour, Min, Sec]);
end;

Взято с сайта

Как конвертировать RGB в TColor

functionRGBToColor(R,G,B:Byte): TColor;
begin
       Result:=B Shl 16 Or
       G Shl 8 Or
       R;
end;

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

RGB -> TColor

RGB(r,g,b:byte):tcolor

TColor -> RGB

GetRValue(color:tcolor)
GetGValue(color:tcolor)
GetBValue(color:tcolor)

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

Как конвертировать виртуальную клавишу в ASCII код?

Получаем символ, соответствующий виртуальной клавише:

function GetCharFromVKey(vkey: Word): string;
var
  keystate: TKeyboardState;
  retcode: Integer;
begin
  Win32Check(GetKeyboardState(keystate));
  SetLength(Result, 2);
  retcode := ToAscii(vkey,
    MapVirtualKey(vkey, 0),
    keystate, @Result[1],
    0);
  case retcode of
    0: Result := '';
    1: SetLength(Result, 1);
    2: ;
    else
      Result := '';
  end;
end;

{
Использование:
procedure TForm1.Edit1KeyDown
  (Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  ShowMessage(GetCharFromVKey(Key));
end;
}

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

Как конвертировать WideString в String?

{:Converts Unicode string to Ansi string using specified code page.
  @param   ws       Unicode string.
  @param   codePage Code page to be used in conversion.
  @returns Converted ansi string.
}

function WideStringToString(const ws: WideString; codePage: Word): AnsiString;
var
  l: integer;
begin
  if ws = ' then
    Result := '
  else
  begin
    l := WideCharToMultiByte(codePage,
      WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
      @ws[1], - 1, nil, 0, nil, nil);
    SetLength(Result, l - 1);
    if l > 1 then
      WideCharToMultiByte(codePage,
        WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
        @ws[1], - 1, @Result[1], l - 1, nil, nil);
  end;
end; { WideStringToString }

{:Converts Ansi string to Unicode string using specified code page.
  @param   s        Ansi string.
  @param   codePage Code page to be used in conversion.
  @returns Converted wide string.
}
function StringToWideString(const s: AnsiString; codePage: Word): WideString;
var
  l: integer;
begin
  if s = ' then
    Result := '
  else
  begin
    l := MultiByteToWideChar(codePage, MB_PRECOMPOSED, PChar(@s[1]), - 1, nil, 0);
    SetLength(Result, l - 1);
    if l > 1 then
      MultiByteToWideChar(CodePage, MB_PRECOMPOSED, PChar(@s[1]),
        - 1, PWideChar(@Result[1]), l - 1);
  end;
end; { StringToWideString }

Взято с сайта

Как копировать и удалять таблицы?

Here is an example of a routine that I use for copying and deleting tables. It uses DB, DBTables, DbiProcs,DbiErrs, and DbiTypes.

You simply provide the directory to copy from, the source table name, the directory to copy to, and the destination table name, and the BDE will copy the entire table, indexes and all to the new file.

The delete function takes the path to delete from and the name of the table to delete, the BDE takes care of deleting all associated files (indexes, etc.).

These procedures have been pulled off a form of mine, and I've edited them to remove some dependencies that existed with that form. They should now be completely stand-alone.

procedureTConvertForm.CopyTable(FromDir, SrcTblName, ToDir, DestTblName: string);
var
  DBHandle: HDBIDB;
  ResultCode: DBIResult;
  Src, Dest, Err: array[0..255] of Char;
  SrcTbl, DestTbl: TTable;
begin
  SrcTbl := TTable.Create(Application);
  DestTbl := TTable.Create(Application);
  try
    SrcTbl.DatabaseName := FromDir;
    SrcTbl.TableName := SrcTblName;
    SrcTbl.Open;
    DBHandle := SrcTbl.DBHandle;
    SrcTbl.Close;
    ResultCode := DbiCopyTable(DBHandle, false,
      StrPCopy(Src, FromDir + '\' + SrcTblName), nil,
      StrPCopy(Dest, ToDir + '\' + DestTblName));
    if ResultCode <> DBIERR_NONE then
    begin
      DbiGetErrorString(ResultCode, Err);
      raise EDatabaseError.Create('While copying ' +
        FromDir + '\' + SrcTblName + ' to ' +
        ToDir + '\' + DestTblName + ', the '
        + ' database engine   generated the error '''
        + StrPas(Err) + '''');
    end;
  finally
    SrcTbl.Free;
    DestTbl.Free;
  end;
end;

procedure TConvertForm.DeleteTable(Dir, TblName: string);
var
  DBHandle: HDBIDB;
  ResultCode: DBIResult;
  tbl, Err: array[0..255] of Char;
  SrcTbl, DestTbl: TTable;
begin
  SrcTbl := TTable.Create(Application);
  try
    SrcTbl.DatabaseName := Dir;
    SrcTbl.TableName := TblName;
    SrcTbl.Open;
    DBHandle := SrcTbl.DBHandle;
    SrcTbl.Close;
    ResultCode := DbiDeleteTable(DBHandle,
      StrPCopy(Tbl, Dir + '\' + TblName), nil);
    if ResultCode <> DBIERR_NONE then
    begin
      DbiGetErrorString(ResultCode, Err);
      raise EDatabaseError.Create('While deleting ' +
        Dir + '\' + TblName + ', the database ' +
        'engine generated the error ''' + StrPas(Err) + '''');
    end;
  finally
    SrcTbl.Free;
  end;
end;

Взято с

Delphi Knowledge Base

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

Некоторые функции для копирования и вставки Bitmap-объектов через буфер обмена.

function CopyClipToBuf(DC: HDC; Left, Top, Width, Height: Integer;  Rop: LongInt; var CopyDC: HDC; var CopyBitmap: HBitmap): Boolean;
var
  TempBitmap: HBitmap;
begin
  Result := False;
  CopyDC := 0;
  CopyBitmap := 0;
  if DC <> 0 then
    begin
      CopyDC := CreateCompatibleDC(DC);
      if CopyDC <> 0 then
        begin
          CopyBitmap := CreateCompatibleBitmap(DC, Width, Height);
          if CopyBitmap <> 0 then
            begin
              TempBitmap := CopyBitmap;
              CopyBitmap := SelectObject(CopyDC, CopyBitmap);
              Result := BitBlt(CopyDC, 0, 0, Width, Height, DC, Left, Top, Rop);
              CopyBitmap := TempBitmap;
            end;
        end;
    end;
end;

function CopyBufToClip(DC: HDC; var CopyDC: HDC; var CopyBitmap: HBitmap;
           Left, Top, Width, Height: Integer;
           Rop: LongInt; DeleteObjects: Boolean): Boolean;
var
  TempBitmap: HBitmap;
begin
  Result := False;
  if (DC <> 0) and (CopyDC <> 0) and (CopyBitmap <> 0) then
    begin
      TempBitmap := CopyBitmap;
      CopyBitmap := SelectObject(DC, CopyBitmap);
      Result := BitBlt(DC, Left, Top, Width, Height, CopyDC, 0, 0, Rop);
      CopyBitmap := TempBitmap;
      if DeleteObjects then
        begin
          DeleteDC(CopyDC);
          DeleteObject(CopyBitmap);
        end;
    end;
end;

Как копировать и вставлять TreeNode?

var
SL : TStringList;

procedure TForm1.CutBtnClick(Sender: TObject);
var
   i, j, StartLevel : integer;
   TNSel : TTreeNode;
begin
   TNSel := TreeView1.Selected;
   if TNSel <> nil then begin
     StartLevel := TNSel.Level;
     i := TNSel.AbsoluteIndex;
     j := i; // note for later deletion
     if SL = nil then
       SL := TStringList.Create
     else
       SL.Clear;
     SL.AddObject(TNSel.Text, pointer(0));
     inc(i);
     with TreeView1 do begin
       while Items[i].Level > StartLevel do begin
         {stop before next sibling to top node\}
         SL.AddObject(Items[i].Text, pointer(Items[i].Level - StartLevel));
         inc(i);
       end; {while Items[i].Level > StartLevel\}
       Items[j].Delete;
     end; {with TreeView1\}
   end; {if TNSel <> nil\}
end;

procedure TForm1.PasteBtnClick(Sender: TObject);
var
   i, Level : integer;
   TNSel, TN : TTreeNode;
begin
   with TreeView1 do begin
     TNSel := Selected;
     if TNSel <> nil then begin
       TN := Items.Insert(TNSel, SL.Strings[0]);
       Level := integer(SL.Objects[0]); // should be 0
       for i := 1 to SL.Count - 1 do begin
         if integer(SL.Objects[i]) < Level then begin
           {go up one level\}
           TN := TN.Parent;
           Level := integer(SL.Objects[i]);
         end; {if integer(SL.Objects[i]) < Level\}
         if Level = integer(SL.Objects[i]) then
           {same level\}
           TN := Items.Add(TN, SL.Strings[i])
         else begin
           {go down one level\}
           TN := Items.AddChild(TN, SL.Strings[i]);
           Level := integer(SL.Objects[i]);
         end; {if Level = integer(SL.Objects[i])\}
       end; {for i := 1 to SL.Count - 1\}
     end; {if TNSel <> nil\}
   end; {with TreeView1\}
end;

Взято с

Как копировать образ экрана в файл

На форме у меня стоит TImage (его можно сделать невидимым)

uses JPEG;
...
var i: TJPEGImage;
begin
  try
    i := TJPEGImage.create;
    try
      i.CompressionQuality := 100;
      image.Width := screen.width;
      image.height := screen.height;
      DWH := GetDesktopWindow;
      GetWindowRect(DWH, DRect);
      DescDC := GetDeviceContext(DWH);
      Canv.Handle := DescDC;
      DRect.Left := 0;
      DRect.Top := 0;
      DRect.Right := screen.Width;
      DRect.Bottom := screen.Height;
      Image.Canvas.CopyRect(DRect, Canv, DRect);
      i.assign(Image.Picture.Bitmap);
      I.SaveToFile('M:\MyFile.jpg');
    finally
      i.free;
    end;
  except
  end;

Типы использованных переменных:

Dwh : HWND;
DRect: TRect;
DescDC : HDC;
Canv : TCanvas;

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

Как копировать RTF текст в буффер обмена?

{
You have to dig into the Rich Text Format if you want to copy text to the
clipboard that has format information embedded. The application you paste
this text into has to understand RTF, or the formatting will not show up.

OK, the first step is to register a clipboard format for RTF, since this is
not a predefined format:
}

Var
  CF_RTF : Word;

  CF_RTF := RegisterClipboardFormat('Rich Text Format');

{
The format name has to appear as typed above, this is the name used by MS
Word for Windows and similar MS products.

NOTE: The Richedit Unit declares a constant CF_RTF, which is NOT the
clipboard format handle but the string you need to pass to RegisterClipboard
format! So you can place Richedit into your uses clause and change the line
above to
}

  CF_RTF := RegisterClipboardFormat(Richedit.CF_RTF);

{
The next step is to build a RTF string with the embedded format information.
You will get a shock if you inspect the mess of RTF stuff W4W will put into
the clipboard if you copy just a few characters (the app below allows you to
inspect the clipboard), but you can get away with a lot less. The bare
minimum would be something like this (inserts an underlined 44444):
}

const
  testtext: PChar = '{\rtf1\ansi\pard\plain 12{\ul 44444}}';

{
The correct balance of opening and closing braces is extremely important, one
mismatch and the target app will not be able to interpret the text
correctly. If you want to control the font used for the pasted text you need
to add a fonttable (the default font is Tms Rmn, not the active font in the
target app!). See example app below, testtext2. If you want more info, the
full RTF specs can be found on www.microsoft.com, a subset is also described
in the Windows help compiler docs (hcw.hlp, comes with Delphi).
}

unit Clipfmt1;

interface

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

type
  TForm1 = class(TForm)
    MemFormats: TMemo;
    label1: TLabel;
    BtnShowFormats: TButton;
    BtnGetRTF: TButton;
    BtnSetRTF: TButton;
    MemExample: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure BtnShowFormatsClick(Sender: TObject);
    procedure BtnGetRTFClick(Sender: TObject);
    procedure BtnSetRTFClick(Sender: TObject);
  private
  public
    CF_RTF: Word;
  end;

var
  Form1: TForm1;

implementation

uses Clipbrd;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  // register clipboard format rtf
  CF_RTF := RegisterClipboardFormat('Rich Text Format');
  if CF_RTF = 0 then
  begin
    ShowMessage('Unable to register the Rich Text clipboard format!');
    Application.Terminate;
  end;
  BtnShowFormats.Click;
end;

// show clipboard formats
procedure TForm1.BtnShowFormatsClick(Sender: TObject);
var
  buf: array [0..60] of Char;
  n: Integer;
  fmt: Word;
  Name: string[30];
begin
  MemFormats.Clear;
  for n := 0 to Clipboard.FormatCount - 1 do
  begin
    fmt := Clipboard.Formats[n];
    if GetClipboardFormatName(fmt, buf, Pred(SizeOf(buf))) <> 0 then
      MemFormats.Lines.Add(StrPas(buf))
    else
    begin
      case fmt of
        1: Name := 'CF_TEXT';
        2: Name := 'CF_BITMAP';
        3: Name := 'CF_METAFILEPICT';
        4: Name := 'CF_SYLK';
        5: Name := 'CF_DIF';
        6: Name := 'CF_TIFF';
        7: Name := 'CF_OEMTEXT';
        8: Name := 'CF_DIB';
        9: Name := 'CF_PALETTE';
        10: Name := 'CF_PENDATA';
        11: Name := 'CF_RIFF';
        12: Name := 'CF_WAVE';
        13: Name := 'CF_UNICODETEXT';
        14: Name := 'CF_ENHMETAFILE';
        15: Name := 'CF_HDROP (Win 95)';
        16: Name := 'CF_LOCALE (Win 95)';
        17: Name := 'CF_MAX (Win 95)';
        $0080: Name := 'CF_OWNERDISPLAY';
        $0081: Name := 'CF_DSPTEXT';
        $0082: Name := 'CF_DSPBITMAP';
        $0083: Name := 'CF_DSPMETAFILEPICT';
        $008E: Name := 'CF_DSPENHMETAFILE';
        $0200..$02FF: Name := 'private format';
        $0300..$03FF: Name := 'GDI object';
        else
          Name := 'unknown format';
      end;
      MemFormats.Lines.Add(Name);
    end;
  end;
end;

// get rtf code from clipboard
procedure TForm1.BtnGetRTFClick(Sender: TObject);
var
  MemHandle: THandle;
begin
  with Clipboard do
  begin
    Open;
    try
      if HasFormat(CF_RTF) then
      begin
        MemHandle := GetAsHandle(CF_RTF);
        MemExample.SetTextBuf(GlobalLock(MemHandle));
        GlobalUnlock(MemHandle);
      end
      else
        MessageDlg('The clipboard contains no RTF text!',
          mtError, [mbOK], 0);
    finally
      Close;
    end;
  end;
end;

// set rtf code to the clipboard
procedure TForm1.BtnSetRTFClick(Sender: TObject);
const
  testtext: PChar = '{\rtf1\ansi\pard\plain 12{\ul 44444}}';
  testtext2: PChar = '{\rtf1\ansi' +
    '\deff4\deflang1033{\fonttbl{\f4\froman\fcharset0\fprq2 Times New Roman;}}' +
    '\pard\plain 12{\ul 44444}}';
  flap: Boolean = False;
var
  MemHandle: THandle;
  rtfstring: PChar;
begin
  with Clipboard do
  begin
    if flap then
      rtfstring := testtext2
    else
      rtfstring := testtext;
    flap := not flap;
    MemHandle := GlobalAlloc(GHND or GMEM_SHARE, StrLen(rtfstring) + 1);
    if MemHandle <> 0 then
    begin
      StrCopy(GlobalLock(MemHandle), rtfstring);
      GlobalUnlock(MemHandle);
      Open;
      try
        AsText := '1244444';
        SetAsHandle(CF_RTF, MemHandle);
      finally
        Close;
      end;
    end
    else
      MessageDlg('Global Alloc failed!',
        mtError, [mbOK], 0);
  end;
end;

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

Как копировать векторное изображение?

procedureTForm1.Button1Click(Sender: TObject);
var
  mf: TMetaFile;
  mfc: TMetaFileCanvas;
  i: integer;
  ClipBrdFormat: word;
  data: cardinal;
  palette: hPalette;
  p: array [0..90] of TPoint;
begin
  mf := TMetaFile.Create;
  mf.Width := 100;
  mf.Height := 100;
  mfc := TMetafileCanvas.Create(mf, 0);
  with mfc do
  begin
    Pen.Color := clBlack;
    FrameRect(ClipRect);

    MoveTo(0, 50);
    LineTo(100, 50);
    LineTo(95, 48);
    MoveTo(100, 50);
    LineTo(95, 52);

    MoveTo(50, 100);
    LineTo(50, 0);
    LineTo(48, 5);
    MoveTo(50, 0);
    LineTo(52, 5);

    Brush.Style := bsClear;
    Font.name := 'arial';
    Font.Size := 6;
    TextOut(55, 0, 'Y');
    TextOut(95, 38, 'X');

    Pen.Color := clRed;
    for i := low(p) to high(p) do
      p[i] := Point(i, round(50 - 30 * sin((i - 50) / 5)));
    Polyline(p);
  end;
  mfc.Free;
  mf.SaveToClipboardFormat(ClipBrdFormat, data, palette);

  OpenClipboard(Application.Handle);
  EmptyClipboard;
  SetClipboardData(ClipBrdFormat, data);
  CloseClipboard;

  mf.Inch := 200;
  Form1.Canvas.Draw(0, 0, mf);
  mf.Free;
end;

Взято с

Как корректно прервать выполнение SQL-запроса?

Дает ли Delphi возможность корректно прервать выполнение SQL-запроса к серверу Oracle с помощью BDE? Например, чтобы при использовании с SQL Plus после отправки SQL-запроса на выполнение на экране появлялось окно с кнопкой Cancel, которое давало бы возможность в любой момент прервать выполнение этого запроса?

Насколько мне известно, для этой цели лучше всего использовать функции Oracle Call Interface (низкоуровневый API Oracle). В комплекте поставки Oracle есть соответствующие примеры для C, и переписать их на Pascal несложно.

Некоторые драйверы SQL Link позволяют прекратить выполнение запроса, если время его выполнения превышает заранее заданное значение (параметр MAX QUERY TIME соответствующего драйвера). Однако драйвер ORACLE, к сожалению, в их число не входит.

Взято из

Как локализовать (русифицировать) ресурсы какого-либо пакета (runtime package)?

1) Вынимаете pесуpсы из этого модуля.
2) Пеpеводите их на дpугой язык. (напpимеp pусский)
3) Создаете в Delphi свой пpоект Dll-ки (с именем того модуля, из котоpого вы
вынули pесуpсы, напpимеp vcl30), в котоpый включаете _пеpеведенные_
pесуpсы:
{$R vcl30rus.res}
4) Собиpаете все это.
5) Пеpеименовываете полученную vcl30.Dll в vcl30.rus и кидаете ее в System.
Если вы хотите, пpиложение "говоpило" по pусски только тогда, когда в
pегиональных установках стоит Russia - то тогда это все.
Если же вы хотите, чтобы ваше пpиложение _всегда_ поднимало pусские pесуpсы,
то необходимо сделать следующее добавление в Registry:
HKEY_CURRENT_USER\SOFTWARE\Borland\Delphi\Locales
"X:\MyProject\MyApp.exe" = "rus"

Тепеpь, когда ваше пpиложение будет поднимать pakages, то всегда будут бpаться
pусские pесуpсы. Дpугие пpиложения, напpимеp Delphi - это не затpонет.
Таким обpазом можно заменять даже DFM-ки из пpоекта.

Более подpобно об этом - см Help - Index - Localizing...

Alexander Simonenko .alex@protec.kiev.ua.(2:463/249)

Как менять шрифт в RichEdit горячими клавишами?

Следующий пример показывает, как можно изменять шрифт в компоненте TRichEdit при помощи следующих комбинаций клавиш:

Ctrl + B - Включает и выключает жирность (Bold) шрифта
Ctrl + I - Включает и выключает (Italic) шрифта
Ctrl + S - Включает и выключает зачёркивание (Strikeout) шрифта
Ctrl + U - Включает и выключает подчёркивание (Underline) шрифта

Замечание: Так же можно устанавливать сразу несколько типов шрифта.

Пример:

const
  KEY_CTRL_B = 02;
  KEY_CTRL_I =  9;
  KEY_CTRL_S = 19;
  KEY_CTRL_U = 21;

procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char);
begin
  case Ord(Key) of
    KEY_CTRL_B: begin
      Key := #0;
      if fsBold in (Sender as TRichEdit).SelAttributes.Style then
      (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style - [fsBold] else
      (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style + [fsBold];
    end;
    KEY_CTRL_I: begin
      Key := #0;
      if fsItalic in
      (Sender as TRichEdit).SelAttributes.Style then
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style - [fsItalic]
      else
       (Sender as TRichEdit).SelAttributes.Style :=
       (Sender as TRichEdit).SelAttributes.Style + [fsItalic];
    end;
    KEY_CTRL_S: begin
       Key := #0;
      if fsStrikeout in
      (Sender as TRichEdit).SelAttributes.Style then
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style - [fsStrikeout]
      else
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style + [fsStrikeout];
    end;
    KEY_CTRL_U: begin
       Key := #0;
      if fsUnderline in
      (Sender as TRichEdit).SelAttributes.Style then
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style - [fsUnderline]
      else
        (Sender as TRichEdit).SelAttributes.Style :=
        (Sender as TRichEdit).SelAttributes.Style + [fsUnderline];
    end;
  end;
end;

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

Как мне избавиться от выскакивающего окна CPU при ошибках?

HKEY_CURRENT_USER\Software\Borland\Delphi\4.0\Debugging

ViewCPUOnException=0

Взято с сайта

Как мне отправить на принтер чистый поток данных?

Под Win16 Вы можете использовать функцию SpoolFile, или
Passthrough escape, если принтер поддерживает последнее.
Под Win32 Вы можете использовать WritePrinter.

'иже пример открытия принтера и записи чистого потока данных в принтер.
Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet
5MP",
чтобы функция сработала успешно.

Конечно, Вы можете включать в поток данных любые необходимые управляющие коды,

которые могут потребоваться.

uses WinSpool;

procedure WriteRawStringToPrinter(PrinterName:String; S:String);
var
  Handle: THandle;
  N: DWORD;
  DocInfo1: TDocInfo1;
begin
  if not OpenPrinter(PChar(PrinterName), Handle, nil) then
  begin
    ShowMessage('error ' + IntToStr(GetLastError));
    Exit;
  end;
  with DocInfo1 do begin
    pDocName := PChar('test doc');
    pOutputFile := nil;
    pDataType := 'RAW';
  end;
  StartDocPrinter(Handle, 1, @DocInfo1);

  StartPagePrinter(Handle);
  WritePrinter(Handle, PChar(S), Length(S), N);
  EndPagePrinter(Handle);
  EndDocPrinter(Handle);
  ClosePrinter(Handle);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WriteRawStringToPrinter('HP', 'Test This');
end;

(Borland FAQ N714, переведен Акжаном Абдулиным)

Взято с сайта

Как мне узнать о воздействии мыши на иконку, находящуюся на Tray?

При добавлении иконки на Tray вы указывали окно - обработчик сообщения и сообщение (CallbackMessage). Теперь окно, указанное вами будет при любых событиях мыши, происходящих над иконкой получать сообщение, указанное при добавлении иконки. При этом параметры lParam и wParam будут задействованы следующим образом:

(UINT)wParam - содержит ID иконки, над которой произошло
событие
(UINT)lParam - содержит стандартное событие мыши, такое
как WM_MOUSEMOVE или WM_LBUTTONDOWN.

При этом, информация о клавишах смены регистра, так же как и местоположения события, передаваемые при стандартных " настоящих" сообщениях мыши, теряются. Hо положение курсора можно узнать функцией GetCursorPos(), а состояние клавиш смены регистра - функцией GetKeyState(), описанных в winuser.h.

Взято из FAQ:

Как можно гарантированно очистить экран в консольном приложении?

Автор: Олег Кулабухов

Нужно просто использовать GetConsoleScreenBufferInfo() для ввода нескольких пустых строк.

programProject1;
{$APPTYPE CONSOLE}
uses
  Windows;
{$R *.RES}
var
  sbi: TConsoleScreenBufferInfo;
  i: integer;
begin
  Writeln('A Console Applicaiton');
  Writeln('Press Enter To Clear The Screen');
  GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
    sbi);
  Readln;
  GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
    sbi);
  for i := 0 to sbi.dwSize.y do
    writeln;
  Writeln('Press Enter To End');
  Readln;
end.

Взято с

Как можно из своей программы закрыть чужую?

PostThreadMessage(AnotherProg_MainThreadID,WM_CLOSE,0,0);
PostMessage(AnotherProg_MainWindow,WM_CLOSE,0,0);

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

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

Как можно определить Handle окна,над которым находится мышка?

WindowFromPoint
ChildWindowFromPoint

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

Как можно открыть отчёт (в режиме Print Preview а также print direct) в MS Access ?

var
  Access: Variant;
begin
  // Открываем Access
  try
    Access := GetActiveOleObject('Access.Application');
  except
    Access := CreateOleObject('Access.Application');
  end;
  Access.Visible := True;

  // Открываем базу данных
  // Второй параметр указывает - будет ли база открыта в Exclusive режиме
  Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);

  // открываем отч?т
  {Значение второго пораметра может быть одним из следующих
  acViewDesign, acViewNormal, or acViewPreview. acViewNormal,
  которые устанавливаются по умолчанию, для печати отч?та.
  Если Вы не используете библиотеку типов, то можете определить
  эти значения следующими:

  const
  acViewNormal = $00000000;
  acViewDesign = $00000001;
  acViewPreview = $00000002;

  Третий параметр - это имя очереди для текущей базы данных.
  Четв?ртый параметр - это строка для SQL-евского WHERE -
  то есть строка SQL, минус WHERE.}

  Access.DoCmd.OpenReport('Titles by Author', acViewPreview, EmptyParam,
    EmptyParam);

  < ... >

  // Закрываем базу данных
  Access.CloseCurrentDatabase;

  // Закрываем Access
  {const
  acQuitPrompt = $00000000;
  acQuitSaveAll = $00000001;
  acQuitSaveNone = $00000002;}
  Access.Quit(acQuitSaveAll);
end;

Как можно отменить реакию ComboBox на F4?

procedure TForm1.ComboBox1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key=vk_F4 then key:=0;
end;

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

Как можно перекодировать сообщение (содержание) из Win в КОИ8-Р для отправки по EMail?

const
Koi: Array[0..66] of Char = ("T", "Ё", "ё", "А", "Б", "В", "Г", "Д", "Е", "Ж",
                "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р",
                "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ",
                "Ы", "Ь", "Э", "Ю", "Я", "а", "б", "в", "г", "д",
                "е", "ж", "з", "и", "й", "к", "л", "м", "н", "о",
                "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш",
                "щ", "ъ", "ы", "ь", "э", "ю", "я");
Win: Array[0..66] of Char = ("ё", "Ё", "T", "ю", "а", "б", "ц", "д", "е", "ф",
                "г", "х", "и", "й", "к", "л", "м", "н", "о", "п",
                "я", "р", "с", "т", "у", "ж", "в", "ь", "ы", "з",
                "ш", "э", "щ", "ч", "ъ", "Ю", "А", "Б", "Ц", "Д",
                "Е", "Ф", "Г", "Х", "И", "Й", "К", "Л", "М", "Н",
                "О", "П", "Я", "Р", "С", "Т", "У", "Ж", "В", "Ь",
                "Ы", "З", "Ш", "Э", "Щ", "Ч", "Ъ");

function WinToKoi(Str: String): String;
var
i, j, Index: Integer;
begin
Result := ""

for i := 1 to Length(Str) do
begin
  Index := -1;
  for j := Low(Win) to High(Win) do
   if Win[j] = Str[i] then
   begin
    Index := j;
    Break;
   end;

  if Index = -1 then Result := Result + Str[i]
         else Result := Result + Koi[Index];
end;
end;

function KoiToWin(Str: String): String;
var
i, j, Index: Integer;
begin
Result := ""

for i := 1 to Length(Str) do
begin
  Index := -1;
  for j := Low(Win) to High(Win) do
   if Koi[j] = Str[i] then
   begin
    Index := j;
    Break;
   end;

  if Index = -1 then Result := Result + Str[i]
         else Result := Result + Win[Index];
end;
end;

procedure SendFileOnSMTP(Host: String;
             Port: Integer;
             Subject,
             FromAddress, ToAddress,
             Body,
             FileName: String);
var
NMSMTP: TNMSMTP;
begin
if DelSpace(ToAddress) = "" then Exit;
if ToAddress[1] = "" then Exit;

if (DelSpace(FileName) <> "") and not FileExists(FileName) then
  raise Exception.Create("SendFileOnSMTP: file not exist: " + FileName);

NMSMTP := TNMSMTP.Create(nil);
try
  NMSMTP.Host := Host;
  NMSMTP.Port := Port;
  NMSMTP.Charset := "koi8-r"
  NMSMTP.PostMessage.FromAddress := FromAddress;
  NMSMTP.PostMessage.ToAddress.Text := ToAddress;
  NMSMTP.PostMessage.Attachments.Text := FileName;
  NMSMTP.PostMessage.Subject := Subject;
  NMSMTP.PostMessage.Date := DateTimeToStr(Now);
  NMSMTP.UserID := "netmaster"
  NMSMTP.PostMessage.Body.Text := WinToKoi(Body);
  NMSMTP.FinalHeader.Clear;
  NMSMTP.TimeOut := 5000;
  NMSMTP.Connect;
  NMSMTP.SendMail;
  NMSMTP.Disconnect;
finally
  NMSMTP.Free;
end;
end;

Взято с сайта

Как можно получить звук с микрофона?

unit receiver;
interface
uses mmsystem, classes;
const
samp_per_sec = 44100;
samp_cnt = samp_per_sec div 5;
buf_len = samp_cnt * 2;
type
PSample16M = ^TSample16M;
TSample16M = SmallInt;
PArrayOfSample = ^TArrayOfSample;
TArrayOfSample = array[1..samp_cnt] of TSample16M;
TReceiver = class
private
hwi: Integer;
fmt: tWAVEFORMATEX;
whdr1: WAVEHDR;
buf1: TArrayOfSample;
whdr2: WAVEHDR;
buf2: TArrayOfSample;
FStoped: Boolean;
FOnChange: TNotifyEvent;
procedure SetStoped(const Value: Boolean);
public
Peak: Integer;
Buffer: PArrayOfSample;
destructor Destroy; override;
procedure Start;
procedure Stop;
property Stoped: Boolean read FStoped write SetStoped;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
var rec: TReceiver;

implementation

procedure waveInProc(const hwi, uMsg, dwInstance: Integer; var hdr: WAVEHDR; const dwP2: Integer); stdcall;
const divs = samp_cnt div 100;
var
i, p: Integer;
buf: PArrayOfSample;
begin
if rec.Stoped then Exit;
case uMsg of
WIM_OPEN: begin end;
WIM_DATA: begin
rec.Buffer := PArrayOfSample(hdr.lpData);
buf := PArrayOfSample(hdr.lpData);
p := 0;
for i := 0 to samp_cnt div divs do p := p + Abs(buf[i * divs]);
rec.Peak := p div (samp_cnt div divs);
if Assigned(rec.FOnChange) then rec.FOnChange(rec);
waveInUnprepareHeader(hwi, @hdr, SizeOf(WAVEHDR));
waveInPrepareHeader(hwi, @hdr, SizeOf(WAVEHDR));
waveInAddBuffer(hwi, @hdr, SizeOf(WAVEHDR));
end;
WIM_CLOSE: begin end;
end;
end;

{ TReceiver }

destructor TReceiver.Destroy;
begin
Stoped := True;
inherited;
end;

procedure TReceiver.SetStoped(const Value: Boolean);
begin
FStoped := Value;
if Value then
begin
waveInStop(hwi);
waveInUnprepareHeader(hwi, @whdr1, SizeOf(WAVEHDR));
waveInUnprepareHeader(hwi, @whdr2, SizeOf(WAVEHDR));
waveInReset(hwi);
waveInClose(hwi);
end
else
begin
with fmt do
begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := 1;
nSamplesPerSec := samp_per_sec;
nBlockAlign := 2;
nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
wBitsPerSample := 16;
cbSize := 0;
end;
waveInOpen(@hwi, WAVE_MAPPER, @fmt, Cardinal(@waveInProc), hInstance, CALLBACK_FUNCTION);
with whdr1 do
begin
lpData := @buf1;
dwBufferLength := buf_len;
dwBytesRecorded := 0;
dwUser := 0;
dwFlags := 0;
dwLoops := 0;
lpNext := nil;
reserved := 0;
end;
waveInPrepareHeader(hwi, @whdr1, SizeOf(WAVEHDR));
waveInAddBuffer(hwi, @whdr1, SizeOf(WAVEHDR));
with whdr2 do
begin
lpData := @buf2;
dwBufferLength := buf_len;
dwBytesRecorded := 0;
dwUser := 0;
dwFlags := 0;
dwLoops := 0;
lpNext := nil;
reserved := 0;
end;
waveInPrepareHeader(hwi, @whdr2, SizeOf(WAVEHDR));
waveInAddBuffer(hwi, @whdr2, SizeOf(WAVEHDR));
waveInStart(hwi);
end;
end;

procedure TReceiver.Start;
begin
Stoped := False;
end;

procedure TReceiver.Stop;
begin
Stoped := True;
end;

initialization
rec := TReceiver.Create;
finalization
rec.Free;
end.

вот. отображать уровень можно через поле Peak при событии OnChange, там же (в этом событии) можно работать с полем Buffer в котором как раз содержется записанный сигнал.
Вся работа осуществляется через глобальную переменную rec . Возможно это не лучшая реализация с точки зрения ООП, но работает Запись происходит с глубиной 16 бит и частотой 44100 в режиме моно. После небольшой переделки все это может работать с любыми частотами и каналами и глубинами.

Автор cully
Взято с Vingrad.ru

Как изменить оконную процедуру для TForm?

Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог.

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure WndProc(var Message: TMessage); override;
    procedure Button1Click(Sender: TObject);
  private
  {Private declarations}
  public
  {Public declarations}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WndProc(var Message: TMessage);
begin
  if Message.Msg = WM_CANCELMODE then
    begin
      Form1.Caption := 'A dialog or message box has popped up';
    end
  else
    inherited // <- остальное сделает родительская процедура
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('Test Message');
end;

Как изменить порт для принтера?

Взято с

Delphi Knowledge Base

Как изменить размеры полигона?

Взято с

Delphi Knowledge Base

Как изменить шрифт hint?

Как изменить шрифт и выравнивание в заголовке формы?

Взято с

Delphi Knowledge Base

Как изменить шрифт определённой строки в DBGrid?

Как изменить системное время?

Как изменить стандартный цвет ProgressBar?

Как изменить уровень громкости микрофона?

Как изменить заголовок чужого окна?

SetWindowText(FindWindow(nil,'Текущий заголовок'), 'Желаемый');

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

Как изменить значение свойства компонента по имени?

Взято из

Как извлечь иконку из EXE или DLL?

Как я могу работать с IB с клиентского компьютера?

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

Взято из

FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349

Как экспортировать процедуру в EXE файле

Как экспортировать содержимое DBGrid в Excel или ClipBoard?

Как экспортировать StringGrid в MS Word таблицу?

Как экспортировать таблицу базы данных в ASCII-файл?

Как экспортировать таблицу в MS Word в TStringGrid?

Как экспортировать все таблицы в CSV файл?

Взято с

Delphi Knowledge Base

Как экстрагировать аудиодорожку из AVI файла?

Как экстрагировать фрейм из AVI?

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

Как качественно увеличить изображение при помощи билинейной интерполяции

Как клонировать процесс?

Как консольное приложение может узнать, что Винды завершаются?

Взято с

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

uCodePageConverter

SAMPLE

Взято с

Delphi Knowledge Base

Как конвертировать RFC дату и обратно?

Взято с

Как конвертировать RGB в TColor

functionRGBToColor(R,G,B:Byte): TColor;
begin
       Result:=B Shl 16 Or
       G Shl 8 Or
       R;
end;

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

RGB -> TColor

RGB(r,g,b:byte):tcolor

TColor -> RGB

GetRValue(color:tcolor)
GetGValue(color:tcolor)
GetBValue(color:tcolor)

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

Как конвертировать виртуальную клавишу в ASCII код?

Как конвертировать WideString в String?

Как копировать и удалять таблицы?

Взято с

Delphi Knowledge Base

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

Как копировать и вставлять TreeNode?

Взято с

Как копировать образ экрана в файл

Как копировать RTF текст в буффер обмена?

Как копировать векторное изображение?

Взято с

Как корректно прервать выполнение SQL-запроса?

Взято из

Как локализовать (русифицировать) ресурсы какого-либо пакета (runtime package)?

Как менять шрифт в RichEdit горячими клавишами?

Как мне избавиться от выскакивающего окна CPU при ошибках?

HKEY_CURRENT_USER\Software\Borland\Delphi\4.0\Debugging

ViewCPUOnException=0

Взято с сайта

Как мне отправить на принтер чистый поток данных?

Как мне узнать о воздействии мыши на иконку, находящуюся на Tray?

Как можно гарантированно очистить экран в консольном приложении?

Взято с

Как можно из своей программы закрыть чужую?

Как можно определить Handle окна,над которым находится мышка?

WindowFromPoint
ChildWindowFromPoint

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

Как можно открыть отчёт (в режиме Print Preview а также print direct) в MS Access ?

Как можно отменить реакию ComboBox на F4?

procedure TForm1.ComboBox1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key=vk_F4 then key:=0;
end;

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

Как можно перекодировать сообщение (содержание) из Win в КОИ8-Р для отправки по EMail?

Как можно получить звук с микрофона?