Валентин Озеров

Советы по Delphi. Версия 1.0.6

Жанр:

Программирование

Автор:

Валентин Озеров

«Советы по Delphi. Версия 1.0.6»

2540

читать постранично

Настроики

Фон текста:

Текст
Текст
Текст
Текст

Аа
Roboto
Аа
Garamond
Аа
Fira Sans
Аа
Times

Обзор

Данный раздел содержит справочную информацию. Как и сами "Советы", он разбит на темы и перечисляет содержащиеся в них сами советы и их количество. По причине большого количества советов, плохих телефонных линий в России, проблематичности большинства пользователей сидеть в Интернете без оглядки на часы, да и просто ввиду непредназначенности Интернета для публикования справочных систем, "Советы по Delphi" не предусматривают online-версии и существуют в виде скомпилированного файла с удобной системой инсталляции.

Введение

Что такое "Советы по Delphi"?

"Советы по Delphi" – коллекция ответов на нетрадиционные вопросы программирования на Delphi, нестандартных решений, хитростей и интересных идей. Для практической пользы дела приведены конкретные примеры кода, позволяющие донести идею или полностью ответить на заданный вопрос.

Aвтором предусматривается попытка на периодичность издания, подробности получения новых версий смотрите на страничке "Получение". При составлении "Советов" не ставилась цель включить ВСЕ материалы, отбирались лишь самые интересные. Источником "Советов" служили многочисленные западные источники (FAQ), кропотливо отобранные и переведенные на русский язык.

Учитывая плачевное состояние наших линий, "Советы" практически не содержат графики. Весь приведенный код отформатирован таким образом, чтобы вы могли скопировать его прямо со странички в свое приложение. По этой же причине отсутствует online-версия "Советов". Тем не менее, оглавление советов приведены на страничке "Индексы" (дабы не оказался кот в мешке).

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

Шлите примеры, советы, полезности, статьи и давайте ссылки на свои и не свои сайты. От вас самих зависит наполняемость советов. Авторы! Дайте вторую жизнь вашим произведениям! Присылайте статьи и переводы!

Предупреждение

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

Тем не менее, если Ваш компьютер все-таки взорвался, сообщите мне пожалуйста об этом и я просмотрю код в поисках ошибки.

Объявление

Aвтор ищет возможность размещения домашней странички "Советов" с возможностью размещения на ней самих "Советов". Желателен канал не меньше 64К и возможность работы по FTP. Страничка небольшая, но "Советы" – растущий файл, который трудно разместить, а тем более скачать с бесплатных серверов. Буду благодарен за предоставленную возможность.

Лицензионное соглашение

Использование Вами любой версии Советов по Delphi указывает на то, что Вы принимаете все условия данного лицензионного соглашения:

Предоставление лицензии

Bалентин Озеров предоставил Вам ограниченную лицензию на "Советы по Delphi". Она НЕ ВКЛЮЧАЕТ В СЕБЯ лицензию на изменение, транслирование, перепроектирование, декомпилирование, дизассемблирование (за исключением случаев, когда соответствующие законы специально запрещают такое ограничение), или создание других программных продуктов, основанных на этом.

Особые условия

Ограничение на обратное конструирование, декомпиляцию и дизассемблирование.

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

Tак как все программное обеспечение бесплатно, компания Mechanical Result и автор не несут ответственности за любые последствия использования данного программного обеспечения на вашем компьютере.

Советы по Delphi распространяется по принципу "КАК ЕСТЬ", т.е. без гарантий любого вида, включая отсутствие гарантии на соответствие указанным задачам и отсутствие сбоев. Весь риск относительно качества и эффективности программного обеспечения лежит на Вас. Если использование данной программы приведет к проблемам, Вы принимаете на себя всю стоимость любого обслуживания и ремонта.

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

Распространение

Вы свободны в распространении Советов по Delphi на любом общественном (открытом) Web/FTP/Gopher сервере без обязательного получения разрешения автора, пока это распространение проводится АБСОЛЮТНО БЕСПЛАТНО. Если Вы хотите издать данный продукт на или совместно с любым носителем (например, на компакт диске с журналом или книгой, на любой коллекции программного обеспечения, совместно с другим программным обеспечением или любым другим дистрибутивным пакетом), требуется разрешение автора. Обычно разрешение может быть получено без проблем – свободно, за исключением некоторых особых случаев.

Помните

Валентин Озеров – единственый человек, который может дать разрешение на коммерческое использование и распространение справочной системы Советы по Delphi.

ЕСЛИ ВЫ НЕ ПОНИМАЕТЕ КАКОЙ-ЛИБО ЧАСТИ ДАННОГО ЛИЦЕНЗИОННОГО СОГЛАШЕНИЯ ИЛИ ВСЕГО СОГЛАШЕНИЯ В ЦЕЛОМ, СВЯЖИТЕСЬ СО МНОЙ ПО ЭЛЕКТРОННОЙ ПОЧТЕ ИЛИ ЛЮБЫМ ДРУГИМ СПОСОБОМ, ЧТОБЫ Я МОГ ОБЪЯСНИТЬ ИХ ВАМ.

Рассылка

Bероятно вы хотели бы иметь у себя самую последнюю версия "Советов по Delphi"? Нет ничего проще. Выберите подходящий способ, отправьте мне письмо и не забудьте указать Ваш email, ФИО и город проживания (исключительно для статистики). Вам будет посылаться раз в месяц небольшой файл (около 150Кб), который позволит установить справочную систему через Интернет.

Вам необходимо:

Подписаться на ежемесячную рассылку? (посылается небольшой файл setup.exe, производящий инсталляцию с сервера).

Прекратить подписку?

Oпределитесь и нажмите на соответствующую ссылку.

Цены

Услуга Стоимость Справочная система "Советы по Delphi" Бесплатно Размещение монопольного банера на титульной странице в течение месяца На правах обмена Прием советов Бесплатно

Ссылки

Разработчик Delphi

Русскоязычные

N Сервер Описание 1 Российское представительство Inprise Фирма – разработчик Delphi

Англоязычные

N Сервер Описание 1 Inprise Фирма – разработчик Delphi

Сайты, посвященные Delphi

Англоязычные

N Сервер Описание 1 Delphi Super Page Самая большая в мире коллекция компонентов для всех продуктов фирмы Borland.

Пиратские сайты

Русскоязычные

N Сервер Описание 1 KiraSoft Warez Page Delphi distr, DB Aware, Communication, General, Reports, Experts, Misc, Tools, Links 2 Barry's Delphi Page VCL's, VCL packs, Help Design, FAQ's, IB DataBase, Utilities, Forum

Другие

N Сервер Описание 1 /~dce Delphi Components Crack (with Dr.Dai) Как там написано, "Following components ONLY for Delphi 3.0", остальное понять трудно, как и идентифицировать родной язык автора сайта, хотя по скриншотам разобраться что и где лежит вполне можно

Домашние страницы

Русскоязычные

N Сервер Описание 1 Delphi Russian Suite Сайт, посвященный программированию на Дельфи. Автор страницы Алексей Спицын. Можно скачать документацию по Дельфи (в том числе и на русском языке). Есть список ссылок на страницы в интернете, посвященные Дельфи, а также на адреса электронных версий компьютерных журналов.

Алгоритмы

Преобразования

HEX→Integer

Решение 1

var

i: integer;

s: string;

begin

s:= '$' + ThatHexString;

i:= StrToInt(a);

end;

Решение 2

CONST HEX: ARRAY['A'..'F'] OF INTEGER = (10,11,12,13,14,15);

VAR str : String;

Int, i: integer;

BEGIN

READLN(str);

Int:= 0;

FOR i:= 1 TO length(str) DO

IF str[i] < 'a' THEN Int:= Int * 16 + ord(str[i]) – 48

ELSE Int:= Int * 16 + hex[str[i]];

WRITELN(Int);

READLN;

END.

Преобразование десятичного числа в шестнадцатиричное

Самое простое преобразование – через строку.

HexString:= Format('%0x', DecValue);

Преобразование ASCII в шестнадцатиричное представление

Строка представляет собой массив байтов в виде ASCII-символов. Необходимо организовать преобразование типов по аналогии с Delphi-функциями Ord и Chr.

Функция BytesToHexStr преобразует, к примеру, набор байтов [0,1,1,0] в строку '30313130', HexStrToBytes выполнит обратное преобразование.

unit Hexstr;

interface

uses String16, SysUtils;

Type

PByte = ^BYTE;

procedure BytesToHexstr(var hHexStr: String; pbyteArray: PByte; InputLength: WORD);

procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer);

procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD);

implementation

procedure BytesToHexStr(var hHexStr: String; pbyteArray: PByte; InputLength: WORD);

Const

HexChars : Array[0..15] of char = '0123456789ABCDEF';

var

i, j: WORD;

begin

SetLength(hHexStr, (InputLength * 2));

FillChar(hHexStr, sizeof(hHexStr), #0);

j:= 1;

for i := 1 to InputLength do begin

hHexStr[j]:= Char(HexChars[pbyteArray^ shr 4]); inc(j);

hHexStr[j]:= Char(HexChars[pbyteArray^ and 15]); inc(j);

inc(pbyteArray);

end;

procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD);

var

i: WORD;

c: byte;

begin

SetLength(Response, InputLength);

FillChar(Response, SizeOf(Response), #0);

for i:= 0 to (InputLength – 1) do begin

c:= BYTE(HexBytes[i]) And BYTE($f);

if c > 9 then Inc(c, $37)

else Inc(c, $30);

Response[i + 1]:= char(c);

end;{for}

end;

procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer);

{pbyteArray указывает на область памяти, хранящей результаты}

var

i, j: WORD;

tempPtr: PChar;

twoDigits: String[2];

begin

tempPtr:= pbyteArray;

j:= 1;

for i:= 1 to (Length(hHexStr) DIV 2) do begin

twoDigits:= Copy(hHexStr, j, 2); Inc(j, 2);

PByte(tempPtr)^:= StrToInt('$' + twoDigits); Inc(tempPtr);

end;{for}

end;

end.

UNIT string16.

interface

{$IFNDEF Win32}

procedure SetLength(var S: string; Len: Integer);

procedure SetString(var Dst: string; Src: PChar; Len: Integer);

{$ENDIF}

implementation

{$IFNDEF Win32}

procedure SetLength(var S: string; Len: Integer);

begin

if len > 255 then S[0]:= Chr(255)

else S[0]:= Chr(Len)

end;

procedure SetString(var Dst: string; Src: PChar; Len: Integer);

begin

if Len > 255 then Move(Src^, Dst[1], 255)

else Move(Src^, Dst[1], Len);

SetLength(Dst, Len);

end;

{$ENDIF}

end.

Преобразование двоичного числа в десятичное

Может ли кто-нибудь дать мне идею простого преобразования двоичного кода (base2) в десятичный (base10)?

Решение 1

/////////////////////////////////////////////////////////////////////////

// преобразование 32-битного base2 в 32-битный base10 //

// максимальное число = 99 999 999, возвращает –1 при большем значении //

/////////////////////////////////////////////////////////////////////////

function base10(base2:integer) : integer; assembler;

asm

cmp eax,100000000 // проверка максимального значения

jb @1 // значение в пределах допустимого

mov eax,-1 // флаг ошибки

jmp @exit // выход если –1

@1:

push ebx // сохранение регистров

push esi

xor esi,esi // результат = 0

mov ebx,10 // вычисление десятичного логарифма

mov ecx,8 // преобразование по формуле 10^8-1

@2:

mov edx,0 // удаление разницы

div ebx // eax – целочисленное деление на 10, edx – остаток от деления на 10

add esi,edx // результат = результат + разность[I]

ror esi,4 // перемещение разряда

loop @2 // цикл для всех 8 разрядов

mov eax,esi // результат функции

pop esi // восстанавление регистров

pop ebx

@exit:

end;

Решение 2

function IntToBin(Value: Longint; Size: Integer): String;

var

i: Integer;

begin

Result :='';

for i:= Size downto 0 do begin

if value and (1 shl i)<>0 then begin

Result:= Result+'1';

end else begin

Result:= Result+'0';

end;

Function BinToInt(Value: String): Longint;

var

i,Size: Integer;

begin

Result:= 0;

Size:= Length(Value);

for i:=Size downto 0 do begin

if copy(value,i,1) = '1' then begin

Result:= Result + (1 shl i);

end;

Решение 3

Следующая функция получает в качестве параметра Base (1..16) любую десятичную величину и возвращает результат в виде строки, содержащей точное значение BaseX. Вы можете использовать данный алгоритм для преобразования арабских чисел в римские (смотри ниже).

function DecToBase(Decimal: Longint; const Base: Byte): String;

const Symbols: String[16] = '0123456789ABCDEF';

var

scratch: String;

remainder: Byte;

begin

scratch:= '';

repeat

remainder:= Decimal mod base;

scratch:= Symbols[remainder + 1] + scratch;

Decimal:= Decimal div base;

until (decimal = 0);

Result:= scratch;

end;

Передайте данной функции любую десятичную величину (1…3999), и она возвратит строку, содержащую точное значение в римской транскрипции.

function DecToRoman(Decimal: Longint ): String;

const Romans: Array[1..13] of String = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');

Arabics: Array[1..13] of integer = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);

var

i: Integer;

scratch: String;

begin

scratch:= '';

for i := 13 downto 1 do

while (decimal >= arabics[i]) do begin

Decimal:= Decimal – Arabics[i];

scratch:= scratch + Romans[i];

end;

Result:= scratch;

end;

Преобразование ICO в BMP

Решение 1

Попробуйте:

var

Icon: TIcon;

Bitmap: TBitmap;

begin

Icon:= TIcon.Create;

Bitmap:= TBitmap.Create;

Icon.LoadFromFile('c:\picture.ico');

Bitmap.Width:= Icon.Width;

Bitmap.Height:= Icon.Height;

Bitmap.Canvas.Draw(0, 0, Icon);

Bitmap.SaveToFile('c:\picture.bmp');

Icon.Free;

Bitmap.Free;

end;

Решение 2

Способ преобразования изображения размером 32×32 в иконку.

unit main;

interface

uses

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

type TForm1 = class(TForm)

Button1: TButton;

Image1: TImage;

Image2: TImage;

procedure Button1Click(Sender: Tobject);

procedure FormCreate(Sender: Tobject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

Procedure Tform1.Button1Click(Sender: Tobject);

var winDC, srcdc, destdc : HDC;

oldBitmap : HBitmap;

iinfo : TICONINFO;

begin

GetIconInfo(Image1.Picture.Icon.Handle, iinfo);

WinDC:= getDC(handle);

srcDC:= CreateCompatibleDC(WinDC);

destDC:= CreateCompatibleDC(WinDC);

oldBitmap:= SelectObject(destDC, iinfo.hbmColor);

oldBitmap:= SelectObject(srcDC, iinfo.hbmMask);

BitBlt(destdc, 0, 0, Image1.picture.icon.width, Image1.picture.icon.height, srcdc, 0, 0, SRCPAINT);

Image2.picture.bitmap.handle := SelectObject(destDC, oldBitmap);

DeleteDC(destDC);

DeleteDC(srcDC);

DeleteDC(WinDC);

image2.Picture.Bitmap.savetofile(ExtractFilePath(Application.ExeName) + 'myfile.bmp');

end;

Procedure Tform1.FormCreate(Sender: Tobject);

begin

image1.picture.icon.loadfromfile('c:\myicon.ico');

end;

end.

Unix-строки (чтение и запись Unix-файлов)

Данный модуль позволяет читать и записывать файлы формата Unix.

unit StreamFile;

interface

Uses SysUtils;

Procedure AssignStreamFile(var f: text; FileName: String);

implementation

Const BufferSize = 128;

Type

TStreamBuffer = Array[1..High(Integer)] of Char;

TStreamBufferPointer = ^TStreamBuffer;

TStreamFileRecord = Record

Case Integer Of

1: (

Filehandle: Integer;

Buffer: TStreamBufferPointer;

BufferOffset: Integer;

ReadCount: Integer;

);

2: (

Dummy : Array[1..32] Of Char

)

End;

Function StreamFileOpen(var f : TTextRec): Integer;

Var

Status: Integer;

Begin

With TStreamFileRecord (F.UserData) Do Begin

GetMem(Buffer, BufferSize);

Case F.Mode Of

fmInput:

FileHandle:= FileOpen(StrPas(F.Name), fmShareDenyNone);

fmOutput:

FileHandle:= FileCreate(StrPas(F.Name));

fmInOut:

Begin

FileHandle:= FileOpen(StrPas(F.Name), fmShareDenyNone Or fmOpenWrite or fmOpenRead);

If FileHandle <> -1 Then status:= FileSeek(FileHandle, 0, 2); { Перемещаемся в конец файла. }

F.Mode:= fmOutput;

End;

BufferOffset:= 0;

ReadCount:= 0;

F.BufEnd:= 0; { В этом месте подразумеваем что мы достигли конца файла (eof). }

If FileHandle = -1 Then Result := -1

Else Result:= 0;

End;

Function StreamFileInOut(var F: TTextRec): Integer;

Procedure Read(var Data: TStreamFileRecord);

Procedure CopyData;

Begin

While (F.BufEnd < Sizeof(F.Buffer) - 2) And (Data.BufferOffset <= Data.ReadCount) And (Data.Buffer [Data.BufferOffset] <> #10) Do Begin

F.Buffer[F.BufEnd]:= Data.Buffer^[Data.BufferOffset];

Inc(Data.BufferOffset);

Inc(F.BufEnd);

End;

If Data.Buffer [Data.BufferOffset] = #10 Then Begin

F.Buffer[F.BufEnd]:= #13;

Inc(F.BufEnd);

F.Buffer[F.BufEnd]:= #10;

Inc(F.BufEnd);

Inc(Data.BufferOffset);

End;

Begin

F.BufEnd:= 0;

F.BufPos:= 0;

F.Buffer:= '';

Repeat Begin

If (Data.ReadCount = 0) Or (Data.BufferOffset > Data.ReadCount) Then Begin

Data.BufferOffset:= 1;

Data.ReadCount:= FileRead(Data.FileHandle, Data.Buffer^, BufferSize);

End;

CopyData;

End Until (Data.ReadCount = 0) Or (F.BufEnd >= Sizeof (F.Buffer) - 2);

Result:= 0;

End;

Procedure Write(var Data: TStreamFileRecord);

Var

Status: Integer;

Destination: Integer;

II: Integer;

Begin

With TStreamFileRecord(F.UserData) Do Begin

Destination:= 0;

For II:= 0 To F.BufPos - 1 Do Begin

If F.Buffer[II] <> #13 Then Begin

Inc(Destination);

Buffer^[Destination]:= F.Buffer[II];

End;

Status:= FileWrite(FileHandle, Buffer^, Destination);

F.BufPos:= 0;

Result:= 0;

End;

Begin

Case F.Mode Of

fmInput:

Read(TStreamFileRecord(F.UserData));

fmOutput:

Write(TStreamFileRecord(F.UserData));

End;

Function StreamFileFlush(var F: TTextRec): Integer;

Begin

Result:= 0;

End;

Function StreamFileClose(var F : TTextRec): Integer;

Begin

With TStreamFileRecord(F.UserData) Do Begin

FreeMem(Buffer);

FileClose(FileHandle);

End;

Result:= 0;

End;

Procedure AssignStreamFile(var F: Text; Filename: String);

Begin

With TTextRec(F) Do Begin

Mode:= fmClosed;

BufPtr:= @Buffer;

BufSize:= Sizeof(Buffer);

OpenFunc:= @StreamFileOpen;

InOutFunc:= @StreamFileInOut;

FlushFunc:= @StreamFileFlush;

CloseFunc:= @StreamFileClose;

StrPLCopy(Name, FileName, Sizeof(Name) - 1);

End;

end.

Преобразование BMP в JPEG в Delphi 3

Используя Delphi 3, как мне сохранить BMP-изображение в JPEG-файле?

Допустим, Image1 – компонент TImage, содержащий растровое изображение. Используйте следующий фрагмент кода для конвертации вашего изображения в JPEG-файл:

var

MyJpeg: TJpegImage;

Image1: TImage;

begin

Image1:= TImage.Create;

MyJpeg:= TJpegImage.Create;

Image1.LoadFromFile('TestImage.BMP'); // Чтение изображения из файла

MyJpeg.Assign(Image1.Picture.Bitmap); // Назначание изображения объекту MyJpeg

MyJpeg.SaveToFile('MyJPEGImage.JPG'); // Сохранение на диске изображения в формате JPEG

end;

Декомпиляция звукового файла формата Wave и получение звуковых данных

Интересно, есть ли технология преобразования Wave-формата в обычный набор звуковых данных? К примеру, мне необходимо удалить заголовок и механизм (метод) сжатия, которые могут компилироваться и сохраняться вместе с Wave-файлами.

У меня есть программа под D1/D2, которая читает WAV-файлы и вытаскивает исходные данные, но она не может их восстанавить, используя зашитый алгоритм сжатия.

unit LinearSystem;

interface

{============== Тип, описывающий формат WAV ==================}

type wavheader = record

nChannels : Word;

nBitsPerSample : LongInt;

nSamplesPerSec : LongInt;

nAvgBytesPerSec : LongInt;

RIFFSize : LongInt;

fmtSize : LongInt;

formatTag : Word;

nBlockAlign : LongInt;

DataSize : LongInt;

end;

{============== Поток данных сэмпла ========================}

const MaxN = 300; { максимальное значение величины сэмпла }

type SampleIndex = 0..MaxN+3;

type DataStream = array[SampleIndex] of Real;

var N: SampleIndex;

{============== Переменные сопровождения ======================}

type Observation = record

Name : String[40]; {Имя данного сопровождения}

yyy : DataStream; {Массив указателей на данные}

WAV : WAVHeader; {Спецификация WAV для сопровождения}

Last : SampleIndex; {Последний доступный индекс yyy}

MinO, MaxO : Real; {Диапазон значений yyy}

end;

var K0R, K1R, K2R, K3R: Observation;

K0B, K1B, K2B, K3B : Observation;

{================== Переменные имени файла ===================}

var StandardDatabase: String[80];

BaseFileName: String[80];

StandardOutput: String[80];

StandardInput: String[80];

{=============== Объявления процедур ==================}

procedure ReadWAVFile(var Ki, Kj : Observation);

procedure WriteWAVFile(var Ki, Kj : Observation);

procedure ScaleData(var Kk: Observation);

procedure InitallSignals;

procedure InitLinearSystem;

implementation

{$R *.DFM}

uses VarGraph, SysUtils;

{================== Стандартный формат WAV-файла ===================}

const MaxDataSize : LongInt = (MaxN+1)*2*2;

const MaxRIFFSize : LongInt = (MaxN+1)*2*2+36;

const StandardWAV : WAVHeader = (

nChannels : Word(2);

nBitsPerSample : LongInt(16);

nSamplesPerSec : LongInt(8000);

nAvgBytesPerSec : LongInt(32000);

RIFFSize : LongInt((MaxN+1)*2*2+36);

fmtSize : LongInt(16);

formatTag : Word(1);

nBlockAlign : LongInt(4);

DataSize : LongInt((MaxN+1)*2*2)

);

{================== Сканирование переменных сопровождения ===================}

procedure ScaleData(var Kk : Observation);

var I : SampleIndex;

begin

{Инициализация переменных сканирования}

Kk.MaxO:= Kk.yyy[0];

Kk.MinO:= Kk.yyy[0];

{Сканирование для получения максимального и минимального значения}

for I:= 1 to Kk.Last do begin

if kk.maxo < kk.yyy[i] then kk.maxo:= kk.yyy[i];

if kk.mino > kk.yyy[i] then kk.mino:= kk.yyy[i];

end;

end; { scaledata }

procedure ScaleAllData;

begin

ScaleData(K0R);

ScaleData(K0B);

ScaleData(K1R);

ScaleData(K1B);

ScaleData(K2R);

ScaleData(K2B);

ScaleData(K3R);

ScaleData(K3B);

end; {scalealldata}

{================== Считывание/запись WAV-данных ===================}

VAR InFile, OutFile: file of Byte;

type Tag = (F0, T1, M1);

type FudgeNum = record

case X:Tag of

F0 : (chrs : array[0..3] of byte);

T1 : (lint : LongInt);

M1 : (up,dn: Integer);

end;

var ChunkSize : FudgeNum;

procedure WriteChunkName(Name: String);

var i: Integer;

MM: Byte;

begin

for i:= 1 to 4 do begin

MM:= ord(Name[i]);

write(OutFile, MM);

end;

end; {WriteChunkName}

procedure WriteChunkSize(LL:Longint);

var I: integer;

begin

ChunkSize.x:=T1;

ChunkSize.lint:=LL;

ChunkSize.x:=F0;

for I:= 0 to 3 do Write(OutFile,ChunkSize.chrs[I]);

end;

procedure WriteChunkWord(WW: Word);

var I: integer;

begin

ChunkSize.x:=T1;

ChunkSize.up:=WW;

ChunkSize.x:=M1;

for I:= 0 to 1 do Write(OutFile,ChunkSize.chrs[I]);

end; {WriteChunkWord}

procedure WriteOneDataBlock(var Ki, Kj : Observation);

var I: Integer

begin

ChunkSize.x:=M1;

with Ki.WAV do begin

case nChannels of

if nBitsPerSample=16 then begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}

ChunkSize.up = trunc(Ki.yyy[N]+0.5);

if N<MaxN then ChunkSize.dn := trunc(Ki.yyy[N+1]+0.5);

N:= N+2;

end else begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}

