Отправляет email-рассылки с помощью сервиса Sendsay
  Все выпуски  

Часто задаваемые вопросы по программированию в Delphi 16.09.02


Информационный Канал Subscribe.Ru


Частые вопросы по программированию в Delphi

 ВОПРОСЫ:

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

function CopyClipToBuf(DC: HDC; Left, Top, Width, Height:Integer; Rop:LongInt; varCopyDC: 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;

2. Как читать и записывать звук ?

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

При нажатии Button1 создается звуковой файл в памяти (то есть в памяти создается заголовок,
затем идут данные - все точно так же, как в обычном wav-файле), сохраняется на диск и одновременно
 начинает воспроизводиться. Для этого используется функция playsound.
Остановить воспроизведение можно кнопкой Button2.

При нажатии Button3 открывается файл ex.wav (если Вы уже нажимали Button1, то он существует).
Далее из файла считываются данные и для каждого канала находится средняя громкость.
Не уверен, что это самый правильный способ, но здесь за громкость
 я взял просто среднее арифметическое.
Результаты выводятся в заголовок окна. Для каждого канала выводится значение
в процентах от максимально возможной громкости.

Теперь о самой структуре данных. Она очень проста. Если канал один, то данные записаны подряд:
первое значение,
второе значение,
третье значение
...
Если же в файле два канала, то они чередуются:
первое значение первого канала, первое значение второго канала,
второе значение первого канала, второе значение второго канала,
третье значение первого канала, третье значение второго канала,
...
Если файл восьми битный, то каждое значение занимает 1 байт, если шестнадцати битный - 2 байта.
 Это соответствует типам shortint и smallint соответственно.


В этой программе данные записываются при помощи процедуры GetData.
 SaveSound вызывает ее для каждого значения.
В качестве параметров передаются канал и номер. А возвращаемое значение передается
 через нетипизированный параметр res. Такой подход позволяет избежать проблем с типами данных.

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

Скачать все необходимые для компиляции файлы проекта можно на program.dax.ru.

uses MMSystem, wavfile;

procedure TForm1.Button1Click(Sender: TObject);
const
  fr = 11025; {Частота в герцах}
  len = 1; {Длина звука в секундах}

  procedure GetData(ch: smallint; index: integer; var res);
  var
    v: smallint absolute res; // конечное значение
    amp: single; // амплитуда
  begin
    if ch = 0
      then amp := sin(index * 2 * Pi / (fr * len))
      else amp := cos(index * 2 * Pi / (fr * len));
    v := round(amp * (random(60000) - 30000));
  end;

var
  M: TMemoryStream; // поток для хранения информации в памяти
  F: TFileStream; // Поток для созранения файла
begin
  M := nil; F := nil;
  try
    M := TMemoryStream.Create;
    randomize;
    SaveSound(M {Куда записывать}, round(fr * len) {len секунд},
      fr {частота}, 16 {16 бит}, 2 {2 каналла}, @GetData);
    // Воспроизведение звука:
    if not playsound(M.Memory, 0, SND_MEMORY or SND_LOOP or SND_ASYNC)
      then ShowMessage('Can not play the sound');

    F := TFileStream.Create('ex.wav', fmCreate);
    M.Position := 0;
    F.CopyFrom(M, M.Size);
  finally
    M.Free; F.Free;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  playsound(nil, 0, 0); // Остановка воспроизведения
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  SampleCount, SamplesPerSec: integer;
  BitsPerSample, Channeles: smallint;
  F: TFileStream;
  Volume: array [0..1] of single;
  ToPercent: single;
  buf: pointer;
  buf8: ^shortint;
  buf16: ^smallint;
  i, ch: integer;
begin
  F := nil; buf := nil;
  try
    Volume[0] := 0; Volume[1] := 0;
    F := TFileStream.Create('ex.wav', fmOpenRead);
    ReadWaveHeader(F, SampleCount, SamplesPerSec,
      BitsPerSample, Channeles);

    // Чтение данных:
    GetMem(buf, SampleCount * Channeles * BitsPerSample);
    F.Read(buf^, SampleCount * Channeles * BitsPerSample);
    if BitsPerSample = 8 then begin
      buf8 := buf;
      for i := 0 to SampleCount - 1 do
        for ch := 0 to Channeles - 1 do begin
          Volume[ch] := Volume[ch] + abs(buf8^);
          inc(buf8); // Переход к следующему элементу
        end
    end else begin
      buf16 := buf;
      for i := 0 to SampleCount - 1 do
        for ch := 0 to Channeles - 1 do begin
          Volume[ch] := Volume[ch] + abs(buf16^);
          inc(buf16); // Переход к следующему элементу
        end;
    end;

    // Вывод результатов:
    ToPercent := (1 shl BitsPerSample) / 100 * SampleCount;
    if Channeles = 1
      then Form1.Caption := Format('volume: %2.2f%%',
        [Volume[0] / ToPercent])
      else Form1.Caption := Format('left: %2.2f%%, right: %2.2f%%',
        [Volume[0] / ToPercent, Volume[1] / ToPercent]);
  finally
    F.Free;
    FreeMem(buf);
  end;
end;

--------------------------------------------------------------------------------

unit wavfile;

interface

uses classes, sysutils;

type
  TWaveHeader = record
    idRiff: array [0..3] of char;
    RiffLen: longint;
    idWave: array [0..3] of char;
    idFmt: array [0..3] of char;
    InfoLen: longint;
    WaveType: smallint;
    Ch: smallint;
    Freq: longint;
    BytesPerSec: longint;
    align: smallint;
    Bits: smallint;
  end;

  TDataHeader = record
    idData: array [0..3] of char;
    DataLen: longint;
  end;

  TGetData = procedure(ch: smallint; index: integer; var res);
  TSetData = procedure(ch: smallint; index: integer; data: smallint);

procedure CreateWaveHeader(SampleCount, SamplesPerSec: integer;
  BitsPerSample, Channeles: smallint; var WaveHeader: TWaveHeader;
  var DataHeader: TDataHeader);
procedure ReadWaveHeader(Stream: TStream;
  var SampleCount, SamplesPerSec: integer;
  var BitsPerSample, Channeles: smallint);
procedure SaveSound(Stream: TStream; SampleCount, SamplesPerSec: integer;
  BitsPerSample, Channeles: smallint; GetData: TGetData);

implementation

procedure Creat
  BitsPerSample, Channeles: smallint; var WaveHeader: TWaveHeader;
  var DataHeader: TDataHeader);
