Delphi - база знаний

         

Как изменить оконную процедуру для 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;



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


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





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?


Как изменить шрифт 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?


Как изменить шрифт определённой строки в 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?



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

А вот при помощи следующей команды можно разукрасить 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?


Как извлечь иконку из 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 с клиентского компьютера?





Можно использовать 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 файле


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



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


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





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


Как экспортировать содержимое 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 таблицу?


Как экспортировать 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-файл?


Как экспортировать таблицу базы данных в 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?


Как экспортировать таблицу в 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 файл?


Как экспортировать все таблицы в 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 файла?


Как экстрагировать аудиодорожку из 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?


Как экстрагировать фрейм из 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 дату и обратно?


Как конвертировать 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


Как конвертировать 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 код?


Как конвертировать виртуальную клавишу в 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?


Как конвертировать 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 через буфер обмена?




Некоторые функции для копирования и вставки 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?


Как копировать и вставлять 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 текст в буффер обмена?


Как копировать 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-запроса?


Как корректно прервать выполнение 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)?


Как локализовать (русифицировать) ресурсы какого-либо пакета (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 горячими клавишами?


Как менять шрифт в 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 при ошибках?


Как мне избавиться от выскакивающего окна 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?




При добавлении иконки на 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 окна,над которым находится мышка?


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



WindowFromPoint
ChildWindowFromPoint

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





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


Как можно открыть отчёт (в режиме 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?


Как можно перекодировать сообщение (содержание) из 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;



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


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





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?


Как изменить шрифт 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?


Как изменить шрифт определённой строки в 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?



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

А вот при помощи следующей команды можно разукрасить 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?


Как извлечь иконку из 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 с клиентского компьютера?





Можно использовать 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 файле


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



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


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





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


Как экспортировать содержимое 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 таблицу?


Как экспортировать 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-файл?


Как экспортировать таблицу базы данных в 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?


Как экспортировать таблицу в 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 файл?


Как экспортировать все таблицы в 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 файла?


Как экстрагировать аудиодорожку из 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?


Как экстрагировать фрейм из 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 дату и обратно?


Как конвертировать 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


Как конвертировать 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 код?


Как конвертировать виртуальную клавишу в 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?


Как конвертировать 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 через буфер обмена?




Некоторые функции для копирования и вставки 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?


Как копировать и вставлять 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 текст в буффер обмена?


Как копировать 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-запроса?


Как корректно прервать выполнение 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)?


Как локализовать (русифицировать) ресурсы какого-либо пакета (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 горячими клавишами?


Как менять шрифт в 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 при ошибках?


Как мне избавиться от выскакивающего окна 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?




При добавлении иконки на 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 окна,над которым находится мышка?


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



WindowFromPoint
ChildWindowFromPoint

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





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


Как можно открыть отчёт (в режиме 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?


Как можно перекодировать сообщение (содержание) из 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