for I:=0 to 3 do ChunkSize.chrs[I]:= trunc(Ki.yyy[N+I]+0.5);

N:= N+4;

end;

if nBitsPerSample=16 then begin {2 Двухканальный 16-битный сэмпл}

ChunkSize.dn:= trunc(Ki.yyy[N]+0.5);

ChunkSize.up := trunc(Kj.yyy[N]+0.5);

N:= N+1;

end else begin {4 Двухканальный 8-битный сэмпл}

ChunkSize.chrs[1]:= trunc(Ki.yyy[N]+0.5);

ChunkSize.chrs[3]:= trunc(Ki.yyy[N+1]+0.5);

ChunkSize.chrs[0]:= trunc(Kj.yyy[N]+0.5);

ChunkSize.chrs[2]:= trunc(Kj.yyy[N+1]+0.5);

N:= N+2;

end;

end; {with wav do begin..}

end; {четырехбайтовая переменная "chunksize" теперь заполнена}

ChunkSize.x:=T1;

WriteChunkSize(ChunkSize.lint);{помещаем 4 байта данных}

end; {WriteOneDataBlock}

procedure WriteWAVFile(var Ki, Kj : Observation);

var MM: Byte;

I: Integer;

OK: Boolean;

begin

{Приготовления для записи файла данных}

AssignFile(OutFile, StandardOutput); { Файл, выбранный в диалоговом окне }

ReWrite(OutFile);

With ki.wav do begin

DataSize:= nChannels*(nBitsPerSample div 8)*(Ki.Last+1);

RIFFSize:= DataSize+36;

fmtSize:= 16;

end;

{Записываем ChunkName "RIFF"}

WriteChunkName('RIFF');

{Записываем ChunkSize}

WriteChunkSize(Ki.WAV.RIFFSize);

{Записываем ChunkName "WAVE"}

WriteChunkName('WAVE');

{Записываем tag "fmt_"}

WriteChunkName('fmt ');

{Записываем ChunkSize}

Ki.WAV.fmtSize:= 16; {должно быть 16-18}

WriteChunkSize(Ki.WAV.fmtSize);

{Записываем formatTag, nChannels}

WriteChunkWord(Ki.WAV.formatTag);

WriteChunkWord(Ki.WAV.nChannels);

{Записываем nSamplesPerSec}

WriteChunkSize(Ki.WAV.nSamplesPerSec);

{Записываем nAvgBytesPerSec}

WriteChunkSize(Ki.WAV.nAvgBytesPerSec);

{Записываем nBlockAlign, nBitsPerSample}

WriteChunkWord(Ki.WAV.nBlockAlign);

WriteChunkWord(Ki.WAV.nBitsPerSample);

{Записываем метку блока данных "data"}

WriteChunkName('data');

{Записываем DataSize}

WriteChunkSize(Ki.WAV.DataSize);

N:=0; {первая запись-позиция}

while N<=Ki.Last do WriteOneDataBlock(Ki,Kj);{помещаем 4 байта и увеличиваем счетчик n}

{Освобождаем буфер файла}

CloseFile(OutFile);

end; {WriteWAVFile}

procedure InitSpecs;

begin

end; { InitSpecs }

procedure InitSignals(var Kk : Observation);

var J: Integer;

begin

for J:= 0 to MaxN do Kk.yyy[J]:= 0.0;

Kk.MinO:= 0.0;

Kk.MaxO:= 0.0;

Kk.Last:= MaxN;

end; {InitSignals}

procedure InitAllSignals;

begin

InitSignals(K0R);

InitSignals(K0B);

InitSignals(K1R);

InitSignals(K1B);

InitSignals(K2R);

InitSignals(K2B);

InitSignals(K3R);

InitSignals(K3B);

end; {InitAllSignals}

var chunkname: string[4];

procedure ReadChunkName;

var I : integer;

MM : Byte;

begin

ChunkName[0]:= chr(4);

for i := 1 to 4 do begin

Read(InFile, MM);

ChunkName[I]:=chr(MM);

end;

end; {ReadChunkName}

procedure ReadChunkSize;

var I: integer;

MM : Byte;

begin

ChunkSize.x:= F0;

ChunkSize.lint := 0;

for i:= 0 to 3 do begin

Read(InFile, MM);

ChunkSize.chrs[I]:= MM;

end;

ChunkSize.x:= T1;

end; {ReadChunkSize}

procedure ReadOneDataBlock(var Ki,Kj:Observation);

var I: Integer;

begin

if n<=maxn then begin

ReadChunkSize; {получаем 4 байта данных}

ChunkSize.x:=M1;

with Ki.WAV do case nChannels of

if nBitsPerSample=16 then begin {1..2 Помещаем в буфер одноканальный 16-битный сэмпл}

Ki.yyy[N]:=1.0*ChunkSize.up;

if N<MaxN then Ki.yyy[N+1]:=1.0*ChunkSize.dn;

N:= N+2;

end else begin {1..4 Помещаем в буфер одноканальный 8-битный сэмпл}

for I:=0 to 3 do Ki.yyy[N+I]:=1.0*ChunkSize.chrs[I];

N := N+4;

end;

if nBitsPerSample=16 then begin {2 Двухканальный 16-битный сэмпл}

Ki.yyy[N]:=1.0*ChunkSize.dn;

Kj.yyy[N]:=1.0*ChunkSize.up;

N:= N+1;

end else begin {4 Двухканальный 8-битный сэмпл}

Ki.yyy[N]:=1.0*ChunkSize.chrs[1];

Ki.yyy[N+1]:=1.0*ChunkSize.chrs[3];

Kj.yyy[N]:=1.0*ChunkSize.chrs[0];

Kj.yyy[N+1]:=1.0*ChunkSize.chrs[2];

N:= N+2;

end;

if N<=MaxN then begin {LastN:= N;}

Ki.Last:= N;

if Ki.WAV.nChannels=2 then Kj.Last := N;

end else begin {lastn := maxn;}

Ki.Last:= MaxN;

if Ki.WAV.nChannels=2 then Kj.Last := MaxN;

end;

end; {ReadOneDataBlock}

procedure ReadWAVFile(var Ki, K : Observation);

var MM: Byte;

I: Integer;

OK: Boolean;

NoDataYet: Boolean;

DataYet: Boolean;

nDataBytes: LongInt;

begin

if FileExists(StandardInput)then with Ki.WAV do begin { Вызов диалога открытия файла }

OK:= True; {если не изменится где-нибудь ниже}

{Приготовления для чтения файла данных}

AssignFile(InFile, StandardInput); { Файл, выбранный в диалоговом окне }

Reset(InFile);

{Считываем ChunkName "RIFF"}

ReadChunkName;

if ChunkName<>'RIFF' then OK:= False;

{Считываем ChunkSize}

ReadChunkSize;

RIFFSize:= ChunkSize.lint; {должно быть 18,678}

{Считываем ChunkName "WAVE"}

ReadChunkName;

if ChunkName<>'WAVE' then OK:= False;

{Считываем ChunkName "fmt_"}

ReadChunkName;

if ChunkName<>'fmt ' then OK:= False;

{Считываем ChunkSize}

ReadChunkSize;

fmtSize:= ChunkSize.lint; {должно быть 18}

{Считываем formatTag, nChannels}

ReadChunkSize;

ChunkSize.x:= M1;

formatTag:= ChunkSize.up;

nChannels:= ChunkSize.dn;

{Считываем nSamplesPerSec}

ReadChunkSize;

nSamplesPerSec := ChunkSize.lint;

{Считываем nAvgBytesPerSec}

ReadChunkSize;

nAvgBytesPerSec:= ChunkSize.lint;

{Считываем nBlockAlign}

ChunkSize.x:= F0;

ChunkSize.lint:= 0;

for i:= 0 to 3 do begin

Read(InFile, MM);

ChunkSize.chrs[I]:= MM;

end;

ChunkSize.x:= M1;

nBlockAlign:= ChunkSize.up;

{Считываем nBitsPerSample}

nBitsPerSample:= ChunkSize.dn;

for I:= 17 to fmtSize do Read(InFile,MM);

NoDataYet:= True;

while NoDataYet do begin

{Считываем метку блока данных "data"}

ReadChunkName;

{Считываем DataSize}

ReadChunkSize;

DataSize:= ChunkSize.lint;

if ChunkName <> 'data' then begin

for I:= 1 to DataSize do {пропуск данных, не относящихся к набору звуковых данных}

Read(InFile, MM);

end else NoDataYet:= False;

end;

nDataBytes:= DataSize;

{Наконец, начинаем считывать данные для байтов nDataBytes}

if nDataBytes>0 then DataYet:= True;

N:=0; {чтение с первой позиции}

while DataYet do begin

ReadOneDataBlock(Ki,Kj); {получаем 4 байта}

nDataBytes:= nDataBytes-4;

if nDataBytes<=4 then DataYet:= False;

end;

ScaleData(Ki);

if Ki.WAV.nChannels=2 then begin Kj.WAV:= Ki.WAV;

ScaleData(Kj);

end;

{Освобождаем буфер файла}

CloseFile(InFile);

end else begin

InitSpecs;{файл не существует}

InitSignals(Ki);{обнуляем массив "Ki"}

InitSignals(Kj);{обнуляем массив "Kj"}

end;

end; { ReadWAVFile}

{================= Операции с набором данных ====================}

const MaxNumberOfDataBaseItems = 360;

type SignalDirectoryIndex = 0..MaxNumberOfDataBaseItems;

VAR DataBaseFile: file of Observation;

LastDataBaseItem: LongInt; {Номер текущего элемента набора данных}

ItemNameS: array[SignalDirectoryIndex] of String[40];

procedure GetDatabaseItem(Kk : Observation; N : LongInt);

begin

if N<MaxNumberOfDataBaseItems then begin

Seek(DataBaseFile, N);

Read(DataBaseFile, Kk);

end else InitSignals(Kk);

end; {GetDatabaseItem}

procedure PutDatabaseItem(Kk : Observation; N : LongInt);

begin

if N<MaxNumberOfDataBaseItems then if N<=LastDataBaseItem then begin

Seek(DataBaseFile, N);

Write(DataBaseFile, Kk);

LastDataBaseItem:= LastDataBaseItem+1;

end else while lastdatabaseitem<=n do begin

Seek(DataBaseFile, LastDataBaseItem);

Write(DataBaseFile, Kk);

LastDataBaseItem:= LastDataBaseItem+1;

end else ReportError(1); {Попытка чтения MaxNumberOfDataBaseItems}

end; {PutDatabaseItem}

procedure InitDataBase;

begin

LastDataBaseItem:= 0;

if FileExists(StandardDataBase) then begin

Assign(DataBaseFile,StandardDataBase);

Reset(DataBaseFile);

while not EOF(DataBaseFile) do begin

GetDataBaseItem(K0R, LastDataBaseItem);

ItemNameS[LastDataBaseItem]:= K0R.Name;

LastDataBaseItem:= LastDataBaseItem+1;

end;

if EOF(DataBaseFile) then if LastDataBaseItem>0 then LastDataBaseItem:= LastDataBaseItem-1;

end;

end; {InitDataBase}

function FindDataBaseName(Nstg: String): LongInt;

var ThisOne : LongInt;

begin

ThisOne:= 0;

FindDataBaseName:= –1;

while ThisOne<LastDataBaseItem do begin

if Nstg = ItemNameS[ThisOne] then begin

FindDataBaseName:= ThisOne;

Exit;

end;

ThisOne:= ThisOne+1;

end;

end; {FindDataBaseName}

{======================= Инициализация модуля ========================}

procedure InitLinearSystem;

begin

BaseFileName:= '\PROGRA~1\SIGNAL~1\';

StandardOutput:= BaseFileName + 'K0.wav';

StandardInput:= BaseFileName + 'K0.wav';

StandardDataBase:= BaseFileName + 'Radar.sdb';

InitAllSignals;

InitDataBase;

ReadWAVFile(K0R,K0B);

ScaleAllData;

end; {InitLinearSystem}

begin {инициализируемый модулем код}

InitLinearSystem;

end. {Unit LinearSystem}

Даты

Вычисление даты Пасхи

function TtheCalendar.CalcEaster:String;

var B,D,E,Q:Integer;

GF:String;

begin

B:= 225-11*(Year Mod 19);

D:= ((B-21)Mod 30)+21;

If d>48 then Dec(D);

E:= (Year+(Year Div 4)+d+1) Mod 7;

Q:= D+7-E;

If q<32 then begin

If ShortDateFormat[1]='d' then Result:= IntToStr(Q)+'/3/'+IntToStr(Year)

else Result:='4/'+IntToStr(Q-31)+'/'+IntToStr(Year);

end else begin

If ShortDateFormat[1]='d' then Result:= IntToStr(Q-31)+'/4/'+IntToStr(Year)

else Result:='4/'+IntToStr(Q-31)+'/'+IntToStr(Year);

end;

{вычисление страстной пятницы}

If Q<32 then begin

If ShortDateFormat[1]='d' then GF:= IntToStr(Q-2)+'/3/'+IntToStr(Year)

else GF:='3/'+IntToStr(Q-2)+'/'+IntToStr(Year);

end else begin

If ShortDateFormat[1]='d' then GF:= IntToStr(Q-31-2)+'/4/'+IntToStr(Year)

else GF:='4/'+IntToStr(Q-31-2)+'/'+IntToStr(Year);

end;

Дни недели

Кто-нибудь пробовал написать функцию, возвращающую для определенной даты день недели?

Моя функция как раз этим и занимается.

unit datefunc;

interface

function checkdate(date : string): boolean;

function Date2julian(date : string): longint;

function Julian2date(julian : longint): string;

function DayOfTheWeek(date: string): string;

function idag: string;

implementation

uses sysutils;

function idag() : string;

{Получает текущую дату и возвращает ее в формате YYYYMMDD для использования

другими функциями данного модуля.}

var

Year, Month, Day: Word;

begin

DecodeDate(Now, Year, Month, Day);

result:= IntToStr(year)+ IntToStr(Month) +IntToStr(day);

end;

function Date2julian(date : string) : longint;

{Получает дату в формате YYYYMMDD.

Если у вас другой формат, в первую очередь преобразуйте его.}

var

month, day, year:integer;

ta, tb, tc : longint;

begin

month:= strtoint(copy(date,5,2));

day:= strtoint(copy(date,7,2));

year:= strtoint(copy(date,1,4));

if month > 2 then month:= month – 3

else begin

month:= month + 9;

year:= year – 1;

end;

ta:= 146097 * (year div 100) div 4;

tb:= 1461 * (year MOD 100) div 4;

tc:= (153 * month + 2) div 5 + day + 1721119;