var
  len: integer;
begin
  if (SampleCount < 0) or (SamplesPerSec < 1) or
    (not BitsPerSample in [8, 16]) or
    (not Channeles in [1, 2])
    then raise Exception.Create('Wrong params');

  len := SampleCount * BitsPerSample div 8 * Channeles;
  with WaveHeader do begin
    idRiff := 'RIFF';
    RiffLen := len + 38;
    idWave := 'WAVE';
    idFmt := 'fmt ';
    InfoLen := 16;
    WaveType := 1;
    Ch := Channeles;
    Freq := SamplesPerSec;
    BytesPerSec := SamplesPerSec * BitsPerSample div 8 * Channeles;
    align := Channeles * BitsPerSample div 8;
    Bits := BitsPerSample;
  end;
  with DataHeader do begin
    idData := 'data';
    DataLen := len;
  end;
end;

procedure ReadWaveHeader(Stream: TStream;
  var SampleCount, SamplesPerSec: integer;
  var BitsPerSample, Channeles: smallint);
var
  WaveHeader: TWaveHeader;
  DataHeader: TDataHeader;
begin
  Stream.Read(WaveHeader, sizeof(TWaveHeader));
  with WaveHeader do begin
    if idRiff < > 'RIFF' then raise EReadError.Create('Wrong idRIFF');
    if idWave < > 'WAVE' then raise EReadError.Create('Wrong idWAVE');
    if idFmt < > 'fmt ' then raise EReadError.Create('Wrong idFmt');
    if WaveType < > 1 then raise EReadError.Create('Unknown format');
    Channeles := Ch;
    SamplesPerSec := Freq;
    BitsPerSample := Bits;
    Stream.Seek(InfoLen - 16, soFromCurrent);
  end;
  Stream.Read(DataHeader, sizeof(TDataHeader));
  if DataHeader.idData = 'fact' then begin
    Stream.Seek(4, soFromCurrent);
    Stream.Read(DataHeader, sizeof(TDataHeader));
  end;
  with DataHeader do begin
    if idData < > 'data' then raise EReadError.Create('Wrong idData');
    SampleCount := DataLen div (Channeles * BitsPerSample div 8)
  end;
end;

procedure SaveSound(Stream: TStream; SampleCount, SamplesPerSec: integer;
  BitsPerSample, Channeles: smallint; GetData: TGetData);
var
  WaveHeader: TWaveHeader;
  DataHeader: TDataHeader;
  buf: smallint;
  BytesPerSample: smallint;
  i: integer;
