Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 3 апреля!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Запись и чтение из файла массива записей 2


 type TR=Record
         Name:string[100];
         Age:Byte;
         Income:Real;
        end;
 var f:file of TR;
     r:TR;
 
 begin
 //assign file 
   assignFile(f, 'MyFileName');
 //open file 
   if FileExists('MyFileName') then
     reset(f)
   else
     rewrite(f);
 //чтение 10й записи 
   seek(f,10);
   read(f,r);
 //запись 20й записи 
  seek(f, 20);
  write(f,r);
  closefile(f);
 end;
 




Чтение и запись звука

Автор: Даниил Карапетян
WEB сайт: http://program.dax.ru

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

При нажатии 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.
 




Скопировать строку в Буфер и прочитать её

По понятиям "чайников" -- "кофейники" просто ламеры...


 uses
   ClipBrd;
 
 procedure StrToClipbrd(StrValue: string);
 var
   S: string;
   hMem: THandle;
   pMem: PChar;
 begin
   hMem := GlobalAlloc(GHND or GMEM_SHARE, Length(StrValue) + 1);
   if hMem <> 0 then
   begin
     pMem := GlobalLock(hMem);
     if pMem <> nil then
     begin
       StrPCopy(pMem, StrValue);
       GlobalUnlock(hMem);
       if OpenClipboard(0) then
       begin
         EmptyClipboard;
         SetClipboardData(CF_TEXT, hMem);
         CloseClipboard;
       end
       else
         GlobalFree(hMem);
     end
     else
       GlobalFree(hMem);
   end;
 end;
 
 function GetStrFromClipbrd: string;
 begin
   if Clipboard.HasFormat(CF_TEXT) then
     Result := Clipboard.AsText
   else
   begin
     ShowMessage('There is no text in the Clipboard!');
     Result := '';
   end;
 end;
 
 
 // write "Hallo" to the clipboard and read it back. 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   StrToClipbrd('Hallo');
   ShowMessage(GetStrFromClipbrd);
 end;
 




Реализация событий COM+ в среде Delphi

Введение

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

GUI пользователя должен уметь обрабатывать различное количество событий, например, таких как: нажатие на кнопку мыши, перемещение мыши по экрану и т.д. Приблизительно так же может возникнуть потребность обрабатывать события внутри объектов COM. В данной статье мы рассмотрим принцип работы свободно связанных событий и создадим наглядное приложение для демонстрации использования такого типа событий в COM+. (Для более детальной информации о события в COM+ смотрите статью А.Новика «Система поддержки событий COM+» на сайте журнала «Клиент-Сервер»).

Что такое свободно связанные события? Понятие «Издатель-Подписчик»

До появления COM+, модель COM поддерживала систему событий, реализованную через интерфейс IConnectionPointContainer. Это жестко связанные события. (В данной статье, мы не будем рассматривать реализацию этого подхода). В COM+ появилось новое понятие: СВОБОДНО СВЯЗАННЫЕ СОБЫТИЯ (Loosely coupled events - LCE), разработанные для удовлетворения потребностей распределенных вычислений.

В COM+ Инициатор события (Издатель) и потребитель (Подписчик) свободно связаны.

Информация от различных издателей хранится в каталоге COM+, а подписчики указывают, какую информацию они хотят получать, регистрируясь в каталоге.

Архитектура событий в COM+

Для реализации свободно связанных событий вы должны создать компонент EventClass, который будет зарегистрирован в каталоге COM+. Подписчики вызываются объектом события, который определяет и активизирует объекты, подписанные на него.

Следует различать виды подписки. Существует временная и постоянная подписки:

Временная подписка (transient)
создается средствами административного API. Для более детальной информации можно обратиться в MSDN. Управлять жизненным циклом такой подписки нужно программными средствами. А не средствами ComponentServices.
Постоянная подписка (persistent)
создается средствами ComponentServices. Такая подписка в состоянии пережить перезапуск системы.

Фильтрация существует только в системе COM+. Такой возможности нет в системе жестко связанных событий. Её суть мы рассмотрим дальше, при более детальном изучении примера.

Пример реализации компонента EventClass

Допустим, у нас существует задача на базе существующей системы, функционирующей в среде COM+, реализовать систему ведения собственно журнала событий в текстовом файле. Для начала нам нужно реализовать компонент EventClass, о котором речь шла выше. Он будет представлять собой пустую заглушку для подписчика. Именно через него будут запускаться наши подписчики в каталоге COM+.

Когда компонент-издатель будет создавать событие, компонент EventClass передаст все входящие параметры события и активизирует всех подписчиков.

Важно! Метод события может содержать только входные параметры [in]. Выходным может быть только результирующий тип HRESULT, принятый в COM для определения статуса завершения S_OK, в результате удачи или E_FAIL, в результате неудачи выполнения метода.

Запустим среду Delphi, создадим простую ActiveX библиотеку и поместим в неё объект автоматизации (Automation Object). Определим нумератор типов ошибок и создадим интерфейс ISysLogEvent с методом ReportLog.


 type
 
 LogMessageTypes = TOleEnum;
 
 const
   lmtInformation = $00000000;
   lmtWarning = $00000001;
   lmtError = $00000002;
   lmtFatal = $00000003;
   lmtDebug = $00000004;
   lmtUnknown = $00000005;
 
 type
   TSysLogEvent = class(TAutoObject, ISysLogEvent)
   protected
   { Protected declarations }
     procedure ReportLog(enMsgType: LogMessageTypes; const strUserName,
       strModuleName, strMsgText: WideString); safecall;
 end;
 

В разделе Implementation создадим заглушку метода для EventClass:


 implementation
 
 uses
   ComServ;
 
 procedure TSysLogEvent.ReportLog(enMsgType: LogMessageTypes;
   const strUserName, strModuleName, strMsgText: WideString);
 begin
 
 // Event class methods are not implemented.
 
 end;
 
 initialization
 
 TAutoObjectFactory.Create(ComServer, TSysLogEvent, Class_SysLogEvent,
   ciMultiInstance, tmApartment);
 
 end.
 

На этом закончим. Остается зарегистрировать заглушку в нашем приложении COM+. Если приложение не создано, создайте его через средства ComponentServices.

Пример реализации Объекта-подписчика

После регистрации компонента EventClass создадим компонент-подписчик:

  1. Точно так же, как при создании компонента EventClass создадим библиотеку и объект автоматизации. Немного будет отличаться наполнение реализации методов и метод регистрации.
  2. Создадим интерфейс с методом, аналогичным методу интерфейса ILogEvent – ISysLog

Важно! Не забудьте подключить в вашу библиотеку типов зарегистрированную в ComponentServices библиотеку с заглушкой EventClass и укажите интерфейс ISysLogEvent в разделе Implements.

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


 unit SysLogUnit;
 
 interface
 
 uses
   ComObj, ActiveX, SystemLogger_TLB, StdVcl, LogEvent_TLB, Dialogs;
 
 type
   TSysLog = class(TAutoObject, ISysLog, ISysLogEvent)
   protected
     { Protected declarations }
     procedure ReportLog(enMsgType: LogMessageTypes; const strUserName,
       strModuleName, strMsgText: WideString); safecall;
 end;
 
 implementation
 
 uses
   ComServ, SysUtils;
 
 procedure TSysLog.ReportLog(enMsgType: LogMessageTypes; const strUserName,
   strModuleName, strMsgText: WideString);
 begin
   ShowMessage('MessageType : '+IntToStr(enMsgtype)+#10#13+
   'ModuleName : '+strModuleName+#10#13+
   'UserName : '+strUserName+#10#13+
   'TextMessage : '+strMsgText);
 end;
 
 initialization
   TAutoObjectFactory.Create(ComServer, TSysLog, Class_SysLog,
     ciMultiInstance, tmApartment);
 end.
 

Зарегистрируйте компонент в каталоге COM+ и подпишите его к компоненту EventClass.

Далее следуйте инструкциям визарда.

Итак, у вас на компьютере установлены объекты EventClass и подписчик.

Пример реализации методов издателя

Создадим простенькое приложение и проверим существующею связку. Создайте бизнес-объект COM+ инициирующий в любом своем методе метод-событие ReportLog.

Пример реализации объекта приведен ниже:


 unit BsObjectUnit;
 
 interface
 
 uses
   ComObj, ActiveX, BsObject_TLB, StdVcl, LogEvent_TLB;
 
 type
   TBusinessObject = class(TAutoObject, IBusinessObject)
   protected
     { Protected declarations }
     function NewObject(param1: Integer): HResult; safecall;
 end;
 
 implementation
 
 uses
   ComServ;
 
 function TBusinessObject.NewObject(param1: Integer): HResult;
 var
   LogEvent: ISysLogEvent;
 begin
   LogEvent := CoSysLogEvent.Create;
   try
     LogEvent.ReportLog(lmtInformation, 'Nonamed', 'BsObjectUnit',
       'TBusinessObject.NewObject executed!')
   except
     LogEvent.ReportLog(lmtInformation, 'Nonamed', 'BsObjectUnit',
       'TBusinessObject.NewObject failed!')
   end;
 end;
 
 initialization
 TAutoObjectFactory.Create(ComServer, TBusinessObject,
   Class_BusinessObject, ciMultiInstance, tmApartment);
 
 end.
 

После вызова метода NewObject у объекта BusinessObject будет создано событие, которое создаст объект SysLog и запишет и отобразит информацию в диалоговом окне. Подписчиков у созданного объекта EventClass может быть неограниченное количество с самыми разнообразными функциями, от отображения диалогового окна до записи данных в отдельную БД.

Фильтры

Механизм фильтрации подписчиков использует строку условия фильтрации, являющуюся свойством подписки. Такая фильтрация выполняется для каждого метода и каждой подписки. Вы можете использовать строку, используя имена параметров из библиотеки типов. Можно использовать так же стандартные операции отношения, вложенные скобки и ключевые слова AND, OR, NOT. Строка может быть определена с помощью средств ComponentServices или средств административного API.




Сравнение чисел с плавающей точкой

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

У меня два числа с плавающей запятой неправильно сравниваются! Задаю if d1=d2 ..., или if d1<>d2, а результат иногда неверный. В чем дело? Это баг Дельфи?

Нет. Просто в отличие от целочисленных IEEE числа с плавающей запятой являются приблизительными значениями и вы не должны использовать = или <> для сравнивания двух чисел такого типа. Вместо этого вычтите из одного числа другое и сравните разницу с очень малой величиной.

Например.


 if abs(d1-d2) < 0.00001 then
   ShowMessage('D1 и D2 равны');
 