result:= ta + tb + tc

end;

function mdy2date(month, day, year : integer): string;

var

y, m, d : string;

begin

y:= '000'+inttostr(year);

y:= copy(y,length(y)-3,4);

m:= '0'+inttostr(month);

m:= copy(m,length(m)-1,2);

d:= '0'+inttostr(day);

d:= copy(d,length(d)-1,2);

result:= y+m+d;

end;

function Julian2date(julian : longint): string;

{Получает значение и возвращает дату в формате YYYYMMDD}

var

x,y,d,m : longint;

month,day,year : integer;

begin

x:= 4 * julian – 6884477;

y:= (x div 146097) * 100;

d:= (x MOD 146097) div 4;

x:= 4 * d + 3;

y:= (x div 1461) + y;

d:= (x MOD 1461) div 4 + 1;

x:= 5 * d – 3;

m:= x div 153 + 1;

d:= (x MOD 153) div 5 + 1;

if m < 11 then month:= m + 2

else month:= m – 10;

day:= d;

year:= y + m div 11;

result:= mdy2date(month, day, year);

end;

function checkdate(date : string): boolean;

{Дата должна быть в формате YYYYMMDD.}

var

julian: longint;

test: string;

begin

{Сначала преобразовываем строку в юлианский формат даты.

Это позволит получить необходимое значение.}

julian:= Date2julian(date);

{Затем преобразовываем полученную величину в дату.

Это всегда будет правильной датой. Для проверки делаем обратное преобразование.

Результат проверки передаем как выходной параметр функции.}

test:= Julian2date(julian);

if date = test then result:= true

else result:= false;

end;

function DayOfTheWeek(date : string): string;

{Получаем дату в формате YYYYMMDD и возвращаем день недели.}

var

julian: longint;

begin

julian:= (Date2julian(date)) MOD 7;

case julian of

0: result:= 'Понедельник';

1: result := 'Вторник';

2: result:= 'Среда';

3: result:= 'Четверг';

4: result:= 'Пятница';

5: result:= 'Суббота';

6: result:= 'Воскресенье';

end;

end.

Формат даты

У меня есть неотложная задача: в настоящее время я разрабатываю проект, где я должен проверять достоверность введенных дат с применением маски __/__/____, например 12/12/1997.

Некоторое время назад я делал простой шифратор/дешифратор дат, проверяющий достоверность даты. Код приведен ниже.

function CheckDateFormat(SDate: string): string;

var

IDateChar: string;

x,y: integer;

begin

IDateChar:='.,\/';

for y:=1 to length(IDateChar) do begin

x:= pos(IDateChar[y],SDate);

while x>0 do begin

Delete(SDate,x,1);

Insert('-',SDate,x);

x:= pos(IDateChar[y],SDate);

end;

CheckDateFormat:= SDate;

end;

function DateEncode(SDate:string):longint;

var

year, month, day: longint;

wy, wm, wd: longint;

Dummy: TDateTime;

Check: integer;

begin

DateEncode:= -1;

SDate:= CheckDateFormat(SDate);

Val(Copy(SDate,1,pos('-',SDate)-1),day,check);

Delete(Sdate,1,pos('-',SDate));

Val(Copy(SDate,1,pos('-',SDate)-1),month,check);

Delete(SDate,1,pos('-',SDate));

Val(SDate,year,check);

wy:= year;

wm:= month;

wd:= day;

try

Dummy:= EncodeDate(wy,wm,wd);

except

year:= 0;

month:= 0;

day:= 0;

end;

DateEncode:= (year*10000)+(month*100)+day;

end;

Функция DateSer

Привет, я хочу в качестве совета поделиться функцией DateSer, которую я написал перед этим на VB. Данная функция весьма полезна но, к сожалению, ее нет в Delphi. Применяется она так:

DecodeDate(Date,y,m,d);

NewDate:= DateSer(y-4,m+254,d+1234);

или приблизительно так….

function DateSer(y,m,d: Integer): TDateTime;

const

mj: array[1..12] of integer=(31,28,31,30,31,30,31,31,30,31,30,31);

var

add: Integer;

begin

while (true) do begin

y:=y+(m-1) div 12;

m:= (m-1) mod 12 +1;

if m<=0 then begin

Inc(m,12);

Dec(y);

end;

if ((y mod 4 = 0) and ((y mod 100<>0) or (y mod 400=0))) and (m=2) then add:=1 //дополнительный день в феврале

else add:=0;

if (d>0) and (d<=(mj[m]+add)) then break;

if d>0 then begin Dec(d,mj[m]+add); Inc(m); end

else begin Inc(d,mj[m]+add); Dec(m); end;

end;

Result:=EncodeDate(y,m,d);

end;

Разное

Ханойская башня

"Ханойская башня" построена на очень простом алгоритме. Здесь я привожу этот алгоритм, который Вы сможете без труда воспроизвести.

type

THanoiBin = 0..2;

THanoiLevel = 0..9;

procedure MoveDisc(FromPin, ToPin : THanoiPin; Level : THanoiLevel);

// Это Вы должны сделать сами. Переместите один диск с одного штырька на другой.

// Диск окажется наверху (естественно, выше него дисков не будет)

Вы можете каким угодно образом перемещать диски 3-х пирамид. 3 пирамиды – наиболее простая разновидность алгоритма. Таким образом процедура переноса диска (MoveDisc) аналогична операции переноса диска на верхний уровень (MoveTopDisc): переместить диск наверх с одного штырька (FromPin) на другой штырек (ToPin) и передать указатель на штырек-приемник (MoveTower) вместе с уровнем расположения перемещенного диска. Другое решение заключается в использовании трех массивов [THanoiLevel] логического типа. В этом случае триггер "Истина (True)" означает наличие на пирамиде диска с размером, соответствующим порядковому номеру элемента массива THanoiLevel.

procedure MoveTower(FromPin, ToPin : THanoiPin; Level : THanoiLevel);

begin

if HanoiLevel <= High(THanoiLevel) then begin

MoveTower(FromPin, 3 – FromPin – ToPin, Level + 1);

MoveDisc(FromPin, ToPin, Level);

MoveTower(3 – FromPin – ToPin, ToPin, Level + 1);

end;

Чтобы переместить пирамиду целиком, вы должны вызвать процедуру MoveTower следующим образом:

MoveTower(0, 1, Low(THanoiLevel));

Алгоритм (уравнение) для определения восхода/захода солнца и луны (BASIC)

Я нашел алгоритм, написанный на BASIC и вычисляющий восход-заход солнца и восход-заход луны. Может кто-нибудь сможет перенести это на Pascal?

(в случае чего сообщите мне по адресу st_evil@mail.ru)

10 ' Восход-заход солнца

20 GOSUB 300

30 INPUT "Долгота (град)";B5,L5

40 INPUT "Часовая зона (час)";H

50 L5=L5/360: Z0=H/24

60 GOSUB 1170: T=(J-2451545)+F

70 TT=T/36525+1: ' TT = столетия,

80 ' начиная с 1900.0

90 GOSUB 410: T=T+Z0

100 '

110 ' Получаем положение солнца

120 GOSUB 910: A(1)=A5: D(1)=D5

130 T=T+1

140 GOSUB 910: A(2)=A5: D(2)=D5

150 IF A(2)<A(1) THEN A(2)=A(2)+P2

160 Z1=DR*90.833: ' Вычисление зенита

170 S=SIN(B5*DR): C=COS(B5*DR)

180 Z=COS(Z1): M8=0: W8=0: PRINT

190 A0=A(1): D0=D(1)

200 DA=A(2)-A(1): DD=D(2)-D(1)

210 FOR C0=0 TO 23

220 P=(C0+1)/24

230 A2=A(1)+P*DA: D2=D(1)+P*DD

240 GOSUB 490

250 A0=A2: D0=D2: V0=V2

260 NEXT

270 GOSUB 820: ' Вывод информации?

280 END

290 '

300 ' Константы

310 DIM A(2),D(2)

320 P1=3.14159265: P2=2*P1

330 DR=P1/180: K1=15*DR*1.0027379

340 S$="Заход солнца в "

350 R$="Восход солнца в "

360 M1$="В этот день солнце не восходит"

370 M2$="В этот день солнце не заходит"

380 M3$="Солнце заходит весь день"

390 M4$="Солнце восходит весь день"

400 RETURN

410 ' Получение часового пояса

420 T0=T/36525

430 S=24110.5+8640184.813*T0

440 S=S+86636.6*Z0+86400*L5

450 S=S/86400: S=S-INT(S)

460 T0=S*360*DR

470 RETURN

480 '

490 ' Просматриваем возможные события на полученный час

500 L0=T0+C0*K1: L2=L0+K1

510 H0=L0-A0: H2=L2-A2

520 H1=(H2+H0)/2: ' Часовой угол,

530 D1=(D2+D0)/2: ' наклон в

540 ' получасе

550 IF C0>0 THEN 570

560 V0=S*SIN(D0)+C*COS(D0)*COS(H0)-Z

570 V2=S*SIN(D2)+C*COS(D2)*COS(H2)-Z

580 IF SGN(V0)=SGN(V2) THEN 800

590 V1=S*SIN(D1)+C*COS(D1)*COS(H1)-Z

600 A=2*V2-4*V1+2*V0: B=4*V1-3*V0-V2

610 D=B*B-4*A*V0: IF D<0 THEN 800

620 D=SQR(D)

630 IF V0<0 AND V2>0 THEN PRINT R$;

640 IF V0<0 AND V2>0 THEN M8=1

650 IF V0>0 AND V2<0 THEN PRINT S$;

660 IF V0>0 AND V2<0 THEN W8=1

670 E=(-B+D)/(2*A)

680 IF E>1 OR E<0 THEN E=(-B-D)/(2*A)

690 T3=C0+E+1/120: ' Округление

700 H3=INT(T3): M3=INT((T3-H3)*60)

710 PRINT USING "##:##";H3;M3;

720 H7=H0+E*(H2-H0)

730 N7=-COS(D1)*SIN(H7)

740 D7=C*SIN(D1)-S*COS(D1)*COS(H7)

750 AZ=ATN(N7/D7)/DR

760 IF D7<0 THEN AZ=AZ+180

770 IF AZ<0 THEN AZ=AZ+360

780 IF AZ>360 THEN AZ=AZ-360

790 PRINT USING ", азимут ###.#";AZ

800 RETURN

810 '

820 ' Процедура вывода информации

830 IF M8=0 AND W8=0 THEN 870

840 IF M8=0 THEN PRINT M1$

850 IF W8=0 THEN PRINT M2$

860 GOTO 890

870 IF V2<0 THEN PRINT M3$

880 IF V2>0 THEN PRINT M4$

890 RETURN

900 '

910 ' Фундаментальные константы

920 ' (Van Flandern &

930 ' Pulkkinen, 1979)

940 L=.779072+.00273790931*T

950 G=.993126+.0027377785*T

960 L=L-INT(L): G=G-INT(G)

970 L=L*P2: G=G*P2

980 V=.39785*SIN(L)

990 V=V-.01000*SIN(L-G)

1000 V=V+.00333*SIN(L+G)

1010 V=V-.00021*TT*SIN(L)

1020 U=1-.03349*COS(G)

1030 U=U-.00014*COS(2*L)

1040 U=U+.00008*COS(L)

1050 W=-.00010-.04129*SIN(2*L)

1060 W=W+.03211*SIN(G)

1070 W=W+.00104*SIN(2*L-G)

1080 W=W-.00035*SIN(2*L+G)

1090 W=W-.00008*TT*SIN(G)

1100 '

1110 ' Вычисление солнечных координат

1120 S=W/SQR(U-V*V)

1130 A5=L+ATN(S/SQR(1-S*S))

1140 S=V/SQR(U):D5=ATN(S/SQR(1-S*S))

1150 R5=1.00021*SQR(U)

1160 RETURN

1165 '

1170 ' Календарь –> JD

1180 INPUT "Год, Месяц, День";Y,M,D

1190 G=1: IF Y<1583 THEN G=0

1200 D1=INT(D): F=D-D1-.5

1210 J=-INT(7*(INT((M+9)/12)+Y)/4)

1220 IF G=0 THEN 1260

1230 S=SGN(M-9): A=ABS(M-9)

1240 J3=INT(Y+S*INT(A/7))

1250 J3=-INT((INT(J3/100)+1)*3/4)

1260 J=J+INT(275*M/9)+D1+G*J3

1270 J=J+1721027+2*G+367*Y

1280 IF F>=0 THEN 1300

1290 F=F+1: J=J-1

1300 RETURN

1310 '

1320 ' Программа вычисляет время восхода и захода

1330 ' солнца по дате (с точностью до минуты) в пределах

1340 ' нескольких текущих столетий. Производит корректировку, если географическая

1350 ' точка находится в арктичиском или антарктическом регионе, где заход или восход солнца

1360 ' на текущую дату может не состояться. Вводимые данные: положительная северная широта и

1370 ' отрицательная западная долгота. Часовой пояс указывается относительно Гринвича

1380 ' (например, 5 для EST и 4 для EDT). Алгоритм обсуждался в

1390 ' "Sky & Telescope" за август 1994, страница 84.

Автоматический формат даты в компоненте Edit

PROCEDURE TForm1.Edit1Exit(Sender: TObject);

BEGIN

IF Edit1.Text<>'' THEN BEGIN

TRY

StrToDate(Edit1.Text);

EXCEPT

Edit1.SetFocus;

MessageBeep(0);

raise Exception.Create('"'+Edit1.Text + '" – некорректная дата');

END {try};

Edit1.Text:= DateToStr(StrToDate(Edit1.Text));

END{if};

END;

Win API

Переменные среды

Получение переменных DOS

Какие функции Windows API позволяют получить переменные DOS?

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

Функция GetEnvironmentVariable возвращает значения переменных среды опрашиваемого процесса. Величина также возвращается в виде строки с завершающим нулем.

Изменение системного времени из Delphi

Как я могу сменить системное время Windows 95 из программы, написанной на Delphi 2.0?

Вот правильное решение:

//*************************************************************************

// Функция (раздел Public) SetPCSystemTime изменяет системную дату и время.

// Параметр(ы) : tDati Новая дата и время

// Возвращаемые значения: True – успешное завершение

// False – метод не сработал

//*************************************************************************

function SetPCSystemTime(tDati: TDateTime): Boolean;

var

tSetDati: TDateTime;

vDatiBias: Variant;

tTZI: TTimeZoneInformation;

tST: TSystemTime;

begin

GetTimeZoneInformation(tTZI);

vDatiBias := tTZI.Bias / 1440;

tSetDati := tDati + vDatiBias;

with tST do begin

wYear:= StrToInt(FormatDateTime('yyyy', tSetDati));

wMonth:= StrToInt(FormatDateTime('mm', tSetDati));

wDay:= StrToInt(FormatDateTime('dd', tSetDati));

wHour:= StrToInt(FormatDateTime('hh', tSetDati));

wMinute:= StrToInt(FormatDateTime('nn', tSetDati));

wSecond:= StrToInt(FormatDateTime('ss', tSetDati));

wMilliseconds:= 0;

end;

SetPCSystemTime:= SetSystemTime(tST);

end;

Завершение работы Windows

События, происходящие в приложениях Delphi при завершении работы Windows

Я провел небольшое исследование, и вот что я выяснил:

При закрытии приложения (используя системное меню или вызывая метод закрытия формы), возникают следующие события:

1. FormCloseQuery – действие по умолчанию, устанавливает переменную CanClose в значание TRUE и продолжает закрытие формы.

2. FormClose

3. FormDestroy

Если приложение активно и вы пытаетесь завершить работу Windows (Shut Down), происходят следующие события (с соблюдением последовательности):

1. FormCloseQuery

2. FormDestroy

Мы видим, что метод FormClose в этом случае не вызывается.

Теперь воспроизведем всю последовательность событий, происходящую при попытке завершить работу Windows:

1. Windows посылает сообщение WM_QUERYENDSESSION всем приложениям и ожидает ответ.

2. Каждое приложение получает сообщение и возвращает одну из величин: не равную нулю – приложение готово завершить свою работу, 0 – приложение не может завершить свою работу.

3. Если одно из приложений возвращает 0, Windows не завершает свою работу, а снова рассылает всем окнам сообщение, на этот раз WM_ENDSESSION.

4. Каждое приложение должно снова подтвердить свою готовность завершить работу, поэтому операционная система ожидает ответа TRUE, резонно предполагая, что оставшиеся приложения с момента предыдущего сообщения закрыли свои сессии и готовы завершить работу. Теперь посмотрим, как на это реагирует Delphi-приложение: приложение возвращает значение TRUE и немедленно вызывает метод FormDestroy, игнорируя при этом метод FormClose. Налицо проблема.

5. Завершение работы Windows.

Первое решение проблемы: приложение Delphi на сообщение WM_QUERYENDSESSION должно возвратить 0, не дав при этом Windows завершить свою работу. При этом бессмысленно пытаться воспользоваться методом FormCloseQuery, поскольку нет возможности определить виновника завершения работы приложения (это может являться как результатом сообщения WM_QUERYENDSESSION, так и просто действием пользователя при попытке закрыть приложение).

Другое решение состоит в том, чтобы при получении сообщения WM_QUERYENDSESSION самим выполнить необходимые действия, вызвав метод FormClose.

Пример:

unit Unit1;

interface

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

type TForm1 = class(TForm)

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

private

{--------------------------------------------------------}

{ Объявляем свой обработчик сообщения WM_QUERYENDSESSION }

{--------------------------------------------------------}

procedure WMQueryEndSession(var Message: TWMQueryEndSession); message WM_QUERYENDSESSION;

public

{ Public declarations }

end;

var Form1: TForm1;

implementation

{$R *.DFM}

{--------------------------------------------------------------}

{ Создаем процедуру обработки сообщения WM_QUERYENDSESSION. }

{ Приложение получит только это сообщение при попытке Windows }

{ завершить работу }

{--------------------------------------------------------------}

procedure TForm1.WMQueryEndSession(var Message: TWMQueryEndSession);

begin

inherited; { сначала сообщание должен обработать наследуемый метод }

{--------------------------------------------------------------------}

{ в этой точке вы также можете сообщить Windows о неготовности }

{ приложения завершить работу… }

{ Message.Result:=0; }

{-------------------------------------------или----------------------}

{ вызов процедуры освобождения ресурсов, предусмотренной в FormClose }

{ MyCleanUpProcedure; }

{--------------------------------------------------------------------}

end;

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

begin

MyCleanUpProcedure;

end;

end.

Я не тестировал этот код, но могу предположить, что он должен работать. Сообщите, если это не так!

Завершение работы Windows

Каким образом запустить процесс завершения работы операционной системы (функция ExitWindows) из кода моей программы? Мне необходимо перезапустить операционную систему без перезапуска компьютера.

Ok, приводим обе функции для перезапуска операционной системы:

procedure TMainForm.RestartWindowsBtnClick(Sender: TObject);

begin

if not ExitWindows(EW_RestartWindows, 0) then ShowMessage('Приложение не может завершить работу');

end;

procedure TMainForm.RebootSystemBtnClick(Sender: TObject);

begin

if not ExitWindows(EW_RebootSystem, 0) then ShowMessage('Приложение не может завершить работу');

end;

Функция ExitWindows не была правильно задокументирована Microsoft'ом и не содержит описания возвращаемого значения. Более того, информация о этой функции практически не встречается в других источниках. Вот правильное определение этой функции:

function ExitWindows(dwReturnCode: Longint; Reserved: Word): Bool;

Режим энергосбережения (Power saver)

Управление монитором

Выключить монитор:

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);

Включить монитор:

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, –1);

Разное

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

Решение 1

Алгоритм, применяемый мною:

В блоке begin..end модуля .dpr:

begin

if HPrevInst <>0 then begin

ActivatePreviousInstance;

Halt;

end;

Реализация в модуле:

unit PrevInst;

interface

uses WinProcs, WinTypes, SysUtils;

type

PHWnd = ^HWnd;

function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; export;

procedure ActivatePreviousInstance;

implementation

function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool;

var

ClassName : array[0..30] of char;

begin