begin
  CreateWaveHeader(SampleCount, SamplesPerSec, BitsPerSample,
    Channeles, WaveHeader, DataHeader);
  Stream.Write(WaveHeader, sizeof(TWaveHeader));
  Stream.Write(DataHeader, sizeof(TDataHeader));
  BytesPerSample := BitsPerSample div 8;
  if Channeles = 1
  then
    for i := 0 to SampleCount - 1 do begin
      GetData(0, i, buf);
      Stream.Write(buf, BytesPerSample);
    end
  else
    for i := 0 to SampleCount - 1 do begin
      GetData(0, i, buf);
      Stream.Write(buf, BytesPerSample);
      GetData(1, i, buf);
      Stream.Write(buf, BytesPerSample);
    end;
end;

end.

3. Как добится того чтобы TMemo и TEdit имели работали не только в режиме вставки символов, но и в режиме замены ?

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

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

var
    Form1: TForm1;

implementation

{$R *.DFM}

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

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

4. Как подключить сетевой диск ?

//Пример открытия стандартного диалога
procedure TForm1.Button1Click(Sender: TObject);
 begin
  WNetConnectionDialog(Handle,RESOURCETYPE_DISK)
 end;
//Так же можно подключить и принтер
procedure TForm1.Button1Click(Sender: TObject);
 begin
  WNetConnectionDialog(Handle,RESOURCETYPE_PRINT)
 end;
//либо можно использовать следующий код
procedure TForm1.Button2Click(Sender: TObject);
var NetResource: TNetResource;
begin { заполняем структуру TNetResource }
 NetResource.dwType:= RESOURCETYPE_DISK;
 NetResource.lpLocalName := 'S:';
 NetResource.lpRemoteName := '\\myserver\public';
 NetResource.lpProvider := '';
 { подключаем сетевой ресурс, используя структуру TNetResource }
 If ( WNetAddConnection2(NetResource,'', {Password (if needed) or empty}, '', {User name (if needed) or empty}, CONNECT_UPDATE_PROFILE)<>NO_ERROR)
  Then
  Raise Excepcion.Create('unable to map drive')
 //так же существуют другие константы для определения возникшей ошибки
 //ERROR_ACCESS_DENIED, ERROR_ALREADY_ASSIGNED, и т.д.
end;
//так же можно и отключить сетевой ресурс...
procedure TForm1.Button2Click(Sender: TObject);
begin
 if WNetCancelConnection2( 'S:',0,TRUE) <> NO_ERROR
  then
   Raise Exception.create('Error disconnecting map drive');
 //соответственно можно использовать другие константы для определения ошибки
 //ERROR_DEVICE_IN_USE, ERROR_NOT_CONNECTED, и т.д.
end;

5. Как изменить размер Jpeg и сохранить его в новый файл ?

procedure TForm1.Button1Click(Sender: TObject);
var
bmp: TBItmap;
jpg: TJpegImage;
scale: Double;
begin
if opendialog1.execute then begin
jpg:= TJpegImage.Create;
try
jpg.Loadfromfile( opendialog1.filename );
if jpg.Height > jpg.Width then
scale := 50 / jpg.Height
else
scale := 50 / jpg.Width;
bmp:= Tbitmap.Create;
try
{Create thumbnail bitmap, keep pictures aspect ratio}
bmp.Width := Round( jpg.Width * scale );
bmp.Height:= Round( jpg.Height * scale );
bmp.Canvas.StretchDraw( bmp.Canvas.Cliprect, jpg );
{Draw thumbnail as control}
Self.Canvas.Draw( 100, 10, bmp );
{Convert back to JPEG and save to file}
jpg.Assign( bmp );
jpg.SaveToFile(ChangeFileext( opendialog1.filename, '_thumb.JPG' ));
finally
bmp.free;
end;
finally
jpg.free;
end;
end;

 КРАТКОЕ СОДЕРЖАНИЕ СТАТЕЙ:

Работа с СОМ портом 

...Win API стандартизирует работу с оборудованием. Для получения доступа к аппаратуре используется следующая последовательность шагов:
1. Получить Handler устройства вызовом CreateFile с именем устройства. Более подробно см Windows SDK Help.
2. Для управления устройством вызывать функции API для данного устройства, либо посылать IOCTL(input - otput control) последнее через DeviceIOCtl(подробно см Windows SDK Help).
3. Закрыть устройство CloseHandle(Handler);...

 КОМПОНЕНТЫ:

Async Professional 3 

...Огромный набор компонент необходимых для работы с портами,модемами,факсами. Поддержка TAPI, голосовые функции...

Вопросы по программированию в Delphi - www.mydelphi.hoha.ru

С уважением, Сергей
mydelphi@hoha.ru
Здесь может быть и Ваш баннер тоже

http://subscribe.ru/
E-mail: ask@subscribe.ru
Отписаться
Убрать рекламу

В избранное