Окно в виде кольца с изогнутой заголовочной полосой


 unit Unit1;
 
 interface
 
 uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls,
   Forms, Dialogs, Buttons, StdCtrls;
 
 type
   TForm1 = class(TForm)
     SpeedButton1: TSpeedButton;
     Button1: TButton;
     procedure FormCreate(Sender: TObject);
     procedure FormPaint(Sender: TObject);
     procedure Button1Click(Sender: TObject);
   private
     { Private declarations }
     rTitleBar : THandle;
     Center : TPoint;
     CapY : Integer;
     Circum : Double;
     SB1 : TSpeedButton;
     RL, RR : Double;
     procedure TitleBar(Act : Boolean);
     procedure WMNCHITTEST(var Msg: TWMNCHitTest); message WM_NCHITTEST;
     procedure WMNCACTIVATE(var Msg: TWMNCACTIVATE); message WM_NCACTIVATE;
     procedure WMSetText(var Msg: TWMSetText); message WM_SETTEXT;
   public
   { Public declarations }
 end;
 
 var
   Form1: TForm1;
 
 implementation
 {$R *.DFM}
 
 const
   TitlColors : array[Boolean] of TColor = (clInactiveCaption, clActiveCaption);
   TxtColors : array[Boolean] of TColor = (clInactiveCaptionText, clCaptionText);
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   rTemp, rTemp2 : THandle;
   Vertices : array[0..2] of TPoint;
   X, Y : INteger;
 begin
   Caption := 'Delphi World is great!';
   BorderStyle := bsNone; {required}
   if Width > Height then
     Width := Height
   else
     Height := Width; {harder to calc if width <> height}
   Center := Point(Width div 2, Height div 2);
   CapY := GetSystemMetrics(SM_CYCAPTION)+8;
   rTemp := CreateEllipticRgn(0, 0, Width, Height);
   rTemp2 := CreateEllipticRgn((Width div 4), (Height div 4),
   3*(Width div 4), 3*(Height div 4));
   CombineRgn(rTemp, rTemp, rTemp2, RGN_DIFF);
   SetWindowRgn(Handle, rTemp, True);
   DeleteObject(rTemp2);
   rTitleBar := CreateEllipticRgn(4, 4, Width-4, Height-4);
   rTemp := CreateEllipticRgn(CapY, CapY, Width-CapY, Height-CapY);
   CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_DIFF);
   Vertices[0] := Point(0,0);
   Vertices[1] := Point(Width, 0);
   Vertices[2] := Point(Width div 2, Height div 2);
   rTemp := CreatePolygonRgn(Vertices, 3, ALTERNATE);
   CombineRgn(rTitleBar, rTitleBar, rTemp, RGN_AND);
   DeleteObject(rTemp);
   RL := ArcTan(Width / Height);
   RR := -RL + (22 / Center.X);
   X := Center.X-Round((Center.X-1-(CapY div 2))*Sin(RR));
   Y := Center.Y-Round((Center.Y-1-(CapY div 2))*Cos(RR));
   SB1 := TSpeedButton.Create(Self);
   with SB1 do
   begin
     Parent := Self;
     Left := X;
     Top := Y;
     Width := 14;
     Height := 14;
     OnClick := Button1Click;
     Caption := 'X';
     Font.Style := [fsBold];
   end;
 end;
 
 procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitTest);
 begin
   inherited;
   with Msg do
     with ScreenToClient(Point(XPos,YPos)) do
       if PtInRegion(rTitleBar, X, Y) and
       (not PtInRect(SB1.BoundsRect, Point(X,Y))) then
         Result := htCaption;
 end;
 
 procedure TForm1.WMNCActivate(var Msg: TWMncActivate);
 begin
   inherited;
   TitleBar(Msg.Active);
 end;
 
 procedure TForm1.WMSetText(var Msg: TWMSetText);
 begin
   inherited;
   TitleBar(Active);
 end;
 
 procedure TForm1.TitleBar(Act: Boolean);
 var
   TF : TLogFont;
   R : Double;
   N, X, Y : Integer;
 begin
   if Center.X = 0 then
     Exit;
   with Canvas do
   begin
     Brush.Style := bsSolid;
     Brush.Color := TitlColors[Act];
     PaintRgn(Handle, rTitleBar);
     R := RL;
     Brush.Color := TitlColors[Act];
     Font.name := 'Arial';
     Font.Size := 12;
     Font.Color := TxtColors[Act];
     Font.Style := [fsBold];
     GetObject(Font.Handle, SizeOf(TLogFont), @TF);
     for N := 1 to Length(Caption) do
     begin
       X := Center.X-Round((Center.X-6)*Sin(R));
       Y := Center.Y-Round((Center.Y-6)*Cos(R));
       TF.lfEscapement := Round(R * 1800 / pi);
       Font.Handle := CreateFontIndirect(TF);
       TextOut(X, Y, Caption[N]);
       R := R - (((TextWidth(Caption[N]))+2) / Center.X);
       if R < RR then
         Break;
     end;
     Font.name := 'MS Sans Serif';
     Font.Size := 8;
     Font.Color := clWindowText;
     Font.Style := [];
   end;
 end;
 
 procedure TForm1.FormPaint(Sender: TObject);
 begin
   with Canvas do
   begin
     Pen.Color := clBlack;
     Brush.Style := bsClear;
     Pen.Width := 1;
     Pen.Color := clWhite;
     Arc(1, 1, Width-1, Height-1, Width, 0, 0, Height);
     Arc((Width div 4)-1, (Height div 4)-1,
     3*(Width div 4)+1, 3*(Height div 4)+1, 0, Height, Width, 0);
     Pen.Color := clBlack;
     Arc(1, 1, Width-1, Height-1, 0, Height, Width, 0);
     Arc((Width div 4)-1, (Height div 4)-1,
     3*(Width div 4)+1, 3*(Height div 4)+1, Width, 0, 0, Height);
     TitleBar(Active);
   end;
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Close;
 end;
 
 end.
 




Преобразование дробной и целой части REAL-числа в два целых

Я написал программу, которая делает это. Это DOS-программа. Вы вызываете ее с десятичным числом, передаваемым в качестве параметра. После чего программка выведет 3 колонки, в первой будет находиться исходное число, две остальные будут содержать числитель и знаменатель. Вы можете преобразовать программу в функцию и применять ее в своих приложениях, но, думаю, это несложно, и с этим вы справитесь сами.

Для ее запуска достаточно в подсказке DOS набрать ее имя и число:

CONTFRAC 3.141592654

 program contfrac; { непрерывные дроби }
 {$N+}
 const
   order = 20;
 var
   y, lasterr, error, x: extended;
   a: array[0..order] of longint;
   i, j, n: integer;
   op, p, q: longint;
 begin
   lasterr := 1E30;
   val(paramstr(1), y, n);
   if n <> 0 then
     halt;
   x := y;
   a[0] := trunc(x);
 
   writeln;
   writeln(a[0]: 20, a[0]: 14, 1: 14);
 
   { это может вызвать резкую головную боль и галлюцинации }
 
   for i := 1 to order do
   begin
     x := 1.0 / frac(x);
     a[i] := trunc(x);
     p := 1;
     q := a[i];
     for j := pred(i) downto 0 do
     begin
       op := p;
       p := q;
       q := a[j] * q + op;
     end;
     error := abs(y - int(q) / int(p));
     if abs(error) >= abs(lasterr) then
       halt;
     writeln(a[i]: 20, q: 14, p: 14, error: 10);
     if error < 1E-18 then
       halt;
     lasterr := error;
   end;
 end.
 

Теперь попытаюсь объяснить мой алгоритм (он, по-моему, достаточно быстрый). Вот схема:

Допустим, мы используем число 23.56.

Берем наше натуральное число и производим целочисленное деление на 1.

23.56 div 1 = 23

Теперь вычитаем результат из числа, с которого мы начали.

23.56 - 23 = .56

Для преобразования значения в целое мы просто умножаем его на 100, и, при необходимости, приводим его к целому.

             valA := (val div 100);
              valB := (valA - val); or valB := (valA - val) * 100;
 
                 val = 23.56
                 ValA = 23
                 ValB = .56 or 56



Как завершить сеанс работы или перезагрузить Windows

Для этого нам потребуются определённые привелегии:


 function SetPrivilege(aPrivilegeName: string;
   aEnabled: boolean): boolean;
 var
   TPPrev,
     TP: TTokenPrivileges;
   Token: THandle;
   dwRetLen: DWord;
 begin
   Result := False;
   OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES
     or TOKEN_QUERY, @Token);
 
   TP.PrivilegeCount := 1;
   if (LookupPrivilegeValue(nil, PChar(aPrivilegeName),
     TP.Privileges[0].LUID)) then
   begin
     if (aEnabled) then
       TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
     else
       TP.Privileges[0].Attributes := 0;
 
     dwRetLen := 0;
     Result := AdjustTokenPrivileges(Token, False, TP,
       SizeOf(TPPrev),
       TPPrev, dwRetLen);
   end;
   CloseHandle(Token);
 end;
 
 function WinExit(iFlags: integer): boolean;
 //   возможные флаги:
 //   EWX_LOGOFF
 //   EWX_REBOOT
 //   EWX_SHUTDOWN
 begin
   Result := True;
   if (SetPrivilege('SeShutdownPrivilege', true)) then
   begin
     if (not ExitWindowsEx(iFlags, 0)) then
     begin
       Result := False;
     end;
     SetPrivilege('SeShutdownPrivilege', False)
   end
   else
   begin
     Result := False;
   end;
 end;
 




Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet

Автор: Nomadic


 Resync( [rmExact, rmCenter] );
 




RecCount в таблицах ASCII

Автор: Mark Edington

В Delphi 1.0 для получения количества записей в ASCII файле (.TXT- и .SCH-файлы) я пользовался свойством RecordCount компонента TTable. В Delphi 2.0 эта функциональность не поддерживается! Я прав или не прав? Во всяком случае как мне получить количество записей, содержащихся в ASCII таблице?

В Delphi 2.0, свойство RecordCount отображается на недокументированную функцию BDE DbiGetExactRecordCount. Данное изменение было сделано для обеспечения правильных величин при работе с "живыми" запросами. Очевидно, данное API по какой-то причине не поддерживает текстовые файлы.