Result := true;

if GetWindowWord(Wnd, GWW_HINSTANCE) = HPrevInst then begin

GetClassName(Wnd, ClassName, 30);

if STRIComp(ClassName,'TApplication')=0 then begin

TargetWindow^:= Wnd;

Result := false;

end;

procedure ActivatePreviousInstance;

var

PrevInstWnd: HWnd;

begin

PrevInstWnd:= 0;

EnumWindows(@EnumApps,LongInt(@PrevInstWnd));

if PrevInstWnd <> 0 then if IsIconic(PrevInstWnd) then

ShowWindow(PrevInstWnd,SW_Restore)

else

BringWindowToTop(PrevInstWnd);

end;

end.

Решение 2

Предоставленное разработчиками Delphi 2 Пачекой (Pacheco) и Тайхайрой (Teixeira) и значительно переработанное.

unit multinst;

{Применение:

Необходимый код в исходном проекте

if InitInstance then begin

Application.Initialize;

Application.CreateForm(TFrmSelProject, FrmSelProject);

Application.Run;

end;

Это все понятно (я надеюсь)}

interface

uses Forms, Windows, Dialogs, SysUtils;

const

MI_NO_ERROR = 0;

MI_FAIL_SUBCLASS = 1;

MI_FAIL_CREATE_MUTEX = 2;

{ Проверка правильности запуска приложения с помощью описанных ниже функций. }

{ Количество флагов ошибок MI_* может быть более одного. }

function GetMIError: Integer;

Function InitInstance : Boolean;

implementation

const

UniqueAppStr : PChar; {Различное для каждого приложения}

var

MessageId: Integer;

WProc: TFNWndProc = Nil;

MutHandle: THandle = 0;

MIError: Integer = 0;

function GetMIError: Integer;

begin

Result:= MIError;

end;

function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint): Longint; StdCall;

begin

{ Если это – сообщение о регистрации… }

if Msg = MessageID then begin

{ если основная форма минимизирована, восстанавливаем ее }

{ передаем фокус приложению }

if IsIconic(Application.Handle) then begin

Application.MainForm.WindowState:= wsNormal;

ShowWindow(Application.Mainform.Handle, sw_restore);

end;

SetForegroundWindow(Application.MainForm.Handle);

end

{ В противном случае посылаем сообщение предыдущему окну }

else Result:= CallWindowProc(WProc, Handle, Msg, wParam, lParam);

end;

procedure SubClassApplication;

begin

{ Обязательная процедура. Необходима, чтобы обработчик }

{ Application.OnMessage был доступен для использования. }

WProc:= TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC, Longint(@NewWndProc)));

{ Если происходит ошибка, устанавливаем подходящий флаг }

if WProc = Nil then MIError:= MIError or MI_FAIL_SUBCLASS;

end;

procedure DoFirstInstance;

begin

SubClassApplication;

MutHandle:= CreateMutex(Nil, False, UniqueAppStr);

if MutHandle = 0 then

MIError:= MIError or MI_FAIL_CREATE_MUTEX;

end;

procedure BroadcastFocusMessage;

{ Процедура вызывается, если уже имеется запущенная копия Вашей программы. }

var

BSMRecipients: DWORD;

begin

{ Не показываем основную форму }

Application.ShowMainForm:= False;

{ Посылаем другому приложению сообщение и информируем о необходимости }

{ перевести фокус на себя }

BSMRecipients:= BSM_APPLICATIONS;

BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE, @BSMRecipients, MessageID, 0, 0);

end;

Function InitInstance : Boolean;

begin

MutHandle:= OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);

if MutHandle = 0 then begin

{ Объект Mutex еще не создан, означая, что еще не создано }

{ другое приложение. }

ShowWindow(Application.Handle, SW_ShowNormal);

Application.ShowMainForm:=True;

DoFirstInstance;

result:= True;

end else begin

BroadcastFocusMessage;

result:= False;

end;

initialization

begin

UniqueAppStr:= Application.Exexname;

MessageID:= RegisterWindowMessage(UniqueAppStr);

ShowWindow(Application.Handle, SW_Hide);

Application.ShowMainForm:=FALSE;

end;

finalization

begin

if WProc <> Nil then

{ Приводим приложение в исходное состояние }

SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));

end;

end.

Решение 3

VAR MutexHandle:THandle;

Var UniqueKey: string;

FUNCTION IsNextInstance:BOOLEAN;

BEGIN

Result:=FALSE;

MutexHandle:=0;

MutexHandle:=CREATEMUTEX(NIL,true, uniquekey);

IF MutexHandle<>0 THEN BEGIN

IF GetLastError=ERROR_ALREADY_EXISTS THEN BEGIN

Result:=TRUE;

CLOSEHANDLE(MutexHandle);

MutexHandle:=0;

END;

begin

CmdShow:=SW_HIDE;

MessageId:=RegisterWindowMessage(zAppName);

Application.Initialize;

IF IsNextInstance THEN PostMessage(HWND_BROADCAST, MessageId,0,0)

ELSE BEGIN

Application.ShowMainForm:=FALSE;

Application.CreateForm(TMainForm, MainForm);

MainForm.StartTimer.Enabled:=TRUE;

Application.Run;

END;

IF MutexHandle<>0 THEN CLOSEHANDLE(MutexHandle);

end.

В MainForm вам необходимо вставить обработчик внутреннего сообщения

PROCEDURE TMainForm.OnAppMessage(VAR M:TMSG; VAR Ret:BOOLEAN);

BEGIN

IF M.Message=MessageId THEN BEGIN

Ret:=TRUE;

// Поместить окно наверх !!!!!!!!

END;

INITIALIZATION

ShowWindow(Application.Handle, SW_Hide);

END.

Каким образом, программным путем, можно узнать о завершении запущенной программы?

16-битная версия:

uses Wintypes,WinProcs,Toolhelp,Classes,Forms;

Function WinExecAndWait(Path: string; Visibility: word): word;

var

InstanceID: THandle;

PathLen: integer;

begin

{ Преобразуем строку в тип PChar }

PathLen:= Length(Path);

Move(Path[1],Path[0],PathLen);

Path[PathLen]:= #00;

{ Пытаемся запустить приложение }

InstanceID:= WinExec(@Path,Visibility);

if InstanceID < 32 then { значение меньше 32 указывает на ошибку приложения }

WinExecAndWait:= InstanceID

else begin

Repeat

Application.ProcessMessages;

until Application.Terminated or (GetModuleUsage(InstanceID) = 0);

WinExecAndWait:= 32;

end;

32-битная версия:

function WinExecAndWait32(FileName: String; Visibility: integer):integer;

var

zAppName:array[0..512] of char;

zCurDir:array[0..255] of char;

WorkDir:String;

StartupInfo:TStartupInfo;

ProcessInfo:TProcessInformation;

begin

StrPCopy(zAppName,FileName);

GetDir(0,WorkDir);

StrPCopy(zCurDir,WorkDir);

FillChar(StartupInfo,Sizeof(StartupInfo),#0);

StartupInfo.cb:= Sizeof(StartupInfo);

StartupInfo.dwFlags:= STARTF_USESHOWWINDOW;

StartupInfo.wShowWindow:= Visibility;

if not CreateProcess(nil,

zAppName, { указатель командной строки }

nil, { указатель на процесс атрибутов безопасности }

nil, { указатель на поток атрибутов безопасности }

false, { флаг родительского обработчика }

CREATE_NEW_CONSOLE or { флаг создания }

NORMAL_PRIORITY_CLASS,

nil, { указатель на новую среду процесса }

nil, { указатель на имя текущей директории }

StartupInfo, { указатель на STARTUPINFO }

ProcessInfo) then result := –1 { указатель на process_inf }

else begin

WaitforSingleObject(ProcessInfo.hProcess,INFINITE);

GetExitCodeProcess(ProcessInfo.hProcess,Result);

end;

Получение имени модуля

Вот мое решение. Я использовал его во многих программах и смело рекомендую его вам.

procedure TForm1.Button1Click(Sender: TObject);

var

szFileName: array[0..49] of char;

szModuleName: array[0..19] of char;

iSize : integer;

begin

StrPCopy(szModuleName, 'NameOfModule');

iSize:= GetModuleFileName(GetModuleHandle(szModuleName), szFileName, SizeOf(szFileName));

if iSize > 0 then ShowMessage('Имя модуля с полным путем: ' + StrPas(szFileName))

else ShowMessage('Имя модуля не встречено');

end;

Извлечение из EXE-файла иконки и рисование ее в TImage.

Каким образом извлечь иконку из EXE– и DLL-файлов (ExtractAssociatedIcon) и отобразить ее на компоненте Timage или небольшой области на форме?

uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);

var

IconIndex: word;

h: hIcon;

begin

IconIndex:= 0;

h:= ExtractAssociatedIcon(hInstance, 'C:\WINDOWS\NOTEPAD.EXE', IconINdex);

DrawIcon(Form1.Canvas.Handle, 10, 10, h);

end;

Паскаль

Массивы

Динамические массивы

Очень простой пример…

Const MaxBooleans = (High(Cardinal) – $F) div sizeof(boolean);

Type

TBoolArray = array[1..MaxBooleans] of boolean;

PBoolArray = ^TBoolArray;

Var

B: PBoolArray;

N: integer;

BEGIN

N:= 63579;

{= получение памяти под динамический массив.. =}

GetMem(B, N*sizeof(boolean));

{= работа с массивом… =}

B^[3477]:= FALSE;

{= возвращение памяти в кучу =}

{$IFDEF VER80}

FreeMem(B, N*sizeof(boolean));

{$ELSE}

FreeMem(B);

{$ENDIF}

END.

Массив в Delphi

Раздел 1

Вот несколько функций для операций с двухмерными массивами. Самый простой путь для создания собственной библиотеки. Процедуры SetV и GetV позволяют читать и сохранять элементы массива VArray (его Вы можете объявить как угодно). Например:

type

VArray : Array[1..1] of double;

var

X: ^VArray;

NR, NC: Longint;

begin

NR:= 10000;

NC:= 100;

if AllocArray(pointer(X), N*Sizeof(VArray)) then exit;

SetV(X^, NC, 2000, 5, 3.27); { X[2000,5] := 3.27 }

end;

function AllocArray(var V: pointer; const N: longint): Boolean;

begin {распределяем память для массива v размера n}

try

GetMem(V, N);

except

ShowMessage('ОШИБКА выделения памяти. Размер:' + IntToStr(N));

Result:= True;

exit;

end;

FillChar(V^, N, 0); {в случае включения длинных строк заполняем их нулями}

Result:= False;

end;

procedure SetV(var X: Varray; const N,ir,ic: LongInt;const value: double);

begin {заполняем элементами двухмерный массив x размером ? x n : x[ir,ic] := value}

X[N*(ir-1) + ic]:= value;

end;

function GetV(const X: Varray; const N, ir,ic : Longint): double;

begin {возвращаем величины x[ir,ic] для двухмерного массива шириной n столбцов}

Result:= X[N*(ir-1) + ic];

end;

Раздел 2

Самый простой путь – создать массив динамически

Myarray:= GetMem(rows * cols * sizeof(byte,word,single,double и пр.)

сделайте функцию fetch_num типа

function fetch_num(r,c:integer): single;

result:= pointer + row + col*rows

и затем вместо myarray[2,3] напишите

myarray.fetch_num(2,3)

поместите эти функции в ваш объект и работа с массивами станет пустячным делом. Я экспериментировал с многомерными (вплоть до 8) динамическими сложными массивами и эти функции показали отличный результат.

Раздел 3

Вот способ создания одно– и двухмерных динамических массивов:

–- модуль для создания двух очень простых классов обработки динамических массивов

-- TDynaArray : одномерный массив

-- TDynaMatrix : двумерный динамический массив

unit DynArray;

INTERFACE

uses SysUtils;

Type TDynArrayBaseType = double;

Const vMaxElements = (High(Cardinal) – $f) div sizeof(TDynArrayBaseType);

{= гарантирует максимально возможный массив =}

Type

TDynArrayNDX = 1..vMaxElements;

TArrayElements = array[TDynArrayNDX] of TDynArrayBaseType;

{= самый большой массив TDynArrayBaseType, который мы может объявить =}

PArrayElements = ^TArrayElements;

{= указатель на массив =}

EDynArrayRangeError = CLASS(ERangeError);

TDynArray = CLASS

Private

fDimension: TDynArrayNDX;

fMemAllocated: word;

Function GetElement(N: TDynArrayNDX): TDynArrayBaseType;

Procedure SetElement(N: TDynArrayNDX; const NewValue: TDynArrayBaseType);

Protected

Elements : PArrayElements;

Public

Constructor Create(NumElements : TDynArrayNDX);

Destructor Destroy; override;

Procedure Resize(NewDimension : TDynArrayNDX); virtual;

Property dimension: TDynArrayNDX read fDimension;

Property Element[N : TDynArrayNDX] : TDynArrayBaseType read GetElement write SetElement; default;

END;

Const

vMaxMatrixColumns = 65520 div sizeof(TDynArray);

{= построение матрицы класса с использованием массива объектов TDynArray =}

Type

TMatrixNDX = 1..vMaxMatrixColumns;

TMatrixElements = array[TMatrixNDX] of TDynArray;

{= каждая колонка матрицы будет динамическим массивом =}

PMatrixElements = ^TMatrixElements;

{= указатель на массив указателей… =}

TDynaMatrix = CLASS

Private

fRows : TDynArrayNDX;

fColumns : TMatrixNDX;

fMemAllocated : longint;

Function GetElement(row: TDynArrayNDX; column: TMatrixNDX): TDynArrayBaseType;

Procedure SetElement(row: TDynArrayNDX; column: TMatrixNDX; const NewValue: TDynArrayBaseType);

Protected

mtxElements: PMatrixElements;

Public

Constructor Create(NumRows : TDynArrayNDX; NumColumns : TMatrixNDX);

Destructor Destroy; override;

Property rows: TDynArrayNDX read fRows;

Property columns: TMatrixNDX read fColumns;

Property Element[row : TDynArrayNDX; column : TMatrixNDX] : TDynArrayBaseType read GetElement write SetElement; default;

END;

IMPLEMENTATION

-- методы TDynArray

Constructor TDynArray.Create(NumElements : TDynArrayNDX);

BEGIN {==TDynArray.Create==}

inherited Create;

fDimension:= NumElements;

GetMem(Elements, fDimension*sizeof(TDynArrayBaseType));

fMemAllocated:= fDimension*sizeof(TDynArrayBaseType);

FillChar(Elements^, fMemAllocated, 0);

END; {==TDynArray.Create==}

Destructor TDynArray.Destroy;

BEGIN {==TDynArray.Destroy==}

FreeMem(Elements, fMemAllocated);

inherited Destroy;

END; {==TDynArray.Destroy==}

Procedure TDynArray.Resize(NewDimension: TDynArrayNDX);

BEGIN {TDynArray.Resize==}

if (NewDimension < 1) then raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [NewDimension]);

Elements:= ReAllocMem(Elements, fMemAllocated, NewDimension*sizeof(TDynArrayBaseType));

fDimension:= NewDimension;

fMemAllocated:= fDimension*sizeof(TDynArrayBaseType);

END; {TDynArray.Resize==}

Function TDynArray.GetElement(N: TDynArrayNDX) : TDynArrayBaseType;

BEGIN {==TDynArray.GetElement==}

if (N < 1) OR (N > fDimension) then raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [N]);

result:= Elements^[N];

END; {==TDynArray.GetElement==}

Procedure TDynArray.SetElement(N: TDynArrayNDX; const NewValue: TDynArrayBaseType);

BEGIN {==TDynArray.SetElement==}

if (N < 1) OR (N > fDimension) then raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [N]);

Elements^[N]:= NewValue;

END; {==TDynArray.SetElement==}

-- методы TDynaMatrix

Constructor TDynaMatrix.Create(NumRows: TDynArrayNDX; NumColumns: TMatrixNDX);

Var col : TMatrixNDX;

BEGIN {==TDynaMatrix.Create==}

inherited Create;

fRows:= NumRows;

fColumns:= NumColumns;

{= выделение памяти для массива указателей (т.е. для массива TDynArrays) =}

GetMem(mtxElements, fColumns*sizeof(TDynArray));

fMemAllocated:= fColumns*sizeof(TDynArray);

{= теперь выделяем память для каждого столбца матрицы =}

for col := 1 to fColumns do BEGIN

mtxElements^[col]:= TDynArray.Create(fRows);

inc(fMemAllocated, mtxElements^[col].fMemAllocated);

END;

END; {==TDynaMatrix.Create==}

Destructor TDynaMatrix.Destroy;

Var col : TMatrixNDX;

BEGIN {==TDynaMatrix.Destroy;==}

for col:= fColumns downto 1 do BEGIN

dec(fMemAllocated, mtxElements^[col].fMemAllocated);

mtxElements^[col].Free;

END;

FreeMem(mtxElements, fMemAllocated);

inherited Destroy;

END; {==TDynaMatrix.Destroy;==}

Function TDynaMatrix.GetElement(row: TDynArrayNDX; column: TMatrixNDX): TDynArrayBaseType;

BEGIN {==TDynaMatrix.GetElement==}

if (row < 1) OR (row > fRows) then raise EDynArrayRangeError.CreateFMT('Индекс строки вышел за границы диапазона : %d', [row]);

if (column < 1) OR (column > fColumns) then raise EDynArrayRangeError.CreateFMT('Индекс столбца вышел за границы диапазона : %d', [column]);

result:= mtxElements^[column].Elements^[row];

END; {==TDynaMatrix.GetElement==}

Procedure TDynaMatrix.SetElement(row: TDynArrayNDX; column: TMatrixNDX; const NewValue: TDynArrayBaseType);

BEGIN {==TDynaMatrix.SetElement==}

if (row < 1) OR (row > fRows) then raise EDynArrayRangeError.CreateFMT('Индекс строки вышел за границы диапазона : %d', [row]);

if (column < 1) OR (column > fColumns) then raise EDynArrayRangeError.CreateFMT('Индекс столбца вышел за границы диапазона : %d', [column]);

mtxElements^[column].Elements^[row]:= NewValue;

END; {==TDynaMatrix.SetElement==}

END.

-Тестовая программа для модуля DynArray-

uses DynArray, WinCRT;

Const

NumRows: integer = 7;

NumCols: integer = 5;

Var

M: TDynaMatrix;

row, col: integer;

BEGIN

M:= TDynaMatrix.Create(NumRows, NumCols);

for row:= 1 to M.Rows do for col:= 1 to M.Columns do M[row, col]:= row + col/10;

writeln('Матрица');

for row:= 1 to M.Rows do BEGIN

for col:= 1 to M.Columns do write(M[row, col]:5:1);

writeln;

END;

writeln;

writeln('Перемещение');

for col:= 1 to M.Columns do BEGIN

for row:= 1 to M.Rows do write(M[row, col]:5:1);

writeln;

END;

M.Free;

END.

Базы данных

Создание

Создание db-файла во время работы приложения

uses DB, DBTables, StdCtrls;

procedure TForm1.Button1Click(Sender: TObject);

var

tSource, TDest: TTable;

begin

TSource:= TTable.create(self);

with tsTSource do begin

DatabaseName:= 'dbdemos';

TableName:= 'customer.db';

open;

end;

TDest:= TTable.create(self);

with TDest do begin

DatabaseName:= 'dbdemos';

TableName:= 'MyNewTbl.db';

FieldDefs.Assign(TSource.FieldDefs);

IndexDefs.Assign(TSource.IndexDefs);

CreateTable;

end;

TSource.close;

end;

Доступ

Очень медленный доступ к таблице при первом обращении

Данная проблема возникает из-за того, что BDE вначале запрашивает базу данных для получения информации о таблице, прежде чем он начнет с ней работать. Как только появляется информация о таблице, она кэшируется и обращение к таблице во время всего сеанса (пока TDatabase.Connection имеет значение True) происходит практически мгновенно. Для того, чтобы использовать кэшируемую информацию и при последующем запуске приложения, в конфигурации BDE найдите необходимый псевдоним и установите BDE CACHE = TRUE и BDE CACHE DIR = 'C:\temp' или любой другой удобный каталог.

ПРИМЕЧАНИЕ:

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

Поиск

Поиск величины при вводе

Каким способом можно производить поиск подходящих величин в момент ввода? Табличный курсор (визуально) должен перемещаться к наиболее подходящему значению при добавлении пользователем новых символов водимой величины.

Первоначально код писался под Delphi 1. Это может и не лучшее решение, но это работает.

Для поиска величины таблица держится открытой. Индекс должен, естественно, принадлежать полю, используемому элементом управления EditBox. В случае изменения содержимого EditBox, новое значение используется для вызова стандартной функции FindNearest таблицы TTable. Возвращаемая величина снова присваивается свойcтву Text элемента EditBox.

Я привел лишь общее решение задачи. Фактически во время изменения значения я включал таймер на период 1/3 секунды и в обработчике события OnTimer проводил операцию поиска (с выключением таймера). Это позволяло пользователю набирать без задержки нужный текст без необходимости производить поиск в расчете на вновь введенный символ (поиск проводился только при возникновении задержки в 1/3 секунды).

Вам также может понадобиться специальный обработчик нажатия клавиши backspace или добавления символа в любое место строки.

Вместо возвращения результатов элементу EditBox (который перезаписывает введенное пользователем значение), вы можете передавать результаты другому элементу управления, например компоненту ListBox. Вы также можете отобразить несколько наиболее подходящих значений, к примеру так:

procedure Edit1OnChange(…);

var i:integer;

begin

if not updating then exit; {сделайте обновление где-нибудь еще – например при срабатывании таймера}

updating:= false;

Table1.FindNearest([Edit1.text]);

ListBox1.clear;

i:= 0;

while (i < 5) and (not (table1.eof)) do begin

listbox.items.add(Table1.fields[0].asString);

inc(i);

table1.next;

end;

listbox1.itemindex:= 0;

end;

Быстрый поиск в базах данных

Я представляю на Ваш суд утилиту быстрого поиска по базе данных. Данная технология производит поиск по полям, преобразуя их значения в строки (все значения преобразуются в верхний регистр, включая действительные числа). Данное решение может быть не самым быстрым, однако на поверку оно оказывается быстрее остальных, обнаруженных мною в Интернете (может вам повезет больше). Более того, представьте, что действительное значение какого-либо поля равно 4.509375354, а значение поиска равно 7, в этом случае утилита засчитает "попадание". Утилита удобна также тем, что она за один проход производит поиск более, чем в одном поле. Это удобно, если у Вас имеются, к примеру, два поля с адресами. Это моя первая "серьезная" разработка, так как первое, с чем я столкнулся, изучая Delphi, стала необходимость включения процедуры поиска в любое приложение, работающее с базой данных. А так как поиск – вещь тоже сугубо специфическая, как и любое приложение, то мне пришлось побороть свой страх перед "крутым программированием" и попробовать написать свой поисковый механизм, удовлетворивший меня (и, надеюсь, других) своей скоростью и возможностью "мульти"-поиска по нескольким полям. Я надеюсь, что он поможет тем программистам, кто часто сталкивается с подобными задачами. Технология довольно легка для понимания, но если у Вас возникли какие-либо вопросы, пошлите мне письмо электронной почтой, я буду рад Вам помочь. Посмотрев код, можно легко узнать поддерживаемые типы полей (добавить новые не составит проблем). Если кто-либо обнаружит ошибочный код или расширит функциональность утилиты, пожалуйста, пошлите это мне, я буду весьма благодарен. Спасибо.

unit Finder;

interface

uses DB, DBTables, SysUtils;

function GrabMemoFieldAsPChar(TheField: TMemoField): PChar;

function DoFindIn(TheField: TField; SFor: String): Boolean;

function FindIt(TheTable : TDataSet; TheFields: array of integer; SearchBackward: Boolean; FromBeginning: Boolean; SFor: String): boolean;

{применение функции FindIt – if FindIt(NotesSearchT, [NotesSearchT.FieldByName('Leadman').Index], False, True, SearchText.Text) then DoSomething; }

implementation

function GrabMemoFieldAsPChar(TheField: TMemoField): PChar;

begin

with TBlobStream.Create(TheField, bmRead) do begin

GetMem(Result, Size + 1);

FillChar(Result^, Size + 1, #0);

Read(Result^, Size);

Free;

end;

function DoFindIn(TheField : TField; SFor : String): Boolean;

var

PChForMemo: PChar;

begin

Result:= False;

case TheField.DataType of

ftString: begin

if (Pos(SFor, UpperCase(TheField.AsString))> 0) then Result := True;

end;

ftInteger: begin

if (Pos(SFor, TheField.AsString)> 0) then Result:= True;

end;

ftBoolean: begin

if SFor = UpperCase(TheField.AsString) then Result:= True;

end;

ftFloat: begin

if (Pos(SFor, TheField.AsString) > 0) then Result := True;

end;

ftCurrency: begin

if (Pos(SFor, TheField.AsString) > 0) then Result := True;

end;

ftDate..ftDateTime: begin

if (Pos(SFor, TheField.AsString) > 0) then Result := True;

end;

ftMemo: begin

SFor[Ord(SFor[0]) + 1]:= #0;

PChForMemo:= GrabMemoFieldAsPChar(TMemoField(TheField));

StrUpper(PChForMemo);

if not (StrPos( PChForMemo, @SFor[1] ) = nil) then Result:= True;

FreeMem(PChForMemo, StrLen(PChForMemo + 1));

end;

function FindIt(TheTable: TDataSet; TheFields: array of integer; SearchBackward: Boolean; FromBeginning: Boolean; SFor: String): boolean;

var

i, HighTheFields, LowTheFields: integer;

BM: TBookmark;

begin

TheTable.DisableControls;

BM:= TheTable.GetBookmark;

try

LowTheFields:= Low(TheFields);

HighTheFields:= High(TheFields);

SFor:= UpperCase(SFor);

Result:= False;

if FromBeginning then TheTable.First;

if SearchBackwardthen begin

TheTable.Prior;

while not TheTable.BOF do begin

for i:= LowTheFields to HighTheFields do begin

if DoFindIn(TheTable.Fields[TheFields[i]], SFor) then begin

Result := True;

Break;

end;

if Result then Break else TheTable.Prior;

end;

end else begin

TheTable.Next;

while not TheTable.EOF do begin

for i:= LowTheFields to HighTheFields do begin

if DoFindIn(TheTable.Fields[TheFields[i]], SFor) then begin

Result:= True;

Break;

end;

if Result then Break else TheTable.Next;

end;

finally

TheTable.EnableControls;

if not Result then TheTable.GotoBookmark(BM);

TheTable.FreeBookmark(BM);

end;

end.

Калькуляция

Хитрость OnCalcFields

Событие OncalcFields генерится ОЧЕНЬ часто и может быть необязательным и занимать большое количество времени, например, у вас есть таблица с неким вычисляемым полем, и при каждом редактировании таблицы вызывается следующий код:

MyCalcField.AsInteger:= Table1Field1.AsInteger + 10;

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

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

Procedure TForm1.BigProcessingFunction;

begin

Table1.OnCalcFields:= nil;

<Включите любые по сложности вычисления в этом месте!>

Table1.OnCalcFields:= Table1OnCalcFields;

end;

Поля не вычисляются в течение времени обработки, которое может быть достаточно велико, но при наличие громоздких вычислений специфического поля (или даже нескольких полей), все вычисляется за один проход!

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

dBASE

Таблицы dBASE: Структура .DBF-файла

Иногда возникает необходимость поработать с таблицей dBASE напрямую, без Borland Database Engine (BDE). К примеру, если .DBT-файл (содержащий MEMO-данные) для данной таблицы безвозвратно потерян, .DBF-файл становится абсолютно непригодным, поскольку байт в заголовке .DBF-файла указывает, что таблица должна содержать соответствующий MEMO-файл. Решение этой проблемы потребует обнуление этого байта, для того чтобы таблица не указывала на сопутствующий MEMO-файл. Или, если Вам захотелось написать собственную программу для работы с данными.

Ниже приводяся структуры .DBF-файлов для таблиц dBASE. Представлены структуры файлов для различных версий dBASE: dBASE III PLUS 1.1, dBASE IV 2.0, dBASE 5.0 под DOS и dBASE 5.0 для Windows.

Структура заголовка файла данных для таблицы dBASE III PLUS.

Заголовок табличного файла Байт Содержание Описание 0 1-й байт Определение наличия MEMO-файла в таблице dBASE III PLUS (03h без MEMO-файла (.DBT-файл;) 83h с MEMO-файлом). 1-3 3 байта Дата последнего обновления в формате YYMMDD 4-7 32-битное число Количество записей в таблице 8-9 16-битное число Количество байтов, занимаемых заголовком 10-11 16-битное число Количество байтов, занимаемых записью 12-14 3 байта Зарезервированная область 15-27 13 байт Зарезервировано для сетевой версии dBASE III PLUS 28-31 4 байта Зарезервированная область 32-n 32 байта Массив с описаниями полей (структура каждого такого описания показана ниже) n+1 1 байт Хранится значение 0Dh, выполняющее роль терминатора описаний полей

n – последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.

Описание поля таблицы Байт Содержание Описание 0-10 11 байт Имя поля в ASCII (заполнено нулями). 11 1 байт Тип поля в ASCII (C, D, L, M или N) 12-15 4 байта Адрес данных поля (ссылка на память, а не на диск) 16 1 байт Размер поля в бинарном формате 17 1 байт Порядковый номер поля в бинарном формате 18-19 2 байта Зарезервировано для сетевой версии dBASE III PLUS 20 1 байт ID рабочей области 21-22 2 байта Зарезервировано для сетевой версии dBASE III PLUS 23 1 байт Флаг установки поля 24-31 1 байт Зарезервированная область

Записи таблицы

Записи в табличном файле располагаются непосредственно за заголовком таблицы. Данным записи предшествует байт, указывающий на удаленность записи: значение 20h (пробел) указывает что запись не удалена, значение 2Ah (звездочка) – запись была удалена. Поля упаковываются записями без разделителей полей или терминаторов записи. Конец файла помечается единственным байтом (с EOF-маркером), OEM-код которого соответствует значению 26 (1Ah). Вы можете ввести данные в кодовой странице OEM как показано ниже.

Допустимый тип данных таблиц dBASE Тип данных Возможные значения C (Символы) Все символы кодовой страницы OEM D (Дата) Числа и символ-разделитель для месяца, дня и года (внутренний формат записи – 8 цифр в формате YYYYMMDD) N (Числовой) – . 0 1 2 3 4 5 6 7 8 9 L (Логический) ? Y y N n T t F f (? – не инициализировано) M (Мемо) Все символы кодовой страницы OEM (внутренний формат записи – 10 цифр, содержащих номер .DBT-блока)

Бинарные-, MEMO-, OLE-поля и .DBT-файлы

MEMO-поля хранят данные в .DBT-файлах, состоящих из перечисляемых последовательных блоков (0, 1, 2 и т.д.). Размер блока равен 512 байт. Первый блок в .DBT-файле (нулевой блок) – заголовок .DBT-файла.

MEMO-поле каждой записи .DBF-файла содержит номер (значение указывается в кодовой странице OEM), указывающий на блок с хранимыми данными. Если поле не содержит никаких данных, .DBF-файл будет заполнен пробелами (20h) (а не числами).

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

Данная информация взята из руководства по использованию dBASE III Plus ("Using dBASE III PLUS", Appendix C).

Структура заголовка файла данных для таблицы dBASE IV 2.0.

Заголовок табличного файла Байт Содержание Описание 0 1-й байт Контроль файла dBASE под Windows: биты 0-2 указывают номер версии, бит 3 - наличие MEMO-файла dBASE IV или dBASE под Windows, биты 4-6 - наличие dBASE IV SQL-таблицы, бит 7 - наличие любого .DBT MEMO-файла (MEMO-файл таблицы dBASE III Plus, dBASE IV или dBASE под Windows) 1-3 3 байта Дата последнего обновления в формате YYMMDD 4-7 32-битное число Количество записей в таблице 8-9 16-битное число Количество байтов, занимаемых заголовком 10-11 16-битное число Количество байтов, занимаемых записью 12-13 2 байта Зарезервированная область, заполнена нулями 14 1 байт Флаг, указывающий на наличие незавершенной транзакции dBASE IV 15 1 байт Флаг кодировки таблицы dBASE IV 16-27 12 байт Зарезервированная область для многопользовательского использования dBASE IV 28 1 байт Флаг наличия MDX-файла: 01H - файл для данной таблицы присутствует, 00H - файл отсутствует 29 1 байт ID драйвера языка 30-31 2 байта Зарезервированная область, заполнена нулями 32-n по 32 байта Массив с описаниями полей (структура данного массива показана ниже) n+1 1 байт 0DH в качестве терминатора

n - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.

Описание поля таблицы Байт Содержание Описание 0-10 11 байт Имя поля в ASCII (заполнено нулями). 11 1 байт Тип поля в ASCII (C, D, F, L, M или N) 12-15 4 байта Зарезервированная область 16 1 байт Размер поля в бинарном формате 17 1 байт Порядковый номер поля в бинарном формате 18-19 2 байта Зарезервированная область 20 1 байт ID рабочей области 21-30 10 байт Зарезервированная область 31 1 байт Флаг MDX-поля: 01H если поле имеет метку индекса в MDX-файле, 00H – нет.

Записи таблицы:

Допустимый тип данных таблиц dBASE Тип данных Возможные значения C (Символы) Все символы кодовой страницы OEM D (Дата) Числа и символ-разделитель для месяца, дня и года (внутренний формат записи – 8 цифр в формате YYYYMMDD) F (Бинарные числа с плавающей точкой) – . 0 1 2 3 4 5 6 7 8 9 N (Числовой) – . 0 1 2 3 4 5 6 7 8 9 L (Логический) ? Y y N n T t F f (? – не инициализировано) M (Мемо) Все символы кодовой страницы OEM (внутренний формат записи – 10 цифр, содержащих номер .DBT-блока)

Memo-поля и .DBT-файлы

MEMO-поля хранят данные в .DBT-файлах, состоящих из перечисляемых последовательных блоков (0, 1, 2 и т.д.). Переменная BLOCKSIZE определяет размер каждого блока. Первый блок в .DBT-файле (нулевой блок) – заголовок .DBT-файла.

Данная информация взята из справочника по dBASE IV ("dBASE IV Language Reference", Appendix D).

Структура заголовка файла данных для таблицы dBASE 5.0 под DOS.

Заголовок табличного файла Байт Содержание Описание 0 1-й байт Контроль файла dBASE под Windows: биты 0-2 указывают номер версии, бит 3 - наличие MEMO-файла dBASE IV или dBASE под Windows, биты 4-6 - наличие dBASE IV SQL-таблицы, бит 7 - наличие любого .DBT MEMO-файла (MEMO-файл таблицы dBASE III Plus, dBASE IV или dBASE под Windows) 1-3 3 байта Дата последнего обновления в формате YYMMDD 4-7 32-битное число Количество записей в таблице 8-9 16-битное число Количество байтов, занимаемых заголовком 10-11 16-битное число Количество байтов, занимаемых записью 12-13 2 байта Зарезервированная область, заполнена нулями 14 1 байт Флаг, указывающий на наличие незавершенной транзакции 15 1 байт Флаг кодировки 16-27 12 байт Зарезервированная область для многопользовательского использования 28 1 байт Флаг наличия MDX-файла: 01H - файл для данной таблицы присутствует, 00H - файл отсутствует 29 1 байт ID драйвера языка 30-31 2 байта Зарезервированная область, заполнена нулями 32-n по 32 байта Массив с описаниями полей (структура данного массива показана ниже) n+1 1 байт 0DH в качестве терминатора

n - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.

Описание поля таблицы Байт Содержание Описание 0-10 11 байт Имя поля в ASCII (заполнено нулями). 11 1 байт Тип поля в ASCII (B, C, D, F, G, L, M или N) 12-15 4 байта Зарезервированная область 16 1 байт Размер поля в бинарном формате 17 1 байт Порядковый номер поля в бинарном формате 18-19 2 байта Зарезервированная область 20 1 байт ID рабочей области 21-30 10 байт Зарезервированная область 31 1 байт Флаг MDX-поля: 01H если поле имеет метку индекса в MDX-файле, 00H – нет.

Записи таблицы

Допустимый тип данных таблиц dBASE Тип данных Возможные значения C (Символы) Все символы кодовой страницы OEM D (Дата) Числа и символ-разделитель для месяца, дня и года (внутренний формат записи – 8 цифр в формате YYYYMMDD) F (Бинарные числа с плавающей точкой) – . 0 1 2 3 4 5 6 7 8 9 N (Числовой) – . 0 1 2 3 4 5 6 7 8 9 L (Логический) ? Y y N n T t F f (? – не инициализировано) M (Мемо) Все символы кодовой страницы OEM (внутренний формат записи – 10 цифр, содержащих номер .DBT-блока)

MEMO-поля и .DBT-файлы

Если вы удаляете текст в МЕМO-поле, в отличие от dBASE III PLUS, таблица dBASE 5.0 под DOS для ввода нового текста использует удаленную область. dBASE III PLUS всегда добавляет новый текст в конец .DBT-файла. В dBASE III PLUS размер .DBT-файла растет всякий раз при добавления нового текста, даже если перед этим текст был удален.

Данная информация взята из справочника по dBASE под DOS ("dBASE for DOS Language Reference manual", Appendix C).

Структура заголовка файла данных для таблицы dBASE 5.0 под Windows.

Заголовок табличного файла Байт Содержание Описание 0 1-й байт Контроль файла dBASE под Windows: биты 0-2 указывают номер версии, бит 3 - наличие MEMO-файла dBASE IV или dBASE под Windows, биты 4-6 - наличие dBASE IV SQL-таблицы, бит 7 - наличие любого .DBT MEMO-файла (MEMO-файл таблицы dBASE III Plus, dBASE IV или dBASE под Windows) 1-3 3 байта Дата последнего обновления в формате YYMMDD 4-7 32-битное число Количество записей в таблице 8-9 16-битное число Количество байтов, занимаемых заголовком 10-11 16-битное число Количество байтов, занимаемых записью 12-13 2 байта Зарезервированная область, заполнена нулями 14 1 байт Флаг, указывающий на наличие незавершенной транзакции dBASE IV 15 1 байт Флаг кодировки таблицы dBASE IV 16-27 12 байт Зарезервированная область для многопользовательского использования 28 1 байт Флаг наличия MDX-файла: 01H - файл для данной таблицы присутствует, 00H - файл отсутствует 29 1 байт ID драйвера языка 30-31 2 байта Зарезервированная область, заполнена нулями 32-n по 32 байта Массив с описаниями полей (структура данного массива показана ниже) n+1 1 байт 0DH в качестве терминатора

n - последний байт массива с описаниями полей. Размер массива зависит от количества полей в табличном файле.

Записи таблицы

Допустимый тип данных таблиц dBASE Тип данных Возможные значения B (Бинарный) Все символы кодовой страницы OEM (внутренний формат записи – 10 цифр, содержащих номер .DBT-блока). C (Символы) Все символы кодовой страницы OEM D (Дата) Числа и символ-разделитель для месяца, дня и года (внутренний формат записи – 8 цифр в формате YYYYMMDD) G (Общий) Все символы кодовой страницы OEM или OLE (внутренний формат записи - 10 цифр, содержащих номер .DBT-блока). N (Числовой) – . 0 1 2 3 4 5 6 7 8 9 L (Логический) ? Y y N n T t F f (? – не инициализировано) M (Мемо) Все символы кодовой страницы OEM (внутренний формат записи – 10 цифр, содержащих номер .DBT-блока)

Бинарные, МЕМО, OLE-поля и .DBT-файлы

Бинарные, MEMO и OLE-поля хранят данные в .DBT-файлах, состоящих из перечисляемых последовательных блоков (0, 1, 2 и т.д.). Переменная BLOCKSIZE определяет размер каждого блока. Первый блок в .DBT-файле (нулевой блок) – заголовок .DBT-файла.

Бинарное, OLE– или MEMO-поле каждой записи .DBF-файла содержит номер (значение указывается в кодовой странице OEM), указывающий на блок с хранимыми данными. Если поле не содержит никаких данных, .DBF-файл будет заполнен пробелами (20h) (а не числами).

Если вы удаляете текст в бинарном, OLE– или МЕМO-поле, в отличие от dBASE III PLUS и dBASE IV, таблица dBASE 5.0 под Windows для ввода нового текста использует удаленную область. dBASE III PLUS всегда добавляет новый текст в конец .DBT-файла. В dBASE III PLUS размер .DBT-файла растет всякий раз при добавления нового текста, даже если перед этим текст был удален.

Данная информация взята из справочника по dBASE под Windows ("dBASE for Windows Language Reference manual", Appendix C).

Предупреждение: У Вас есть право использовать данную техническую информацию с продуктом фирмы Borland только лишь в случае, когда это не противоречит Лицензионному соглашению, поставляемую с программным продуктом.

Разное

Сканирование версии структуры базы данных

Спасибо за идеи, высказанные в группах новостей и присланные по электронной почте. Я думаю, что нашел лучшее решение.

Очевидно, BDE содержит номер версии структуры, по крайней мере для файлов Paradox. (Я не могу поручиться за dBase и другие форматы.) Всякий раз при изменении структуры (например, в Database Desktop) BDE увеличивает номер версии. Следующий модуль содержит функцию, которая возвращает версию структуры базы данных:

(*****************************************************************************

* DbUtils.pas

* Утилита для работы с базами данных

* Создана 09/20/96

*****************************************************************************)

unit Dbutils;

(****************************************************************************)

interface

(****************************************************************************)

uses DbTables;

function DbGetVersion(table: TTable): LongInt;

(****************************************************************************)

implementation

(****************************************************************************)

uses Db, DbiProcs, DbiTypes, {DbiErrs,} SysUtils;

{---------------------------------------------------------------------------}

* Цель: определение номера версии структуры таблицы

* Параметры: table (I) – интересующая нас таблица

* Возвращаемая величина: номер версии

* Исключительная ситуация: EDatabaseError

function DbGetVersion(table: TTable): LongInt;

var

hCursor : hDBICur;

tableDesc: TBLFullDesc;

cName : array[0..255] of char;

begin

{ копируем имя таблицы в строку 'с' }

StrPCopy(cName, table.TableName);

{ просим BDE создать запись, содержащую информацию об определенной таблице }

Check(DbiOpenTableList(table.DBHandle, True, False, cName, hCursor));

{ получаем запись, содержащую информацию о структуре }

Check(DbiGetNextRecord(hCursor, dbiNOLOCK, @tableDesc, nil));

{ возвращаем поле записи, содержащее номер версии структуры нашей таблицы }

Result:= tableDesc.tblExt.iRestrVersion;

Check(DbiCloseCursor(hCursor));

end;

end.

Перемещение таблиц

Здесь я привожу примеры программ, которые я использую для копирования и удаления таблиц. Необходимые для работы модули: DB, DBTables, DbiProcs,DbiErrs, и DbiTypes. Вам всего лишь необходимо указать каталог расположения, исходное имя таблицы, каталог назначения и имя таблицы, куда будет скопирована исходная таблица и BDE скопирует таблицу целиком со всеми индексами. Процедура удаления в качестве входных параметров использует каталог расположения и имя таблицы, при этом BDE удаляет как саму таблицу, так и все файлы, связанные с ней (индексы и т.п.). Для тестирования данные процедуры были помещены в новое приложение и мне пришлось их немного отредактировать, чтобы удалить некоторые зависимости, которые были связаны с главной формой приложения. Теперь процедуры являются полностью автономными и могут быть помещены в отдельный модуль. (Не забудьте включить его в список используемых модулей). Пользуйтесь на здоровье!

procedure TConvertForm.CopyTable(FromDir, SrcTblName, ToDir, DestTblName: String);

var

DBHandle: HDBIDB;

ResultCode: DBIResult;

Src, Dest, Err: Array[0..255] of char;

SrcTbl, DestTbl: TTable;

begin

SrcTbl:= TTable.Create(Application);

DestTbl:= TTable.Create(Application);

try

SrcTbl.DatabaseName:= FromDir;

SrcTbl.TableName:= SrcTblName;

SrcTbl.Open;

DBHandle:= SrcTbl.DBHandle;

SrcTbl.Close;

ResultCode:= DbiCopyTable(DBHandle,false,

StrPCopy(Src,FromDir + '\' + SrcTblName), nil, StrPCopy(Dest,ToDir + '\' + DestTblName));

if (ResultCode <> DBIERR_NONE) then begin

DbiGetErrorString(ResultCode,Err);

raise EDatabaseError.Create('При копировании ' + FromDir + '\' + SrcTblName + ' в ' + ToDir + '\' + DestTblName + ' ,' + 'BDE сгенерировал ошибку ''' + StrPas(Err) + '''');

end;

finally

SrcTbl.Free;

DestTbl.Free;

end;

procedure TConvertForm.DeleteTable(Dir, TblName: String);

var

DBHandle: HDBIDB;

ResultCode: DBIResult;

tbl, Err: Array[0..255] of char;

SrcTbl, DestTbl: TTable;

SrcTbl:= TTable.Create(Application);

try

SrcTbl.DatabaseName:= Dir;

SrcTbl.TableName:= TblName;

SrcTbl.Open;

DBHandle:= SrcTbl.DBHandle;

SrcTbl.Close;

ResultCode:= DbiDeleteTable(DBHandle, StrPCopy(Tbl,Dir + '\' + TblName), nil);

if (ResultCode <> DBIERR_NONE) then begin

DbiGetErrorString(ResultCode,Err);

raise EDatabaseError.Create('Удаляя ' + Dir + '\' + TblName + ', BDE ' + 'сгенерировал ошибку ''' + StrPas(Err) + '''');

end;

finally

SrcTbl.Free;

end;

Прокрутка таблицы: хитрость PeekMessage()

На днях я решил поиграть с API-функцией PeekMessage(). Функция работает, но ловить ее нужно следующим образом.

Я прокручиваю таблицу, связанную с набором данных. "Поиск" в наборе данных замедляет процесс скролирования (условимся называть "поиском" синхронное перемещение табличного курсора в процессе скроллирования, при котором текущей записью становится запись, ближайшая к нажимаемой кнопке полосы прокрутки). Возникла задача: необходимо отменить "поиск" (процесс слежения) и переместить указатель на необходимую запись только в случае остановки пользователем процесса скроллирования, другими словами – пока пользователь осуществляет скроллирование, "поиск" необходимо отменить. Итак, ко мне в голову пришла мысль, что с помощью PeekMessage() можно выловить определенное сообщение и тем самым отменить поиск во время прокрутки. Звучит просто, но на самом деле все оказалось наоборот.

Я установил фильтр поиска сообщений на WM_MOUSEFIRST/LAST. Ситуация: пользователь непрерывно прокручивает DBGrid вниз, т.е. держит нажатой нижнюю кнопку скроллирования. В результате PeekMessage() возвращает False – нас это не устраивает, это не то, что мы хотим. Положительный результат можно получить только в случае сверхскоростных манипуляций мышью.

Если в фильтре использовать 0 и 0, чтобы поймать любое сообщение, результат всегда будет True. Причина, очевидно в том, что любой щелчок мыши в области DBGrid никак не обойдется без последствий, генерация системой сообщения PAINT яркий тому пример, поэтому PeekMessage может возвратить True в любое время, что тоже не может нам помочь.

Было бы хорошо, если бы дескриптор DBGrid получал событие OnMouseUp() во время его скроллирования. Обидно, но OnMouseUp() работает только с DBGrid, а не с полосами прокрутки. OnMouseUp() с TForm при KeyPreview:=true не работает, я проверял.

После пришла идея опросить состояние кнопок мыши с помощью функции GetKeyState(). Пока кнопка нажата (DOWN), "поиск" запрещен, и наоборот. UP (кнопка отжата) свидетельствует об окончании процесса скроллирования. Данный способ работы с окном во время манипуляций с его полосой прокрутки заработал без проблем. Теперь все в порядке: поиска во время прокрутки не происходит и табличный курсор также никуда не перемещается.

Рассмотренная тема имеет отношение к полосам прокрутки, а события OnKeyUp() и OnMouseUp() могут применяться где-нибудь еще.

BDE

Псевдонимы

Задание псевдонима программным путем

Эта информация поможет вам разобраться в вопросе создания и использования ПСЕВДОНИМОВ баз данных в ваших приложениях.

Вне Delphi создание и конфигурирование псевдонимов осуществляется утилитой BDECFG.EXE. Тем не менее, применяя компонент TDatabase, вы можете в вашем приложении создать и использовать псевдоним, не определенный в IDAPI.CFG.

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

Некоторые варианты решения задачи:

Пример #1: Пример #1 создает и конфигурирует псевдоним для базы данных STANDARD (.DB, .DBF). Псевдоним затем используется компонентом TTable.

Пример #2: Пример #2 создает и конфигурирует псевдоним для базы данных INTERBASE (.gdb). Псевдоним затем используется компонентом TQuery для подключения к двум таблицам базы данных.

Пример #3: Пример #3 создает и конфигурирует псевдоним для базы данных STANDARD (.DB, .DBF). Демонстрация ввода псевдонима пользователем и его конфигурация во время выполнения программы.

Пример #1: Используем базу данных .DB или .DBF (STANDARD)

1. Создаем новый проект.

2. Располагаем на форме следующие компоненты: – TDatabase, TTable, TDataSource, TDBGrid, and TButton.

3. Дважды щелкаем на компоненте TDatabase или через контекстное меню (правая кнопка мыши) вызываем редактор базы данных.

4. Присваиваем базе данных имя 'MyNewAlias'. Это имя будет выполнять роль псевдонима в свойстве DatabaseName для компонентов типа TTable, TQuery, TStoredProc.

5. Выбираем в поле Driver Name (имя драйвера) пункт STANDARD.

6. Щелкаем на кнопке Defaults. Это автоматически добавляет путь (PATH=) в секцию перекрытых параметров (окно Parameter Overrides).

7. Устанавливаем PATH= to C:\DELPHI\DEMOS\DATA (PATH=C:\DELPHI\DEMOS\DATA).

8. Нажимаем кнопку OK и закрываем окно редактора.

9. В компоненте TTable свойству DatabaseName присваиваем 'MyNewAlias'.

10. В компоненте TDataSource свойству DataSet присваиваем 'Table1'.

11. В компоненте DBGrid свойству DataSource присваиваем 'DataSource1'.

12. Создаем в компоненте TButton обработчик события OnClick.

procedure TForm1.Button1Click(Sender: TObject);

begin

Table1.Tablename:= 'CUSTOMER';

Table1.Active:= True;

end;

13. Запускаем приложение.

*** В качестве альтернативы шагам 3 – 11, вы можете включить все эти действия в сам обработчик:

procedure TForm1.Button1Click(Sender: TObject);

begin

Database1.DatabaseName:= 'MyNewAlias';

Database1.DriverName:= 'STANDARD';

Database1.Params.Clear;

Database1.Params.Add('PATH=C:\DELPHI\DEMOS\DATA');

Table1.DatabaseName:= 'MyNewAlias';

Table1.TableName:= 'CUSTOMER';

Table1.Active:= True;

DataSource1.DataSet:= Table1;

DBGrid1.DataSource:= DataSource1;

end;

Пример #2: Используем базу данных INTERBASE

1. Создаем новый проект.

2. Располагаем на форме следующие компоненты: – TDatabase, TQuery, TDataSource, TDBGrid, and TButton.

5. Выбираем в поле Driver Name (имя драйвера) пункт INTRBASE.

SERVER NAME=IB_SERVEER:/PATH/DATABASE.GDB

USER NAME=MYNAME

OPEN MODE=READ/WRITE

SCHEMA CACHE SIZE=8

LANGDRIVER=

SQLQRYMODE=

SQLPASSTHRU MODE=NOT SHARED

SCHEMA CACHE TIME=-1

PASSWORD=

7. Устанавливаем следующие параметры

SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB

USER NAME=SYSDBA

OPEN MODE=READ/WRITE

SCHEMA CACHE SIZE=8

LANGDRIVER=

SQLQRYMODE=

SQLPASSTHRU MODE=NOT SHARED

SCHEMA CACHE TIME=-1

PASSWORD=masterkey

8. В компоненте TDatabase свойство LoginPrompt устанавливаем в 'False'. Если в секции перекрытых параметров (Parameter Overrides) задан пароль (ключ PASSWORD) и свойство LoginPrompt установлено в 'False', при соединении с базой данный пароль запрашиваться не будет. Предупреждение: при неправильно указанном пароле в секции Parameter Overrides и неактивном свойстве LoginPrompt вы не сможете получить доступ к базе данных, поскольку нет возможности ввести правильный пароль – диалоговое окно "Ввод пароля" отключено свойством LoginPrompt.

9. Нажимаем кнопку OK и закрываем окно редактора.

10. В компоненте TQuery свойству DatabaseName присваиваем 'MyNewAlias'.

11. В компоненте TDataSource свойству DataSet присваиваем 'Query1'.

12. В компоненте DBGrid свойству DataSource присваиваем 'DataSource1'.

13. Создаем в компоненте TButton обработчик события OnClick.

procedure TForm1.Button1Click(Sender: TObject);

begin

Query1.SQL.Clear;

Query1.SQL.ADD('SELECT DISTINCT * FROM CUSTOMER C, SALES S WHERE (S.CUST_NO = C.CUST_NO) ORDER BY C.CUST_NO, C.CUSTOMER');

Query1.Active:= True;

end;

14. Запускаем приложение.

Пример #3: Ввод псевдонима пользователем

Этот пример выводит диалоговое окно и создает псевдоним на основе информации, введенной пользователем.

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

1. Выполняем шаги 1-11 из примера #1.

2. Пишем следующий обработчик события OnClick компонента TButton:

procedure TForm1.Button1Click(Sender: TObject);

var

NewString: string;

ClickedOK: Boolean;

begin

NewString:= 'C:\';

ClickedOK:= InputQuery('Database Path', 'Path: –> C:\DELPHI\DEMOS\DATA', NewString);

if ClickedOK then begin

Database1.DatabaseName:= 'MyNewAlias';

Database1.DriverName:= 'STANDARD';

Database1.Params.Clear;

Database1.Params.Add('Path=' + NewString);

Table1.DatabaseName:= 'MyNewAlias';

Table1.TableName:= 'CUSTOMER';

Table1.Active:= True;

DataSource1.DataSet:= Table1;

DBGrid1.DataSource:= DataSource1;

end;

3. Запускаем приложение.

Информация о псевдонимах BDE

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

Обратите внимание на метод GetAliasParams класса TSession.

Возвращенная строка будет содержать искомый путь.

Я пользуюсь следующей функцией:

uses DbiProcs, DBiTypes;

function GetDataBaseDir(const Alias : string): String;

(* Возвращает каталог расположения базы данных по заданному псевдониму

(без обратного слеша) *)

var

sp: PChar;

Res: pDBDesc;

begin

try

New(Res);

sp:= StrAlloc(length(Alias)+1);

StrPCopy(sp,Alias);

if DbiGetDatabaseDesc(sp,Res) = 0 then Result:= StrPas(Res^.szPhyName)

else Result:= '';

finally

StrDispose(sp);

Dispose(Res);

end;

Мультимедиа

Аудио-компакт

Получение идентификатора диска

Как получить идентификатор находящегося в CD-ROM'е аудио-компакта?

const

MCI_INFO_PRODUCT = $00000100;

MCI_INFO_FILE = $00000200;

MCI_INFO_MEDIA_UPC = $00000400;

MCI_INFO_MEDIA_IDENTITY = $00000800;

MCI_INFO_NAME = $00001000;

MCI_INFO_COPYRIGHT = $00002000;

{ блок параметров для командного сообщения MCI_INFO }

type

PMCI_Info_ParmsA = ^TMCI_Info_ParmsA;

PMCI_Info_ParmsW = ^TMCI_Info_ParmsW;

PMCI_Info_Parms = PMCI_Info_ParmsA;

TMCI_Info_ParmsA = record

dwCallback: DWORD;

lpstrReturn: PAnsiChar;

dwRetSize: DWORD;

end;

TMCI_Info_ParmsW = record

dwCallback: DWORD;

lpstrReturn: PWideChar;

dwRetSize: DWORD;

end;

TMCI_Info_Parms = TMCI_Info_ParmsA;

Идентификатор возвращается функцией MCI_INFO_MEDIA_IDENTITY в виде строки с десятичным числом. Для получения дополнительной информации обратитесь к электронной справке (Win32 и компонент TMediaPlayer).

Аппаратное обеспечение

CD-ROM

Открытие и закрытие привода CD-ROM

Есть ли Win32 API функция, позволяющая не только открыть НО И ЗАКРЫТЬ CD-ROM? Хотелось бы не тянуться ручками к РС, а нажать мышкой на кнопку. Компонентом TMediaPlayer пользоваться не хочу, тем более компакт он может только извлечь…

Для закрытия CD-ROM:

mciSendString('Set cdaudio door open wait', nil, 0, handle);

Для открытия CD-ROM:

mciSendString('Set cdaudio door closed wait', nil, 0, handle);

Не забудьте включить MMSystem в список используемых модулей (uses).

Операционная система

Буфер обмена

Просмотр буфера обмена

Пример на основе простого модуля-класса, осуществляющего просмотр буфера обмена.

unit ClipboardViewer;

interface

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

type TForm1 = class(tform)

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

FNextViewerHandle : THandle;

procedure WMDrawClipboard(var message: TMessage); message WM_DRAWCLIPBOARD;

procedure WMChangeCBCHain(var message: TMessage); message WM_CHANGECBCHAIN;

public

end;

var Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

// Проверяем работоспособность функции.

// При невозможности просмотра буфера обмена

// функция возвратит значение Nil.

FNextViewerHandle:= SetClipboardViewer(Handle);

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

// Восстанавливаем цепочки.

ChangeClipboardChain(Handle, FNextViewerHandle);

end;

procedure TForm1.WMDrawClipboard(var message: TMessage);

begin

// Вызывается при любом изменении содержимого буфера обмена

message.Result := SendMessage(WM_DRAWCLIPBOARD, FNextViewerHandle, 0, 0);

end;

procedure TForm1.WMChangeCBCHain(var message: TMessage);

begin

// Вызывается при любом изменении цепочек буфера обмена.

if message.wParam = FNextViewerHandle then begin

// Удаляем следующую цепочку просмотра. Корректируем внутреннюю переменную.

FNextViewerHandle:= message.lParam;

// Возвращаем 0 чтобы указать, что сообщение было обработано

message.Result:= 0;

end else begin

// Передаем сообщение следующему окну в цепочке.

message.Result:= SendMessage(FNextViewerHandle, WM_CHANGECBCHAIN, message.wParam, message.lParam);

end;

end.

Копирование в буфер обмена

Две вспомогательных процедуры:

procedure CopyButtonClick(Sender: TObject);

begin

If ActiveControl is TMemo then TMemo(ActiveControl).CopyToClipboard;

If ActiveControl is TDBMemo then TDBMemo(ActiveControl).CopyToClipboard;

If ActiveControl is TEdit then TEdit(ActiveControl).CopyToClipboard;

If ActiveControl is TDBedit then TDBedit(ActiveControl).CopyToClipboard;

end;

procedure PasteButtonClick(Sender: TObject);

begin

If ActiveControl is TMemo then TMemo(ActiveControl).PasteFromClipboard;

If ActiveControl is TDBMemo then TDBMemo(ActiveControl).PasteFromClipboard;

If ActiveControl is TEdit then TEdit(ActiveControl).PasteFromClipboard;

If ActiveControl is TDBedit then TDBedit(ActiveControl).PasteFromClipboard;

end;

Форма как графический объект

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

uses clipbrd;

procedure TShowVRML.Kopieren1Click(Sender: TObject);

var bitmap:tbitmap;

begin

bitmap:=tbitmap.create;

bitmap.width:=clientwidth;

bitmap.height:=clientheight;

try

with bitmap.Canvas do CopyRect (clientrect,canvas,clientrect);

clipboard.assign(bitmap);

finally

bitmap.free;

end;

Компоненты

BitBtn

Смена иконки BitBtn во время работы приложения

Иконка компонента является инкапсулированным объектом, требующим для хранения изображения некоторый участок памяти. Следовательно, при замене иконки, память, связанная с первоначальной иконкой, должна возвратиться в кучу, а для новой иконки требуется новое распределение памяти. По правилам Delphi, этим должен заниматься метод "Assign". Ниже приведен код всей процедуры замены иконки.

implementation

{$R *.DFM}

var n: integer; // При инициализации программы данное значение будет равным нулю

procedure TForm1.Button1Click(Sender: TObject);

var Image: TBitmap;

begin // Изменение иконки в bitbtn1

Image:= TBitmap.Create;

if n < ImageList1.Count then ImageList1.GetBitmap(n, Image); {end if}

BitBtn1.Glyph.Assign(Image) // Примечание: Для изменения свойств объекта используется метод Assign

inc(n,2); // В данный момент кнопка содержит две иконки!

if n > ImageList1.Count then n:= 0; {end if}

Image.Free;

end;

procedure TForm1.Button2Click(Sender: TObject);

begin // добавляем новую иконку кнопки в список imagelist1

if OpenDialog1.Execute then ImageList1.FileLoad(rtBitMap,OpenDialog1.FileName,clBtnFace);

label1.Caption:= 'Количество иконок = ' + IntToStr(ImageList1.Count);

end;

DBGrid

Использование опции MultiSelect в DBGRID

Есть пример в Delphi Technical Information… Его можно посмотреть по адресу

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

в табличной сетке и отображать второе поле

набора данных.

Метод DisableControls применяется для того, чтобы

DBGrid не обновлялся во время изменения набора данных.

Последняя позиция набора данных сохраняется как

TBookmark.

Метод IndexOf вызывается для проверки

существования закладки.

Решение использовать метод IndexOf, а не метод

Refresh должно определяться

спецификой приложения.

procedure TForm1.SelectClick(Sender: TObject);

var

x: word;

TempBookmark: TBookMark;

begin

DBGrid1.Datasource.Dataset.DisableControls;

with DBgrid1.SelectedRows do if Count <> 0 then begin

TempBookmark:= DBGrid1.Datasource.Dataset.GetBookmark;

for x:= 0 to Count - 1 do begin

if IndexOf(Items[x]) > –1 then begin

DBGrid1.Datasource.Dataset.Bookmark:= Items[x];

showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString);

end;

DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark);

DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark);

DBGrid1.Datasource.Dataset.EnableControls;

end;

Edit

Массив Edit-компонентов

Procedure DoSomethingWithEditControls;

Var K: Integer;

EditArray: Array[0..99] of Tedit;

begin

Try

For K:= 0 to 99 do begin

EditArray[K]:= TEdit.Create(Self);

EditArray[K].Parent:= Self;

SetSomeOtherPropertiesOfTEdit; {Устанавливаем необходимые свойства TEdit}

Left:= 100; Top:= K*10;

OnMouseMove:= WhatToDoWhenMouseIsMoved; {Что-то делаем при перемещении мыши}

end;

DoWhateverYouWantToDoWithTheseEdits; {Делаем все что хотим с полученным массивом Edit-компонентов}

Finally

For K:= 0to 99do EditArray[K].Free;

end;

Примечание: узнать доступные свойства компонента можно непосредственно в инспекторе объектов и (или) в текстовом режиме вашей формы (щелкните на форме правой кнопкой мыши и выберите пункт View as Text)

Label

3D-рамка для текстовых компонентов

Один из примеров создания текстового компонента с трехмерной декоративной контурной рамкой (для создания компонента потребовалось около получаса. Он демонстрирует только принцип получения рамки. Я не стал колдовать над свойствами типа ParentFont…, т.к. это заняло бы еще немало времени и места).

unit IDSLabel;

interface

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

type TIDSLabel = class(TBevel)

private

{ Private declarations }

FAlignment: TAlignment;

FCaption: String;

FFont: TFont;

FOffset: Byte;

FOnChange: TNotifyEvent;

procedure SetAlignment(taIn : TAlignment);

procedure SetCaption(const strIn: String);

procedure SetFont(fntNew: TFont);

procedure SetOffset(bOffNew: Byte);

protected

{ Protected declarations }

constructor Create(compOwn: TComponent); override;

destructor Destroy; override;

procedure Paint; override;

public

{ Public declarations }

published

{ Published declarations }

property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;

property Caption: String read FCaption write SetCaption;

property Font: TFont read FFont write SetFont;

property Offset: Byte read FOffset write SetOffset;

property OnChange: TNotifyEvent read FOnChange write FOnChange;

end;

implementation

constructor TIDSLabel.Create;

begin

inherited Create(compOwn);

FFont:= TFont.Create;

with compOwn as TForm do FFont.Assign(Font);

Offset:= 4;

Height:= 15;

end;

destructor TIDSLabel.Destroy;

begin

FFont.Free;

inherited Destroy;

end;

procedure TIDSLabel.Paint;

var

wXPos, wYPos : Word;

begin

{Рисуем рамку}

inherited Paint;

{Назначаем шрифт}

Canvas.Font.Assign(Font);

{Вычисляем вертикальную позицию}

wYPos:= (Height – Canvas.TextHeight(Caption)) div 2;

{Вычисляем горизонтальную позицию}

wXPos:= Offset;

case alignment of

taRightJustify: wXPos:= Width – Canvas.TextWidth(Caption) – Offset;

taCenter: wXPos := (Width – Canvas.TextWidth(Caption)) div 2;

end;

Canvas.Brush:= Parent.Brush;

Canvas.TextOut(wXPos,wYPos,Caption);

end;

procedure TIDSLabel.SetAlignment;

begin

FAlignment:= taIn;

Invalidate;

end;

procedure TIDSLabel.SetCaption;

begin

FCaption:= strIn;

if Assigned(FOnChange) then FOnChange(Self);

Invalidate;

end;

procedure TIDSLabel.SetFont;

begin

FFont.Assign(fntNew);

Invalidate;

end;

procedure TIDSLabel.SetOffset;

begin

FOffset:= bOffNew;

Invalidate;

end;

end.

ScrollBox

Синхронизация двух компонентов Scrollbox

Решить задачу помогут обработчики событий OnScroll (в данном примере два компонента ScrollBox (ScrollBar1 и ScrollBar2) расположены на форме TMainForm):

procedure TMainForm.ScrollBar1Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);

begin

ScrollBar2.Position:= ScrollPos;

end;

procedure TMainForm.ScrollBar1Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);

begin

ScrollBar1.Position:= ScrollPos;

end;

Splitter

Конструирование Splitter

У меня есть форма с расположенными на ней компонентами TreeView и Memo. Значение свойства align обоих компонентов позволяет им занимать всю форму. Я хотел бы расположить между ними движок типа Splitter, пропорционально меняющий их размеры (один шире, другой меньше и наоборот), но к сожалению я обладаю лишь дистрибутивом Delphi2 (Splitter вошел в палитру только в Delphi3). Какой компонент мог бы сымитировать поведение Splitter и как это реализовать?

Предположим, Ваш TreeView расположен в левой, а Memo в правой части формы. Вам нужно сделать следующее:

• Установите свойство Align компонента TreeView на alLeft.

• Вырежьте (Ctrl-X) компонент TMemo из вашей формы.

• Добавьте компонент Panel и присвойте его свойству Align значение alClient.

• Внутри панели разместите другой компонент Panel.

• Установите его ширину, равной 8 пикселам, свойству Align присвойте значение alLeft.

• Скопируйте вырезанный компонент TMemo в панель Panel1 и присвойте свойству Align значение alClient.

Panel2 – движок: теперь вам необходимо добавить процедуры, приведенные ниже. Ваш код будет выглядеть приблизительно так:

type TForm1 = class(tform)

TreeView1: TTreeview;

Panel1: TPanel;

Panel2: TPanel;

Memo1: TMemo;

procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

procedure Panel1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

private

Resizing: Boolean;

public

…

end;

procedure TForm1.Panel2MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

Resizing:=true;

end;

procedure TForm1.Panel2MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

Resizing:= false;

end;

procedure TForm1.Panel2MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

begin

if Resizing then begin

TreeView1.Width:=TreeView1.Width+X;

// Предохранение от странных ошибок перерисовки при изменении размеров:

Panel1.Invalidate;

end;

Код может быть модифицирован для получения горизонтального движка – идея, надеюсь, понятна…

StatusBar

Обработчик события OwnerDraw в компоненте StatusBar

Обработчик должен выглядеть примерно так:

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect);

begin

with statusbar1.Canvas do begin

Brush.Color:= clRed;

FillRect(Rect);

TextOut(Rect.Left, Rect.Top, 'Панель '+IntToStr(Panel.Index));

end;

StringGrid

Установка атрибутов –=Только для чтения=– у столбцов компонента StringGrid

Манипулирование вышеуказанным атрибутом возможно в обработчике события OnSelectCell:

if Col mod 2 = 0 then grd.Options:= grd.Options + [goEditing]

else grd.Options:= grd.Options – [goEditing];

Помещение изображения в ячейку StringGrid

Возможно ли поместить изображение в одну из ячеек компонента StringGrid?

Такое позволяет обработчик события OnDrawCell. Приводим скелет кода, демонстрирующий принцип вывода изображения в ячейке компонента:

with StringGrid1.Canvas do begin

{…}

Draw(Rect.Left, Rect.Top, Image1.Picture.Graphic);

{…}

end;

Достичь цели позволяют методы Draw() и StretchDraw() объекта TCanvas. В приведенном примере переменная Image1 класса TImage содержит заранее загруженное изображение.

Сохранение и чтение Tstringgrid

Как мне сохранить целый Stringgrid со всеми ячейками в файле?

Procedure SaveGrid;

var f:textfile;

x,y: integer;

begin

assignfile(f,'Filename');

rewrite(f);

writeln(f,stringgrid.colcount);

writeln(f,stringgrid.rowcount);

For x:= 0 to stringgrid.colcount-1 do For y:= 0 to stringgrid.rowcount-1 do writeln(F, stringgrid.cells[x,y]);

closefile(f);

end;

Procedure LoadGrid;

var f:textfile;

temp,x,y:integer;

tempstr:string;

begin

assignfile(f,'Filename');

reset(f);

readln(f,temp);

stringgrid.colcount:= temp;

readln(f,temp);

stringgrid.rowcount:= temp;

For x:=0 to stringgrid.colcount-1 do For y:=0 to stringgrid.rowcount-1 do begin

readln(F, tempstr);

stringgrid.cells[x,y]:= tempstr;

end;

closefile(f);

end;

TabbedNotebook

Добавление элементов управления в TTabbedNotebook и TNotebook

Я несколько раз видел в конференциях вопросы типа "как мне добавить элементы управления в TTabbedNotebook или TNotebook во время выполнения программы?". Теперь, когда у меня выдалось несколько свободных минут, я попытаюсь осветить этот вопрос как можно подробнее:

TTabbedNotebook

Добавление элементов управления в TTabbedNotebook во время проектирования – красивая и простая задача. Все, что Вам нужно – это установить свойство PageIndex или ActivePage на необходимую страницу и начать заполнять ее элементами управления.

Добавление элементов управление во время выполнения приложения также очень просто. Тем не менее, в прилагаемой документации по Delphi вы не найдете рецептов типа Что-и-Как. Видимо для того, чтобы окончательно запутать начинающих программистов, фирма-изготовитель даже не удосужилась включить исходный код TTabbedNotebook в VCL-библиотеку. Таким образом, TTabbedNotebook остается для некоторых тайной за семью печатями. К счастью, я имею некоторый опыт, коим и хочу поделиться.

Первым шагом к раскрытию тайны послужит просмотр файла \DELPHI\DOC\TABNOTBK.INT, интерфейсной секции модуля TABNOTBK.PAS, в котором определен класс TTabbedNotebook. Беглый просмотр позволяет обнаружить класс TTabPage, описанный как хранилище элементов управления отдельной страницы TTabbedNotebook.

Вторым шагом в исследовании TTabbedNotebook может стать факт наличия свойством Pages типа TStrings. В связи с этим отметим, что Delphi-классы TStrings и TStringList соорганизуются с двумя свойствами: Strings и Objects. Другими словами, для каждой строки в TStrings есть указатель на соответствующий Objects. Во многих случаях этот дополнительный указатель игнорируется, нам же он очень пригодится.

После небольшого эксперимента выясняем, что свойство Objects указывает на нашу копию TTabPage и ссылается на имя страницы в свойстве Strings. Блестяще! Всегда полезно знать что ищешь. Теперь посмотрим что мы можем сделать:

{ Данная процедура добавляет кнопку в случайной позиции на }

{ текущей странице данного TTabbedNotebook. }

procedure AddButton(tabNotebook : TTabbedNotebook);

var

tabpage: TTabPage;

button: TButton;

begin

with tabNotebook do tabpage:= TTabPage(Pages.Objects[PageIndex]);

button:= TButton.Create(tabpage);

try

with button do begin

Parent:= tabpage;

Left:= Random(tabpage.ClientWidth – Width);

Top:= Random(tabpage.ClientHeight – Height);

end;

except

button.Free;

end;

TNotebook

Операция по заполнению элементами управления компонента TNotebook почти такая же, как и в TTabbedNotebook – разница лишь в типе класса – TPage вместо TTabPage. Тем не менее, если вы заглянете в DELPHI\DOC\EXTCTRLS.INT, декларацию класса TPage вы там не найдете. По неизвестной причине Borland не включил определение TPage и в DOC-файлы, поставляемые с Delphi. Декларация TPage в EXTCTRLS.PAS (можно найти в библиотеке VCL-исходников), правда, расположена в интерфейсной части модуля. Мы восполним пропущенную информацию о классе TPage:

TPage = class(TCustomControl)

private

procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;

protected

procedure ReadState(Reader: TReader); override;

procedure Paint; override;

public

constructor Create(AOwner: TComponent); override;

published

property Caption;

property Height stored False;

property TabOrder stored False;

property Visible stored False;

property Width stored False;

end;

Теперь, по аналогии с вышеприведенной процедурой, попробуем добавить кнопку на TNotebook. Все, что мы должны сделать – заменить "TTabbedNotebook" на "TNotebook" и "TTabPage" на "TPage". Вот что должно получиться:

{ Данная процедура добавляет кнопку в случайной позиции на }

{ текущей странице данного TNotebook. }

procedure AddButton(Notebook1: TNotebook);

var

page: TPage;

button: TButton;

begin

with Notebook1 do page:= TPage(Pages.Objects[PageIndex]);

button:= TButton.Create(page);

try

with button do begin

Parent:= page;

Left:= Random(page.ClientWidth – Width);

Top:= Random(page.ClientHeight – Height);

end;

except

button.Free;

end;

Остальное не менее просто!

Недоступная закладка в компоненте Tabbednotebook

Есть ли возможность в компоненте Tabbednotebook сделать какую-либо страницу недоступной? То есть не позволять пользователю щелкать на ней и видеть ее содержимое?

Да, такая возможность существует. Самый простой путь – удалить страницу, например так:

with TabbedNotebook do Pages.Delete(PageIndex);

и снова включить ее (при необходимости), перегрузив форму.

Блокировка (а не удаление) немного мудренее, поскольку необходима организация цикла в процедуре создания формы, присваивающая имена закладкам компонента TabbedNotebook. Например так:

J:= 0;

with TabbedNotebook do for I:= 0 to ComponentCount - 1 do if Components[I].ClassName = 'TTabButton' then begin

Components[I].Name:= ValidIdentifier(TTabbedNotebook(Components[I].Owner).Pages[J]) + 'Tab';

Inc(J);

end;

где ValidIdentifier ValidIdentifier – функция, которая возвращает правильный Pascal-идентификатор, производный от строки 'Tab':

function ValidIdentifier(theString: str63): str63;

{--------------------------------------------------------}

{ Конвертирует строку в правильный Pascal-идентификатор, }

{ удаляя все неправильные символы и добавляя символ '_', }

{ если первый символ – цифра }

{--------------------------------------------------------}

var

I, Len: Integer;

begin

Len:= Length(theString);

for I:= Len downto 1 do if not (theString[I] in LettersUnderscoreAndDigits) then Delete(theString, I, 1);

if not (theString[1] in LettersAndUnderscore) then theString:= '_' + theString;

ValidIdentifier:= theString;

end; {ValidIdentifier}

Затем мы можем сделать закладку компонента TabbedNotebook недоступной:

with TabbedNotebook do begin

TabIdent:= ValidIdentifier(Pages[PageIndex]) + 'Tab';

TControl(FindComponent(TabIdent)).Enabled:= False;

{ Переключаемся на первую доступную страницу: }

for I:= 0 to Pages.Count – 1 do begin

TabIdent:= ValidIdentifier(Pages[I]) + 'Tab';

if TControl(FindComponent(TabIdent)).Enabled then begin

PageIndex:= I;

Exit;

end;

end; {for}

end; {with TabbedNotebook}

следующий код восстанавливает доступность страницы:

with TabbedNotebook do for I:= 0 to Pages.Count - 1 do begin

TabIdent:= ValidIdentifier(Pages[I]) + 'Tab';

if not TControl(FindComponent(TabIdent)).Enabled:= True;

end; {for}

Table

Создание компонента TTable без формы

Решение 1

Действительно, любой компонент можно создать и без (вне) формы или любого другого дочернего компонента. Для этого я использую параметр nil:

FSession:= TSession.Create(nil);

FDatabase:= TDatabase.Create(nil);

FSession.SessionName:= 'DBSession'

FDatabase.Connected:= False;

FDatabase.AliasName:= Database;

FDatabase.DatabaseName:= USER_DATABASE;

FDatabase.SessionName:= FSession.SessionName;

FUserTBL:= TTable.Create(nil);

FUserTBL.DatabaseName:= FDatabase.DatabaseName;

FUserTBL.SessionName:= FSession.SessionName;

FUserTBL.TableName:= USERTBL;

FUserTBL.IndexName:= USERSpIndex;

FUserSource:= TDataSource.Create(nil);

FUserSource.DataSet:= FUserTBL;

Решение 2

Я привожу некоторый код, касающийся описываемой проблемы: он работал, когда я использовал его в большом приложении. Я не знаю специфического метода создания компонента TTable вне родителей, поэтому я пошел путем создания своего класса от TTable во время инициализации модуля. Удобство такого подхода объясняется наличием под рукой всегда готового к работе экземпляра класса, стоит всего-лишь добавить модуль к вашему приложению. Конечно, новый класс не должен иметь одиноко выглядящую процедуру со странной технологией фильтрации данных :=))), да и не помешала бы публикация нескольких событий, но этот пример призван все-го лишь продемонстрировать иной подход к решаемой задаче.

unit Unit2;

interface

uses db, DBTables, dialogs;

type fake = class(Ttable)

procedure fakeFilterRecord(DataSet: TDataSet; var Accept: Boolean);

end;

var

MyTable: fake;

implementation

procedure fake.fakeFilterRecord(DataSet: TDataSet; var Accept: Boolean);

begin

showmessage('Здравствуй, Вася');

end;

Initialization

MyTable:= fake.create(nil);

With Mytable do begin

DataBaseName:= 'dbdemos';

TableName:= 'biolife';

OnFilterRecord:= MyTable.fakeFilterRecord;

Filtered:= true;

active:= true;

end;

{проверка получением неких данных…}

showmessage(MyTable.fields[1].asstring);

Finalization

{Важно! MyTable не имеет родителя, – уничтожаем объект сами, иначе память не высвобождается…}

MyTable.free;

end.

TreeView

Ускорение работы TreeView

Представляем вашему вниманию немного переработанный компонент TreeView, работающий быстрее своего собрата из стандартной поставки Delphi. Кроме того, была добавлена возможность вывода текста узлов и пунктов в жирном начертании (были использованы методы TreeView, хотя, по идее, необходимы были свойства TreeNode. Мне показалось, что это будет удобнее).

Для сравнения:

TreeView:

128 сек. для загрузки 1000 элементов (без сортировки)*

270 сек. для сохранения 1000 элементов (4.5 минуты!!!)

HETreeView:

1.5 сек. для загрузки 1000 элементов – ускорение около 850%!!! (2.3 секунды без сортировки = stText)*

0.7 сек. для сохранения 1000 элементов – ускорение около 3850%!!!

Примечание:

• Все операции выполнялись на медленной машине 486SX 33 Mгц, 20 Mб RAM.

• Если TreeView пуст, загрузка происходит за 1.5 секунды, плюс 1.5 секунды на стирание 1000 элементов (общее время загрузки составило 3 секунды). В этих условиях стандартный компонент TTreeView показал общее время 129.5 секунд. Очистка компонента осуществлялась вызовом функции SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).

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

unit HETreeView;

{$R-}

// Описание: Реактивный TreeView

TREEVIEW:

128 сек. для загрузки 1000 элементов (без сортировки)*

270 сек. для сохранения 1000 элементов (4.5 минуты!!!)

HETREEVIEW:

1.5 сек. для загрузки 1000 элементов – ускорение около 850%!!! (2.3 секунды без сортировки = stText)*

0.7 сек. для сохранения 1000 элементов – ускорение около 3850%!!!

NOTES:

– Все операции выполнялись на медленной машине 486SX 33 Mгц, 20 Mб RAM.

– * Если TTreeView пуст, загрузка происходит за 1.5 секунды,

плюс 1.5 секунды на стирание 1000 элементов (общее время загрузки составило 3 секунды).

В этих условиях стандартный компонент TreeView показал общее время 129.5 секунд.

Очистка компонента осуществлялась вызовом функции

SendMessage(hwnd, TVM_DELETEITEM, 0, Longint(TVI_ROOT)).

interface

uses SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, CommCtrl, tree2vw;

type THETreeView = class(TTreeView)

private

FSortType: TSortType;

procedure SetSortType(Value: TSortType);

protected

function GetItemText(ANode: TTreeNode): string;

public

constructor Create(AOwner: TComponent); override;

function AlphaSort: Boolean;

function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;

procedure LoadFromFile(const AFileName: string);

procedure SaveToFile(const AFileName: string);

procedure GetItemList(AList: TStrings);

procedure SetItemList(AList: TStrings);

//Жирное начертание шрифта 'Bold' должно быть свойством TTreeNode, но...

function IsItemBold(ANode: TTreeNode): Boolean;

procedure SetItemBold(ANode: TTreeNode; Value: Boolean);

published

property SortType: TSortType read FSortType write SetSortType default stNone;

end;

procedure Register;

implementation

function DefaultTreeViewSort(Node1, Node2: TTreeNode; lParam: Integer): Integer; stdcall;

begin

{with Node1 do

if Assigned(TreeView.OnCompare) then

TreeView.OnCompare(Node1.TreeView, Node1, Node2, lParam, Result)

else}

Result:= lstrcmp(PChar(Node1.Text), PChar(Node2.Text));

end;

constructor THETreeView.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FSortType:= stNone;

end;

procedure THETreeView.SetItemBold(ANode: TTreeNode; Value: Boolean);

var

Item: TTVItem; Template: Integer;

begin

if ANode = nil then Exit;

if Value then Template:= -1 else Template:= 0;

with Item do begin

mask:= TVIF_STATE;

hItem:= ANode.ItemId;

stateMask:= TVIS_BOLD;

state:= stateMask and template;

end;

TreeView_SetItem(Handle, Item);

end;

function THETreeView.IsItemBold(ANode: TTreeNode): Boolean;

var

Item: TTVItem;

begin

Result:= False;

if ANode = nil then Exit;

with Item do begin

mask:= TVIF_STATE;

hItem:= ANode.ItemId;

if TreeView_GetItem(Handle, Item) then Result:= (state and TVIS_BOLD) <> 0;

end;

procedure THETreeView.SetSortType(Value: TSortType);

begin

if SortType <> Value then begin

FSortType:= Value;

if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or (SortType in [stText, stBoth]) then AlphaSort;

end;

procedure THETreeView.LoadFromFile(const AFileName: string);

var

AList: TStringList;

begin

AList:= TStringList.Create;

Items.BeginUpdate;

try

AList.LoadFromFile(AFileName);

SetItemList(AList);

finally

Items.EndUpdate;

AList.Free;

end;

procedure THETreeView.SaveToFile(const AFileName: string);

var

AList: TStringList;

begin

AList:= TStringList.Create;

try

GetItemList(AList);

AList.SaveToFile(AFileName);

finally

AList.Free;

end;

procedure THETreeView.SetItemList(AList: TStrings);

var

ALevel, AOldLevel, i, Cnt: Integer;

S: string;

ANewStr: string;

AParentNode: TTreeNode;

TmpSort: TSortType;

function GetBufStart(Buffer: PChar; var ALevel: Integer): PChar;

begin

ALevel:= 0;

while Buffer^ in [' ', #9] do begin

Inc(Buffer);

Inc(ALevel);

end;

Result:= Buffer;

end;

begin

//Удаление всех элементов – в обычной ситуации подошло бы Items.Clear, но уж очень медленно

SendMessage(handle, TVM_DELETEITEM, 0, Longint(TVI_ROOT));

AOldLevel:= 0;

AParentNode:= nil;

//Снятие флага сортировки

TmpSort:= SortType;

SortType:= stNone;

try

for Cnt := 0 to AList.Count-1 do begin

S:= AList[Cnt];

if (length(s) = 1) and (s[1] = chr($1a)) then break;

ANewStr:= GetBufStart(PChar(S), ALevel);

if (ALevel > AOldLevel) or (AParentNode = nil) then begin

if ALevel - AOldLevel > 1 then raise Exception.Create('Неверный уровень TreeNode');

end else begin

for i:= AOldLevel downto ALevel do begin

AParentNode:= AParentNode.Parent;

if (AParentNode = nil) and (i - ALevel > 0) then raise Exception.Create('Неверный уровень TreeNode');

end;

AParentNode:= Items.AddChild(AParentNode, ANewStr);

AOldLevel:= ALevel;

end;

finally

//Возвращаем исходный флаг сортировки…

SortType:= TmpSort;

end;

procedure THETreeView.GetItemList(AList: TStrings);

var

i, Cnt: integer;

ANode: TTreeNode;

begin

AList.Clear;

Cnt:= Items.Count -1;

ANode:= Items.GetFirstNode;

for i:= 0 to Cnt do begin

AList.Add(GetItemText(ANode));

ANode:= ANode.GetNext;

end;

function THETreeView.GetItemText(ANode: TTreeNode): string;

begin

Result:= StringOfChar(' ', ANode.Level) + ANode.Text;

end;

function THETreeView.AlphaSort: Boolean;

var

I: Integer;

begin

if HandleAllocated then begin

Result:= CustomSort(nil, 0);

end else Result:= False;

end;

function eView.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;

var

SortCB: TTVSortCB;

I: Integer;

Node: TTreeNode;

begin

Result:= False;

if HandleAllocated then begin

with SortCB do begin

if not Assigned(SortProc) then lpfnCompare:= @DefaultTreeViewSort

else lpfnCompare:= SortProc;

hParent:= TVI_ROOT;

lParam:= Data;

Result:= TreeView_SortChildrenCB(Handle, SortCB, 0);

end;

if Items.Count > 0 then begin

Node:= Items.GetFirstNode;

while Node <> nil do begin

if Node.HasChildren then Node.CustomSort(SortProc, Data);

Node:= Node.GetNext;

end;

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

procedure Register;

begin

RegisterComponents('Win95', [THETreeView]);

end;

end.

Разное

Создание компонента во время работы приложения

Var

MyButton: TButton;

MyButton:= TButton.Create(MyForm); // MyForm теперь "обладает" MyButton

with MyButton do BEGIN

Parent:= MyForm; // Выбираем родителей. MyForm "усыновляет" MyButton

height:= 32;

width:= 128;

caption:= 'Я здесь!';

left := (MyForm.ClientWidth – width) div 2;

top := (MyForm.ClientHeight – height) div 2;

END;

Inprise также рассказывала об этом в выпусках TechInfo.

Поищите

ti2938.asc Creating Dynamic Components at Runtime

на публичном WWW или FTP сайте компании Inprise.

Получение индекса компонента в списке родителя

Мне необходимо найти индекс компонента в родительском списке дочерних элементов управления. Я попытался модифицировать prjexp.dll, но без успеха. У кого-нибудь есть идеи?

Есть такая функция. Ищет родителя заданного компонента, перебирает список и возвращает индекс искомого компонента. Функция прошла многочисленные тесты и вполне работоспособна.

{ функция, возвращающая индекс искомого компонента в

списке родителя; возвращает –1 при отсутствии компонента }

function IndexInParent(vControl: TControl): integer;

var

ParentControl: TWinControl;

begin

{делаем "слепок" родителя через базовый класс на предмет доступности }

ParentControl:= TForm(vControl.Parent);

if (ParentControl <> nil) then begin

for Result:= 0 to ParentControl.ControlCount - 1 do begin

if (ParentControl.Controls[Result] = vControl) then exit;

end;

{ если мы уж попали в это место, то либо не найден компонент, либо компонент не имел родителя }

Result:= –1;

end;

Массив компонентов…

Возможно ли создание массива компонентов? Для показа статуса я использую набор LED-компонентов и хотел бы иметь к ним доступ, используя массив.

Прежде всего необходимо объявить массив:

LED: array[1..10] of TLed; (10 элементов компонентного типа TLed)

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

for counter:= 1 to 10 do begin

LED[counter]:= TLED.Create;

LED[counter].top:= …

LED[counter].Left:= …

LED[counter].Parent:= Mainform; {что-то типа этого}

end;

Если компоненты уже присутствуют на форме (в режиме проектирования), сделайте их элементами массива, например так:

leds:= 0;

for counter:= 0 to Form.Componentcount do begin

if (components[counter] is TLED) then begin

inc(leds);

LED[leds]:= TLED(components[counter]);

end

end;

Тем не менее у нас получился массив со случайным расположением LED-компонентов. Я предлагаю назначить свойству Tag каждого LED-компонента порядковый номер его расположения в массиве, а затем заполнить массив, используя это свойство:

for counter := 0 to Form.Componentcount do begin

if (components[counter] is TLED) then begin

LED[Component[counter].tag]:= TLED(components[counter]);

end

end;

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

Дублирование компонентов и их потомков во время выполнения приложения

Приведенный ниже код содержит функцию DuplicateComponents, позволяющую проводить клонирование любых компонентов и их потомков во время выполнения приложения. Действия ее напоминают операцию копирования/вставки (copy/paste) во время разработки приложения. Новые компоненты при создании получают тех же родителей, владельцев (в случае применения контейнеров) и имена (естественно, несколько отличающихся), что и оригиналы. В данной функции есть вероятность багов, но я пока их не обнаружил. Ошибки и недочеты могут возникнуть из-за редко применяемых специфических методов, которые, вместе с тем, могут помочь программистам, столкнувшимися с аналогичными проблемами.

Данная функция может оказаться весьма полезной в случае наличия нескольких одинаковых областей на форме с необходимостью синхронизации изменений в течение некоторого промежутка времени. Процедура создания дубликата проста до безобразия: разместите на TPanel или на другом родительском компоненте необходимые элементы управления и сделайте: "newpanel := DuplicateComponents(designedpanel)".

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

type TUniqueReader = Class(TReader)

LastRead: TComponent;

procedure ComponentRead(Component: TComponent);

procedure SetNameUnique(Reader: TReader; Component: TComponent; var Name: string);

end;

implementation

procedure TUniqueReader.ComponentRead(Component: TComponent);

begin

LastRead:= Component;

end;

procedure TUniqueReader.SetNameUnique( // Задаем уникальное имя считываемому компоненту, например, "Panel2", если "Panel1" уже существует

Reader: TReader; Component: TComponent; // Считываемый компонент

var Name: string // Имя компонента для дальнейшей модификации

);

var

i: Integer;

tempname: string;

begin

i:= 0;

tempname:= Name;

while Component.Owner.FindComponent(Name) <> nil do begin

Inc(i);

Name:= Format('%s%d', [tempname, i]);

end;

function DuplicateComponents(

AComponent: TComponent // исходный компонент

): TComponent; // возвращаемся к созданию нового компонента

procedure RegisterComponentClasses(AComponent: TComponent);

var i : integer;

begin

RegisterClass(TPersistentClass(AComponent.ClassType));

if AComponent is TWinControl then

if TWinControl(AComponent).ControlCount > 0 then

for i:= 0 to (TWinControl(AComponent).ControlCount-1) do RegisterComponentClasses(TWinControl(AComponent).Controls[i]);

end;

var

Stream: TMemoryStream;

UniqueReader: TUniqueReader;

Writer: TWriter;

begin

result:= nil;

UniqueReader:= nil;

Writer:= nil;

try

Stream:= TMemoryStream.Create;

RegisterComponentClasses(AComponent);

try

Write:= TWriter.Create(Stream, 4096);

Writer.Root:= AComponent.Owner;

Writer.WriteSignature;

Writer.WriteComponent(AComponent);

Writer.WriteListEnd;

finally

Writer.Free;

end;

Stream.Position:= 0;

try

UniqueReader:= TUniqueReader.Create(Stream, 4096); // создаем поток, перемещающий данные о компоненте в конструктор

UniqueReader.OnSetName:= UniqueReader.SetNameUnique;

UniqueReader.LastRead:= nil;

if AComponent is TWinControl then UniqueReader.ReadComponents( // считываем компоненты и суб-компоненты

TWinControl(AComponent).Owner, TWinControl(AComponent).Parent, UniqueReader.ComponentRead

)

else UniqueReader.ReadComponents( // читаем компоненты

AComponent.Owner, nil, UniqueReader.ComponentRead

);

result:= UniqueReader.LastRead;

finally

UniqueReader.Free;

end;

finally

Stream.Free;

end;

События

Создание

Создание события во время выполнения приложения

на примере переопределения события в Memo:

memo.onchange:= memo1Change;

procedure TForm1.Memo1Change(Sender: TObject);

begin

panel1.caption:= 'Содержимое было изменено';

end;

Задержка выполнения

Задержка выполнения OnChange (Delphi 2)

В случае нажатия пользователем клавиши или изменении текущего элемента компонента ComboBox, вы обратите внимание на досадную задержку, возникающую при генерации события OnChange.

Так как "работа кипит", я хотел бы отреагировать на изменение ItemIndex несколько позднее, например, 100 миллисекунд спустя. Вот что у меня получилось. Созданный в Delphi2, код подходит также и для Delphi 1. На простой форме располагаем компоненты ComboBox и Label. Необходимым дополнением является вызов Application.ProcessMessages, позволяющий избежать замедления работы PC, когда очередь сообщений для формы пуста.

unit Unit1;

interface

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

const

// Просто некоторая константа сообщения

PM_COMBOCHANGE = WM_USER + 8001;

// 500 миллисекунд

CWantedDelay = 500;

type TForm1 = class(TForm)

ComboBox1: TComboBox;

Label1: TLabel;

procedure ComboBox1Change(Sender: TObject);

private

procedure PMComboChange(var message : TMessage); message PM_COMBOCHANGE;

public

end;

var Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ComboBox1Change(Sender: TObject);

begin

PostMessage(Handle, PM_COMBOCHANGE, 0, 0);

end;

procedure TForm1.PMComboChange(var message : TMessage);

const

InProc: BOOLEAN = FALSE;

StartTick: LONGINT = 0;

begin

if InProc then begin

// Обновляем стартовое время задержки

StartTick:= GetTickCount;

end else begin

// Организация цикла

InProc:= TRUE;

// Инициализация стартового времени

StartTick:= GetTickCount;

// Ожидаем истечения стартового времени.

// Пока стартовое время не исчерпалось, позволяем операционной системе обрабатывать сообщения

while GetTickCount - StartTick < CWantedDelay do Application.ProcessMessages;

// Иллюстративное приращение счетчика, задающее некоторую реальную работу обработчику события OnChange

Label1.Caption:= IntToStr(StrToIntDef(Label1.Caption, 0) + 1);

// Завершение цикла

InProc:= FALSE;

end;

end.

Миграция

Delphi3

Получение констант с определением ошибки функцией LoadStr

Возбуждение исключения и передача строковой константы ошибки из CONSTS.PAS (как это делалось в Delphi 1 и Delphi 2) в Delphi3 невозможна. Например:

raise SomeException.Create(LoadStr(SInsertLineError));

в Delphi3 теперь не работает. Я предлагаю использовать выражение

raise SomeException.Create({$IFNDEF VER100}LoadStr{$ENDIF}(SInsertLineError));

для вызова функции LoadStr "по нужде", устаревшей почему-то для этих целей в Delphi 3.

При попытке вызвать данную функцию в Delphi 3 (для получения типа ошибки, декларированной в модуле CONSTS(.PAS/.DCU)), мы получаем следующую ошибку компилятора: "Incompatible types: 'Integer' and 'String'"

Никакой информации по этому поводу я не нашел ни в фирменной документации, ни на Borland-сервере.

Ошибки

Delphi2

Ошибка в руководстве "Getting Started" на странице 42

Я только что установил Delphi 2.0, все прошло успешно и без единой ошибки, в процессе инсталляции коментарии и замечания не возникали.

Далее в Delphi 2.0 я открываю руководство "Getting Started" (Подготовка). Согласно странице 42, "Adding a display grid" (добавление и отображение сетки данных), добавляю на форму DBGrid, устанавливаю DataSource в GDSDataModule.CustomerSource, но данные в DBGrid не отображаются, хотя на странице 42 написано "Immediately, the data is displayed in the DBGrid" (данные немедленно будут отображены в DBGrid).

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

При вызове из меню Delphi "Database Explorer" все таблицы и их данные видятся без проблем.

Таблицу необходимо открыть. Установите свойство Active компонента Тable в True.

Комментарии к книге «Советы по Delphi. Версия 1.0.6», Валентин Озеров

Всего 0 комментариев

Комментариев к этой книге пока нет, будьте первым!

Войти

Аа

Аа

Аа

Аа

Валентин Озеров

«Советы по Delphi. Версия 1.0.6»

Аа

Аа

Аа

Аа

Обзор

Введение

Что такое "Советы по Delphi"?

Предупреждение

Объявление

Лицензионное соглашение

Предоставление лицензии

Особые условия

Распространение

Помните

Рассылка

Цены

Ссылки

Разработчик Delphi

Русскоязычные

Англоязычные

Сайты, посвященные Delphi

Англоязычные

Пиратские сайты

Русскоязычные

Другие

Домашние страницы

Русскоязычные

Алгоритмы

Преобразования

HEX→Integer

Решение 1

Решение 2

Преобразование десятичного числа в шестнадцатиричное

Преобразование ASCII в шестнадцатиричное представление

Преобразование двоичного числа в десятичное

Решение 1

Решение 2

Решение 3

Преобразование ICO в BMP

Решение 1

Решение 2

Unix-строки (чтение и запись Unix-файлов)

Преобразование BMP в JPEG в Delphi 3

Декомпиляция звукового файла формата Wave и получение звуковых данных

Даты

Вычисление даты Пасхи

Дни недели

Формат даты

Функция DateSer

Разное

Ханойская башня

Алгоритм (уравнение) для определения восхода/захода солнца и луны (BASIC)

Автоматический формат даты в компоненте Edit

Win API

Переменные среды

Получение переменных DOS

Изменение системного времени из Delphi

Завершение работы Windows

События, происходящие в приложениях Delphi при завершении работы Windows

Пример:

Завершение работы Windows

Режим энергосбережения (Power saver)

Управление монитором

Разное

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

Решение 1

Решение 2

Решение 3

Каким образом, программным путем, можно узнать о завершении запущенной программы?

16-битная версия:

32-битная версия:

Получение имени модуля

Извлечение из EXE-файла иконки и рисование ее в TImage.