Вы можете обойти эту проблему, вызывая функцию API BDE DbiGetRecordCount напрямую (добавьте BDE к списку используемых модулей):


 procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word;
 var
   RecCount: Integer;
 begin
   Check(DbiGetRecordCount(Table1.Handle, RecCount);
 end;
 




Получение имени обработчика события

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


 procedure TForm1.Button3Click(Sender: TObject);
 var
   P: record case Integer of
       1: (E: TNotifyEvent);
       2: (P: Pointer);
   end;
 begin
   P.E := Button1.OnClick;
   Panel1.Caption := 'Обработчик события = ' + MethodName(P.P);
   ShowMessage(Format('%p', [P.P]));
 end;
 




Как получить номер записи в dBASE или Paradox

Попали в одну камеру разбойник и хакер. Разбойник:
- Я вот сижу за ограбление магазина... А ты за что сидишь? Хакер:
- Ограбил банк на 7 миллионов долларов... Разбойник:
- Да ты че... ни фига себе.. как же ты унес их из банка - денег-то офигенно много? Хакер рассказывает в общих чертах о компьютерах, сетях, взломах и т. д. Разбойник:
- Ну ни фига себе, а как же ты попался? Хакер:
- Брандмауэр засек и сработала защита.. Разбойник:
- Ах ты... Брандмауэр, твою мать... Всегда знал, что евреев опасаться надо...


 function FindRecordNumber (aDataSet : TDataSet): longint;
  var
   cP: CurProps;
   rP: RECProps;
   DBRes: DBiResult;
  begin
   {Return 0 if dataset is not Paradox or dBase}
   Result := 0;
 
   with aDataset do
    begin
     if state = dsInactive then exit;
 
     {we need to make this call to grab the cursor's iSeqNums}
     DBRes := DBiGetCursorProps(Handle,cP);
     if DBRes <> DBIERR_NONE then exit;
 
     {synchronize the BDE cursor with the dataset's cursor}
     UpdateCursorPos;
 
     {fill rP with the current record's properties}
     DBRes := DBiGetRecord(Handle,DBiNOLOCK,nil,@rP);
     if DBRes <> DBIERR_NONE then exit;
 
     {what kind of dataset are we looking at?}
     case cP.iSeqNums of
      0: result := rP.iPhyRecNum; {dBase}
      1: result := rP.iSeqNum;    {Paradox}
     end;
    end;
  end;
 




Запись RecNo из RecordCount

Автор: Mike Downey

...какой метод вовращает номер текущей записи? (т.е.: Я хочу использовать это вместе с функцией RecordCount и выводить для пользователя в строке состояния нечто вроде: "Запись #n из x")

Вот функция, возвращающая номер текущей записи в наборе данных DataSet. В основном я все скопировал и расставил комментарии, которые теперь лишают меня возможности поговорить на эту тему. Могли бы вы получить эти цифирьки из DBIPROCS.INT?


 function RecordNumber(Dataset: TDataset): Longint;
 var
   CursorProps: CurProps;
   RecordProps: RECProps;
 begin
   { Возвращаем 0, если набор данных не Paradox или dBASE }
   Result := 0;
 
   with Dataset do
   begin
     { Набор данных активен? }
     if State = dsInactive then
       DBError(SDataSetClosed);
 
     { Нам необходимо сделать этот вызов, чтобы "захватить" курсор iSeqNums }
     Check(DbiGetCursorProps(Handle, CursorProps));
 
     { Синхронизируем курсор BDE с курсором набора данных }
     UpdateCursorPos;
 
     { Заполняем RecordProps текущими свойствами записи }
     Check(DbiGetRecord(Handle, dbiNOLOCK, nil, @RecordProps));
 
     { С каким типом набора данных мы работаем? }
     case CursorProps.iSeqNums of
       0: Result := RecordProps.iPhyRecNum; { dBASE   }
       1: Result := RecordProps.iSeqNum; { Paradox }
     end; { case }
   end; { with }
 end; { function }
 

Затем, в обработчике события OnDataChange DataSet, я использовал команду:


 MyTextVariable := 'Запись ' + IntToStr( RecordNumber( tImport ) ) +
 ' из ' + IntToStr( tImport.RecordCount ) ;
 




Перекодирование

Этот алгоритм позволяет перекодировать текст. Реализованы кодировки Windows-1251, KOI8-R, ISO-8859-5 и DOS. Кодировка – это таблица, в которой указано, например, что символ под номером 160 - это русская буква "а", а под номером 150 – "Ц" и т. д. Кодировки различаются номерами русских букв (как располагать английские буквы договорились). Разные компьютеры в Интернете используют разные кодировки. И поэтому, когда русский текст идет по Интернету, его многократно перекодируют.

Этот алгоритм обеспечивает высокую скорость перекодирования больших объемов данных.


 procedure TForm1.Button1Click(Sender: TObject);
 var
   code1, code2: TCode;
   s: string;
   c: char;
   i: integer;
   chars: array [char] of char;
   str: array [TCode] of string;
 begin
   case ComboBox1.ItemIndex of
     1: code1 := koi;
     2: code1 := iso;
     3: code1 := dos;
     else code1 := win;
   end;
   case ComboBox2.ItemIndex of
     1: code2 := koi;
     2: code2 := iso;
     3: code2 := dos;
     else code2 := win;
   end;
   s := Memo1.Text;
 
   Str[win] := 'АаБбВвГгДдЕеЖжЗзИиЙйКкЛлМмНнОоПпРрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯя';
   Str[koi] := 'юЮаАбБцЦдДеЕфФгГхХиИйЙкКлЛмМнНоОпПяЯрРсСтТуУжЖвВьЬыЫзЗшШэЭщЩчЧъЪ';
   Str[iso] := 'РрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯяа¹б¸в?гƒдºе¾ж³з¿и¼йšкœлžм?н§о¢пŸ';
   Str[dos] := '€ ?¡‚¢ƒ£„¤…¥†¦‡§ˆ¨‰©Šª‹"Œ¬?­Ž®?¯?а'б'в“г”д•е–ж—з˜и™йšк›лœм?нžоŸп';
 
   for c := #0 to #255 do
     Chars[c] := c;
 
   for i := 1 to Length(Str[win]) do
     Chars[Str[code2][i]] := Str[code1][i];
 
   for i := 1 to Length(s) do
     s[i] := Chars[s[i]];
 
   Memo2.Text := s;
 end;
 




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




Перекодировка текста DOS-Windows-Koi8


Подходит компьютерщик (К) к газетному киоску и спрашивает у продавца (П):
К: - Есть ли у вас свежий номер 'Компьютерного обозрения'?
П: - Есть.
К: - Ну тогда, пожалуйста, один номер в кодировке KOI8-R


 procedure WinToDos;
 var
   Src, Str: PChar;
 begin
   Src := Memo1.Lines.GetText; //Берем текст из TMemo как тип PChar
   CharToOem(Src, Str); //API функция для перевода текста
   Memo2.Lines.Text := StrPas(Str);//Записываем назад
 end;
 
 procedure DosToWin;
 var
   Src, Str: PChar;
 begin
   Src := Memo1.Lines.GetText; //Берем текст из TMemo как тип PChar
   OemToChar(Src, Str); //API функция для перевода текста
   Memo2.Lines.Text := StrPas(Str);//Записываем назад
 end;
 
 var
   koi8toalt : array [0..127] of char = (
   CHR($c4), Chr($b3), Chr($da), Chr($bf),
   Chr($c0), Chr($d9), Chr($c3), Chr($b4),
   Chr($c2), Chr($c1), Chr($c5), Chr($df),
   Chr($dc), Chr($db), Chr($dd), Chr($de),
   Chr($b0), Chr($b1), Chr($b2), Chr($f4),
   Chr($fe), Chr($f9), Chr($fb), Chr($f7),
   Chr($f3), Chr($f2), Chr($ff), Chr($f5),
   Chr($f8), Chr($fd), Chr($fa), Chr($f6),
   Chr($cd), Chr($ba), Chr($d5), Chr($f1),
   Chr($d6), Chr($c9), Chr($b8), Chr($b7),
   Chr($bb), Chr($d4), Chr($d3), Chr($c8),
   Chr($be), Chr($bd), Chr($bc), Chr($c6),
   Chr($c7), Chr($cc), Chr($b5), Chr($f0),
   Chr($b6), Chr($b9), Chr($d1), Chr($d2),
   Chr($cb), Chr($cf), Chr($d0), Chr($ca),
   Chr($d8), Chr($d7), Chr($ce), Chr($fc),
   Chr($ee), Chr($a0), Chr($a1), Chr($e6),
   Chr($a4), Chr($a5), Chr($e4), Chr($a3),
   Chr($e5), Chr($a8), Chr($a9), Chr($aa),
   Chr($ab), Chr($ac), Chr($ad), Chr($ae),
   Chr($af), Chr($ef), Chr($e0), Chr($e1),
   Chr($e2), Chr($e3), Chr($a6), Chr($a2),
   Chr($ec), Chr($eb), Chr($a7), Chr($e8),
   Chr($ed), Chr($e9), Chr($e7), Chr($ea),
   Chr($9e), Chr($80), Chr($81), Chr($96),
   Chr($84), Chr($85), Chr($94), Chr($83),
   Chr($95), Chr($88), Chr($89), Chr($8a),
   Chr($8b), Chr($8c), Chr($8d), Chr($8e),
   Chr($8f), Chr($9f), Chr($90), Chr($91),
   Chr($92), Chr($93), Chr($86), Chr($82),
   Chr($9c), Chr($9b), Chr($87), Chr($98),
   Chr($9d), Chr($99), Chr($97), Chr($9a));
 
 function Koi8toWin(const Data: PChar; DataLen: Integer): PChar;
 var
   PCh: PChar;
   i: Integer;
 begin
   PCh := Data;
   for i := 1 to DataLen do
   begin
     if Ord(Pch^) > 127 then
       Pch^ := koi8toalt[Ord(Pch^) - 128];
     Inc(PCh);
   end;
   PCh := Data;
   OemToCharBuff(PCh, PCh, DWORD(DataLen));
   Result := Data;
 end;
 




Перекодировка текста из Win1251 в KOI8-R и наоборот


Встречается компьютерщик(К) со своим старым другом(Д), бывшем алкашем.
- (К) Ну что, больше не пьешь?
- (Д) Закодировался.
- (К) В какой кодировке?
- (Д) KOI-8.
- (К) Говорят, в Windows-1251 дольше не пьют.


 type
   TConvertChars = array [#128..#255] of char;
 
 const
   Win_KoiChars: TConvertChars = (
   #128,#129,#130,#131,#132,#133,#134,#135,#136,#137,#060,#139,#140,#141,#142,#143,
   #144,#145,#146,#147,#148,#169,#150,#151,#152,#153,#154,#062,#176,#157,#183,#159,
   #160,#246,#247,#074,#164,#231,#166,#167,#179,#169,#180,#060,#172,#173,#174,#183,
   #156,#177,#073,#105,#199,#181,#182,#158,#163,#191,#164,#062,#106,#189,#190,#167,
   #225,#226,#247,#231,#228,#229,#246,#250,#233,#234,#235,#236,#237,#238,#239,#240,
   #242,#243,#244,#245,#230,#232,#227,#254,#251,#253,#154,#249,#248,#252,#224,#241,
   #193,#194,#215,#199,#196,#197,#214,#218,#201,#202,#203,#204,#205,#206,#207,#208,
   #210,#211,#212,#213,#198,#200,#195,#222,#219,#221,#223,#217,#216,#220,#192,#209);
 
   Koi_WinChars: TConvertChars = (
   #128,#129,#130,#131,#132,#133,#134,#135,#136,#137,#138,#139,#140,#141,#142,#143,
   #144,#145,#146,#147,#148,#149,#150,#151,#152,#153,#218,#155,#176,#157,#183,#159,
   #160,#161,#162,#184,#186,#165,#166,#191,#168,#169,#170,#171,#172,#173,#174,#175,
   #156,#177,#178,#168,#170,#181,#182,#175,#184,#185,#186,#187,#188,#189,#190,#185,
   #254,#224,#225,#246,#228,#229,#244,#227,#245,#232,#233,#234,#235,#236,#237,#238,
   #239,#255,#240,#241,#242,#243,#230,#226,#252,#251,#231,#248,#253,#249,#247,#250,
   #222,#192,#193,#214,#196,#197,#212,#195,#213,#200,#201,#202,#203,#204,#205,#206,
   #207,#223,#208,#209,#210,#211,#198,#194,#220,#219,#199,#216,#221,#217,#215,#218);
 
 function Win_KoiConvert(const St: string): string;
 var
   i: integer;
 begin
   Result:=St;
   for i:=1 to Length(St) do
     if St[i]>#127 then
       Result[i]:=Win_KoiChars[St[i]];
 end;
 




Распознавание кодировки. Перекодировка.

Приходит программист к окулисту. Тот его усаживает напротив таблицы, берет указку:
- Читайте!
- "БНОПНЯ"... Доктор, у вас что-то не то с кодировкой!

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


 type
   TCode = (win, koi, iso, dos);
 
 const
   CodeStrings: array [TCode] of string = ('win','koi','iso','dos');
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   str: array [TCode] of string;
   norm: array ['А'..'я'] of single;
   code1, code2: TCode;
   min1, min2: TCode;
   count: array [char] of integer;
   d, min: single;
   s, so: string;
   chars: array [char] of char;
   c: char;
   i: integer;
 begin
   so := Memo1.Text;
 
   norm['А'] := 0.001;
   norm['Б'] := 0;
   norm['В'] := 0.002;
   norm['Г'] := 0;
   norm['Д'] := 0.001;
   norm['Е'] := 0.001;
   norm['Ж'] := 0;
   norm['З'] := 0;
   norm['И'] := 0.001;
   norm['Й'] := 0;
   norm['К'] := 0.001;
   norm['Л'] := 0;
   norm['М'] := 0.001;
   norm['Н'] := 0.001;
   norm['О'] := 0.001;
   norm['П'] := 0.002;
   norm['Р'] := 0.002;
   norm['С'] := 0.001;
   norm['Т'] := 0.001;
   norm['У'] := 0;
   norm['Ф'] := 0;
   norm['Х'] := 0;
   norm['Ц'] := 0;
   norm['Ч'] := 0.001;
   norm['Ш'] := 0.001;
   norm['Щ'] := 0;
   norm['Ъ'] := 0;
   norm['Ы'] := 0;
   norm['Ь'] := 0;
   norm['Э'] := 0.001;
   norm['Ю'] := 0;
   norm['Я'] := 0;
   norm['а'] := 0.057;
   norm['б'] := 0.01;
   norm['в'] := 0.031;
   norm['г'] := 0.011;
   norm['д'] := 0.021;
   norm['е'] := 0.067;
   norm['ж'] := 0.007;
   norm['з'] := 0.013;
   norm['и'] := 0.052;
   norm['й'] := 0.011;
   norm['к'] := 0.023;
   norm['л'] := 0.03;
   norm['м'] := 0.024;
   norm['н'] := 0.043;
   norm['о'] := 0.075;
   norm['п'] := 0.026;
   norm['р'] := 0.038;
   norm['с'] := 0.034;
   norm['т'] := 0.046;
   norm['у'] := 0.016;
   norm['ф'] := 0.001;
   norm['х'] := 0.006;
   norm['ц'] := 0.002;
   norm['ч'] := 0.011;
   norm['ш'] := 0.004;
   norm['щ'] := 0.004;
   norm['ъ'] := 0;
   norm['ы'] := 0.012;
   norm['ь'] := 0.012;
   norm['э'] := 0.003;
   norm['ю'] := 0.005;
   norm['я'] := 0.015;
 
   Str[win] := 'АаБбВвГгДдЕеЖжЗзИиЙйКкЛлМмНнОоПпРрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯя';
   Str[koi] := 'юЮаАбБцЦдДеЕфФгГхХиИйЙкКлЛмМнНоОпПяЯрРсСтТуУжЖвВьЬыЫзЗшШэЭщЩчЧъЪ';
   Str[iso] := 'РрСсТтУуФфХхЦцЧчШшЩщЪъЫыЬьЭэЮюЯяа№бёвђгѓдєеѕжізїијйљкњлћмќн§оўпџ';
   Str[dos] := 'Ђ ЃЎ‚ўѓЈ"¤…Ґ†¦‡§€Ё‰©ЉЄ‹"ЊЌЋ®ЏЇђа'б'в"г"дoе-ж-зи™йљк›лњмќнћоџпз?и™йљк›лњмќнћоџп';
   for c := #0 to #255 do
     Chars[c] := c;
 
   min1 := win;
   min2 := win;
   min := 0;
   s := so;
   fillchar(count, sizeof(count), 0);
   for i := 1 to Length(s) do
     inc(count[s[i]]);
   for c := 'А' to 'я' do
     min := min + sqr(count[c] / Length(s) - norm[c]);
   for code1 := low(TCode) to high(TCode) do
   begin
     for code2 := low(TCode) to high(TCode) do
     begin
       if code1 = code2 then
         continue;
 
       s := so;
       for i := 1 to Length(Str[win]) do
         Chars[Str[code2][i]] := Str[code1][i];
       for i := 1 to Length(s) do
         s[i] := Chars[s[i]];
       fillchar(count, sizeof(count), 0);
       for i := 1 to Length(s) do
         inc(count[s[i]]);
       d := 0;
       for c := 'А' to 'я' do
         d := d + sqr(count[c] / Length(s) - norm[c]);
       if d < min then
       begin
         min1 := code1;
         min2 := code2;
         min := d;
       end;
     end;
   end;
 
   s := Memo1.Text;
   if min1 <> min2 then
   begin
     for c := #0 to #255 do
       Chars[c] := c;
     for i := 1 to Length(Str[win]) do
       Chars[Str[min2][i]] := Str[min1][i];
     for i := 1 to Length(s) do
       s[i] := Chars[s[i]];
   end;
   Form1.Caption := CodeStrings[min2] + ' ' + CodeStrings[min1];
 
   Memo2.Text := s;
 end;
 




Передача массива записей символов в Memo

Юзер заходит в магазин:
- А какой компьютер лучше? Windows или Pentium.

Обработка больших строк в 16-битной версии Delphi задача далеко непростая. Особенно когда строки являются частью структуры записи и вы хотите передать их в TMemo. В данном совете показано как создать структуру записи размером 1000 символов, прочесть в нее содержимое Memo и затем записать ее обратно в Memo. Основной метод, который мы здесь используем - метод Memo GetTextBuf. Используемая структура записи представляет собой простую строку и массив из 1000 символов, но структура могла бы быть сложнее.


 unit URcrdIO;
 
 interface
 
 uses
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls, dbtables;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     Memo1: TMemo;
     Button2: TButton;
     procedure Button1Click(Sender: TObject);
     procedure Button2Click(Sender: TObject);
   private
     { Private declarations }
   public
     { Public declarations }
   end;
 
 type
   TMyRec = record
     MyArray: array[1..1000] of char;
     mystr: string;
   end;
 
 var
   Form1: TForm1;
   MyRec: TMyRec;
   mylist: TStringlist;
   PMyChar: PChar;
   myfile: file;
   mb: TStream;
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 
 begin
 
   assignfile(myfile, 'c:\testblob.txt');
   rewrite(myfile, 1);
   fillchar(MyRec.MyArray, sizeof(MyRec.MyArray), #0);
   pmychar := @MyRec.MyArray;
   StrPCopy(pmychar, memo1.text);
   Blockwrite(MyFile, MyRec, SizeOf(MyRec));
   closefile(MyFile);
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 begin
 
   assignfile(myfile, 'c:\testblob.txt');
   reset(myfile, 1);
   fillchar(MyRec.MyArray, sizeof(MyRec.MyArray), #0);
 
   Blockread(MyFile, MyRec, SizeOf(MyRec));
   pmychar := @MyRec.MyArray;
   Memo1.SetTextBuf(pmychar);
 end;
 
 end.
 




При обращении клиента, к уже редактируемой записи другим клиентом, выдаётся сообщение

Ответ 1:

Самое дешевое решение - завести поле, в которое будет записываться ID usera перед началом операции.

Перед началом обновления данных выполняете следующее.
1. При старте программы каждому юзеру раздаете уникальный ID.
2. Перед началом обновления данных записываете ID в поле в и коммитете данные. После этого поле будет залочено для этого юзера.
3. Вносите изменения.
4. В блокирующее поле записываете 0 и коммитете.

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

Если не делать ничего подобного то запросто при многопользовательской работе можно получить
deadlock на сервере а есть не очень хорошо.

Ответ 2:

Так сделать нельзя. Можно по другому. Оцени критические ситуации и поставь проверку на триггер или еще лучше сделай 
с помощью CHECK.
Например: колличество на складе не может быть меньше 0 CHECK TOVAR_COUNT>0
Если один из клиентов изменил количество , а второй попытался снять больше чем есть на складе - то сервер выдаст 
ошибку, которую ты можешь обработать программой.

Очень хорошая книга по этой теме П.В. Шумаков - Дельфи 3 и разработка приложений баз данных.
После ее прочтения 80% твоих вопросов будут решены.

Ответ 3:

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

В начале критическую секцию необходимо объявить в составе класса или
отдельно:


 SectionLock: TCriticalSection;
 

Затем:


 procedure TForm1.FormCreate(Sender: TObject);
 begin
   SectionLock := TCriticalSection.Create;
 end;
 
 procedure TForm1.FormDestroy(Sender: TObject);
 begin
   SectionLock.Free;
 end;
 

Теперь при инициализации Вашего метода можно использовать SectionLock:


 SectionLock.Acquire;
 try
   DoSomething;
 finally
   SectionLock.Release;
 end;
 
 // или
 
 SectionLock.Enter;
 try
   DoSomething;
 finally
   SectionLock.Leave;
 end;
 

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


 if Lock then
   "Ответ - занято"
 
 SectionLock.Enter;
 try
   Lock := True;
   DoSomething;
 finally
   SectionLock.Leave;
   Lock := False;
 end;
 

P.S. Что бы сервер мог одновременно реагировать на несколько запросов, его необходимо реализовать в СОМ технологии.




Запись nnn из nnn

Автор: OAmiry (Borland)

Нет ли метода или свойства, позволяющих осуществить сабж из Delphi?

Для этого необходимо поработать с BDE. Нижеприведенный код у меня работает прекрасно. Условия выполнения:
A) Вы используете таблицы dBASE
B) На форме расположен компонент DBNavigator
B) На форме расположен табличный компонент с именем Table1
C) На форме расположен компонент Label с именем Label1
D) Обработчик события OnClick компонента DBNavigator имеет следующий код:


 procedure TForm1.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
 var
   pRecProperty: pRECProps;
 begin
   if Button in [nbFirst, nbPrior, nbNext, nbLast] then
   begin
     if MaxAvail > SizeOf(RECProps) then
     begin
       GetMem(pRecProperty, SizeOf(RECProps));
       DbiGetRecord(Table1.Handle, dbiNOLOCK, nil, pRecProperty);
       Label1.Caption := Concat('Запись: ', IntToStr(pRecProperty^.iPhyRecNum),
         ' из ', IntToStr(Table1.RecordCount));
       FreeMem(pRecProperty, SizeOf(RECProps));
     end;
   end;
 end;
 

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




Запись звука


Автор: John Mertus


 var
   WaveRecorder : TWaveRecorder;
   // 4 размером 2048 байт
   WaveRecorder := TwaveRecorder(2048, 4);
 
 { Устанавливает параметры дискретизации }
 with WaveRecorder.pWavefmtEx do
 begin
   wFormatTag := WAVE_FORMAT_PCM;
   nChannels := 1;
   nSamplesPerSec := 20000;
   wBitsPerSample := 16;
   nAvgBytesPerSec := nSamplesPerSec*(wBitsPerSample div 8)*nChannels;
 end;
 
 // Затем используем вариантную запись, поскольку я не знаю
 // как получить адрес самого объекта
 WaveRecorder.SetupRecord(@WaveRecorder);
 
 // Начинаем запись
 WaveRecorder.StartRecord;
 
 // При каждом заполнении буфера вызывается процедура
 WaveRecorder.Processbuffer.
 
 // Заканчиваем запись
 WaveRecorder.StopRecord;
 WaveRecorder.Destroy;
 
 {
 
 Имя файла: RECUNIT.PAS V 1.01
 Создан: Авг 19 1996 в 21:56 на IBM ThinkPad
 Ревизия #7: Авг 22 1997, 15:01 на IBM ThinkPad
 -John Mertus
 
 Данный модуль содержит необходимые процедуры для записи звука.
 
 Версия 1.00 - первый релиз
 1.01 - добавлен TWaveInGetErrorText
 }
 
 {-Unit-RECUNIT----------John Mertus---Авг 96---}
 
 unit RECUNIT;
 
 interface
 
 uses
   Windows, MMSystem, SysUtils, MSACM;
 
 { Ниже определен класс TWaveRecorder для обслуживания входа звуковой }
 { карты. Ожидается, что новый класс будет производным от TWaveRecorder }
 { и перекроет TWaveRecorder.ProcessBuffer. После начала записи данная }
 { процедура вызывается каждый раз при наличии в буфере аудио-данных. }
 
 const
   MAX_BUFFERS = 8;
 
 type
   PWaveRecorder = ^TWaveRecorder;
   TWaveRecorder = class(TObject)
     constructor Create(BfSize, TotalBuffers : Integer);
     destructor Destroy; override;
     procedure ProcessBuffer(uMsg : Word; P : Pointer; n : Integer); virtual;
   private
     fBufferSize : Integer; // Размер буфера
     BufIndex : Integer;
     fTotalBuffers : Integer;
 
     pWaveHeader : array [0..MAX_BUFFERS-1] of PWAVEHDR;
     hWaveHeader : array [0..MAX_BUFFERS-1] of THANDLE;
     hWaveBuffer : array [0..MAX_BUFFERS-1] of THANDLE;
     hWaveFmtEx : THANDLE;
     dwByteDataSize : DWORD;
     dwTotalWaveSize : DWORD;
 
     RecordActive : Boolean;
     bDeviceOpen : Boolean;
 
     { Внутренние функции класса }
     function InitWaveHeaders : Boolean;
     function AllocPCMBuffers : Boolean;
     procedure FreePCMBuffers;
 
     function AllocWaveFormatEx : Boolean;
     procedure FreeWaveFormatEx;
 
     function AllocWaveHeaders : Boolean;
     procedure FreeWaveHeader;
 
     function AddNextBuffer : Boolean;
     procedure CloseWaveDeviceRecord;
   public
     { Public declarations }
     pWaveFmtEx : PWaveFormatEx;
     WaveBufSize : Integer; { Размер поля nBlockAlign }
     InitWaveRecorder : Boolean;
     RecErrorMessage : string;
     QueuedBuffers,
     ProcessedBuffers : Integer;
     pWaveBuffer : array [0..MAX_BUFFERS-1] of lpstr;
     WaveIn : HWAVEIN; { Дескриптор Wav-устройства }
 
     procedure StopRecord;
     function 477576218068StartRecord : Boolean;
     function 477576218068SetupRecord(P : PWaveRecorder) : Boolean;
 end;
 
 implementation
 
 function TWaveInGetErrorText(iErr : Integer) : string;
 { Выдает сообщения об ошибках WaveIn в формате Pascal }
 { iErr - номер ошибки }
 var
   PlayInErrorMsgC : array [0..255] of Char;
 begin
   waveInGetErrorText(iErr,PlayInErrorMsgC,255);
   TWaveInGetErrorText := StrPas(PlayInErrorMsgC);
 end;
 
 function TWaveRecorder.AllocWaveFormatEx : Boolean;
 { Распределяем формат большого размера, требуемый для инсталляции ACM-в}
 var
   MaxFmtSize : UINT;
 begin
   { maxFmtSize - сумма sizeof(WAVEFORMATEX) + pwavefmtex.cbSize }
   if( acmMetrics( 0, ACM_METRIC_MAX_SIZE_FORMAT, maxFmtSize ) <> 0) >then
   begin
     RecErrorMessage := 'Ошибка получения размера формата максимального сжатия';
     AllocWaveFormatEx := False;
     Exit;
   end;
 
   { распределяем структуру WAVEFMTEX }
   hWaveFmtEx := GlobalAlloc(GMEM_MOVEABLE, maxFmtSize);
   if (hWaveFmtEx = 0) then
   begin
     RecErrorMessage := 'Ошибка распределения памяти для структуры WaveFormatEx';
     AllocWaveFormatEx := False;
     Exit;
   end;
 
   pWaveFmtEx := PWaveFormatEx(GlobalLock(hWaveFmtEx));
   if (pWaveFmtEx = nil) then
   begin
     RecErrorMessage := 'Ошибка блокировки памяти WaveFormatEx';
     AllocWaveFormatEx := False;
     Exit;
   end;
 
   { инициализация формата в стандарте PCM }
   ZeroMemory( pwavefmtex, maxFmtSize );
   pwavefmtex.wFormatTag := WAVE_FORMAT_PCM;
   pwavefmtex.nChannels := 1;
   pwavefmtex.nSamplesPerSec := 20000;
   pwavefmtex.nBlockAlign := 1;
   pwavefmtex.wBitsPerSample := 16;
   pwavefmtex.nAvgBytesPerSec := pwavefmtex.nSamplesPerSec*
   (pwavefmtex.wBitsPerSample div 8)*pwavefmtex.nChannels;
   pwavefmtex.cbSize := 0;
 
   { Все успешно, идем домой }
   AllocWaveFormatEx := True;
 end;
 
 function TWaveRecorder.InitWaveHeaders : Boolean;
 { Распределяем память, обнуляем заголовок wave и инициализируем }
 var
   i : Integer;
 begin
   { делаем размер буфера кратным величине блока... }
   WaveBufSize := fBufferSize - (fBufferSize mod pwavefmtex.nBlockAlign);
 
   { Устанавливаем wave-заголовки }
   for i := 0 to fTotalBuffers-1 do
     with pWaveHeader[i]^ do
     begin
       lpData := pWaveBuffer[i];      // адрес буфера waveform
       dwBufferLength := WaveBufSize; // размер, в байтах, буфера
       dwBytesRecorded := 0;          // смотри ниже
       dwUser := 0;                   // 32 бита данных пользователя
       dwFlags := 0;                  // смотри ниже
       dwLoops := 0;                  // смотри ниже
       lpNext := nil;                 // зарезервировано; должен быть ноль
       reserved := 0;                 // зарезервировано; должен быть ноль
     end;
 
   InitWaveHeaders := TRUE;
 end;
 
 function TWaveRecorder.AllocWaveHeaders : Boolean;
 { Распределяем и блокируем память заголовка }
 var
   i : Integer;
 begin
   for i := 0 to fTotalBuffers-1 do
   begin
     hwaveheader[i] := GlobalAlloc( GMEM_MOVEABLE or GMEM_SHARE or
     GMEM_ZEROINIT, sizeof(TWAVEHDR));
 
     if (hwaveheader[i] = 0) then
     begin
       { Примечание: Это может привести к утечке памяти, надеюсь скоро исправить }
       RecErrorMessage := 'Ошибка распределения памяти для wave-заголовка';
       AllocWaveHeaders := FALSE;
       Exit;
     end;
 
     pwaveheader[i] := GlobalLock (hwaveheader[i]);
     if (pwaveheader[i] = nil ) then
     begin
       { Примечание: Это может привести к утечке памяти, надеюсь скоро исправить }
       RecErrorMessage := 'Не могу заблокировать память заголовка для записи';
       AllocWaveHeaders := FALSE;
       Exit;
     end;
   end;
   AllocWaveHeaders := TRUE;
 end;
 
 procedure TWaveRecorder.FreeWaveHeader;
 { Просто освобождаем распределенную AllocWaveHeaders память. }
 var
   i : Integer;
 begin
   for i := 0 to fTotalBuffers-1 do
   begin
     if (hWaveHeader[i] <> 0) then
     begin
       GlobalUnlock(hwaveheader[i]);
       GlobalFree(hwaveheader[i]);
       hWaveHeader[i] := 0;
     end
   end;
 end;
 
 function TWaveRecorder.AllocPCMBuffers : Boolean;
 { Распределяем и блокируем память waveform. }
 var
   i : Integer;
 begin
   for i := 0 to fTotalBuffers-1 do
   begin
     hWaveBuffer[i] := GlobalAlloc( GMEM_MOVEABLE or GMEM_SHARE, fBufferSize );
     if (hWaveBuffer[i] = 0) then
     begin
       { Здесь возможна утечка памяти }
       RecErrorMessage := 'Ошибка распределения памяти wave-буфера';
       AllocPCMBuffers := False;
       Exit;
     end;
 
     pWaveBuffer[i] := GlobalLock(hWaveBuffer[i]);
     if (pWaveBuffer[i] = nil) then
     begin
       { Здесь возможна утечка памяти }
       RecErrorMessage := 'Ошибка блокирования памяти wave-буфера';
       AllocPCMBuffers := False;
       Exit;
     end;
     pWaveHeader[i].lpData := pWaveBuffer[i];
   end;
   AllocPCMBuffers := TRUE;
 end;
 
 procedure TWaveRecorder.FreePCMBuffers;
 { Освобождаем использованную AllocPCMBuffers память. }
 var
   i : Integer;
 begin
   for i := 0 to fTotalBuffers-1 do
   begin
     if (hWaveBuffer[i] <> 0) then
     begin
       GlobalUnlock( hWaveBuffer[i] );
       GlobalFree( hWaveBuffer[i] );
       hWaveBuffer[i] := 0;
       pWaveBuffer[i] := nil;
     end;
   end;
 end;
 
 procedure TWaveRecorder.FreeWaveFormatEx;
 { Просто освобождаем заголовки ExFormat headers }
 begin
   if (pWaveFmtEx = nil) then
     Exit;
   GlobalUnlock(hWaveFmtEx);
   GlobalFree(hWaveFmtEx);
   pWaveFmtEx := nil;
 end;
 
 constructor TWaveRecorder.Create(BFSize, TotalBuffers : Integer);
 { Устанавливаем wave-заголовки, инициализируем указатели данных и }
 { и распределяем буферы дискретизации }
 { BFSize - размер буфера в байтах }
 var
   i : Integer;
 begin
   inherited Create;
   for i := 0 to fTotalBuffers-1 do
   begin
     hWaveHeader[i] := 0;
     hWaveBuffer[i] := 0;
     pWaveBuffer[i] := nil;
     pWaveFmtEx := nil;
   end;
   fBufferSize := BFSize;
 
   fTotalBuffers := TotalBuffers;
   { распределяем память для структуры wave-формата }
   if(not AllocWaveFormatEx) then
   begin
     InitWaveRecorder := FALSE;
     Exit;
   end;
 
   { ищем устройство, совместимое с доступными wave-характеристиками }
   if (waveInGetNumDevs < 1 ) then
   begin
     RecErrorMessage := 'Не найдено устройств, способных записывать звук';
     InitWaveRecorder := FALSE;
     Exit;
   end;
 
   { распределяем память wave-заголовка }
   if (not AllocWaveHeaders) then
   begin
     InitWaveRecorder := FALSE;
     Exit;
   end;
 
   { распределяем память буфера wave-данных }
   if (not AllocPCMBuffers) then
   begin
     InitWaveRecorder := FALSE;
     Exit;
   end;
   InitWaveRecorder := TRUE;
 end;
 
 destructor TWaveRecorder.Destroy;
 { Просто освобождаем всю память, распределенную InitWaveRecorder. }
 begin
   FreeWaveFormatEx;
   FreePCMBuffers;
   FreeWaveHeader;
   inherited Destroy;
 end;
 
 procedure TWaveRecorder.CloseWaveDeviceRecord;
 { Просто освобождаем (закрываем) waveform-устройство. }
 var
   i : Integer;
 begin
   { если устройство уже закрыто, то выходим }
   if (not bDeviceOpen) then
     Exit;
 
   { работа с заголовками - unprepare }
   for i := 0 to fTotalBuffers-1 do
     if (waveInUnprepareHeader(WaveIn, pWaveHeader[i],
     sizeof(TWAVEHDR)) <> 0 ) then
       RecErrorMessage := 'Ошибка в waveInUnprepareHeader';
 
   { сохраняем общий объем записи и обновляем показ }
   dwTotalwavesize := dwBytedatasize;
 
   { закрываем входное wave-устройство }
   if (waveInClose(WaveIn) <> 0) then
     RecErrorMessage := 'Ошибка закрытия входного устройства';
 
   { сообщаем вызвавшей функции, что устройство закрыто }
   bDeviceOpen := FALSE;
 end;
 
 procedure TWaveRecorder.StopRecord;
 { Останавливаем запись и устанавливаем некоторые флаги. }
 var
   iErr : Integer;
 begin
   RecordActive := False;
   iErr := waveInReset(WaveIn);
   { прекращаем запись и возвращаем стоящие в очереди буферы }
   if (iErr <> 0) then
     RecErrorMessage := 'Ошибка в waveInReset';
   CloseWaveDeviceRecord;
 end;
 
 function TWaveRecorder.AddNextBuffer : Boolean;
 { Добавляем буфер ко входной очереди и переключаем буферный индекс. }
 var
   iErr : Integer;
 begin
   { ставим буфер в очередь для получения очередной порции данных }
   iErr := waveInAddBuffer(WaveIn, pwaveheader[bufindex], sizeof(TWAVEHDR));
   if (iErr <> 0) then
   begin
     StopRecord;
     RecErrorMessage := 'Ошибка добавления буфера' + TWaveInGetErrorText(iErr);
     AddNextBuffer := FALSE;
     Exit;
   end;
 
   { переключаемся на следующий буфер }
   bufindex := (bufindex+1) mod fTotalBuffers;
   QueuedBuffers := QueuedBuffers + 1;
 
   AddNextBuffer := TRUE;
 end;
 
 procedure BufferDoneCallBack(
 hW : HWAVE;         // дескриптор waveform-устройства
 uMsg : DWORD;       // посылаемое сообщение
 dwInstance : DWORD; // экземпляр данных
 dwParam1 : DWORD;   // определяемый приложением параметр
 dwParam2 : DWORD;   // определяемый приложением параметр
 ); stdcall;
 { Вызывается при наличии у wave-устройства какой-либо информации, }
 { например при заполнении буфера }
 var
   BaseRecorder : PWaveRecorder;
 begin
   BaseRecorder := Pointer(DwInstance);
   with BaseRecorder^ do
   begin
     ProcessBuffer(uMsg, pWaveBuffer[ProcessedBuffers mod fTotalBuffers],
     WaveBufSize);
 
     if (RecordActive) then
       case uMsg of
         WIM_DATA:
         begin
           BaseRecorder.AddNextBuffer;
           ProcessedBuffers := ProcessedBuffers+1;
         end;
       end;
   end;
 end;
 
 function TWaveRecorder.StartRecord : Boolean;
 { Начало записи. }
 var
   iErr, i : Integer;
 begin
   { начало записи в первый буфер }
   iErr := WaveInStart(WaveIn);
   if (iErr <> 0) then
   begin
     CloseWaveDeviceRecord;
     RecErrorMessage := 'Ошибка начала записи wave: ' +
     TWaveInGetErrorText(iErr);
   end;
 
   RecordActive := TRUE;
 
   { ставим в очередь следующие буферы }
   for i := 1 to fTotalBuffers-1 do
     if (not AddNextBuffer) then
     begin
       StartRecord := FALSE;
       Exit;
     end;
 
   StartRecord := True;
 end;
 
 function TWaveRecorder.SetupRecord(P : PWaveRecorder) : Boolean;
 { Данная функция делает всю работу по созданию waveform-"записывателя". }
 var
   iErr, i : Integer;
 begin
   dwTotalwavesize := 0;
   dwBytedatasize := 0;
   bufindex := 0;
   ProcessedBuffers := 0;
   QueuedBuffers := 0;
 
   { открываем устройство для записи }
   iErr := waveInOpen(@WaveIn, WAVE_MAPPER, pWaveFmtEx,
   Integer(@BufferDoneCallBack),
   Integer(P), CALLBACK_FUNCTION + WAVE_ALLOWSYNC );
 
   if (iErr <> 0) then
   begin
     RecErrorMessage := 'Не могу открыть входное устройство для записи: ' + ^M
     + TWaveInGetErrorText(iErr);
     SetupRecord := FALSE;
     Exit;
   end;
 
   { сообщаем CloseWaveDeviceRecord(), что устройство открыто }
   bDeviceOpen := TRUE;
 
   { подготавливаем заголовки }
   InitWaveHeaders();
 
   for i := 0 to fTotalBuffers-1 do
   begin
     iErr := waveInPrepareHeader( WaveIn, pWaveHeader[I], sizeof(TWAVEHDR));
     if (iErr <> 0) then
     begin
       CloseWaveDeviceRecord;
       RecErrorMessage := 'Ошибка подготовки заголовка для записи: ' + ^M +
       TWaveInGetErrorText(iErr);
       SetupRecord := FALSE;
       Exit;
     end;
   end;
 
   { добавляем первый буфер }
   if (not AddNextBuffer) then
   begin
     SetupRecord := FALSE;
     Exit;
   end;
 
   SetupRecord := TRUE;
 end;
 
 procedure TWaveRecorder.ProcessBuffer(uMsg: Word; P : Pointer;
 n: Integer);
 { Болванка процедуры, вызываемой при готовности буфера. }
 begin
 end;
 
 end.
 




Нарушение уникальности записи


 try
   tMyTable.Post;
 except
   on E : EDBEngineError do
     if E.Message = 'Key violation' then
     begin
       MessageDlgC ('Дублирование записи не допускается.', mtError, [mbOk], 0);
       // Я не уверен в том, что это нужно делать:
       tMyTable.Cancel;
     end
     else
       Raise;
 end;
 

Хорошим примером может служить проект DBERRORS.DPR, расположенный в каталоге Delphi 2 Demos. Выглядит это примерно так:

Создайте функцию типа этой:


 function DBError(DataSet: TDataSet;
   E: EDatabaseError; var Action: TDataAction);
 const
   eKeyViol = 9729;
 var
   iDBIError: Integer;
 begin
   if (E is EDBEngineError) then
   begin
     iDBIError := (E as EDBEngineError).Errors[0].Errorcode;
     case iDBIError of
       eKeyViol:
       begin
         MessageDlg('Нарушение уникальности записи ', mtWarning, [mbOK], 0);
         Abort;
       end;
   end;
 

Затем для каждой таблицы вашего приложения создайте следующий обработчик события:


 procedure TMainForm.Table1EditError(DataSet: TDataSet;
   E: EDatabaseError; var Action: TDataAction);
 begin
   DBError(Table1, E, Action);
 end;
 

Таким образом вы можете перехватить множество ошибок. Смотрите примеры от Borland, там много чего есть полезного.




Запись с помощью MediaPlayer

Автор: Nick Hodges

Origin:
- Ори, джинн! Ори, с#ка!

Компонент Mediaplayer работает только с корректными звуковыми файлами и не работает с файлами нулевого размера. Нижеприведенная функция создаст звуковой файл с размером 1. Вариантная запись. Хотелось бы видеть лучшее решение, но пока такой вариант работает у меня без проблем.


 function CreateNewWave(NewFileName: string): Boolean;
 var
   DeviceID: Word;
   Return: LongInt;
   MciOpen: TMCI_Open_Parms;
   MciRecord: TMCI_Record_Parms;
   MciPlay: TMCI_Play_Parms;
   MciSave: TMCI_SaveParms;
   MCIResult: LongInt;
   Flags: Word;
   TempFileName: array[0..255] of char;
 begin
   MediaPlayer.Close;
   try
     StrPCopy(TempFileName, NewFilename);
 
     MciOpen.lpstrDeviceType := 'waveaudio';
     MciOpen.lpstrElementName := '';
     Flags := Mci_Open_Element or Mci_Open_Type;
     MCIResult := MciSendCommand(0, MCI_OPEN, Flags, LongInt(@MciOpen));
     DeviceID := MciOpen.wDeviceId;
 
     MciRecord.dwTo := 1;
     Flags := Mci_To or Mci_Wait;
     MCIResult := MciSendCommand(DeviceID, Mci_Record, Flags,
       LongInt(@MciRecord));
 
     mciPlay.dwFrom := 0;
     Flags := Mci_From or Mci_Wait;
     MciSendCommand(DeviceId, Mci_Play, Flags, LongInt(@MciPlay));
 
     mciSave.lpfileName := TempFilename.CString;
     Flags := MCI_Save_File or Mci_Wait;
     MCIResult := MciSendCommand(DeviceID, MCI_Save, Flags, LongInt(@MciSave));
 
     Result := MciSendCommand(DeviceID, Mci_Close, 0, LongInt(nil)) = 0;
   end;
 end;
 




Как бороться с квадратичностью Image

Автор: Аркадий

Билл-Гей. Тс-с-с...

При вставке какой-либо картинки в Image с произвольными очертаниями, можно легко обратиться к самой картинке а не к ненужному "куску" Image.

Решение:

Вставляем картинку ,например с белым фоном, transpert:=true и на OnMouseOver, или еще где, пишем:


 if image1.picture.bitmep.canvas.pixels[X, Y]<>clwhite then
   image1.cursor:=crHourGlass
 else
   image1.cursor:=crDefault
 

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




Рекурсивные механизмы спуска по дереву

- Каких деревьев не хватает в ботаническом саду?
- Бинарных, - ответил программист.

Нужно использовать рекурсивные механизмы спуска по дереву и иметь метод определения наличия child узлов у текущего узла.


 function  TDBTreeView.RecurseChilds(node: TTreeNode): double;
 begin
   while node <> nil do begin
     if node.HasChildren then
        Result := RecurseChilds(node.GetFirstChild);
     Result := Result + GetResultForNode(node));
     node := node.GetNextSibling;
   end;
 end;
 
 function  TDBTreeView.GetResult(curnode: TTreeNode;): double;
 begin
   Result := 0;
   if curnode = nil then Exit;
   Result := RecurseChilds(curnode.GetFirstChild);
 end;
 




Рекурсивное удаление файлов и подкаталогов

Один программист очень любил рекурсию. И когда шеф начинал требовать у него отчет о проделанной работе, он отсылал его к ... себе. И так до переполнения стека у шефа.


 {
 Здесь я привожу немного сокращенный код, который я создавал для Borland
 Pascal 5.5 под DOS (оригинальный код не делал rmDir, поэтому вы можете
 поэкспериментировать с этим, передав указатель на каталог функции rmDir
 в конце этого кода). Я подозреваю, что Delphi-версия может быть или
 идентичной, или иметь некоторые различии в написании имен функций
 (рекомендую ознакомиться с электронной документацией по Delphi, с темой,
 где описаны функции для работы с файлами). Данный код не предусматривает
 проверку атрибутов файлов, которые могут быть установлены для
 предотвращения удаления файла. (В Pascal 5.5 вам необходимо между парой
 {$I-}{$I+} {поместить функцию, которая вызывает проблему, не знаю,
 делаете ли вы это в Delphi.)
 }
 
 procedure removeTree(DirName: string);
 var
   FileSearch: SearchRec;
 begin
   { для начала пробегаемся, и удаляем все файлы }
   chDir(DirName);
   FindFirst('*.*', Directory, FileSearch);
   while (DosError = 0) do
   begin
     if (FileSearch.name <> '.') and (FileSearch.name <> '..') and
       ((FileSearch.attr and Directory) <> 0) then
     begin
       if DirName[length(DirName)] = '\' then
         removeTree(DirName + FileSearch.Name)
       else
         removeTree(DirName + '\' + FileSearch.Name);
       ChDir(DirName);
     end;
     FindNext(FileSearch)
   end;
 
   { затем пробегаемся, и удаляем все каталоги }
   FindFirst('*.*', AnyFile, FileSearch);
   while (DosError = 0) do
   begin
     if (FileSearch.name <> '.') and (FileSearch.name <> '..') then
       Remove(workdir);
   end;
   FindNext(FileSearch)
 end;
 rmDir(DirName)
 end;
 




Ищем файл рекурсивно

Встречаются двое юзеров. Один говорит:
- Я тут свежий антивирус достал, не хочешь себе установить?
- Нет, мне это не нужно.
- Почему?
- Да мой комп так глючит, что на нем ни один вирус не запустится.


 procedure GetAllFiles(mask: string);
 var
   search: TSearchRec;
   directory: string;
 begin
   directory := ExtractFilePath(mask);
 
   // find all files 
   if FindFirst(mask, $23, search) = 0 then
   begin
     repeat
       // add the files to the listbox 
       Form1.ListBox1.Items.Add(directory + search.Name);
       Inc(Count);
     until FindNext(search) <> 0;
   end;
 
   // Subdirectories/ Unterverzeichnisse 
   if FindFirst(directory + '*.*', faDirectory, search) = 0 then
   begin
     repeat
       if ((search.Attr and faDirectory) = faDirectory) and (search.Name[1] <> '.') then
         GetAllFiles(directory + search.Name + '\' + ExtractFileName(mask));
     until FindNext(search) <> 0;
     FindClose(search);
   end;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   directory: string;
   mask: string;
 begin
   Count := 0;
   Listbox1.Items.Clear;
 
   directory := 'C:\temp\';
   mask := '*.*';
 
   Screen.Cursor := crHourGlass;
   try
     GetAllFiles(directory + mask);
   finally
     Screen.Cursor := crDefault;
   end;
   ShowMessage(IntToStr(Count) + ' Files found');
 end;
 
 
 {**************************************}
 { Code from P. Below: }
 
 // recursively scanning all drives 
 
   { excerpt from form declaration, form has a listbox1 for the
     results, a label1 for progress, a button2 to start the scan,
     an edit1 to get the search mask from, a button3 to stop
     the scan. }
   private
     { Private declarations }
     FScanAborted: Boolean;
 
   public
     { Public declarations }
 
 function ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;
 
 implementation
 
 function TForm1.ScanDrive(root, filemask: string; hitlist: TStrings): Boolean;
   function ScanDirectory(var path: string): Boolean;
   var
     SRec: TSearchRec;
     pathlen: Integer;
     res: Integer;
   begin
     label1.Caption := path;
     pathlen := Length(path);
     { first pass, files }
     res := FindFirst(path + filemask, faAnyfile, SRec);
     if res = 0 then
       try
         while res = 0 do
         begin
           hitlist.Add(path + SRec.Name);
           res := FindNext(SRec);
         end;
       finally
         FindClose(SRec)
       end;
     Application.ProcessMessages;
     Result := not (FScanAborted or Application.Terminated);
     if not Result then Exit;
 
     {second pass, directories}
     res := FindFirst(path + '*.*', faDirectory, SRec);
     if res = 0 then
       try
         while (res = 0) and Result do
         begin
           if ((Srec.Attr and faDirectory) = faDirectory) and
             (Srec.Name <> '.') and
             (Srec.Name <> '..') then
           begin
             path := path + SRec.Name + '\';
             Result := ScanDirectory(path);
             SetLength(path, pathlen);
           end;
           res := FindNext(SRec);
         end;
       finally
         FindClose(SRec)
       end;
   end;
 begin
   FScanAborted := False;
   Screen.Cursor := crHourglass;
   try
     Result := ScanDirectory(root);
   finally
     Screen.Cursor := crDefault
   end;
 end;
 
 procedure TForm1.Button2Click(Sender: TObject);
 var
   ch: Char;
   root: string;
 begin
   root := 'C:\';
   for ch := 'A' to 'Z' do
   begin
     root[1] := ch;
     case GetDriveType(PChar(root)) of
       DRIVE_FIXED, DRIVE_REMOTE:
         if not ScanDrive(root, edit1.Text, listbox1.Items) then
           Break;
     end;
   end;
 end;
 
 procedure TForm1.Button3Click(Sender: TObject);
 begin // aborts scan 
   FScanAborted := True;
 end;
 




Переопределить параметры формы при её создании

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


 unit MainFrm;
 
 interface
 
 uses
   SysUtils, Windows, Messages, Classes, Graphics, Controls,
   Forms, Dialogs, StdCtrls;
 
 type
   TMainForm = class(TForm)
     btnClose: TButton;
     procedure btnCloseClick(Sender: TObject);
   private
     { Private declarations }
   protected
     // Capture the WM_NCHITTEST message to enable moving the form.
     procedure WMNCHitTest(var message: TWMNCHitTest); message WM_NCHITTEST;
   public
     { Public declarations }
     procedure CreateParams(var Params: TCreateParams); override;
 end;
 
 var
   MainForm: TMainForm;
 
 implementation
 
 {$R *.DFM}
 
 procedure TMainForm.WMNCHitTest(var message: TWMNCHitTest);
 begin
   inherited;
   message.Result := HTCAPTION;
 end;
 
 procedure TMainForm.CreateParams(var Params: TCreateParams);
 begin
   inherited CreateParams(Params);
   Params.Style := WS_THICKFRAME or WS_POPUP or WS_BORDER;
 end;
 
 procedure TMainForm.btnCloseClick(Sender: TObject);
 begin
   Close;
 end;
 
 end.
 




FTP - докачка файлов

Периоды зачатия инетчика:
1. Connect
2. Download
3. Disconnect
4. UnZip (Estimated time: 9 месяцев)

»»» Диман

Как качать файлы через интернет по протоколу FTP я разобрался - послать команду RETR - и эдать файл. А какую команду нужно послать, что бы файл начал скачиваться не с начала а с определённого места - т.е. при обрыве связи докачать его. Может кто знает - подскажите. Или может знаете где раскопать инфу по этому вопросу?

»»» Wonder

Читайте RFC 959 "File Transfer Protocol". А делается это просто:


 REST [С_КАКОГО_БАЙТА_ПРОДОЛЖИТЬ]
 RETR [ИМЯ_ФАЙЛА]
 

Но это только в том случае сработает, если FTP сервер поддерживает докачку.

»»» Диман

В связи с этим 2 вопроса:
  1. Подскажите по какому адресу можно прочитать спецификацию RCF 959, а так же другие из этой серии
  2. Как определить - поддерживает ли сервер докачку файлов. Заранее спасибо.

»»» Wonder

Как определить:

  1. Как правило при входе на FTP сервер в т.н. Welcome message либо написано либо нет о поддержке докачки. Что-то типа "This server can resume broken downloads".
  2. Просто проверить, поддерживает сервер команду REST или нет. Проверить в смысле кода ответа (в RFC написаны все возможные коды ответов на все команды)

Где взять:

  1. Пойти на (например) http://www.yahoo.com и поискать "RFC" (ссылок море)
  2. Или воспользоваться (например) ссылкой
    http://src.doc.ic.ac.uk/computing/internet/rfc/rfc959.txt



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


 InvalidateRect(0, nil, true);
 




Можно ли как-то уменьшить мерцание при перерисовке компонента

Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента - то фон компонента перерисовываться не будет.


 constructor TMyControl.Create;
 begin
   inherited;
   ControlStyle := ControlStyle + [csOpaque];
 end;
 




Обновление вычисляемых полей

Автор: OAmiry (Borland)

Разместите строчку типа нижеприведенной в конце кода обработчика события OnCalcFields:


 {предположим, что вы используете DBGrid1}
 if DBGrid1.Showing then
   DBGrid1.Invalidate ;
 




Как заставить Рабочий Стол обновится


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   SendMessage(FindWindow('Progman', 'Program Manager'),
   WM_COMMAND, $A065, 0);
 end;
 




Как заставить Рабочий Стол обновится 2


 procedure RefreshDesktop;
 var
   hDesktop: HWND;
 begin
   hDesktop := FindWindowEx(FindWindowEx(
     FindWindow('Progman', 'Program Manager'), 0,
     'SHELLDLL_DefView', ''), 0, 'SysListView32', '');
   PostMessage(hDesktop, WM_KEYDOWN, VK_F5, 0);
   PostMessage(hDesktop, WM_KEYUP, VK_F5, 1 shl 31);
 end;
 




Обновить список дисков TDriveComboBox с сетевыми дсками и Plug&Play

И вновь я не замечен Plug-n-Play'ем...


 type
   //это наш "class cracer"
   TNewDriveComboBox = class(TDriveComboBox)
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Drive : char;
 begin
   Drive := DriveComboBox1.Drive;
   //вызываем защищенный метод родительского класса
   TNewDriveComboBox(DriveComboBox1).BuildList;
   DriveComboBox1.Drive := Drive;
 end;
 




Как обновить TQuery не потеряв при этом текущей записи


 procedure RefreshQuery(AQuery: TQuery; const FieldsForSearch: string);
 var
   AList: TList;
   AVarArray: Variant;
   i: Byte;
 begin
   AList := TList.Create;
   try
     AQuery.GetFieldList(AList, FieldsForSearch);
     AVarArray := VarArrayCreate([0, AList.Count - 1], varVariant);
     for i := 0 to Pred(AList.Count) do
       AVarArray[i] := TField(AList.Items[i]).AsVariant;
     AQuery.Close;
     AQuery.Open;
     AQuery.Locate(FieldsForSearch, AVarArray, []);
   finally
     AList.Free;
     AVarArray.Free;
   end;
 end;
 




Как зарегистрировать ActiveX-компонент (OCX-файл) на компьютере пользователя


Пpогpаммеp (П) пpивел к себе домой девушку (Д). Посидели, поболтали, пpогpаммеpу не теpпится в постель пеpейти. Он думает "Щаз вот покажу ей, какой у меня Виндоуз последней веpсии стоит, она скажет "Ого, какой у тебя Виндоуз!", а я ей- "Да ну его, пошли лучше потpахаемся." Показал, она - ноль эмоций. П опять думает: "Так... Hу ладно, щаз покажу ей, какой у меня модем кpутой, на 33600, она скажет "Ого, какой у тебя модем весь кpутой!", а я ей - "Да ну его, пошли лучше потpахаемся!" Показал, та же pеакция. Пpогpаммеp думает: "Блин, ну что бы ей еще показать? Во, пpидумал, покажу ей, какой у меня ноутбук весь белой сбоpки, она скажет "Ого, какой у тебя ноутбук весь белый!", а я ей- "Да ну его, пошли лучше потpахаемся!" Показал. Девушка: (Д): Слушай, а может, да ну все это, пошли лучше потpахаемся! (П): Какое потpахаемся, ты смотpи, какой у меня ноутбук весь белый!

Из командной строки:


C:\WINDOWS\SYSTEM\REGSVR32.EXE "c:\my path\myocx.ocx"





Регистрация компонент


 C:\WINNT\system32\regsvr32.exe "c:\AGUN\VoiceMan\FRALIBCS.DLL"
 




Зарегистрировать новый тип файлов


Возлюбленная компьютерщика мурлычет ему на ушко:
- Любимый, ну когда, когда мы будем регистрироваться?
- А на хр#на? Я сейчас и так взломаю...

Не хуже M$ получается! У них свои типы файлов, и у нас будут свои! Всё, что для этого нужно - точно выполнять последовательность действий и научиться копировать в буфер, чтобы не писать все те коды, что будут тут изложены :))

Сначала, естественно, объявляем в uses модуль Registry.


 uses
   Registry;
 

Затем в публичных объявлениях объявляем процедуру регистрации нового типа файлов:


 public
   { Public declarations }
   procedure RegisterFileType(ext: string; FileName: string);
 

Описываем её так:


 procedure TForm1.RegisterFileType(ext: string; FileName: string);
 var
   reg: TRegistry;
 begin
   reg:=TRegistry.Create;
   with reg do
   begin
     RootKey:=HKEY_CLASSES_ROOT;
     OpenKey('.'+ext,True);
     WriteString('',ext+'file');
     CloseKey;
     CreateKey(ext+'file');
     OpenKey(ext+'file\DefaultIcon',True);
     WriteString('',FileName+',0');
     CloseKey;
     OpenKey(ext+'file\shell\open\command',True);
     WriteString('',FileName+' "%1"');
     CloseKey;
     Free;
   end;
 end;
 

Ну а по нажатию какого-нибудь батона регистрируем!


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   RegisterFileType('DelphiWorld', Application.ExeName);
 end;
 




Как зарегистрировать OCX

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

Предположим вы создали OCX с именем "test.ocx".

Теперь его необходимо зарегистрировать в системе:


 var
   OCXHand: THandle;
   RegFunc: TDllRegisterServer; //добавьте OLECtl в список используемых модулей
 begin
   OCXHand := LoadLibrary('c:\windows\system\test.ocx');
   RegFunc := GetProcAddress(OCXHand, 'DllRegisterServer');
     //чуствительность к регистру?
   if RegFunc <> 0 then
     ShowMessage('Ошибка!');
   FreeLibrary(OCXHand);
 end;
 

Для обратной процедуры, "отрегистрации" OCX, вам необходимо всего лишь заменить 'DllRegisterServer' на 'DllUnregisterServer'.

Также для полноты картины вы можете добавить код, извещающий пользователя о процессе регистрации, например так: "Does the file exist" (файл не найден), "Was the call to LoadLibrary successful?" (был ли вызов LoadLibrary успешным?), ...

Некоторые пояснения:

OCX - специфический форма dll, поэтому вы можете загрузить ее в память, используя знакомую уже API функцию LoadLibrary(). OCX экспортирует две функции, осуществляющие ее регистрацию и "отрегистрацию". Для получения адреса этих функций используется соответствующая функция GetProcAddress. После этого остается только вызвать необходимую функцию. И это все! После этого для успокоения души с помощью редактора регистров (regedit.exe) вы можете проверить регистрацию вашего OCX.




Регистрация редактора свойства

Автор: Mike Scott(Mobius Ltd.)

Скажем, вы имеете компонент TContainer, содержащий TContainedClass в свойстве с именем 'Contained' - попробуйте добавить следующую строку к процедуре Register вашего компонента:


 RegisterPropertyEditor( TypeInfo( TContainedClass ),
 TContainer, 'Contained', TClassProperty ) ;
 

Не забудьте добавить TypInfo и DsgnIntf в список используемых модулей.

Все это задокументировано в справке помощи. Первым параметром всегда идет TypeInfo() с "коллекционируемым" классом в качестве параметра, затем контейнерный класс или NIL, если он должен работать для всех экземпляров контейнерного класса с заданным свойством, затем идет имя контейнерного свойства или '', если редактор должен работать для всех свойств, и завершает славную четверку параметров класс TClassProperty, расширяющий классовое свойство, т.е. "создающий" знак "+" в Инспекторе Объектов, позволяющий редактировать вложенные свойства (щелчок на плюсике раскрывает список вложенных свойств описываемого контейнерного класса).




Регистрация WinZip 7.0 (beta)

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

В этой статье мы попытаемся почувствовать себя настоящими исследователями программ. Конечно, это будут только первые робкие шаги, но именно они обычно являются определяющими для всей остальной работы в этом направлении. Нашей целью будет регистрация всемирно известной программы WinZip 7.0 (beta). В статье рассматривается build 1243, для более новой программы возможны некоторые отличия в адресах.

Устанавливаем и запускаем WinZip. Сразу после старта появляется окно, сообщающее о том, что программа не зарегистрирована. Если программу не зарегистрировать это окно будет появляться при каждом новом запуске. Это неудобно! В меню Help выбираем пункт About WinZip... В появившемся окне нажимаем кнопку Register. Открывается окно регистрации. Вводим в поле Имя имя, под которым хотим зарегистрировать программу (я использовал Fox Mulder). В поле РН вводим любую информацию (я обычно использую 200001, чтобы потом при необходимости его легко было опознать) и нажимаем кнопку ОК. Появляется окно, сообщающее, что введена неполная или неверная информация. Обращаю Ваше внимание на это окно. Это типичное окно MessageBox (окно сообщения). Его отличительными чертами являются:

  • неактивная кнопка закрытия окна
  • наличие внутри окна иконки (вид иконки зависит от типа сообщения)
  • наличие одной или нескольких кнопок (их названия и количество также зависит от типа сообщения)

В программе окно MessageBox может создаваться с помощью четырех функций: MessageBox(), MessageBoxA(), MessageBoxIndirect() и MessageBoxIndirectA(). Функции, не оканчивающиеся символом A (MessageBox(), MessageBoxIndirect()) используются преимущественно приложениями Win16 (Windows 3.x) и на них мы будем рассчитывать меньше всего. Остаются две функции: MessageBoxA() и MessageBoxIndirectA(). Какая из них используется программой, определяем опытным путем:

  • Закрываем окно сообщения
  • Активизируем SoftICE (Ctrl+D)
  • Устанавливаем точки прерывания на вызов MessageBoxA() и MessageBoxIndirectA() (bpx MessageBoxA, bpx MessageBoxIndirectA)
  • Возвращаемся в Windows (F5)

Нажимаем кнопку ОК в окне регистрации, программа прерывается при вызове функции и передает управление SoftICE. В окне команд сообщается, что программа прервалась при вызове функции MessageBoxIndirectA() из модуля USER32. И действительно в окне кода мы видим, что курсор стоит на первой строке этой функции и, что имя текущего модуля USER32 (написано внизу окна кода). Дальше мы тоже знаем, что делать:

  • Нажимаем F12 (команда p ret), для продолжения программы до выполнения команды ret. Перед нами вновь появляется знакомое окно сообщения, при нажатии в нем на кнопку ОК программа прерывается и управление передается SoftICE. Мы видим, что теперь программа остановилась в модуле WINZIP32:

 0137:00426920 FF15C4AF4700 call [USER32!MessageBoxIndirectA]
 0137:00426926 EB14         jmp 0042693C <- в этой строке находится курсор
 

Вот мы и нашли то место, где вызывается функция MessageBoxIndirectA() и создается окно сообщения. Теперь можно удалить установленные точки прерывания (команда bc *), т.к. они нам больше не понадобятся. В этой статье мы больше ничего, связанного с функцией MessageBoxIndirectA(), не узнаем. Использовали мы ее по двум причинам:

  1. Чтобы Вы научились устанавливать точки прерывания на вызовы API-функций, и находит место их вызова в программе.
  2. Чтобы прервать программу в модуле WINZIP32. Это необходимо для установки точек прерывания на конкретные адреса в памяти. Как я уже говорил в статье о распределении памяти, каждая программа работает в своем адресном пространстве. Причем, практически у всех запущенных приложений есть разные участки кода с одинаковыми адресами. Поэтому, для установки точки прерывания на некоторый адрес памяти кроме самого этого адреса, необходимо еще правильно указать нужное адресное пространство (или модуль, что в данном случае одно и тоже). Особенностью SoftICE является то, что он устанавливает точку прерывания на адрес в том модуле, в котором прервалось выполнение. Вот почему, для установки точки прерывания на адрес памяти (нам ее еще только предстоит установить) пришлось воспользоваться точкой прерывания на вызов функции MessageBoxIndirectA()

Здесь уместным был бы Ваш вопрос о том, почему для установки этой точки прерывания не пришлось прибегать к каким-либо хитростям? Все очень просто! Точка прерывания на вызов MessageBoxIndirectA() устанавливается на первую команду кода этой функции в модуле USER32. Этот модуль находится в области памяти, которая является общей для всех запущенных приложений Windows (она расположена выше 2-го Гб), поэтому здесь никаких трудностей не возникает.

Итак, продолжим:

  • Мы все еще находимся в SoftICE. Устанавливаем точку прерывания на выполнение команды по адресу 00407CA5 (команда bpx 407CA5).
  • Выходим в Windows (F5) и вновь пытаемся зарегистрироваться. При этом программа прерывается при выполнении команды по адресу 00407CA5, в окне команд SoftICE сообщается, что программа остановилась на точке прерывания по адресу 0137:00407CA5.
  • Вводим команду db eax (показать в окне данных содержимое памяти в виде байт, начиная с адреса, содержащегося в регистре eax) и переписываем 8 символов нашего регистрационного номера (у меня это 409A11AA).
  • Убираем не нужную уже точку прерывания (команда bc *) и выходим в Windows (F5).
  • Наступает решающий момент. Вводим в поле РН полученный регистрационный номер и нажимаем кнопку ОК. Программа просит подтвердить регистрационную информацию, и после нажатия ОК Вы уже являетесь владельцем личного WinZip'а.

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




Регистры - доступ и использование вместо WIN.INI

Плачет молодая забеременевшая программистка, слезами заливается. Над ней висит мать:
- Да как ты могла? Да как ты посмела? Где твои глаза были?
Программистка:
- А он обещал стать зарегистрированным пользователем...


 uses
   Registry, Windows;
 
 var
   TheReg: TRegistry;
   KeyName: string;
   ValueStr: string;
 
 begin
   TheReg := TRegistry.Create;
   try
     TheReg.RootKey := HKEY_CURRENT_USER;
     KeyName := 'Software\MyTinyApp\StartUp';
     if TheReg.OpenKey(KeyName, False) then
     begin
       ValueStr := TheReg.ReadString('WorkPath');
       TheReg.CloseKey;
     end;
   finally
     TheReg.Free;
   end;
 end;
 

Также имейте в виду, что корректное место для сохранения пути к вашему приложению (EXE-файлу) в регистрах Win95 находится по адресу:


 HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\AppPaths\MYAPP.EXE
 

Сохраните полный путь к вашему приложению как значение по умолчанию в этом ключе.

Regstr.pas определяет константу для этого пути (...\App Paths\) как REGSTR_PATH_APPPATHS.

Сохранение полного пути к вашему приложению (EXE-файлу) позволит пользователю запустить его, просто набрав MYAPP (зарегистрированное имя) в стартовом меню Start|Run. Вот пример, регистрирующий путь к вашему приложению:


 uses
   Registry, Regstr;
 
 var
   TheReg: TRegistry;
   KeyName: string;
 
 begin
   TheReg := TRegistry.Create;
   try
     {Проверяем установку AppPath и при необходимости корректируем}
     TheReg.RootKey := HKEY_LOCAL_MACHINE;
     KeyName := REGSTR_PATH_APPPATHS + ExtractFileName(Application.ExeName);
     if TheReg.OpenKey(KeyName, True) then
     begin
       if CompareText(TheReg.ReadString(''), Application.ExeName) <> 0 then
         TheReg.WriteString('', Application.ExeName);
       TheReg.CloseKey;
     end;
   finally
     TheReg.Free;
   end;
 end;
 




Экспорт и импорт из реестра

reg-файлы это, как и ожидалось, формат, понимаемый и поддерживаемый сугубо программой regedit.

Командная строка у неё такая:

  • Импорт в реестр:

 regedit RegData.reg
 

  • Экспорт из реестра:

 regedit /e RegData.reg HKEY_LOCAL_MACHINE\Software\Microsoft\Windows
 

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


 uses
   ShellApi;
 
 procedure TMain.ExportBtnClick(Sender: TObject);
 var
   FileName, Key: string;
 begin
   FileName := ... //заполнить именем файла (расширение указывать)
   Key := ... //заполнить именем ключа, типа
   //Key := 'HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion'
   if ShellExecute(Handle, 'open', 'regedit.exe',
   PChar(Format('/e "%s" "%s"', [FileName, Key])),
   '', SW_SHOWDEFAULT) <= 32
   then //если ошибка, то возвращаемый код <=32
     RaiseLastWin32Error();
 end;
 




Как определить доступные сервера приложений на машине через Registry

Автор: Nomadic

Встречаются два системных администратора, и один спрашивает другого:
- Ты чего такой грустный?
- Да вот сервер вчера "упал".
- Ну да ты что, его до сих пор не "поднял"?
- Поднял, но он со стола упал...

Прочитайте ключ под HKEY_CLASSES_ROOT\CLSID\*, просматривая его насчёт ключей, которые имеют подключ "Borland DataBroker". Эти вхождения и являются серверами приложений.

Ниже пример, который загружает имена доступных серверов приложений в Listbox:


 uses Registry;
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   I: integer;
   TempList: TStringList;
 begin
   TempList := TStringList.Create;
   try
     with TRegistry.Create do
     try
       RootKey := HKEY_CLASSES_ROOT;
       if OpenKey('CLSID', False) then
         GetKeyNames(TempList);
       CloseKey;
       for I := 1 to TempList.Count - 1 do
         if KeyExists('CLSID\' + TempList[I] + '\Borland DataBroker') then
         begin
           if OpenKey('CLSID\' + TempList[I] + '\ProgID', False) then
           begin
             Listbox1.Items.Add(ReadString(''));
             CloseKey;
           end;
         end;
     finally
       Free;
     end;
   finally
     TempList.Free;
   end;
 end;
 




Как из Delphi влиять на реестр (Изменить заголовок корзины)


- Что такое "Мелкие мягкие делишки для маленьких мягких окошечек"?
- Microsoft Works for Microsoft Windows.

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

Для этого нужно:

  1. В области uses объявить модуль Registry:

 uses
   Registry;
 

  1. Объявить переменную класса TRegistry:

 var
   a: TRegistry;
 

  1. Создать эту переменную (имеется в виду - выделить под неё память):

 a := TRegistry.Create;
 

  1. Переменная класса TRegistry имеет тип записи. У переменной типа "запись" есть свои свойства, свои события. И теперь, после того как мы выделили память под эту переменную, нам сперва нужно указать с каким из основных ключей мы хотим взаимодействовать - с помощью свойства RootKey:

 a.RootKey := HKEY_CLASSES_ROOT;
 

  1. Далее мы открываем нужный нам ключ, используя метод OpenKey. Сначала нужно указать путь к нужному ключу (без указания главного, т.к. он уже был указан в предыдущем пункте), а затем логическое значение, обозначающее - будет ли создан ключ в случае его отсутствия (мы написали false - это значит, что ключ создан не будет). Например, мы хотим изменить заголовок корзины (заметьте, обычным способом это сделать нельзя!), тогда код с указанием пути к ключу, отвечающему за эту системную папку будет выглядеть так:

 a.OpenKey('\CLSID\{645FF040-5081-101B-9F08-00AA002F954E}', false);
 

  1. Когда нужный ключ открыт, нам предоставляется возможность редактировать его параметры. Для этого нужно использовать следующие методы: для внесения данных в реестр - WriteString, WriteInteger, WriteFloat, WriteDate и т.д., в зависимости от того какого типа данные мы хотим вносить; для считывания данных из параметра - ReadString, ReadInteger, ReadFloat, ReadDate... :

В данном случае, мы хотим изменить заголовок корзины, т.е. хотим внести данные в реестр, данные строкового типа - поэтому используем метод WriteString:


 a.WriteString('', 'Мусорка');
 

Методу нужно указать 2 параметра: сначала имя параметра, затем заносимое значение. В качестве имени параметра мы не указываем ничего, п.ч. в указанном нами ключе имя корзины - это параметр по умолчанию. В качестве значения можно указать всё, что угодно, например, 'Мусорка'.

  1. После того как мы сделали своё грязное дело, нужно замести следы: сначала закрыть ключ:

 a.CloseKey;
 

а затем освободить выделенную нами память:


 a.Free;
 

ВСЁ! ТЕПЕРЬ МЫ МОЖЕТ СПОКОЙНО ГУЛЯТЬ ПО ВСЕМУ РЕЕСТРУ, И ДЕЛАТЬ ЖИЗНЬ БЕДНОГО ЛАМЕРА НЕВЫНОСИМОЙ!




Удобная загрузка местоположения формы

Автор: Virtualik

Если вы храните параметры местоположения(Top, Left, Width, Height) формы в реестре, то чтобы не загружать данные из нескольких ключей вы можете их записать в один, и из одного же прочитать ;)

По сути, данные записывается в виде record'а. А как это примерно может выглядеть смотрите в примере.


 var
   Ini: TRegIniFile;
 ...
 
 procedure TForm1.FormCreate(Sender: TObject);
 var
   Rct: TRect;
 begin
   Ini := TRegIniFile.Create('<Здесь вы пишете путь к вашим настройкам в
     реестре > ');
   // Если есть данные --> загружаем их
   if Ini.ReadBinaryData('FormPosition', Rct, SizeOf(TRect)) > 0 then
     BoundsRect := Rct;
   ...
 end;
 
 procedure TReply.FormDestroy(Sender: TObject);
 var
   Rct: TRect;
 begin
   // Сохранение данных на выходе
   ...
   Rct := BoundsRect;
   Ini.WriteBinaryData('MsgPos', Rct, SizeOf(TRect));
   Ini.Free;
 end;
 




Получить из регистров информацию о временной зоне (DST)

12 Заповедей от Админа.
1. Прав всегда Админ, ибо в трех лицах есть он единая власть высшая в классе дисплейном!
2. Неправ вечно юзер, ибо прав всегда Админ!
3. Не возжелай ни места, ни системника, ни профиля, ни монитора, ни мыши Админа своего, и да пребудет с тобой вечное благословение его! 4. И если вошел Юзер в систему без высшего на то дозволения (Админа) - горе ему, ибо порушится профиль его!
5. Да убоится юзер установить прогу неустановленную на комп казенный - ибо не дозволено сие!
6. Да не будет превышен профиль юзерский, ибо сказал Админ: "Аз воздам за то обрезанием... профиля твоего!"
7. Не возжелай войти под паролем чужим в систему, ибо надолго потом из дисплейки выйдешь ты!
8. А если кто разрешение на папку сменит - горе юзеру этому, ибо всемогущ в системе своей Админ!
9. Да убоятся пользователи толпиться на местах своих подобно стадам овец безмозглых, ибо всеведущ Админ!
10. И да убоится юзер качать вирусы, ибо админомерзкое занятие сие!
11. А если кто из юзеров возжелает порнухи или чата админа своего - горе и позор ему, ибо высшие удовольствия эти лишь Админу дозволены!
12. А тот юзер, который прочел строки эти и не проникся смирением и не осознал, что тварь он ламероидная и чайник нечищенный в сиянии славы высшего существа Админоподобного - горе ему, ибо навеки отлучены они будут от сети великой!!!
Во имя отца Билли Гейтса, и сына его Microsofta, и святого духа админовского.

HKEYLocalMachine/Software/Microsoft/Windows/CurrentVersion/TimeZones/ - место, где в регистре хранится информация о временных зонах (Timezone). Двоичный код 'TZI' хранит информацию о начале и конце летнего времени. Есть какие-нибудь идеи насчет извлечения этих дат из этой двоичной величины?

Ок, попробую здесь описать бинарную структуру значения TZI:


 int32 Bias;             // Минуты от GMT
                         // (Сидней -600; 0xfffffda8;
                         // или a8, fd, ff, ff)
 int32 StandardBias;     // Смещение для стандартного времени (0)
 int32 DaylightBias;     // Смещение для летнего времени (-60
                         // или 0xffffffc4 )
 int16 ??                          // 0
 int16 StandardStartMonth;         // 3 => Март
 int16 StandardStartDayOfWeek??;   // 0 => Воскресенье
 int16 StandardStartDOWoccurrence; // 1 => 1-й
 int16 StandardStartHour;          // 2 => 02:00:00.00
 int16 StandardStartMins??;        // 0 => 02:00:00.00
 int16 StandardStartSecs??;        // 0 => 02:00:00.00
 int16 StandardStartHunds??;       // 0 => 02:00:00.00
 int16 ??                          // 0
 int16 DaylightStartMonth;         // 0x0a (10) => Октябрь
 int16 DaylightStartDayOfWeek??;   // 0 => Воскресенье
 int16 DaylightStartDOWoccurrence; // 5 => последний
 int16 DaylightStartHour;          // 2 => 02:00:00.00
 int16 DaylightStartMins??;        // 0 => 02:00:00.00
 int16 DaylightStartSecs??;        // 0 => 02:00:00.00
 int16 DaylightStartHunds??;       // 0 => 02:00:00.00
 
 
 




После внесения изменений в реестр, некоторые программы не видят их

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

Необходимо послать всем окнам сообщение WM_WININICHANGE с указанием полного адреса измененного адреса ключа.


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0,
     LongInt(PChar('RegistrySection')));
 end;
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS