Класс для реализации списка Variant'ов на основе TCollection

Класс реализует коллекцию элементов типа Variant, которые могут интерпретироваться как Integer, String или Currency.
Динамический список этих элементов может быть именованным, где каждому элементу присваивается имя. Это условие по умолчанию не обрабатывается, так что с этим классом можно работать просто как с динамическим списком величин типа Variant.
Довольно удобно.
Можно искать в списке по значению (IndexOF), по имени (GetValueFromName), удалять из списка.
Функция JoinList возвращает строку из символьного представления всех элементов списка разделенных заданным сепаратором.

Скачать файл (2K)

unit ListUtils; interface Uses Classes , SysUtils; Type TListsItem = class(TCollectionItem) Private FValue : Variant; FName : String; Protected Function GetAsInteger : LongInt; Procedure SetAsInteger(AValue : LongInt ); Function GetAsString : String; Procedure SetAsString(AValue : String ); Function GetAsCurrency : Currency; Procedure SetAsCurrency(AValue : Currency ); Public procedure AssignTo( Dest: TPersistent ); override; property Value : Variant read FValue write FValue; property Name : String read FName write FName; property AsInteger : LongInt read GetAsInteger write SetAsInteger; property AsString : String read GetAsString write SetAsString; property AsCurrency : Currency read GetAsCurrency write SetAsCurrency; End; TCollectionListItemClass = class (TListsItem); TLists = class (TCollection) private function GetListItem(Index : Integer) : TListsItem; Public Constructor Create(ItemClass: TCollectionItemClass); Function AddItem( Value : Variant; AName : String ='' ) : TListsItem; Procedure FillFromArray(ArValue : array of Variant); Procedure FillFromNamedArray(ArValue , ArName : array of Variant ); Function IndexOf( Value : Variant ) : Integer; Function JoinList( Separator : String = ',') : String; Function GetFromName(AName : String ) : TListsItem; Function GetValueFromName(AName : String; DefaultValue : Variant ) : Variant; Procedure DeleteFromValue( Value : Variant; All : Boolean = FALSE); Procedure DeleteFromName(AName : String ); Property AnItems[Index : Integer] : TListsItem read GetListItem; default; End; implementation //---------------------------------------------------------------------------------------- // TLists //---------------------------------------------------------------------------------------- Constructor TLists.Create(ItemClass: TCollectionItemClass); Begin Inherited Create(ItemClass); End; //---------------------------------------------------------------------------------------- function TLists.GetListItem(Index : Integer) : TListsItem; Begin Result:=TListsItem(Items[Index]); End; //---------------------------------------------------------------------------------------- function TLists.AddItem(Value : Variant; AName : String = '') : TListsItem; Begin Result:=TListsItem(Self.Add); Result.FValue:=Value; Result.FName:=AName; End; //---------------------------------------------------------------------------------------- function TLists.IndexOf(Value : Variant): Integer; begin Result := 0; while (Result < Count) and ( AnItems[Result].Value <> Value) do Inc(Result); IF Result = Count then Result := -1; end; //---------------------------------------------------------------------------------------- Function TLists.JoinList( Separator : String = ',') : String; Var i : Integer; Begin Result:=''; IF Count > 0 Then Begin For i:=0 To Count-1 Do Result:= Result + AnItems[i].AsString + Separator; Result:=Copy(Result , 1 , Length(Result)-1 ); End; End; //---------------------------------------------------------------------------------------- Procedure TLists.DeleteFromValue( Value : Variant; All : Boolean = FALSE); Var i : Integer; Begin i:=IndexOf(Value); IF i >= 0 Then Delete(i); End; //---------------------------------------------------------------------------------------- Procedure TLists.DeleteFromName(AName : String ); Var i : Integer; AItem : TListsItem; Begin AItem:=GetFromName(AName); IF AItem <> nil Then Delete(AItem.Index); End; //---------------------------------------------------------------------------------------- Function TLists.GetFromName(AName : String ) : TListsItem; Var i : Integer; Begin Result:=nil; For i:=0 To Count-1 Do IF CompareText(AnItems[i].FName , AName) = 0 Then Begin Result:=AnItems[i]; Exit; End; End; //---------------------------------------------------------------------------------------- Function TLists.GetValueFromName(AName : String; DefaultValue : Variant ) : Variant; Begin Result:=DefaultValue; IF GetFromName(AName) <> nil Then Result:= GetFromName(AName).Value; End; //---------------------------------------------------------------------------------------- Procedure TLists.FillFromArray(ArValue : array of Variant); Var i : Integer; Begin Clear; For i:=Low(ArValue) TO High(ArValue) Do AddItem(ArValue[i]); End; //---------------------------------------------------------------------------------------- Procedure TLists.FillFromNamedArray(ArValue , ArName : array of Variant ); Var i , No : Integer; Begin FillFromArray(ArValue); No:=High(ArName); IF No > High(ArValue) Then No:=High(ArValue); For i:=Low(ArName) TO No Do AnItems[i].FName:=ArName[i] ; End; //---------------------------------------------------------------------------------------- //**************************************************************************************** //---------------------------------------------------------------------------------------- // TListItem //---------------------------------------------------------------------------------------- procedure TListsItem.AssignTo( Dest: TPersistent ); Begin IF Dest Is TListsItem Then Begin TListsItem(Dest).FValue:=FValue; TListsItem(Dest).FName:=FName; End Else inherited; End; //---------------------------------------------------------------------------------------- Function TListsItem.GetAsInteger : LongInt; Begin if TVarData(FValue).VType <> varNull then Result := TVarData(FValue).vInteger else Result := 0; End; //---------------------------------------------------------------------------------------- Procedure TListsItem.SetAsInteger(AValue : LongInt ); Begin FValue:=AValue; End; //---------------------------------------------------------------------------------------- Function TListsItem.GetAsString : String; Begin Result:=VarToStr(FValue); End; //---------------------------------------------------------------------------------------- Procedure TListsItem.SetAsString(AValue : String ); Begin FValue:=AValue; End; //---------------------------------------------------------------------------------------- Function TListsItem.GetAsCurrency : Currency; Begin if TVarData(FValue).VType <> varNull then Result := TVarData(FValue).vCurrency else Result := 0; End; //---------------------------------------------------------------------------------------- Procedure TListsItem.SetAsCurrency(AValue : Currency ); Begin FValue:=AValue; End; //---------------------------------------------------------------------------------------- end.

Класс TRySharedSream.

unit RySharedStream; interface uses SysUtils, Windows, Classes, RySharedMem; {$IFDEF VER120} {$DEFINE D5} {$ENDIF} {$IFDEF VER130} {$DEFINE D5} {$ENDIF} {$IFDEF VER140} {$DEFINE D6} {$ENDIF} type { TRyPageList } TRyPageList = class(TList) protected function Get(Index: Integer): TRySharedMem; procedure (Index: Integer; Item: TRySharedMem); public property Items[Index: Integer]: TRySharedMem read Get write Put; default; end; { TRySharedStream } TRySharedStream = class(TStream) { Для совместимости с TStream } private FSize : Longint; { Реальный размер записанных данных } FPosition : Longint; FPages : TRyPageList; protected function NewPage: TRySharedMem; public constructor Create; destructor Destroy; override; function Read(var Buffer; Count: Longint): Longint; override; function Write(const Buffer; Count: Longint): Longint; override; function Seek(Offset: Longint; Origin: Word): Longint; override; procedure (NewSize: Longint); override; procedure (Stream: TStream); procedure (const FileName: string); procedure (Stream: TStream); procedure (const FileName: string); public end; implementation uses RyActiveX; {resourcestring CouldNotMapViewOfFile = 'Could not map view of file.';} { TRySharedStream } { * Класс TRySharedStream можно рассматривать как альтернативу временным файлам (т.е. как замену TFileStream). Преимущество : а. Данные никто не сможет просмотреть. б. Страницы, зарезервированные под данные, автомотически освобождаются после уничтожения создавшего ее TRySharedStream'а. * Класс TRySharedStream можно рассматривать как альтернативу TMemoryStream. Преимущество : а. Не надо опасаться нехватки памяти при большом объеме записываемых данных. [случай когда физически нехватает места на диске здесь не рассматривается]. Известные проблемы: На данный момент таких не выявлено. Но есть одно НО. Я не знаю как поведет себя TRySharedStream в результате нехватки места а. на диске б. в файле подкачки (т.е. в системе с ограниченным размером файла подкачки). } const PageSize = 1024000; { размер страницы } constructor TRySharedStream.Create; begin FPosition := 0; { Позиция "курсора" } FSize := 0; { Размер данных } FPages := TRyPageList.Create; FPages.Add(NewPage); end; destructor TRySharedStream.Destroy; begin with FPages do while Count > 0 do begin Items[Count - 1].Free; Delete(Count-1); end; FPages.Free; inherited; end; function TRySharedStream.NewPage: TRySharedMem; begin Result := TRySharedMem.Create(RyActiveX.GUIDToString(RyActiveX.GetGUID), 0, PageSize) { |} {Я знаю что можно не именовать страницу __|} {но оказалось не всегда Win98 правильно создает новую} {неименнованную страницу. а другого способа получения} {уникальной строки я не знаю. } {если у кого-то будут идеи по этому поводу - милости просим.} end; function TRySharedStream.Read(var Buffer; Count: Longint): Longint; var FPos, BPos, FPageNo: Integer; ACount, FCount : Longint; Buf: PChar; begin Buf := @Buffer; ACount := 0; if Count > 0 then begin FCount := FSize - FPosition; {максимальное кол-во, которое можно прочитать} if FCount > 0 then begin if FCount > Count then FCount := Count; {если нам нужно прочитать меньше чем можем} ACount := FCount; {запоминаем сколько надо} FPageNo := FPosition div PageSize; {т.к. у нас многостраничный stream, то находим с какой страницы начать читать} BPos := 0; FPos := FPosition - (PageSize * FPageNo); {с какой позиции на странице читаем} while FCount > 0 do begin if FCount > (PageSize - FPos) then Count := PageSize - FPos else Count := FCount; {определяем сколько можно прочитать со страницы} Move(PChar(FPages.Items[FPageNo].Memory)[FPos], Buf[BPos], Count); {считаваем инфо. в буффер} Inc(FPageNo); {переходим на следующую страницу} Dec(FCount, Count); Inc(BPos, Count); FPos := 0; end; Inc(FPosition, ACount); end end; Result := ACount; end; function TRySharedStream.Write(const Buffer; Count: Longint): Longint; var FPos, BPos, FPageNo: Integer; ASize, ACount, FCount : Longint; Buf: PChar; begin { Функция аналогичная TStream.Write(). Все пояснения по работе с ней см. в help'e. } Buf := @Buffer; if Count > 0 then begin ASize := FPosition + Count; {определяем сколько места нужно для данных} if FSize < ASize then Size := ASize; {если больше чем было, то увеличиваем размер стрима} FCount := Count; {запоминаем сколько надо записать} FPageNo := FPosition div PageSize; {определяем с какой страницы начинаем писать} BPos := 0; FPos := FPosition - (PageSize * FPageNo); {вычисляем позицию на странице} while FCount > 0 do {пока все не напишем ни куда не уходим} begin if FCount > (PageSize - FPos) then ACount := PageSize - FPos else ACount := FCount; Move(Buf[BPos], PChar(FPages.Items[FPageNo].Memory)[FPos], ACount); {пишем сколько влезает до конца страницы} Inc(FPageNo); {переходим на следующую страницу} Dec(FCount, ACount); {уменьшаем кол-во незаписанных на кол-во записанных} Inc(BPos, ACount); FPos := 0; end; FPosition := ASize; end; Result := Count; end; function TRySharedStream.Seek(Offset: Longint; Origin: Word): Longint; begin { Функция аналогичная TStream.Seek(). Все пояснения по работе с ней см. в help'e. } case Origin of soFromBeginning : FPosition := Offset; soFromCurrent : Inc(FPosition, Offset); soFromEnd : FPosition := FSize - Offset; end; if FPosition > FSize then FPosition := FSize else if FPosition < 0 then FPosition := 0; Result := FPosition; end; procedure TRySharedStream.SetSize(NewSize: Longint); var Sz: Longint; begin { Функция аналогичная TStream.SetSize(). Все пояснения по работе с ней см. в help'e. } inherited SetSize(NewSize); if NewSize > (PageSize * FPages.Count) then { Если размер необходимый для записи данных больше размера выделенного под наш stream, то мы должны увеличить размер stream'a} begin { ...но FileMapping не поддерживает изменения размеров "страницы", что не очень удобно, поэтому приходится выкручиваться. } Sz := NewSize div (PageSize * FPages.Count); { думаем сколько нужно досоздать страниц под данные } while Sz > 0 do {создаем страницы} begin FPages.Add(NewPage); Dec(Sz); end; end; FSize := NewSize; { Запоминаем размер данных } if FPosition > FSize then FPosition := FSize; end; procedure TRySharedStream.LoadFromFile(const FileName: string); var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try LoadFromStream(Stream) finally Stream.Free end end; procedure TRySharedStream.LoadFromStream(Stream: TStream); begin CopyFrom(Stream, 0); end; procedure TRySharedStream.SaveToFile(const FileName: string); var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmCreate); try SaveToStream(Stream) finally Stream.Free end end; procedure TRySharedStream.SaveToStream(Stream: TStream); begin Stream.CopyFrom(Self, 0); end; { TRyPageList } function TRyPageList.Get(Index: Integer): TRySharedMem; begin Result := TRySharedMem(inherited Get(Index)) end; procedure TRyPageList.Put(Index: Integer; Item: TRySharedMem); begin inherited Put(Index, Item) end; end.

Алексей Румянцев
Специально для

Прилагается демонстрационный пример использования TRySharedStream : (13 K)

Класс TRyTimer.

Раздел Сокровищница

Описание:
Обертка для стандартного Windows'таймера. Аналог TTimer.
Отличия от TTimer'а:
не тянет за сабой TComponent, uses Forms, Application

Написано на Delphi5. Тестировалось на Win98. WinXP. В случае обнаружения ошибки или несовместимости с другими версиями Delphi и Windows, просьба сообщить автору.

Скачать Демо_Архив (4 K) 22.04.02

Алексей Румянцев

.
Специально для

Класс TSharedSream.

unit SharedStream; interface uses SysUtils, Windows, Classes, Consts; type { TSharedStream } TSharedStream = class(TStream) { Для совместимости с TStream } private FMemory : Pointer; { Указатель на данные } FSize : Longint; { Реальный размер записанных данных } FPageSize : Longint; { Размер выделенной "страницы" под данные } FPosition : Longint; { Текущая позиция "курсора" на "странице" } protected public constructor Create; destructor Destroy; override; function Read(var Buffer; Count: Longint): Longint; override; function Write(const Buffer; Count: Integer): Longint; override; function Seek(Offset: Longint; Origin: Word): Longint; override; procedure SetSize(NewSize: Longint); override; procedure LoadFromStream(Stream: TStream); procedure LoadFromFile(const FileName: string); procedure SaveToStream(Stream: TStream); procedure SaveToFile(const FileName: string); public property Memory: Pointer read FMemory; end; const SwapHandle = $FFFFFFFF; { Handle файла подкачки } implementation resourcestring CouldNotMapViewOfFile = 'Could not map view of file.'; { TSharedStream } { * TSharedStream работает правильно только с файлом подкачки, с обычным файлом проще и надежнее работать TFileStream'ом. * Для тех кто знаком с File Mapping Functions'ами : Класс TSharedStream не может использоваться для синхронизации(разделения) данных среди различных процессов(программ/приложений). [пояснения в конструкторе] * Класс TSharedStream можно рассматривать как альтернативу временным файлам (т.е. как замену TFileStream). Преимущество : а. Данные никто не сможет просмотреть. б. Страница, зарезервированная под данные, автомотически освобождается после уничтожения создавшего ее TSharedStream'а. * Класс TSharedStream можно рассматривать как альтернативу TMemoryStream. Преимущество : а. Не надо опасаться нехватки памяти при большом объеме записываемых данных. [случай когда физически нехватает места на диске здесь не рассматривается]. Известные проблемы: На данный момент таких не выявлено. Но есть одно НО. Я не знаю как поведет себя TSharedStream в результате нехватки места а. на диске б. в файле подкачки (т.е. в системе с ограниченным размером файла подкачки). } constructor TSharedStream.Create; const Sz = 1024000; { Первоначальный размер страницы }{ взят с потолка } var SHandle : THandle; begin FPosition := 0; { Позиция "курсора" } FSize := 0; { Размер данных } FPageSize := Sz; { Выделенная область под данные } { Создаем дескриптор объекта отображения данных. //эта формулировка взята из книги Проще сказать - создаем страницу под данные. //разрешите, я здесь и далее //буду употреблять более протые //информационные вставки. Все подробности по CreateFileMapping в Help'e. } SHandle := CreateFileMapping( SwapHandle, nil, PAGE_READWRITE, 0, Sz, nil ); { Создаем "страницу"___| | | |} { Handle файла подкачки ______| | |} { Задаем размер "страницы"[Sz]. Не может быть = нулю______________| |} { Имя "страницы" должно быть нулевым[nil]_____________________________| иначе Вам в последствии не удастся изменить размер "страницы". (Подробнее см. в TSharedStream.SetSize). * Для тех кто знаком с File Mapping Functions'ами : раз страница осталась неименованной, то Вам не удастся использовать ее для синхронизации(разделения) данных среди различных процессов(программ/приложений). [остальных недолжно волновать это отступление] } if SHandle = 0 then raise Exception.Create(CouldNotMapViewOfFile); { ошибка - неудалось создать объект отображения[т.е. "страница" не создана и указатель на нее = 0]. Это может быть: Если Вы что-либо изменяли в конструкторе - a. Из-за ошибки в параметрах, передоваемых функции CreateFileMapping б. Если Sz FMemory := MapViewOfFile(SHandle, FILE_MAP_WRITE, 0, 0, Sz); { Получаем указатель на данные } if FMemory = nil then raise Exception.Create(CouldNotMapViewOfFile); { Виндус наверно может взбрыкнуться и вернуть nil, но я таких ситуаций не встречал. естественно если на предыдущих дейсвиях не возникало ошибок и если переданы корректные параметры для функции MapViewOfFile() } CloseHandle(SHandle); end; destructor TSharedStream.Destroy; begin UnmapViewOfFile(FMemory); { закрываем страницу. если у Вас не фиксированный размер файла подкачки, то через пару минут вы должны увидеть уменьшение его размера. } inherited Destroy; end; function TSharedStream.Read(var Buffer; Count: Longint): Longint; begin { Функция аналогичная TStream.Read(). Все пояснения по работе с ней см. в help'e. } if Count > 0 then begin Result := FSize - FPosition; if Result > 0 then begin if Result > Count then Result := Count; Move((PChar(FMemory) + FPosition)^, Buffer, Result); Inc(FPosition, Result); end end else Result := 0 end; function TSharedStream.Write(const Buffer; Count: Integer): Longint; var I : Integer; begin { Функция аналогичная TStream.Write(). Все пояснения по работе с ней см. в help'e. } if Count > 0 then begin I := FPosition + Count; if FSize < I then Size := I; System.Move(Buffer, (PChar(FMemory) + FPosition)^, Count); FPosition := I; Result := Count; end else Result := 0 end; function TSharedStream.Seek(Offset: Integer; Origin: Word): Longint; begin { Функция аналогичная TStream.Seek(). Все пояснения по работе с ней см. в help'e. } case Origin of soFromBeginning : FPosition := Offset; soFromCurrent : Inc(FPosition, Offset); soFromEnd : FPosition := FSize - Offset; end; if FPosition > FSize then FPosition := FSize else if FPosition < 0 then FPosition := 0; Result := FPosition; end; procedure TSharedStream.SetSize(NewSize: Integer); const Sz = 1024000; var NewSz : Integer; SHandle : THandle; SMemory : Pointer; begin { Функция аналогичная TStream.SetSize(). Все пояснения по работе с ней см. в help'e. } inherited SetSize(NewSize); if NewSize > FPageSize then { Если размер необходимый для записи данных больше размера выделенного под "страницу", то мы должны увеличить размер "страницы", но... } begin { ...но FileMapping не поддерживает изменения размеров "страницы", что не очень удобно, поэтому приходится выкручиваться. } NewSz := NewSize + Sz; { задаем размер страницы + 1Meтр[чтобы уменьшить работу со страницами]. } { Создаем новую страницу }{ возможные ошибки создания страницы описаны в конструкторе TSharedStream. } SHandle := CreateFileMapping( SwapHandle, nil, PAGE_READWRITE, 0, NewSz, nil ); if SHandle = 0 then raise Exception.Create(CouldNotMapViewOfFile); SMemory := MapViewOfFile(SHandle, FILE_MAP_WRITE, 0, 0, NewSz); if SMemory = nil then raise Exception.Create(CouldNotMapViewOfFile); CloseHandle(SHandle); Move(FMemory^, SMemory^, FSize); { Перемещаем данные из старой "страницы" в новую } UnmapViewOfFile(FMemory); { Закрываем старую "страницу" } FMemory := SMemory; FPageSize := NewSz; { Запоминаем размер "страницы" } end; FSize := NewSize; { Запоминаем размер данных } if FPosition > FSize then FPosition := FSize; end; procedure TSharedStream.LoadFromFile(const FileName: string); var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try LoadFromStream(Stream) finally Stream.Free end end; procedure TSharedStream.LoadFromStream(Stream: TStream); var Count: Longint; begin Stream.Position := 0; Count := Stream.Size; SetSize(Count); if Count > 0 then Stream.Read(FMemory^, Count); end; procedure TSharedStream.SaveToFile(const FileName: string); var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmCreate); try SaveToStream(Stream) finally Stream.Free end end; procedure TSharedStream.SaveToStream(Stream: TStream); begin Stream.Write(FMemory^, FSize); end; end.

Алексей Румянцев
Специально для

Прилагается демонстрационный пример использования TSharedStream : (6.2K)

Комментарий к статье по поводу wsprintf

Сама по себе статья вызывает мало интереса, кроме того, что поднята интересная проблема - вызов с-шной функции с переменным числом параметров. В ответах с использованием массивов вообще, IMHO, ошибка - на стек попадет адрес массива, а в с это совсем не то. Но решение проблемы существует, правда надо ручками повозиться со стеком. Приводимая ниже функция на скорую руку переделывается из работающей в реальном проекте похожего буфера с-паскаль, но там функция в dll имеет тип вызова cdecl и другие обязательные параметры, в связи с чем возможны "опечатки" /*------------------------------------------------------------------*/ // Пишем функцию-переходник, маскируя с-шные "..." паскалевским // array of const function sprintf(out, fmt: Pchar; args: array of const): Integer; var I: Integer; BufPtr: Pchar; S: String; buf: array[0..1024] of char; begin BufPtr := buf; // Формируем буффер параметров. Можно, конечно, и прямо на стеке, // но головной боли слишком много - проще так for I:=low(Par) to High(Par) do case Par[I].VType of vtInteger : // Здесь все просто - 4 байта на стек begin Integer(Pointer(BufPtr)^) := Par[I].VInteger; Inc(BufPtr,4); end; vtExtended: // Здесь хуже - слова надо местами поменять :-(( begin Integer(Pointer(BufPtr)^) := Integer(Pointer(Pchar(Par[I].VExtended)+4)^); Inc(BufPtr,4); Integer(Pointer(BufPtr)^) := Integer(Pointer(Par[I].VExtended)^); Inc(BufPtr,4); end; vtPChar : // Здесь тоже все хорошо - 4 байта begin Pointer(Pointer(BufPtr)^) := Par[I].VPchar; Inc(BufPtr,4); end; vtString, vtAnsiString : // А здесь во избежание чудес надо // копию строки снять begin if Par[I].VType = vtString then S := Par[I].VString^ else S:= string(Par[I].VAnsiString); Pointer(Pointer(BufPtr)^ := StrPCopy(StrAlloc(Length(S)+1), S); Inc(BufPtr,4); end; end; // Поддержку других типов доделывать самостоятельно, // вооружившись толковым пособием по с и ассемблеру I := (BufPtr - buf) div 4; // Сколько раз на стек слово положить asm push dword ptr [out] push dword ptr [fmt] mov ecx, dword ptr [i] mov eax, dword ptr [buf] // stdcall - параметры в прямом // порядке @@1: push dword ptr [eax] add eax, 4 loop @@1 call [wsprintf] mov dword ptr [Result], eax // Сохранить результат mov eax, dword ptr [i] // Привести в порядок стек shl eax, 2 add eax, 8 add esp, eax end; // Почистить строки for I:=low(Par) to High(Par) do case Par[I].VType of vtInteger : Inc(BufPtr,4); vtExtended: Inc(BufPtr,8); vtPChar : Inc(BufPtr,4); vtString, vtAnsiString : begin StrDispose(PChar(PPointer(BufPtr)^)); Inc(BufPtr,4); end; end; end; /*-----------------------------------------------------------------*/ В таком виде методика уже имеет смысл. Изменения при типах вызова cdecl / pascal понятны.

С уважением Владимир Переплетчик.

Смотрите также :

Компилятор синтаксических выражений

Раздел Сокровищница

й Втюрин aka Nemo, дата публикации 01 августа 2002г.

Компонент для выгрузки набора данных в дерево

TDBSTreeView1.0 — компонент предназначен для выгрузки набора данных в дерево.
Оганичение:
Таблица должна иметь вид такой(то есть там должны присутствовать такие поля(названия не имеет значения)): 1 ID - integer(глобальный идатификатор) 2 IDPARENT - integer (ссылка на родительскую запись в этой таблице). Самые верхние узлы имеют в IDPARENT = 0.... Например, такая таблица IDNode IDparent Name 1 0 Первый узел 2 0 Второй узел 3 1 Первый ребенок первого узла 4 1 Второй ребенок первого узла итд Вот, в общем-то, и все ограничение... Наследовалось от TTreeView, поэтому имеет все его свойства. Добавлены свойства DataSource - наверное, не надо объяснять, зачем это надо :). DataField - значения данного поля будут отображаться в узлах дерева. IDNode - Название поля глобального идатификатора. IDParentNode - Название поля ссылки на родительскую запись в этой таблице. ViewField - Зарезервирована для дальнейшего развития. Да, собственно, для чего это делалось: ВАЖНО! Имеет пока одну только функцию LoadDBSTreeView(Root: string); - грузит дерево из НД. И самое главное при "прогулке" по дереву переводит НД на запись соответствующую узлу (просто именно из-за этой функции и писалось) Ах да ещё!...Никаких проверок на корректность присваивания DataSource пока нет, так как писалась для себя. За это, чур, не ругать..
А если найдете ошибки(не граматические естейственно:)..) отпишите плз... а то исправите у себя, а я буду потом десять лет это отлавливать ок?:)

Александров Дмитрий
AlexDBases

Скачать : (9,6 К)

Для данного материала нет комментариев.

Компонент градиентной раскраски областей

Раздел Сокровищница

Как можно увидеть при внимательном рассмотрении, раскраска псевдообъемных фигур производится линейно.
Для более правильного воспроизведения интенсивности цвета необходимо ввести тригонометрическую функцию преобразования интенсивности, но это сильно замедлит воспроизведение фигуры.
Для ускорения воспроизведения фигур в RunTime можно добавить в компонент преобразование рисунка в Bitmap после окончания режима разработки и далее воспроизводить его как картинку.

Компонент реализует градиентную заливку для конуса, цилиндра и сферы. В Design-time настраиваются все основные свойства псевдообъемной фигуры: тип фигуры и ее размер, расположение (кроме сферы), цвет заливки, смещения вершины конуса для получения скошенных и усеченных конусов. Для смены точки освещения и скошенных цилиндров допишете сами, это не сложно.

Проект, демонстрирующий градиентную заливку : Исходные коды + exe (156 K) Исходные коды (6 K)

Компонент "Линия"

Раздел Сокровищница

стa 2001 г.

Компонент предназначен для вычерчивания линий на мнемосхемах и других целей, где количество ломаных линий, созданых одним компонентом, не должно превышать 255.
Инструмент - Delphi 5.1.

Введение даже списка (TList), не говоря уже о коллекции, заметно замедляло отрисовку, поэтому был выбран статический массив записей линий.

Компонент позволяет изменять тощину, стиль и цвет как в режиме разработки, так и в динамике.
Для редактирования используется стандартный редактор компонентов, запускаемый нажатием правой кнопкой мыши.
Редактирование нужно начинать с первой команды выпадающего меню (Edit Lines), а заканчивать - со второй (Exit from Editing). Редактирование заключается в добавлении линий (Add Line) и узлов (Add node), и удалении их (Remove Line и Remove Node).
Можно также менять цвет (Line Color) и стиль линии (LineStyle). Ввиду ограничений, накладываемых операционными системами Windows95 и 98, стили меняются только для линий с толщиной, равной 1. Для Windows NT и 2000 таких ограничений нет.

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

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

К сожалению, компонент имеет существенный недостаток - отсутствие блокировки манипулирования другими компонентами, находящимися на форме, до выхода из режима редактирования линий.
убоко благодарен за любые советы по преодолению указанного недостатка.

убокую благодарность Сергею Губенко и Юрию Зотову за ценные советы по построению компонента.
Компонент могут использовать все без всяких ограничений, но со ссылкой на автора.

Скачать исходные коды (7K)

Компонент MathParser

нов, дата публикации 21 января 2002г

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

Свойства Expression - тип String, математическое выражение, которое нужно вычислить. Например x^2+sin(exp(x))-b+2 Variables - тип TStrings, представляет набор переменных и их значений, разделенных знаком =. Например x=2 b=2 Методы Execute - возвращает значение выражения, при данных значениях переменных.
Возвращаемое значение имеет тип Real. Исключения EUntrueSequence - недопустима последовательность символов, например x(3); EUnknownSymbol - недопустимый символ, например @; EUndeclaredIdentifier- неизвестный идентификатор; EUnknownFunction - неизвестная функция; Допустимые символы: + - плюс; - - минус; * - умножение; / - дделение; ^ - возведение в степень; ( ) -скобки; 1..9 - числа; . или ,- разделитель дробной части; Функции sin - синус; cos-косинус; tan-тангенс; exp-экспонента; ln - логарифм натуральный; sqrt - корень; arctan - арктангенс; Скачать исходные коды: (6К)

Компонент NXDBGrid, позволяющий отображать Dataset в транспонированном виде (столбцы в строках).

Разделу Сокровищница

Создание копонента было вызвано тем, что пришлось отображать объекты со множеством свойств, либо константных, либо изменяемых одновременно.
Стандартный ValueEditor не подходил по нескольким причинам: невозможно отобразить сразу несколько колонок со значениями. неизвестно, насколько хорошо будет передаваться между СОМ-объектами структуры, используемые для хранения значений. нет контроля типов дополнительная морока при состыковке с таблицами БД В конце концов выбор пал на TDBGrid. За основу мы взяли TCustomDBGrid и TCustomGrid.
Класс отнаследован от TCustomGrid, методы TCustomDBGrid были вставлены простым копированием и дополнены функциональностью.

NXDBGrid дополнен возможностью редактирования Даты\времени (т.к. мы отнаследователись от TCustomGrid то мы не смогли вставить стандартный редактор от MS как Inplace, поэтому пришлось написать самим ;-) )
Не смогли добавить дефолтный редактор компонента для DBGrid (по двойному щелчку мыши).
Не смогли реализовать добавление редакторов и валидаторов (Хотели использовать паттерн State (состояние) при изменении текущего столбца), но то ли мы не со всем разобрались, то ли ребята из Борланда замутили ;-)(у некоторых функций забыли поставить Virtual, некоторые объявлены в приватной области).
Добавлены проверки типов данных при редактировании.
Скриншоты :

Использование компонента состоит в изменении свойства Transformed

Технология использования компонента у нас простая. Создаем виртуальный рекордсет, запихиваем в него данные и выполняем присвоение
ADODataset.Recordset = наш рекордсет

Скачать компонент (93K)

и и основных моментов - Александр Ткаченко,
реализация - Денис Полеонов
материал предоставлен специально для

Компонент, позволяющий отображать формулы

Раздел Сокровищница

в А.В., дата публикации 18 октября 2002г.

Предлагаю Вашему вниманию компонент позволяющий отображать формулы (наследник от TCustomLabel).
Возможности - вывод греческих символов - вывод специальных математических символов (в пределах фонта Symbol) - использование верхних и нижних индексов, но не одновременно. - выравнивание выводимой формулы по вертикали и горизонтали - смена начертания внутри формулы

Для задания формулы используется текст свойства Caption. Формула описывается в текстовом режиме.

Зарезервированные символы
, '\', '^','_', '}','{'.

Для вывода зарезервированных символов необходимо использовать их совместно с символом \. Например для вывода пробела ипользуется \, правая фигурная скобка\}. Символы {} зарезервированы для дальнейшнго расширения.

Символы греческого алфавита и спецсимволы: \Delta, \Downarrow, \Gamma, \Lambda, \LeftArrow, \Leftrightarrow, \Omega, \RightArrow, \Phi, \Pi, \Psi, \Sigma, \Theta, \Uparrow, \Upsilon, \Xi, \alpha, \angle, \approx, \beta, \bullet, \cap, \cdot, \chi, \cong, \delta, \diamond, \div, \downarrow, \epsilon, \equiv, \eta, \gamma, \ge, \gets, \in, \infinity, \iota, \kappa, \lambda, \le, \mu, \ne, \notin, \nu, \omega, \oplus, \oslash, \otimes, \partial, \perp, \phi, \pi, \pm, \psi, \rho, \sigma, \subset, \subseteq, \supset, \tau, \theta, \times, \to, \uncup, \uparrow, \upsilon, \varepsilon, \varphi, \varpi, \varsigma, \vee, \wedge, \xi, \zeta. Для задания верхних и нижних идексов используются символы ^ и _ соответственно. Для смены начертания символов \it -- италика (курсив) \bl -- bold (жирный) \ul -- underline (подчеркнутый) \st -- strike (перечеркнутый) \rm -- отмена смены начертания

Недостатки: невозможность использовать струтурные скобки {} работа только на одной базовой линии (нельзя использовать \frac) и т.д. Да и нельзя реализовать TeX в 20-30 строках кода.

Примеры: S=\pi R^2 -- площадь круга С_2 H_5 OH -- OН и есть \Delta \phi = 0 уравнение Пуассона

Скачать (5 K)

Компонент SystemTray

Раздел Сокровищница

рбань С.В., дата публикации 25 сентября 2002г.

Компонент отличается от всех найденных мной аналогов. В нем не реализована только анимация (ну не нужна она мне...), зато он (компонент) САМ взаимодействует с формой и приложением. Это значит, что вы кладете компонент на форму, настраиваете настраиваете его (иконка, хинт, события мыши, всплывающее меню), задаете видимость формы, видимость приложения на панели задач и видимость иконки в трее. Все. Запускаете приложение. Если вы в DesignTime задали невидимую форму, невидимое приложение и видимый значек - ваше приложение появится ТОЛЬКО в трее. Если вы и значек спрятали - тогда вообще ничего не видно :-) Спрятались :-))

В архиве компонент и специальный пример — (236 K)

Компонент TADOUpdateSQL

Раздел Сокровищница

ркуша Алексей, дата публикации 14 мая 2002г.

Здесь представлены работающие компоненты обновления данных, полученных запросом через TADOQuery, аналогичные компонентам BDE TQuery,TUpdateSQL

Компоненты TADOUpdateQuery, TADOUpdateSQL выполняют в точности те же функции что и компоненты BDE TQuery,TUpdateSQL.
Это может способствовать быстрому переводу программ с BDE на ADO. Компоненты работающие (в исходных текстах есть комментарии), но до полной совместимости необходимы доработки, например: отсутствуют события onUpdateRecord, onUpdateError.
Предлагаю всем подключится и довести дело до конца.

type TADOUpdateQuery = class; TADOUpdateSQL = class; // Для правильной работы (логика) нежелательно изменять запрашиваемые поля TADOUpdateQuery = class (TADOQuery) private DelRecords: TADOQuery; FUpdateObject: TADOUpdateSQL; procedure SetUpdateObject(Value: TADOUpdateSQL); procedure ClearBuffer; // физическое удаление записей из буфера удаленных procedure InitBuffer; // создание датасета в которые помещаюися удаленные записи procedure FillBuffer; // перенос записи в буфер удаленных procedure ApplyDelUpdates; protected procedure InternalDelete; override; public constructor Create (AOwner: TComponent); override; destructor Destroy; override; procedure ApplyUpdates; // после успешного выполнения буфер удаленных записей будет пуст и необходим CommitUpdates // так как статусы "тронутых" записей не изменены //(пример вставка записи: будет столько сколько раз // был вызван ApplyUpdates. Неправильно это :-(, кто об этом знает procedure CancelUpdates; // сброс внутренних флагов ADO (вставленных, измененных) и сброс удаленных procedure CommitUpdates; // сброс внутренних флагов ADO (вставленных, измененных) published property UpdateObject: TADOUpdateSQL read FUpdateObject write SetUpdateObject; end; TADOUpdateSQL = class(TComponent) private FDataSet: TADOUpdateQuery; FQueries: array[TUpdateKind] of TADOQuery; FSQLText: array[TUpdateKind] of TStrings; function GetQuery(UpdateKind: TUpdateKind): TADOQuery; function GetSQLIndex(Index: Integer): TStrings; procedure SetSQL(UpdateKind: TUpdateKind; Value: TStrings); procedure SetSQLIndex(Index: Integer; Value: TStrings); protected function GetSQL(UpdateKind: TUpdateKind): TStrings; virtual; function GetDataSet: TADOUpdateQuery; virtual; procedure SetDataSet(ADataSet: TADOUpdateQuery); virtual; procedure SQLChanged(Sender: TObject); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Apply(UpdateKind: TUpdateKind); virtual; // не изменяет статусов записей // при прямом вызове сначала SetParams, не изменяет статусов записей procedure ExecSQL(UpdateKind: TUpdateKind); procedure SetParams(UpdateKind: TUpdateKind); // заполнение параметров property DataSet: TADOUpdateQuery read GetDataSet write SetDataSet; property Query[UpdateKind: TUpdateKind]: TADOQuery read GetQuery; property SQL[UpdateKind: TUpdateKind]: TStrings read GetSQL write SetSQL; published property ModifySQL: TStrings index 0 read GetSQLIndex write SetSQLIndex; property InsertSQL: TStrings index 1 read GetSQLIndex write SetSQLIndex; property DeleteSQL: TStrings index 2 read GetSQLIndex write SetSQLIndex; end; Скачать (5.7 K)

Компонент TComboBox с пошаговым поиском в списке

Раздел Сокровищница

Мне понадобился компонент TComboBox с пошаговым поиском в списке.
Несколько модифицированный стандартный TComboBox компонент с возможностью инкрементального поиска нашел на . Для Borland C++ Builder.
Переписал его на Delphi, может кому пригодится. Всю критику по коду приму по мылу. unit ComboBoxInc; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TComboBoxInc = class(TComboBox) private FTagString:AnsiString; FIncSearch:boolean; Findex:longint; Findex_prev:longint; FText_prev:string; FSelStart_prev:longint; protected procedure KeyUp(var Key:word; Shift:TShiftState);override; procedure KeyDown(var Key:word; Shift:TShiftState);override; public constructor Create (Owner:TComponent);override; published property IncSearch:boolean read FIncSearch write FIncSearch default true; property TagString:AnsiString read FTagString write FTagString; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TComboBoxInc]); end; procedure TComboBoxInc.KeyUp(var Key : word; Shift:TShiftState ); var start :integer; s:string; begin if (Key = 13) then begin start := 0; Findex_prev:=-1; Findex := SendMessage(Handle, CB_FINDSTRING, Findex-1, LongInt(PChar(Text))); FText_prev:=''; if (Findex <> -1) then SendMessage(Handle, CB_SETCURSEL, Findex, 0); SelStart := start; SelLength := GetTextLen()-start; Findex:=-1; inherited; end else begin if (FIncSearch) then begin if (key=8) then SelStart:=FSelStart_prev; start := SelStart; if (key <> 8) then Findex_prev:=Findex; Findex := SendMessage(Handle, CB_FINDSTRING, Findex-1,LongInt(PChar(Text))); FText_prev:=Text; if ((Findex <> -1)and not((Key = VK_DELETE))) then SendMessage(Handle, CB_SETCURSEL, Findex, 0); SelStart := start; SelLength := GetTextLen()-start; end; end; end; procedure TComboBoxInc.KeyDown(var Key : word; Shift:TShiftState ); begin if (Key=8) then begin SetLength(FText_prev,length(FText_prev)-1); Findex:=Findex_prev; Text:=FText_prev; end else FSelStart_prev:=SelStart; end; constructor TComboBoxInc.Create (Owner:TComponent); begin FIncSearch := true; FTagString := ''; inherited; end; end.

Компонент TOraCommentsToFL — загрузка русских наименований колонок из ERwin в DisplayLabels

Раздел Сокровищница

й Седов , дата публикации 29 мая 2002г.

Хочу поделиться идеей, которая, может и приходила уже кому-нибудь в голову, но я пока не встречал таких решений... Для тех, кто проектирует базы данных для Oracle в ERwin. Предлагаю решение для загрузки русских наименований колонок из ERwin в DisplayLabels датасета.

Компонент, конечно, сырой, но я пользуюсь, и очень поиогает. Ненавижу вбивать один текст по 10 раз.
Что нужно сделать: 1. Создать в ErWin скрипт на уровне модели следующего содержания: %ForEachTable() { %ForEachColumn() { COMMENT ON COLUMN %TableName.%ColName IS '%AttName'; }} 2. Сгенерировать базу. 3. В дата-модуле или на форме разместить компонент TOraCommentsToFL. 4.Установить его свойство OraDataSet. 5. Установить свойство LoadFieldLabels в True, после чего названия полей будут загружены из базы Oracle. 6. После этого компонент можно удалить с формы! Примечание:
Требуются установленные компоненты ODAC.

Скачать (3K)

Компоненты для облегчения работы с типовыми операциями поиска, выбора и фильтрации данных

Раздел Сокровищница

Набор компонент писался для облегчения работы с типовыми операциями поиска, выбора и фильтрации данных.

TAkLstDataпредназначена для вывода и выбора данных из набора данных в виде списка. Имеется возможность фильтрации этого списка. Множественный выбор. TAkTreeDataпредназначена для вывода и выбора данных из набора данных. Данные представлены в виде дерева. Существует возможность множественного выбора. TAkFilterDataпозволяет в диалоге задать условия отбора данных используемые в TQuery в разделе WHERE. TEditDataFormпозволяет получать данные (строка, дата, число) А-ля редактор свойств параметра ключа в реестре. TAkFindGridпозволяет искать данные в DBGrid. Компоненты оттестированы для Delphi 5 и необходимо наличие библиотеки RxLib.
Имеется краткая помощь и демо.

Скачать компоненты: (107K)

Компоненты для работы с графикой.

Раздел Сокровищница

Юрий , 16 апреля 2001г.

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

работа с прозрачностью быстрая и гибкая замена необходимых цветов улучшенный компонент TDrawGrid работа с массивами картинок (в т.ч. быстрое восстановление картинки, после того как она была изменена, быстрое сохранение и загрузка картинок, различные процедуры для их обработки (поддерживаются два формата: bmp и jpg) некоторые полезные дополнения, например такие как движущийся текст на неоднородном фоне - полезно для таких случаев, как создание диалогового окна About

А теперь рассмотрим вышеперечисленные пункты немного подробнее. Но для начала, несколько слов о принципах работы этих компонентов. Прежде всего они построены на основе массива объектов типа TBitmap. В 32 битных изображениях цвет кодируется 3 байтами - по одному на синий, зеленый и голубой, плюс добавляется один байт на альфа канал. В этот альфа канал записывается информация о том, следует ли при вставке одной картинки в другую использовать соответствующий пиксель (или игнорировать его). То есть по идее он может принимать два значения: 0 и 1. В этих компонентах использован несколько иной принцип использования альфа канала. Туда записывается число, которое представляет собой коэффициент, используемый при расчете двух пикселей двух различных картинок. То есть, если, скажем альфа канал равен 127, то результирующий пиксель будет являться средним арифметическим двух других пикселей. Значение альфа канала, равное 0 соответствует полной непрозрачности, а равное равное 255 - полной прозрачности вставляемой картинки. Процедура SetAlphaChannel устанавливает заданное значение альфа канала для всех пикселей картинки.

Замена цветов

Также в компонент TGraph добавлено несколько функция для замены цветов. Все эти процедуры работают только с 24 битными рисунками.

procedure ChangeColor(ChangeColorProc: TChangeColorProc; Bitmap: TBitmap; Color: TColor); TChangeColorProc = procedure(var R, G, B: Byte); Наверное, самая простая процедура. Процедура TChangeColorProc вызывается каждый раз при замене очередного пикселя. procedure ChangeColorEx(Bitmap: TBitmap; OldColor, NewColor: TColor; ChangingType: TChangingType); Замена цветом NewColor происходит, когда значение заменяемого пикселя оказывается между значениями OldColor и NewColor если ChangingType = ctEqual, если ChangingType = ctNotEqual, то замена цвета происходит когда значение заменяемого пикселя оказывается вне этого диапазона. Во всех последующих процедурах этот параметр имеет тот же самый смысл, поэтому я не буду описывать его действие. procedure ChangeColorRange(Bitmap: TBitmap; IntensityRecLo, IntensityRecHi, NewIntensityRec: TIntensityRec; ChangingType: TChangingType); TIntensityType = (itRed, itGreen, itBlue); TIntensityRec = array[TIntensityType] of Byte; Как видно выше, тип TIntensityRec представляет из себя не что иное, как 24 битный пиксель. Действие этой процедуры аналогично процедуре ChangeColorEx, за исключением того, что эта немного более гибкая, что ли. procedure ChangeColorRange(Bitmap: TBitmap; IntensityType: TIntensityType; IntensityLo, IntensityHi: Byte; NewIntensityRec: TIntensityRec; ChangingType: TChangingType); Самая быстрая процедура этого типа. Производит замену пикселя по одной из его составляющий: синему, зеленому или красному цвету. Соответственно IntensityLo и IntensityHi это диапазон одного из составляющих цвета пикселей, по границам которого производится замена пикселем NewIntensityRec.

Вот, собственно все процедуры созданные для замены цвета. Вместе они представляют из себя довольно гибкое средство для работы с графикой. Еще одно достоинство - они работают достаточно быстро. Это касается также и других процедур, например на компьютере Pentium Celeron 400 расчет прозрачности двух картинок (обе были (конечно же) 32 битные, размером 1024 на 768) занимал на более 500 миллисекунд.

Компонент TGraphGrid

Следующее, что мы рассмотрим, это компонент TGraphGrid, созданный на основе компонента TDrawGrid. Этот компонент способен отображать картинки с текстом. Чтобы картинки отображались в компоненте в порядке из загрузки, следует установить свойство DefaultOrder в True. Вообще, это не лучший способ для отображения картинки. В компоненте TDrawGrid есть свойство: RefArray: TIntArray
TIntArray = array of Integer; Оно представляет из себя массив ссылок. Поясню на примере. Пусть у на прорисовывается ячейка к координатами Col = 2, Row = 1, где в компоненте TDrawGrid 10 столбцов. В таком случае индекс ячейки (ее порядковый номер) будет равен 12 (нумерация столбцов и рядов начинается с нуля, с нуля также начинается нумерация индекса ячейки). При этом RefArray[12] = 1. В таком случае в ячейке Col = 2, Row = 1 будет прорисовываться картинку с индексом 1. При отсутствии ссылки не другую ячейку RefArray[N] = -1. В таком случае, при условии DefaultOrder = False в ячейке Col = 2, Row = 1 прорисовывалось бы именно картинка с индексом 12. Для более удобного доступа к массиву ссылок есть свойство: property Reference[Col, Row: Integer]: TGridCoord; TGridCoord = record Col, Row: Integer; end; Для задания переменной типа есть функция: function GridCoord(Col, Row: Integer): TGridCoord; Рассмотрим теперь событие, возникающее при прорисовки картинки в ячейке: TDrawPictureEvent = procedure(Sender: TObject; Rect: TRect; Index, Col, Row: Integer; var X, Y: Integer; Picture: TBitmap; var Background: TBitmap; var Continue: Boolean) of object; Параметры X и Y представляют собой координаты левого верхнего угла картинки (по умолчанию равны 0), которые можно изменять, Picture: собственно, сама картинка, Background картинка, по умолчанию равная nil. Если присвоить этому параметру значение, то картинка Background будет представлять собой фон ячейки. Также, если картинка Background по размерам меньше, ячейки, то она автоматически будет размножена. Также в компоненте TGraphGrid есть ряд свойств, которые, я думаю, объяснять не нужно, так как они интуитивно понятны (например свойство Scale - для автоматического масштабирования картинки и т.д.)

(153 K)



И, наконец, последний пункт - дополнение в виде движущегося текста. В компоненте TGraph также еще есть одна функция Appearance, но о ней я пока рассказывать не буду. procedure TGraph.AnimatedText(Canvas: TCanvas; Application: TApplication; Source: TBitmap; List: TStrings; Alignment: TAlignment; X, Y, Decrement: Integer; Delay: LongWord); Свойство Canvas представляет собой объект типа TCanvas на котором и будет осуществляться прорисовка. Application служит для вызова функции ProcessMessages. Source представляет собой фоновую картинку, Alignment - способ выравнивания текста, X, Y, координаты, по ним определяется границы движения текста, Decrement величина, определяющая через сколько пикселей текст будет перерисован. Delay - соответственно, задержка текста в миллисекундах.

(180 K)

Заключение

Если Вам удалось прочитать всю это до конца, то я уверен, Вы сможете найти практическое применение для моих компонентов, а скачать их можно здесь — (11 K)

Копирование на практике

Произведём копирование данных на практике. Для этого создадим новый проект под названием Test. Вносим название баз данных.

Примечание:
Новая база данных (куда мы копируем) должна быть совершенно пустой. У меня её размер составляет 230 Кб. Т.е. в ней нет ничего, кроме системных таблиц InterBase и т.п..

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

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

Там где поле Название заполняем название таблицы. Можно указать Русское название - поле чисто для информации на русском языке.

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

Так как мы копируем информацию в полностью пустую базу данных, то необходимо указать скрипты генерации базы данных. Для этого щёлкаем на закладке Файлы скриптов и указываем заполняем таблицу.

Если указана галочка в поле П, то это означает, что скрипт будет выполнен перед копированием информации в базе данных. Обычно, это скрипт генерируемый системами проектирования баз данных (например ErWin). Если указана галочка И, то это означает, что скрипт будет выполняться.

Примечание:
В качестве раздалителя в скриптах используется ^.

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

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

Это процесс длительный. Программа не забирает всё процессорное время и позволяет в это время Вам работать над другими задачам. При копировании таблиц показывается номер копируемой строки.

После завершения копирования показывается общее количество ошибок, предупреждений, ошибок в скрипте.

Вот мы и сгенерировали полностью работоспособную базу данных. И обошлось практически без потерь информации.

Рудюк Сергей

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

Лицензионное соглашение написано в каждом сооветствующем юните, здесь же написано некоторое пояснение :
TRySharedMem и TRySharedStream - это, по большому счету, базируются на результате(ах) работы FileMappingFunctions, но немалое значение здесь имеет и человеческий фактор: как вы распорядитесь объектами отображения, какой файл вы отобразите и что, как и сколько вы туда запишите никто не может знать, а файловая область, как вы знаете, это не шутка. Поэтому программный код дается вам бесплатно, по принципу "as is". асны с лицензионным соглашением или с некоторыми пунктами - вы не должны использовать данный програмный код в ваших проектах.

ListBox с расшифровкой длинных строк

В некоторых программах я встречал очень удобный дополнительный интерфейс стандартного списка ListBox: при наведении мышки на строчку, которая по ширине полностью не помещалась в контроле, рядом всплывало поясняющее окошко содержащее эту строчку целиком. Это очень удобный интерфейс; если пользователю хочется уточнить, что же в точности написано в скрытой строке списка, то ему не надо расширять/сужать форму, дергать Spliter'ы и так далее, достаточно просто подвести мышку к интересующей его строке.

Когда мне понадобилось снабдить таким интерфейсом ListBox в одном из моих проектов, я решил, что для решения этой задачи можно воспользоваться каким-нибудь сторонним компонентом. Но вот беда, на Torry такого компонента я не нашел. Поиск по другим сайтам выявил несколько похожих компонент, но все они были какими-то недоделанными, самопальными...

Видимо, подумал я, этот компонент легче написать самому; благо тут нет ничего сложного. Так я и сделал. Получились два довольно приличных компонента TTipListBox и TTipCheckListBox, которые и предлагаются вашему вниманию.

С интересом выслушаю все соображения по улучшению функциональности компонента и упрощению его кода. Собственно, я и выкладываю-то эти компоненты ради обсуждения их общественностью. :)

Исходники компонентов и демонстрационный проект (Delphi 5) (7K)

Специально для

Смотрите по теме:

Матрицы в Delphi

Раздел Сокровищница

Уважаемые сограждане. В ответ на вопросы Круглого Стола, в основном, от собратьев студентов, публикую алгоритмы матричного исчисления. В них нет ничего сложного, все базируется на функциях стандартного Borland Pascal еще версии 7.0.
Я понимаю, что уровень подготовки наших преподавателей весьма отстает не то, что от нынешних технологий, но даже и от весьма более ранних, но все-таки попробую помочь собратьям "по-несчастью".... :o)))

Итак, в приведен исходный текст весьма простенькой библиотеки Matrix.pas...
Перечень функций этой библиотеки: type MatrixPtr = ^MatrixRec; MatrixRec = record MatrixRow : byte; MatrixCol : byte; MatrixArray : pointer; end; MatrixElement = real; (* Функция возвращает целочисленную степень *) function IntPower(X,n : integer) : integer; (* Функция создает квадратную матрицу *) function CreateSquareMatrix(Size : byte) : MatrixPtr; (* Функция создает прямоугольную матрицу *) function CreateMatrix(Row,Col : byte) : MatrixPtr; (* Функция дублирует матрицу *) function CloneMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция удаляет матрицу и возвращает TRUE в случае удачи *) function DeleteMatrix(var MPtr : MatrixPtr) : boolean; (* Функция заполняет матрицу указанным числом *) function FillMatrix(MPtr : MatrixPtr;Value : MatrixElement) : boolean; (* Функция удаляет матрицу MPtr1 и присваивает ей значение MPtr2 *) function AssignMatrix(var MPtr1 : MatrixPtr;MPtr2 : MatrixPtr) : MatrixPtr; (* Функция отображает матрицу на консоль *) function DisplayMatrix(MPtr : MatrixPtr;_Int,_Frac : byte) : boolean; (* Функция возвращает TRUE, если матрица 1x1 *) function IsSingleMatrix(MPtr : MatrixPtr) : boolean; (* Функция возвращает TRUE, если матрица квадратная *) function IsSquareMatrix(MPtr : MatrixPtr) : boolean; (* Функция возвращает количество строк матрицы *) function GetMatrixRow(MPtr : MatrixPtr) : byte; (* Функция возвращает количество столбцов матрицы *) function GetMatrixCol(MPtr : MatrixPtr) : byte; (* Процедура устанавливает элемент матрицы *) procedure SetMatrixElement(MPtr : MatrixPtr;Row,Col : byte;Value : MatrixElement); (* Функция возвращает элемент матрицы *) function GetMatrixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement; (* Функция исключает векторы из матрицы *) function ExcludeVectorFromMatrix(MPtr : MatrixPtr;Row,Col : byte) : MatrixPtr; (* Функция заменяет строку(столбец) матрицы вектором *) function SetVectorIntoMatrix(MPtr,VPtr : MatrixPtr;_Pos : byte) : MatrixPtr; (* Функция возвращает детерминант матрицы *) function DetMatrix(MPtr : MatrixPtr) : MatrixElement; (* Функция возвращает детерминант треугольной матрицы *) function DetTriangularMatrix(MPtr : MatrixPtr) : MatrixElement; (* Функция возвращает алгебраическое дополнение элемента матрицы *) function AppendixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement; (* Функция создает матрицу алгебраических дополнений элементов матрицы *) function CreateAppendixMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция транспонирует матрицу *) function TransponeMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция возвращает обратную матрицу *) function ReverseMatrix(MPtr : MatrixPtr) : MatrixPtr; (* Функция умножает матрицу на число *) function MultipleMatrixOnNumber(MPtr : MatrixPtr;Number : MatrixElement) : MatrixPtr; (* Функция умножает матрицу на матрицу *) function MultipleMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; (* Функция суммирует две матрицы *) function AddMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; (* Функция вычитает из первой матрицы вторую *) function SubMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr; (* Функция решает систему методом Гаусса и возвращает LU-матрицы *) (* Результат функции - вектор-столбец решений *) function GausseMethodMatrix(MPtr,VPtr : MatrixPtr;var LPtr,UPtr,BPtr : MatrixPtr) : MatrixPtr;

Мне кажется, что интерфейсное описание весьма простое, но если возникнут какие-либо вопросы - пишите на E-mail - постараюсь ответить на все Ваши вопросы. Может быть, азы матричного исчисления я опишу в виде отдельной статьи по причине множества поступивших вопросов, хотя в этой матричной математике нет ничего сложного :o) Следует отметить, что теория матриц дает в Ваши руки весьма мощный инструмент по анализу данных весьма различного характера, в чем я неоднократно убеждался на практике.

Важные, на мой взгляд, замечания. НЕ СТЕСНЯЙТЕСЬ использовать подход, использующий стандартный тип Pascal - record - в объектах мало чего хорошего в межкомпиляторном взаимодействии. Да и, кстати, использование типа record до сих пор является самым быстрым способом математических расчетов, в отличиие от ООП. Частенько простое 2+2=4 дает существенный выигрыш по времени выполнения, по сравнению с объектным подходом, а если математических вычислений в Вашей программе великое множество....

P.S. Касательно уровня подготовки наших институтских кадров - эта библиотека сдавалась в качестве лабораторного задания аж в трех уральских университетах (кроме скромной персоны студента (ну, это и понятно ;o), и столь простые принципы работы доказывались чуть ли не перед комиссией от кафедры... ;o)))

С уважением,
Специально для

Скачать библиотеку (4 K)

Меню на основе панели инструментов

Раздел Сокровищница

Наверное многие видели меню, которое используется в MS Office или в самой среде Delphi: главные пункты выглядят как flat-кнопки -- плоские, но при перемещении над ними мыши как бы вспухающие. Кроме того, меню оформлено как панель инструментов и может пристыковываться к окну в любом месте.

Я предлагаю вариант реализации такого меню стандартными средствами VCL.

Сразу замечу, что чтобы двигать меню произвольным образом нужно возиться дополнительно ? TToolBar такой возможности не предоставляет.

Само меню оформляется как объект класса TToolBar, главные пункты меню ? стандартные для панели инструментов кнопки TToolButton, выпадающие подменю ? объекты TPopupMenu.

Итак, по пунктам.

1. Создаётся обычная панель инструментов MenuBar: TToolBar У неё устанавливаются следующие свойства: Color = clMenu //цвет как у меню AutoSize = TRUE // нельзя. 2. Создаются кнопки-главные элементы меню, класс TToolButton. У каждой кнопки устанавливаются свойства: AllowAllUp = TRUE AutoSize = TRUE Grouped = TRUE Caption = "Название пункта меню" 3. Для каждой кнопки создаётся своё подменю ? объект класса TPopupMenu В каждом из подменю задаётся соответствующий список пунктов. У кнопок на панели MenuBar свойство DropdownMenu заполняется ссылкой на соответствующий объект TPopupMenu.

Всё? Нет. К сожалению установленный в системе шрифт нельзя задать в design-режиме, а потому: 4. Когда-нибудь, до использования меню (например в обработчике события формы OnCreate) должен исполниться следующий код: var nc: TNonClientMetrics; s: TFontStyles; . . . . begin . . . . //читаем системные настройки в структуру nc nc.cbSize := sizeof(nc); SystemParametersInfo(SPI_GETNONCLIENTMETRICS, sizeof(nc), @nc, 0); with MenuBar.Font do begin Charset := nc.lfMenuFont.lfCharSet; //устанавливаем charset Height := nc.lfMenuFont.lfHeight; //высоту шрифта Name := nc.lfMenuFont.lfFaceName; //гарнитуру шрифта //далее определяем набор стилей s := []; if nc.lfMenuFont.lfWeight >= FW_BOLD then s := s + [fsBold]; if nc.lfMenuFont.lfItalic <> 0 then s := s + [fsItalic]; if nc.lfMenuFont.lfUnderline <> 0 then s := s + [fsUnderline]; if nc.lfMenuFont.lfStrikeOut <> 0 then s := s + [fsStrikeOut]; Style := s; end; 5. Есть ещё один существенный недостаток. Созданное описанным образом меню не считается таковым с точки зрения Windows. Самое явное последствие ? оно не подсвечивается по нажатию клавши Alt. Исправить данный недостаток удалось написанием обработчика сообщения WM_SYSCOMMAND, которое вызывается, в частности, для выделения пункта меню по горячей клавише.

Заведите новый метод в private-секции формы с меню (имя метода и параметра роли не играет): procedure SysCommand(var M: TWMSysCommand); message WM_SYSCOMMAND; Реализация метода такова (код основан на исходниках TToolBar): procedure TMain.SysCommand(var M: TWMSysCommand); begin //проверяется, что это команда - menu accelerator key, что дополнительной //кнопки не нажато (только Alt), что никто не захватил (capture) мышь if (M.CmdType and $FFF0 = SC_KEYMENU) and (M.Key = 0) and (GetCapture() = 0) then begin MenuBar.TrackMenu(nil); //аргумент это кнопка, подменю которой вывалится; nil-никакой, такова //стандартная реакция; если хотите, чтобы подменю первой кнопки //сразу развернулось напишите MenuBar.TrackMenu(MenuBar.Buttons[0]); //можно и просто указать компонент-кнопку: MenuBar.TrackMenu(mb_Options); end else inherited; //условие не выполнили - обрабатываем по умолчанию end; Здесь правда возникает другая проблема -- становится недоступным через клавиатуру системное меню (которое с Переместить/Закрыть и пр.), но это уже не самое страшное. Вот теперь всё! Можете запускать программу и смотреть что получилось.

Несколько замечаний. Описанное меню, по сравнению со стандартным имеет и дополнительные преимущества. Ведь созданные popup-менюшки можно использовать и отдельно, именно в качестве popup. Есть у Вас к примеру popup с операциями над каким-то объектом. Вы настраиваете этот объект так, чтобы по правому клику выскакивало меню и записываете соответствующий элемент в главное меню. Когда объект выделяется, кнопке в главном меню ставится Visible := TRUE, когда теряет фокус: Visible := FALSE. Вот и программа сразу солидней стала :) Можно вместо Visible использовать Enabled. Не забывайте и про событие OnPopup у класса TPopupMenu - это хорошее место для динамического скрытия или запрещения отдельных пунктов, в зависимости от состояния программы. Можно ещё создать обычное TMainMenu (но не ссылаться на него в свойстве Menu у главной формы) и кнопкам в панели задавать не DropdownMenu, MenuItem и ссылаться не на отдельные popup-меню, а на пункты главного меню. Единственное преимущество такого способа это то, что меню создаётся реальное, системное. Пятый пункт, с обработкой WM_SYSCOMMAND в данном случае становится бессмысленным. Тем не менее этот вариант мне понравился меньше, поскольку первый более гибок. Смешать оба варианта не удалось -- с выпадением подменю проблемы начались. Так что рекомендую использовать TPopupMenu, как описано. Примерчик, иллюстрирующий всё здесь написанное, а так же содержащий копию текста, который Вы сейчас читаете, содержится в архиве (10 K)

P.S. Уже после публикации статьи ко мне поступила просьба поместить ссылку на ресурс, который содержит интересную реализацию toolbar-меню:



По сути, это pas-файл, описывающий компонент - наследник TToolBar, в который добавлены дополнительные возможности. А именно: (а) необходимые свойства TToolBar (см. выше) устанавливаются сразу в нужные значения; (б) добавлено свойство Menu: TMainMenu, позволяющее автоматически создать toolbar-меню, на основе существующего главного меню.

Основным недостатком можно считать отсутствие синхронизации между обычным главным меню и создаваемым toolbar-меню. Плюс, учтите всё сказанное во втором замечании.

Достоинство в том, что это законченный компонент, которому достаточно задать свойство Menu и не мучаться больше -- всё остальное оформление он выполнит сам.

Методы фильтрации

Помимо описываемых ниже методов, присущих только TTable, наюоры данных имеют также общие свойства, методы и события для фильтрации - Filter, Filtered, OnFilteredRecord, FindFirst, FindLast, FindNext, FindPrior.

Для фильтрации записей TTable имеет следующие методы:
> SetRangeStart - устанавливает нижнюю границу фильтра;
> EditRangeEnd - утанавливает верхнюю границу фильтра;
> ApplyRange - осуществляет фильтрацию записей в TTable;
> SetRange - имеет тот же эффект, что и последовательное выполнение методов SetRangeStart, EditRangeEnd и ApplyRange. В качестве параметров используются масивы констант, каждый из которых содержит значения ключевых полей.

Фильтрация методами ApplyRange, SetRange должно проводиться по ключевым полям.По умолчанию берется текущий индекс, определяемый свойством TTable.IndexName или TTable.IndexFieldNames. Если значения этих свойств не установлены, по умолчанию используется главный индекс. Поэтому, если нужно использовать индекс, отличный от главного, необходимо явно переустановить значение свойства TTable.IndexName (имя текущего индекса) или TTable.IndexFieldNames (список полей текущего индекса).

Многострочный Hint

Раздел Сокровищница

врилов Сергей, дата публикации 26 ноября 2002г.

Данный модуль является компонентом со стандартной процедурой установки. Работает в среде Delphi 6.

После его регистрации перекрывается редактор свойства Hint в TControl (т.е. во всех control-ах) во время Design-а.
При этом изменяется способ редактирования свойства Hint. У него появляется кнопка "...", он становится многострочным и > 255 символов.
Длинные хинты дольше читать, и, возможно, Вам потребуется изменить свойства (пример): Application.HintPause := 700; Application.HintHidePause := 10000; По умолчанию установлено 500мс и 2500мс

Текст модуля:

unit HintProperty; interface uses Windows, Messages, SysUtils, Classes, designintf, DesignEditors, vcleditors, StdCtrls, StrEdit; type THintProperty = class(TStringListProperty) protected ss : TStringList; function GetStrings: TStrings; override; procedure SetStrings(const Value: TStrings); override; end; procedure Register; implementation uses Controls; procedure Register; begin RegisterPropertyEditor(TypeInfo(string), TControl, 'Hint', THintProperty); end; function THintProperty.GetStrings: TStrings; begin ss := TStringList.Create; ss.Text := GetStrValue; Result := TStrings(ss); end; procedure THintProperty.SetStrings(const Value: TStrings); var l : integer; s : string; begin s := value.Text; l := Length(s); if (l > 0) then SetLength(s, l-2); // чтобы не добавляла в конце пустую строку SetStrValue(s); ss.Destroy; end; end.

Буду признателен за замечания. Гаврилов Сергей
ноябрь 2002г.

Модуль для печати таблиц TStringGrid

Раздел Сокровищница

Как-то потребовалось напечатать таблицу StringGrid. Написал простенький алгоритм.
Может кому-то будет полезен. Добавляем к своему проекту модуль PrnGridUnit. Вызываем процедуру PrintGrid. Наслаждаемся. Для того, чтобы понять как все работает, смотри исходный код, нижеприведенную схему и прилагаемый пример печати.

Из модуля PrintGrid:

//процедура печати StringGrid Var //отступы (поля) сверху и слева страницы LeftMarg,TopMarg:Integer; //переменная для хранения значения отступа сверху от страницы для текущей //строки (в пикселях) CurrLine, //переменная для хранения значения отступа слева от страницы длч положения левой //границы текущей ячейки (в пикселях) LeftBorder, //тоже для правой границы текущей ячейки RightBorder, //переменная для хранения значения отступа сверху от страницы для положения верхней //границы текущей ячейки (в пикселях) TopBorder, //тоже для нижней границы текущей ячейки BottomBorder, //текущая строка таблицы Row, //текущий столбец таблицы Col:Integer; //отступ текста от левой границы ячеки LeftOffset:Integer; //счетчик страниц PageCount:Integer; //флаг конца страницы PageEnded:Boolean; //позиция для печати номеров страниц PageCountPrnPos:Integer; //диалог принтера PrintDialog:TPrintDialog;

Другие небольшие статьи, примеры и программы можете найти на

Скачать пример (35K)

Смотрите так же:

Модуль для получения интервала дат

Модуль предназначен для визуального выбора пользователем интервала дат с различными настройками. В модуле находится одна единственная функция function GetPeriod(var StartDate, EndDate: TDateTime): Boolean; Выходные параметры: StartDate - Начальная дата интервала EndDate - Конечная дата интервала Результат: True - Пользователь нажал "Ok" False - Пользователь нажал "Отмена"

Скачать (3.6K)

Модуль для расчета числовых и логических формул

Раздел Сокровищница

Модуль предназначен для расчета любых математических или логических выражений. В него уже включен набор стандартных математических и логических функций, но можно создавать свои функции любых типов. Можно также создавать свои типы данных. Логика работы с модулем такова, что сначала создается формула, которая затем преобразуется в цифровой вид, т.н. сценарий, по которому будет производиться расчет.
Это нужно для того, чтобы оптимизировать расчет формулы, при этом достигается огромный выигрыш в скорости. Для примера: у меня на компьютере (Athlon 1800XP, 512 MB DDR) расчет средней формулы 10000000 раз происходит за 1 - 1,5 секунды. Это при оптимизированном расчете. А при обычном (мои самые первые неудачные варианты) расчет той же формулы 10000 раз занимал около полминуты. Под словом "средней" я имею ввиду не очень длинную формулу, которая не перегруженна большим количеством функций. Но на саму формулу не накладывается вообще никаких ограничений, она может иметь любое количество операндов, она также может иметь любое количество вложенных выражений.
Вложеннное выражение - это с технической точки зрения отдельная формула, которая находится внутри другой формулы и может иметь еще любое количество вложенных формул. А с точки зрения пользователя это просто выражение, заключенное в скобки и обладающее приоритетом в вычислении.

Модуль экспорта/импорта данных между Oracle и DBF

Краткое описание функций модуля:

Ora2DBF - Функция конвертации данных из Oracle в DBF файл
Параметры: nService - Имя сервиса nUserID - Имя пользователя nPasswd - Пароль fQuery - Файл запроса fTableName - Имя DBF файла isAppend: Boolean; - Добавлять записи в существующий файл или создавать заново ProgressBar - Указатель на объект строки прогресса (допустимо nil) MessageEvent - Указатель на процедуру отображения сообщений (допустимо nil) DBF2Ora - Функция конвертации данных из DBF файла в таблицу Oracle
Параметры: nService - Имя сервиса nUserID - Имя пользователя nPasswd - Пароль fDTable - Имя DBF файла fTableName - Имя таблицы ProgressBar - Указатель на объект строки прогресса (допустимо nil) MessageEvent - Указатель на процедуру отображения сообщений (допустимо nil) Реализована возможность открытия файла DBF без наличия индекса.

Средство разработки: Delphi 5 Необходимо: RxLib Скачать : (4 K)

Смотрите также :

Модуль потоковой записи/чтения структуры и данных объекта TRxMemoryData.

ста 2003г.

RxLib - одна из самых лучших Delphi-библиотек, уже давно ставшая классикой разработки. В ее составе содержится компонент TRxMemoryData - "таблица в памяти", работающая напрямую, без каких-либо дополнительных платформ. Компонент очень удобен для операций с относительно небольшими объемами данных. Разумеется, можно использовать очень качественный и многофункциональный TClientDataSet, однако в условиях разработки на версиях Delphi младше D5 отсутствует возможность поставки приложения без дополнительных DLL. Кроме того, TRxMemoryData гораздо меньше добавляет веса к исполняемому модулю.

Процедуры потоковой записи-чтения позволят организовать на базе TRxMemoryData простую и гибкую систему хранения информации, удобную для реализации задач, оперирующих данными сравнительно небольших объемов, с доступом "по законам" TDataSet. Ниже приводится полный текст модуля.

Проверено на Delphi4 + RxLib 2.75.

Скачать (3K)

unit RxMemDSUtil; // --------------------------------------------------------------------------------------- // Дополнительные инструменты для работы с TRxMemoryData // --------------------------------------------------------------------------------------- interface uses Classes, SysUtils, RxMemDS; type // Прикладные исключения записи и чтения (сообщения на русском) ERxMemoryDataWriteError = class(Exception); ERxMemoryDataReadError = class(Exception); // Обратная связь при чтении-записи TReadWriteRxMemoryDataCallback = procedure(ACurrent, ATotal : Integer; var ACancel : Boolean) of object; // Запись в поток. При ошибках генерируются исключения. procedure WriteRxMemoryDataToStream(AObject : TRxMemoryData; AStream : TStream; ABufSize : Integer = 32768; ACallback : TReadWriteRxMemoryDataCallback = nil); // Чтение из потока (структура и данные будут загружены из потока "как есть" - без учета текущей структуры). // При ошибках генерируются исключения. procedure ReadRxMemoryDataFromStream(AObject : TRxMemoryData; AStream : TStream; ABufSize : Integer = 32768; ACallback : TReadWriteRxMemoryDataCallback = nil); // Запись в файл. При ошибках генерируются исключения. procedure WriteRxMemoryDataToFile(AObject : TRxMemoryData; AFileName : String; AFileMode : Word = (fmCreate or fmOpenWrite or fmShareDenyWrite); ABufSize : Integer = 32768; ACallback : TReadWriteRxMemoryDataCallback = nil); // Чтение из файла. При ошибках генерируются исключения. procedure ReadRxMemoryDataFromFile(AObject : TRxMemoryData; AFileName : String; AFileMode : Word = (fmOpenRead or fmShareDenyWrite); ABufSize : Integer = 32768; ACallback : TReadWriteRxMemoryDataCallback = nil); implementation uses DB, TypInfo; // --------------------------------------------------------------------------------------- // Внутрение типы и константы // --------------------------------------------------------------------------------------- const // Поддерживаемые типы полей (запись, чтение) DefProcessableFields : set of TFieldType = [ ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat, ftCurrency, ftDate, ftTime, ftDateTime, ftAutoInc, ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftBytes ]; // --------------------------------------------------------------------------------------- // Внутрение вызовы // --------------------------------------------------------------------------------------- procedure _WriteFieldValueToStream(AField : TField; AWriter : TWriter); var tmpBool : Boolean; begin with AField, AWriter do begin // Отслеживаем NULL-значение tmpBool := (IsNull and (not (DataType in [ftBlob, ftMemo, ftGraphic, ftFmtMemo]))); WriteBoolean(tmpBool); if(tmpBool) then exit; // Строка или бинарные данные if((DataType in [ftString, ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftBytes]) or IsBlob) then WriteString(AsString) else begin case(DataType) of // Целое ftSmallint, ftInteger, ftWord, ftAutoInc : WriteInteger(AsInteger); // Логическое ftBoolean : WriteBoolean(AsBoolean); // Вещественное ftFloat : WriteFloat(AsFloat); // Валюта ftCurrency : WriteCurrency(AsCurrency); // Дата и время ftDate, ftTime, ftDateTime : WriteDate(AsDateTime); else raise ERxMemoryDataWriteError.Create('Неожиданная ошибка записи (неизвестный тип поля).'); end; end; end; end; procedure _ReadFieldValueFromStream(AField : TField; AReader : TReader); begin with AField, AReader do begin // Отслеживаем NULL-значение if(ReadBoolean) then begin Value := NULL; exit; end; // Строка или бинарные данные if((DataType in [ftString, ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftBytes]) or IsBlob) then AsString := ReadString else begin case(DataType) of // Целое ftSmallint, ftInteger, ftWord, ftAutoInc : AsInteger := ReadInteger; // Логическое ftBoolean : AsBoolean := ReadBoolean; // Вещественное ftFloat : AsFloat := ReadFloat; // Валюта ftCurrency : AsCurrency := ReadCurrency; // Дата и время ftDate, ftTime, ftDateTime : AsDateTime := ReadDate; else raise ERxMemoryDataReadError.Create('Неожиданная ошибка записи (неизвестный тип поля).'); end; end; end; end; procedure _Callback(ACallback : TReadWriteRxMemoryDataCallback; ACurrent, ATotal : Integer; AExceptionClass : ExceptClass); var tmpCancel : Boolean; tmp : String; begin if(not Assigned(ACallback)) then exit; tmpCancel := False; try ACallback(ACurrent, ATotal, tmpCancel); if(tmpCancel) then begin tmp := ' '; if(AExceptionClass = ERxMemoryDataWriteError) then tmp := ' записи '; if(AExceptionClass = ERxMemoryDataReadError) then tmp := ' чтения '; raise AExceptionClass.Create('Процесс' + tmp + 'прерван.'); end; finally tmp := ''; end; end; // --------------------------------------------------------------------------------------- // Внешние вызовы // --------------------------------------------------------------------------------------- // Запись в поток. При ошибках генерируются исключения. procedure WriteRxMemoryDataToStream(AObject : TRxMemoryData; AStream : TStream; ABufSize : Integer; ACallback : TReadWriteRxMemoryDataCallback); var tmpWriter : TWriter; tmpRecNo : Integer; i, n : Integer; begin // Проверка параметров if(not Assigned(AObject)) then raise ERxMemoryDataWriteError.Create('Неверный параметр (AObject).'); if(not Assigned(AStream)) then raise ERxMemoryDataWriteError.Create('Неверный параметр (AStream).'); if(ABufSize 'Неверный параметр (ABufSize).'); with AObject do begin // Получаем текущую позицию (заодно проверям активность таблицы) tmpRecNo := RecNo; // Проверяем типы полей for i := 0 to Fields.Count - 1 do begin if(not (Fields[i].DataType in DefProcessableFields)) then raise ERxMemoryDataWriteError.Create('Поля данного типа не поддерживаются (поле ' + Fields[i].FieldName + ', тип ' + GetEnumName(TypeInfo(TFieldType), Integer(Fields[i].DataType)) + ').'); end; end; // Далее AObject.DisableControls; tmpWriter := TWriter.Create(AStream, ABufSize); try with tmpWriter, AObject do begin // Вызываем callback _Callback(ACallback, 0, RecordCount, ERxMemoryDataWriteError); // Пишем сигнатуру и тип класса WriteSignature; WriteString(ClassName); // Пишем структуру WriteCollection(FieldDefs); // Пишем данные WriteInteger(RecordCount); WriteListBegin; First; n := 0; while(not EOF) do begin for i := 0 to Fields.Count - 1 do _WriteFieldValueToStream(Fields[i], tmpWriter); Inc(n); // Вызываем callback _Callback(ACallback, n, RecordCount, ERxMemoryDataWriteError); // Далее Next; end; WriteListEnd; if(n <> RecordCount) then raise ERxMemoryDataWriteError.Create('Неожиданная ошибка (несовпадение количества записей).'); // Все FlushBuffer; end; finally tmpWriter.Free; AObject.RecNo := tmpRecNo; AObject.EnableControls; end; end; // Чтение из потока (структура и данные будут загружены из потока "как есть" - без учета текущей структуры). // При ошибках генерируются исключения. procedure ReadRxMemoryDataFromStream(AObject : TRxMemoryData; AStream : TStream; ABufSize : Integer; ACallback : TReadWriteRxMemoryDataCallback); var tmpReader : TReader; i, j, n : Integer; begin // Проверка параметров if(not Assigned(AObject)) then raise ERxMemoryDataReadError.Create('Неверный параметр (AObject).'); if(not Assigned(AStream)) then raise ERxMemoryDataReadError.Create('Неверный параметр (AStream).'); if(ABufSize 'Неверный параметр (ABufSize).'); // Проверяем - открыта ли таблица ? (и на чтении, и на записи - должна быть открыта) // AObject.Next; // Далее AObject.DisableControls; tmpReader := TReader.Create(AStream, ABufSize); try with tmpReader, AObject do begin // Чистим таблицу Open; EmptyTable; Close; FieldDefs.Clear; Fields.Clear; // Вызываем callback _Callback(ACallback, 0, 0, ERxMemoryDataReadError); // Читаем сигнатуру и тип класса ReadSignature; if(ReadString <> AObject.ClassName) then raise ERxMemoryDataReadError.Create('Несоответствие типов сохраненного объекта и объекта назначения.'); // Читаем структуру ReadValue; ReadCollection(AObject.FieldDefs); // Открываем Open; // Проверяем типы полей for i := 0 to Fields.Count - 1 do begin if(not (Fields[i].DataType in DefProcessableFields)) then raise ERxMemoryDataReadError.Create('Поля данного типа не поддерживаются (поле ' + Fields[i].FieldName + ', тип ' + GetEnumName(TypeInfo(TFieldType), Integer(Fields[i].DataType)) + ').'); end; // Читаем данные n := ReadInteger; ReadListBegin; j := 0; while(j <> n) do begin Append; for i := 0 to Fields.Count - 1 do _ReadFieldValueFromStream(Fields[i], tmpReader); Post; Inc(j); _Callback(ACallback, j, n, ERxMemoryDataReadError); end; ReadListEnd; if((j <> n) or (n <> RecordCount)) then raise ERxMemoryDataReadError.Create('Неожиданная ошибка (несовпадение количества записей).'); First; // Все end; finally tmpReader.Free; AObject.EnableControls; end; end; // Запись в файл. При ошибках генерируются исключения. procedure WriteRxMemoryDataToFile(AObject : TRxMemoryData; AFileName : String; AFileMode : Word; ABufSize : Integer; ACallback : TReadWriteRxMemoryDataCallback); var tmpStream : TFileStream; begin tmpStream := TFileStream.Create(AFileName, AFileMode); try WriteRxMemoryDataToStream(AObject, tmpStream, ABufSize, ACallback); finally tmpStream.Free; end; end; // Чтение из файла. При ошибках генерируются исключения. procedure ReadRxMemoryDataFromFile(AObject : TRxMemoryData; AFileName : String; AFileMode : Word; ABufSize : Integer; ACallback : TReadWriteRxMemoryDataCallback); var tmpStream : TFileStream; begin tmpStream := TFileStream.Create(AFileName, AFileMode); try ReadRxMemoryDataFromStream(AObject, tmpStream, ABufSize, ACallback); finally tmpStream.Free; end; end; // --------------------------------------------------------------------------------------- end.

Скачать (3K)

Модуль реализации матричных вычислений для массивов больших размеров

В этом модуле «осели» все операции с матрицами и векторами, которые я использовал для работы. Но есть алгоритмы, которые многие, наверняка, увидят впервые: Divide – алгоритм прямого деления, MSqrt – квадратный корень, MAbs – абсолютная величина. Поскольку модуль содержит все, от элементарных операций до матричных, разобраться будет несложно:

Например, решение системы ЛУ( консольное приложение )

Var N : Integer; A : Matrix; b, x : Vector; begin N := . . .; A.Init( N, N ); b.Init( N ); x.Init( N ); // или x.Init( B ); или x.InitRow( A ); . . . { формирование A и b } . . . x.Divide( b, A ); x.Print; . . . end.

Некоторые алгоритмы требуют пояснения, например: Matrix.E( i, j : LongWord ) или Vector.E( i : Integer ) : RealPtr, (RealPtr = ^Real) функция для вычисления адреса элемента матрицы/вектора. Перешла из ДОС когда в модуле использовался алгоритм управления виртуальной памятью для больших размерностей. Matrix.Multiple( X, Y : Vector ) Результатом, которого является произведение вектора X на транспонированный вектор Y - матрица ранга 1. Matrix.Invert( A : Matrix ) – если A[N,M], и N <> M то результат – матрица размера [M,N] – псевдообратная = A+. Matrix.Addition( A : Matrix; B : Real ) – добавление числа в главную диагональ. Matrix.Diag( r : Real ) – присваивание значения главной диагонали. Когда есть исходный текст - разобраться можно всегда.

Этот модуль используется почти во всех реализованных мной численных алгоритмах и методах. Те части, которые писал не я – приводятся без изменений(по возможности) стиля и комментариев.

Скачать (14K)

Модуль VHeapLow — модуль для работы с виртуальной памятью

Этот модуль был написан в 1992 году, для разработки приложений требующих большой объем памяти для хранения и обработки данных. Обычно такие задачи возникают при программной генерации систем уравнений ( линейных или дифференциальных ). Поддержку больших массивов в программе можно увидеть, например, в Turbo Proffesional. Модуль VheapLow - своеобразная реализация механизма управления виртуальной памятью построенная по образу кучи Turbo Pascal. Применение виртуальной памяти это самое очевидное решение проблемы. С развитием железа и ОС барьер в 640k перестал быть препятствием для решения задач большой размерности. А с этим и актуальность, даже очень крутых реализаций, виртуальных массивов отпала ( естественно, зачем нужна двойная виртуализация ? Я, и сам переделывал свои задачи для работы без этого модуля. Переделывается - очень просто: GetVMem - заменяется на GetMem, а FreeVMem на FreeMem.)

Но, совсем недавно, появилась задача обработки больших объемов текстовой информации, и соответственно возник вопрос как ее хранить и накапливать. Самое простое решение - вообще не выгружать программу из памяти, самое сложное - база данных. Но базу данных со сложной организацией данных вполне можно заменить виртуальной кучей( Virtual Heap ), и работать с ней как с обычной памятью. Поскольку блоки памяти, выделенные в виртуальной куче, можно сохранять сколько угодно долго после завершения программы, добавлять и изменять при последующих запусках. Виртуальная куча - это отображение на дисковом пространстве реальной выделенной памяти. Физически виртуальная куча - файл на диске. В заголовке такого файла есть место для нескольких виртуальных адресов пользователя( см. исх. текст ). По ним можно разместить адреса начал всех цепочек данных, а ООП дает очень удобные механизмы для реализации программы.

Основные функции VheapLow : GetVMem - Выделить блок виртуальной памяти. FreeVMem - Освободить память. VirtualToPtr - Центральная процедура модуля. Преобразует виртуальный адрес ( VPtr ) в реальный адрес ОП ( Pointer ). Пример очень простого случая :

Type MyRec = Record A, B : Real; Q, X : Integer; End; MyRecPtr = ^MyRec; VMayRec = object VAddr : VirtualPtr; {- Virtual heap Address -} function Addr : MyRecPtr; procedure Init; procedure Free; end; function VMyRec.Addr : MyRecPtr; begin RESULT := VirtualToPtr( VAddr ); End; Procedure VMyRec.Init; Begin VAddr := GetVMem( SizeOf( MyRec ) ); End; Procedure VmayRec.Free; Begin FreeVMem( Vaddr ); End; ... Var MR : VMayRec; Begin // InitVHeap( имя файла, оставить после выполнения программы) InitVHeap( 'F.vhp', True ); if VHeapStatus = OldVHeap then MR.VAddr := VHBases[ User01 ] else MR.Init; ... With MR.Addr^ do begin Q := Pi; ... ...

Чтобы сохранить виртуальный адрес до следующего запуска программы его нужно записать в один из базовых адресов перед завершением : VHBases[ User01 ] := MR.VAddr; Для строковых переменных свои отдельные функции по образу Turbo/Object Professional : StringToVHeap( S : String ) : VPtr и StringFromVHeap( VP : VPtr ) : String;

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

Модуль еще не полностью переделан под среду Delphi. В нем исправлены лишь явные ошибки, мешающие компилятору. Реализовать все можно абсолютно по-другому и на более высоком уровне. Я, хотел лишь осветить саму идею. Могу добавить, что под ДОС все работало. Была даже программа для разработки структур данных виртуальной памяти. Результатом ее работы был исходный текст модуля с описанием типов объектов и реализацией их методов. К сожалению, программа и ее исходный текст были потеряны вместе с HDD…

{$A-} unit VHEAPLow; {*********************************************************} {* VHEAPLOW.PAS 7.0 *} {* Writen by HNV 1991,92. *} {* Low level support for virtual heap. *} {*********************************************************} interface uses Classes, Dialogs, OpStrDev, SysUtils; const MaxFree = 256; {- size of free list -} type VirtualPtr = Real; VirtualPtrRec = record Len : LongWord; Addr : LongWord; end; Base = array[ 0..11 ] of VirtualPtr; UserBasesType = ( User01, User02, User03, User04, User05, User06, User07, User08, User09, User10 ); VHeapStatus = { Virtual Heap Status } ( NewVHeap, OldVHeap ); const UseKeyAccess : Boolean = false; { True if use key access } ShowHeapStatus : Boolean = false; { True if need show statistics } MaxHeapSpace : LongWord = 0; { Disk Free } } SaveVHeap : Boolean = False; { true if need saving v-heap } VHeapOk : Boolean = true; { VHeap Error flag } BaseAddr : Base = ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ); VHeapCacheProc : Pointer = nil; { Addres of function VirtualToPtr } VHeapErrorProc : Pointer = nil; { Addres of VHeap error routine } {- Virtual Heap File Caching -} MaxCacheSize : LongWord = 0; {- Maximum size of cache -} CacheHeapRatio : Real = 0.5; {- CacheSize / HeapSize -} BytesInCache : LongWord = 0; {- Cache use -} MinCacheLevel : Byte = 8; {- Min number of caching records -} CacheLevel : LongWord = 0; {- Current number of caching records -} CacheRead : LongWord = 0; {- Number of reading records -} CacheWrite : LongWord = 0; {- Number of swaping records -} CacheHits : LongWord = 0; {- Number of cache hits -} CacheEff : Real = 0; {- Caching effect -} CacheSearch : LongWord = 0; {- Cache routine calls -} var VHBases : array[ UserBasesType ] of VirtualPtr Absolute BaseAddr; VHStatus : VHeapStatus; {- Virtual Heap status -} type StringPtr = ^string; VString = object VAddr : VirtualPtr; {- Virtual heap Address -} function Addr : StringPtr; procedure Init; procedure Free; end; procedure InitVHeap( FName : string; Save : Boolean ); {- Initiator of Virtual Heap -} function GetVMem( L : Word ) : VirtualPtr; {- Allocate virtual space -} procedure FreeVMem( V : VirtualPtr ); {- Deallocate virtual space -} function VirtualToPtr( V : VirtualPtr ) : Pointer; {- Converted a virtual pointer to real pointer -} function StrVPtr( V : VirtualPtr ) : StringPtr; {- Converted a virtual pointer to real pointer -} procedure SetCaching( TF : Boolean ); {- Turn Caching OFF if TF is false. -} function StructToVHeap( var S; L : Word ) : VirtualPtr; {- Allocate space for S and return virtual pointer -} procedure StructFromVHeap( var S; V : VirtualPtr ); {- Return S at virtual pointer V -} function StringToVHeap( S : string ) : VirtualPtr; {- Allocate space for S and return virtual pointer -} function StringFromVHeap( V : VirtualPtr ) : string; {- Return S at virtual pointer V -} procedure Statistics( ST : TStrings ); {- Show virtual heap staistics on the screen. -} implementation type FreeListA = array[ 1..MaxFree ] of VirtualPtrRec; FreeListV = array[ 1..MaxFree ] of VirtualPtr; FreeListVHeap = record NFree : LongWord; case Byte of 1 : ( FreeL : FreeListA ); 2 : ( FreeV : FreeListV ); end; FreeListPtrV = ^FreeListVHeap; type CacheAddr = ^CacheRec; CacheRec = record Next : CacheAddr; RecA : Pointer; case byte of 1 : ( HAddr : VirtualPtr ); 2 : ( VRec : VirtualPtrRec ); end; const MaxHeapAddr : LongWord = $7FFFFFFF; MaxHeapBlock : LongWord = $7FFFFFFF; MinHeapBlock : LongWord = 1; HeaderVHeap : string = 'HNV(C)VIRTUAL HEAP FILE V 1.0'; HeaderVFree : string = 'FREE BLOCKS LIST'; Init : Boolean = False; StructRPtr : Pointer = nil; StructVPtr : VirtualPtr = 0; UseFactor : LongWord = 0; DelFreeArea : LongWord = 0; VHeapOrg : LongWord = 0; {- begin of virtual heap -} VHeapPtr : LongWord = 0; {- end of heap -} Caching : Boolean = True; Cache : CacheAddr = nil; var OldExit : Pointer; FreeListArea : FreeListPtrV; F : file; FileName : string; function VString.Addr : StringPtr; begin if VAddr <> 0 then Addr := VirtualToPtr( VAddr ) else begin VAddr := GetVMem( Succ( SizeOf( string ) ) ); Addr := VirtualToPtr( VAddr ); end; end; procedure VString.Init; begin VAddr := 0; end; procedure VString.Free; begin FreeVMem( VAddr ); end; procedure VHeapError( S : string ); begin ShowMessage( S ); Halt( 1 ); end; procedure Abort( S : string ); begin {Inline( $FF/$1E/>VHeapErrorProc );} VHeapError( S ) end; function AllocateFreeList : Pointer; var i : Word; P : Pointer; begin GetMem( P, SizeOf( FreeListVHeap ) ); with FreeListPtrV( P )^ do begin NFree := 0; for i := 1 to MaxFree do begin FreeL[ i ].Len := 0; FreeL[ i ].Addr := 0; end; end; AllocateFreeList := P; end; procedure Store( var S; V : VirtualPtr ); var i : LongWord; VR : VirtualPtrRec Absolute V; begin Inc( CacheWrite ); VHeapOk := True; Seek( F, VR.Addr ); BlockWrite( F, S, VR.Len, i ); VHeapOk := i = VR.Len; end; procedure Load( var S; V : VirtualPtr ); var i : LongWord; VR : VirtualPtrRec Absolute V; begin Inc( CacheRead ); VHeapOk := True; Seek( F, VR.Addr ); BlockRead( F, S, VR.Len, i ); VHeapOk := i = VR.Len; end; procedure LoSwapProc( var P : Pointer; V1, V2 : VirtualPtr ); var VR1 : VirtualPtrRec Absolute V1; VR2 : VirtualPtrRec Absolute V2; begin if P <> nil then begin Store( P^, V1 ); FreeMem( P, VR1.Len ); end; if not VHeapOk then exit; GetMem( P, VR2.Len ); Load( P^, V2 ); end; function LoCacheProc( V : VirtualPtr ) : Pointer; begin VHeapOk := True; if StructVPtr <> V then begin LoSwapProc( StructRPtr, StructVPtr, V ); LoCacheProc := StructRPtr; end else LoCacheProc := StructRPtr; end; procedure CacheNormalizing( L : LongWord ); {--------------------------------------} { Normalizing of Cache size to L value } {--------------------------------------} var P, T : CacheAddr; Done : Boolean; begin repeat P := Cache; T := P; Done := True; while ( BytesInCache + L > MaxCacheSize ) and ( P <> nil ) do with P^ do if Next = nil then begin Store( RecA^, HAddr ); Dec( BytesInCache, VRec.Len ); { Decrement Cache length } if CacheLevel 'INSSUFICIENT MEMORY FOR CACHING.' ); WriteLn( 'PROGRAM TERMINATED.' ); Abort( '$16 CRITICAL ERROR.' ); end; Dec( CacheLevel ); { Decrement Cache level } FreeMem( RecA, VRec.Len ); { Dispose structure } if T <> P then T^.Next := nil { goto next Cache record } else Cache := nil; FreeMem( P, SizeOf( CacheRec ) ); { dispose Cache record } P := nil; Done := False; end else begin T := P; P := Next; end; until Done; end; function AddRecToCache( V : VirtualPtr ) : Pointer; { addition new Cache record to Cache structure } var P : CacheAddr; VR : VirtualPtrRec Absolute V; begin GetMem( P, SizeOf( CacheRec ) ); with P^ do begin Next := Cache; Cache := P; GetMem( RecA, VR.Len ); Inc( CacheLevel ); {- -} Load( RecA^, V ); Inc( BytesInCache, VR.Len ); HAddr := V; AddRecToCache := RecA; end; end; procedure DelCacheRec( V : VirtualPtr ); { deleting Cache record from Cache structure. uses in FreeVmem } var P, T : CacheAddr; begin if not Caching then { exit if Caching is not active } exit; { search a virtual heap pointer in Cache structure } P := Cache; T := P; while P <> nil do with P^ do if HAddr = V then begin Dec( BytesInCache, VRec.Len ); { Decrement Cache length } FreeMem( RecA, VRec.Len ); { Dispose this structure } if T <> P then T^.Next := P^.Next { go to next Cache record } else Cache := P^.Next; { go to next Cache record } FreeMem( P, SizeOf( CacheRec ) ); { dispose Cache record } exit; end else begin T := P; P := Next; end; end; {-------------------------------------------------------} { Center function of VHeapLow unit } { converted a virtual heap pointer to real heap pointer } {-------------------------------------------------------} function VirtualToPtr( V : VirtualPtr ) : Pointer; var P, T : CacheAddr; VR : VirtualPtrRec Absolute V; begin Inc( CacheSearch ); if ( VR.Addr < VHeapOrg ) or ( VR.Addr + VR.Len > VHeapPtr ) then Abort( '$46 Invalid virtual pointer.' ); P := Cache; T := P; while P <> nil do if P^.HAddr = V then begin {- Set top of cache -} if T <> P then begin T^.Next := P^.Next; P^.Next := Cache; Cache := P; end; VirtualToPtr := P^.RecA; Inc( CacheHits ); exit; end else begin T := P; P := P^.Next; end; CacheNormalizing( VR.Len ); VirtualToPtr := AddRecToCache( V ); end; function StrVPtr( V : VirtualPtr ) : StringPtr; {- Converted a virtual pointer to string pointer -} begin StrVptr := VirtualToPtr( V ); end; procedure FlushOldRec; begin if StructRPtr <> nil then Store( StructRPtr^, StructVPtr ); end; procedure SetCaching( TF : Boolean ); {- turn Caching OFF if TF is false -} begin end; function ReadLongWord( var F : file ) : LongWord; var L : LongWord; i : LongWord; begin VHeapOk := True; BlockRead( F, L, SizeOf( LongWord ), i ); if i <> SizeOf( LongWord ) then Abort( '$0B initialization error.' ); ReadLongWord := L; end; function ReadString( var F : file ) : string; var i : LongWord; S : string; begin VHeapOK := True; ReadString := ''; i := ReadLongWord( F ); ShowMessage( intToStr( i ) ); SetLength( S, i ); BlockRead( F, S[ 1 ], i, i ); if i <> Length( S ) then Abort( '$0A Initialization Error.' ); ReadString := S; end; function ReadVirtualPtr( var F : file ) : VirtualPtr; var L : VirtualPtr; i : LongWord; begin VHeapOk := True; BlockRead( F, L, SizeOf( VirtualPtr ), i ); if i <> SizeOf( VirtualPtr ) then Abort( '$13 initialization error.' ); ReadVirtualPtr := L; end; function ReadBoolean( var F : file ) : Boolean; var L : Boolean; i : LongWord; begin VHeapOk := True; BlockRead( F, L, SizeOf( Boolean ), i ); if i <> SizeOf( Boolean ) then Abort( '$0D initialization error.' ); ReadBoolean := L; end; procedure WriteLongWord( var F : file; L : LongWord ); var i : LongWord; begin VHeapOk := True; BlockWrite( F, L, SizeOf( LongWord ), i ); if i <> SizeOf( LongWord ) then Abort( '$10 initialization error.' ); end; procedure WriteString( var F : file; S : string ); var i : LongWord; begin VHeapOK := True; WriteLongWord( F, Length( S ) ); BlockWrite( F, S[ 1 ], Length( S ), i ); if i <> Length( S ) then Abort( '$0F Initialization Error.' ); end; procedure WriteVirtualPtr( var F : file; L : VirtualPtr ); var i : LongWord; begin VHeapOk := True; BlockWrite( F, L, SizeOf( VirtualPtr ), i ); if i <> SizeOf( VirtualPtr ) then Abort( '$12 initialization error.' ); end; procedure WriteBoolean( var F : file; L : Boolean ); var i : LongWord; begin VHeapOk := True; BlockWrite( F, L, SizeOf( Boolean ), i ); if i <> SizeOf( Boolean ) then Abort( '$11 initialization error.' ); end; procedure StoreHeader; begin Seek( F, 0 ); WriteString( F, HeaderVHeap ); WriteLongWord( F, UseFactor ); WriteLongWord( F, DelFreeArea ); WriteLongWord( F, VHeapOrg ); WriteLongWord( F, VHeapPtr ); end; procedure StoreBase; var i : Word; begin for i := 0 to 11 do WriteVirtualPtr( F, BaseAddr[ i ] ); end; procedure StoreFreeList; var i : Word; begin WriteString( F, HeaderVFree ); WriteLongWord( F, FreeListArea^.NFree ); for i := 1 to MaxFree do WriteVirtualPtr( F, FreeListArea^.FreeV[ i ] ); end; procedure LoadHeader; begin Seek( F, 0 ); HeaderVHeap := ReadString( F ); UseFactor := ReadLongWord( F ); DelFreeArea := ReadLongWord( F ); VHeapOrg := ReadLongWord( F ); VHeapPtr := ReadLongWord( F ); end; procedure LoadBase; var i : Word; begin for i := 0 to 11 do BaseAddr[ i ] := ReadVirtualPtr( F ); end; procedure LoadFreeList; var i : Word; begin if ReadString( F ) <> HeaderVFree then Abort( '$32 file is not Virtual Heap' ); FreeListArea^.NFree := ReadLongWord( F ); for i := 1 to MaxFree do FreeListArea^.FreeV[ i ] := ReadVirtualPtr( F ); end; function HasExtension( Name : string; var DotPos : Word ) : Boolean; {-Return whether and position of extension separator dot in a pathname} var I : Word; begin DotPos := 0; for I := Length( Name ) downto 1 do if ( Name[ I ] = '.' ) and ( DotPos = 0 ) then DotPos := I; HasExtension := ( DotPos > 0 ) and ( Pos( '\', Copy( Name, Succ( DotPos ), 64 ) ) = 0 ); end; function ForceExtension( Name, Ext : string ) : string; {-Return a pathname with the specified extension attached} var DotPos : Word; begin if HasExtension( Name, DotPos ) then ForceExtension := Copy( Name, 1, DotPos ) + Ext else ForceExtension := Name + '.' + Ext; end; procedure MakeNewVHeap; var i : Word; begin StoreHeader; for i := 0 to 11 do begin BaseAddr[ i ] := 0; end; StoreBase; FreeListArea^.NFree := 0; StoreFreeList; VHeapOrg := FilePos( F ); VHeapPtr := VHeapOrg; StoreHeader; end; procedure VHeapExit; begin if SaveVHeap then begin if Caching then begin CacheNormalizing( MaxCacheSize ); if Cache <> nil then WriteLn( ' Cache ERROR.' ); end else FlushOldRec; StoreHeader; StoreBase; StoreFreeList; Seek( F, VHeapPtr ); Truncate( F ); Close( F ); end else begin Close( F ); Erase( F ); end; end; { --------------------------- GetVmem --------------------------------} function GetVmemPrim( L : Word ) : VirtualPtr; var V : VirtualPtr; VR : VirtualPtrRec Absolute V; j : Word; K : LongWord; procedure SetVHeapPtr; begin VR.Len := L; VR.Addr := VHeapPtr; Inc( VHeapPtr, L ); end; function Hole : Word; var i : Word; begin Hole := 0; with FreeListArea^ do begin K := MaxHeapBlock; for i := 1 to NFree do if ( FreeL[ i ].Len >= L ) and ( ( FreeL[ i ].Len - L ) < K ) then begin K := FreeL[ i ].Len - L; Hole := i; end; end; end; begin with FreeListArea^ do if NFree = 0 then begin SetVHeapPtr; GetVmemPrim := V; exit; end else begin { Search of Minimum Heap Hole } j := Hole; if j <> 0 then begin VR.Len := L; VR.Addr := FreeL[ j ].Addr; Dec( FreeL[ j ].Len, L ); Inc( FreeL[ j ].Addr, L ); if FreeL[ j ].Len = 0 then begin FreeV[ j ] := FreeV[ NFree ]; Dec( NFree ); end; GetVmemPrim := V; exit; end; SetVHeapPtr; GetVmemPrim := V; end; end; function GetVmem( L : Word ) : VirtualPtr; var V : VirtualPtr; P : ^Byte; begin VHeapOk := True; V := GetVmemPrim( L ); GetMem( P, L ); Store( P^, V ); Freemem( P ); if not VHeapOk then GetVmem := VHeapPtr else GetVmem := V; Dec( MaxHeapSpace, L ); end; { --------------------------- GetVmem --------------------------------} { --------------------------- FreeVmem --------------------------------} procedure SortFreeListByAddress; procedure Sort( l, r : Word ); var i, j : Word; x : LongWord; y : VirtualPtr; begin with FreeListArea^ do begin i := l; j := r; x := FreeL[ ( l + r ) div 2 ].Addr; repeat while FreeL[ i ].Addr < x do i := i + 1; while x < FreeL[ j ].Addr do j := j - 1; if i j; if l < j then sort( l, j ); if i < r then sort( i, r ); end; end; begin {quicksort} ; sort( 1, FreeListArea^.NFree ); end; function ReorgFreeList : Boolean; var Q : LongWord; i : Word; begin ReorgFreeList := False; with FreeListArea^ do begin if NFree MaxHeapBlock then exit; Inc( FreeL[ i ].Len, FreeL[ i + 1 ].Len ); FreeV[ i + 1 ] := FreeV[ NFree ]; Dec( NFree ); ReorgFreeList := True; exit; end; end; end; procedure FreeVmem( V : VirtualPtr ); { Erased a virtual heap pointer } var VR : VirtualPtrRec Absolute V; i : Word; K, j : Word; begin DelCacheRec( V ); { free real heap space if Caching is active } with FreeListArea^ do begin if ( VR.Addr + VR.Len ) <> VHeapPtr then begin if ( NFree + 1 ) > MaxFree then begin K := MaxHeapBlock; j := 1; for i := 1 to MaxFree do if FreeL[ i ].Len < K then begin K := FreeL[ i ].Len; j := i; end; FreeV[ j ] := V; end else begin Inc( NFree ); FreeV[ NFree ] := V; end; end else Dec( VHeapPtr, VR.Len ); repeat if NFree > 1 then SortFreeListByAddress; until not ReorgFreeList; end; end; function StructToVHeap( var S; L : Word ) : VirtualPtr; var V : VirtualPtr; begin StructToVHeap := 0; VHeapOk := True; V := GetVMemPrim( L ); if not VHeapOk then exit; Store( S, V ); StructToVHeap := V; end; procedure StructFromVHeap( var S; V : VirtualPtr ); begin VHeapOk := True; Load( S, V ); end; function StringToVHeap( S : string ) : VirtualPtr; var V : VirtualPtr; begin StringToVHeap := 0; VHeapOk := True; V := GetVMemPrim( Length( S ) ); if not VHeapOk then exit; Store( S, V ); StringToVHeap := V; end; function StringFromVHeap( V : VirtualPtr ) : string; begin VHeapOk := True; StringFromVHeap := StringPtr( VirtualToPtr( V ) )^; end; procedure Statistics( ST : TStrings ); var i : Word; begin with FreeListArea^ do begin UseFactor := 0; if NFree > 0 then for i := 1 to NFree do UseFactor := UseFactor + FreeL[ i ].Len; end; Write( TPStr, '------------ VIRTUAL HEAP STATISTICS ---------------' ); ST.Add( ReturnStr ); Write( TPStr, 'і --- Heap --- і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in Heap......................: ', VHeapPtr - VHeapOrg : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Start Virtual Heap Address.........: ', VHeapOrg : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes available to Virtual Heap....: ', MaxHeapSpace : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і і' ); ST.Add( ReturnStr ); Write( TPStr, '----------------------------------------------------' ); ST.Add( ReturnStr ); Write( TPStr, 'і --- Holes --- і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Number of Heap Holes...............: ', FreeListArea^.NFree : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in accessible Heap Holes.....: ', UseFactor : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in not accessible Heap Holes.: ', DelFreeArea : 10, ' і' ); ST.Add( ReturnStr ); if ( VHeapPtr - VHeapOrg ) <> 0 then Write( TPStr, 'і Percent Holes in Heap..............: ', ( UseFactor + DelFreeArea ) / ( VHeapPtr - VHeapOrg + UseFactor ) * 100 : 8 : 4, ' % і' ); ST.Add( ReturnStr ); Write( TPStr, 'і --- Cache --- і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Bytes in Cache.....................: ', BytesInCache : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і General Cache Space................: ', MaxCacheSize : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Cache Level........................: ', CacheLevel : 10, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і Disk Input : ', CacheRead : 10, '; Output : ', CacheWrite : 10, ' і' ); ST.Add( ReturnStr ); if CacheSearch <> 0 then Write( TPStr, 'і Cache Hits : ', CacheHits : 10, '; Eff [%] : ', CacheHits / CacheSearch * 100 : 10 : 3, ' і' ); ST.Add( ReturnStr ); Write( TPStr, 'і і' ); ST.Add( ReturnStr ); Write( TPStr, '----------------------------------------------------' ); ST.Add( ReturnStr ); end; procedure CalcDiskSize( FName : string ); begin if Pos( ':', FName ) <> 0 then MaxHeapSpace := DiskFree( Pos( UpCase( FName[ 1 ] ), 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' ) ) else MaxHeapSpace := DiskFree( 0 ); end; procedure InitVHeap( FName : string; Save : Boolean ); begin if Init then Abort( '$25 Double Initialization.' ); FileName := FName; SaveVHeap := Save; FreeListArea := AllocateFreeList; if CacheHeapRatio > 0.8 then CacheHeapRatio := 0.8; MaxCacheSize := Trunc( MaxHeapAddr * CacheHeapRatio ); Assign( F, FName ); if not FileExists( FName ) then begin Rewrite( F, 1 ); MakeNewVHeap; VHStatus := NewVHeap; CalcDiskSize( FName ); end else begin Reset( F, 1 ); VHStatus := OldVHeap; if ReadString( F ) <> HeaderVHeap then Abort( 'file is not Virtual Heap.' ); LoadHeader; LoadBase; LoadFreeList; Init := True; CalcDiskSize( FName ); end; end; initialization finalization VHeapExit; end.

Для данного материала нет комментариев.

Модули для рисования математических формул

игорьев, дата публикации 27 ноября 2002г.

Модули ExprDraw и ExprMake служат для рисования математических формул.

Модуль ExprDraw содержит классы, использующиеся для отображения формул. Эти классы описаны в файле .
Создание и установление взаимосвязей между классами, описанными в модуле ExprDraw, для отображения конкретной формулы - занятие трудоёмкое, поэтому для его автоматизации создан модуль ExprMake, который создаёт классы на основании символьной записи формулы. Описание модуля находится в файле .

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

Модули ExprDraw и ExprMake поставляются "as is", в том виде, в каком я сам их использую. Первоначально я разрабатывал их исключительно для личного пользования, но потом решил поделиться. Возможности модулей позволяют отображать очень большой спектр формул. В математическом справочнике Бронштейна и Семендяева мне не удалось найти ни одной формулы, которая была бы модулям "не по зубам". Такие формулы есть в некоторых томах "Курса теоретической физики" Ландау и Лифшица, но это связано исключительно с использованием тических и прочих непонятных букв, все остальные конструкции (включая постоянную Планка и лямбду с чертой) модули отображают без проблем. С одним замечанием: моё личное предпочтение - использование для обозначения векторов стрелки над символом, а не жирного шрифта, поэтому модули поддерживают именно стрелку. Текст модулей практически не содержит комментариев, все комментарии вынесены в файлы и . Эти комментарии далеки от полноты, поэтому тем, кто захочет не только использовать готовую библиотеку, но и изменить что-то в ней, придётся серьёзно поработать, чтобы разобраться в коде.

Модули написаны на Delphi 5, испытаны в Windows 95 OSR 2.1, Windows NT 4.0 SP6 Workstation, Windows 2000 Advanced Server. По идее, ничего не мешает использовать эти модули и в других версиях Delphi, так как они поставляются в исходных кодах. Никакой специальной установки модулей не нужно, просто поместите файлы ExprDraw.pas и ExprMake.pas в один из тех каталогов, в которых Delphi ищет библиотеки, и добавьте ExprDraw и ExprMake в раздел uses своего модуля.

Просьба всем тем, кто будет использовать модули в своих программах, найти в About Box'е или ещё где-нибудь место для фразы типа "Для отображения математических формул используются модули ExprDraw и ExprMake, разработанные Григорьевым Антоном, e-mail."

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

Скачать библиотеку: (278 K)
дата обновления 04.12.02 — решена проблема работы модулей под Windows 98/ME

Убедительная просьба НЕ ПОСЫЛАТЬ мне писем следующих типов: "Что такое каталог, где Delphi ищет библиотеки?" Ответ на такой этот вопрос можно найти в справочной системе Delphi или в любой книге про Delphi для начинающих. "Для чего нужна функция XXXX в классе TExprXXXX?" "Как работает функция XXXX?" и т.п. Все комментарии, которые я считал нужным дать, находятся в файлах Expr*.txt. В остальном разберитесь сами с помощью исходных текстов. "Мне нравятся ваши модули, но не хватает таких-то функций и/или классов: ... Не могли бы вы помочь мне их разработать?" Не мог бы. Вы и так на халяву получили сложную библиотеку, на которую у меня ушло очень много времени. Сделайте хоть что-то сами. Или давайте обсудим стоимость доработки модулей под ваши нужды. "Я начинающий программист, помогите мне, пожалуйста, сделать то-то и то-то..." Для таких вопросов существуют интернет-конференции. Например, "" в "Королевстве Delphi", который я регулярно просматриваю и отвечаю на все вопросы, на которые смогу. Пишите туда, а не в мой ящик. С пожеланиями успешной работы

,
Черноголовка, 27.11.02
Специально для

Набор функций для создания диалоговых окон в стиле диалогов помощника MSOffice 2000.

Раздел Сокровищница

рь Шевченко, дата публикации 26 апреля 2002г.

Заменяет стандартные диалоги из Dialogs.pas, создаваемые по функции CreateMessageDialog (ShowMessage, MessageDlg). Все диалоги можно перемещать мышью за область формы. Чего не стал добиваться, это поведения кнопок, аналогичного кнопкам в диалогах помощника: при наведении на них мышью, они меняют свой вид.
Каждое диалоговое окно можно ассоциировать с Control'ом (хвостик диалога будет указывать на Control), если параметр Control не указан или равен nil, то хвостик в диалогах появляться не будет, и диалог будет размещен по центру главной формы приложения.
Имеется ряд глобальных переменных, действующих на внешний вид всех диалогов: MessageColor - цвет фона диалогов, RoundRectCurve - Размер эллипса для скругления углов формы TriangleWidth - Ширина треугольного хвостика TriangleHeight - Высота треугольного хвостика TriangleIndent - Смещение треугольного хвостика относительно края диалога Состав: unit HSFlatButton - компонент плоской кнопки для отображения в диалогах. unit HSDialogs - собственно, функции для создания диалогов. function CreateHSMessageDialog (const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; { Control, на который указывает хвостик } AEditorControl : TControl = nil; { Позиция хвостика относительно левого края Control } AXCursorOffset : Integer = 20; { Позиция хвостика относительно верхнего (или нижнего) края Control } AYCursorOffset : Integer = 2): TCustomForm; { Замена функции MessageDlg } function HSMessageDlg(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2): Integer; { Замена функции ShowMessage } procedure HSShowMessage(const Msg: string; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2); { Замена функции ShowMessageFmt } procedure HSShowMessageFmt(const Msg: string; Params : array of const; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2); { Замена функции ShowMessage cо стандартной пиктограммой "Ошибка" } procedure HSShowError(const Msg: string; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2); { Замена функции ShowMessageFmt cо стандартной пиктограммой "Ошибка" } procedure HSShowErrorFmt(const Msg: string; Params : array of const; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2); { Замена функции ShowMessage cо стандартной пиктограммой "Предупреждение" } procedure HSShowWarning(const Msg: string; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2); { Замена функции ShowMessageFmt cо стандартной пиктограммой "Предупреждение" } procedure HSShowWarningFmt(const Msg: string; Params : array of const; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2); { Замена функции ShowMessage cо стандартной пиктограммой "Информация" } procedure HSShowInfo(const Msg: string; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2); { Замена функции ShowMessageFmt cо стандартной пиктограммой "Информация" } procedure HSShowInfoFmt(const Msg: string; Params : array of const; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2); { Диалог подтверждения с кнопками "Да"/"Нет" и стандартной пиктограммой "Подтверждение" } function HSConfirmMessage(const Msg: string; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2) : Boolean; { Диалог подтверждения с кнопками "Да"/"Нет" и стандартной пиктограммой "Подтверждение", с параметрами для функции Format } function HSConfirmMessageFmt(const Msg: string; Params : array of const; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2) : Boolean; { Диалог подтверждения с кнопками "Да"/"Нет"/"Отмена" и стандартной пиктограммой "Подтверждение" } function HSAskYesNoCancel(const Msg: string; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2) : Integer; { Диалог подтверждения с кнопками "Да"/"Нет"/"Отмена" и стандартной пиктограммой "Подтверждение", с параметрами для функции Format } function HSAskYesNoCancelFmt(const Msg: string; Params : array of const; AEditorControl : TControl = nil; AXCursorOffset : Integer = 20; AYCursorOffset : Integer = 2) : Integer;

В (11.8K) содержатся unit's для диалогов и тестовый пример.

Любая критика, предложения и пожелания принимаются :-)

С уважением,

Набор классов для работы с журналом событий в WinNT/2000/XP.

Раздел Сокровищница

Класс TDLLCache. Предназначен для хранения списка загруженных динамических библиотек, используемых при формировании текстов сообщений при расшифровке записей журнала событий.
Используется внутри класса TEventLogRecordDecoder.

Методы:

function LoadLibrary( const Name : string; FLags : DWORD ) : HInstance; загружает библиотеку и возвращает ее описатель. procedure UnloadLibrary( const Name : string ); выгружает библиотеку. procedure UnloadAll; выгружает все загруженные библиотеки. Класс TEventLogRecordDecoder. Предназначен для расшифровки данных записи журнала событий. Большинство свойств соответствуют полям структуры EVENTLOGRECORD. Их подробное описание есть в справке и MSDN.

Методы:

constructor Create( const ALogName : string ); ALogName имя журнала. Должно соответствовыть имени одного из подключей ключа HKLM\SYSTEM\CurrentControlSet\Services\Eventlog реестра, обычно Application, System и Security. Это имя можно также задать при помощи свойства LogName. procedure Reset; - выгружает все загруженные при расшифровке динамические библиотеки. procedure GetRawData(Stream : TStream); Сохраняет в поток Stream двоичные данные, содержащиеся в записи о событии. Указатель на этот блок данных можно получить также из свойства Data, а длину - из DataLength. procedure GetRawRecord(Stream : TStream); Сохраняет в поток Stream содержимое записи журнала целиком. procedure ValidateRecord; Выполняет проверку формата записи, и если она не соответствует формату, возбуждает исключение EInvalidEventLogRecord.

Свойства:

property RecPtr : PEVENTLOGRECORD read FRecPtr write FRecPtr; Предназначено для задания указателя на структуру EVENTLOGRECORD, данные которой нужно прочитать. property LogName : string read FLogName write FLogName; Предназначено для задания имени журнала. Класс TEventLog

Методы:

procedure Open; Открывает журнал событий, заданный свойством LogName. procedure OpenBackup( const BackupName : string ); Открывает резервную копию журнала. procedure Close; Закрывает журнал событий procedure Clear( const BackupName : string = '' ); Очищает журнал событий. Журнал должен быть открыт. Если задан параметр BackupName, то создается резервная копия журнала. procedure Backup( const BackupName : string ); Создает резервную копию журнала. function CreateIterator( Direction : TLogIterateDirection=idBackward) : TEventLogIterator; Создает и возвращает итератор, связанный с данным экземпляром класса TEventLog.

Свойства:

property Active : boolean read GetActive write SetActive; Показывает открыт или закрыт журнал. property Count : DWORD read GetCount; Количество записей в журнале property Handle : THandle read FHandle; Описатель открытого журнала. property LogName : string read FLogName write SetLogName; Задает имя журнала. property OldestRecord : DWORD read GetOldestRecord; Номер самой старой записи в журнале. property RegKey : string read GetRegKey; Имя корневого ключа реестра для выбранного журнала. Класс TEventLogIterator Предназначен для перемещения по открытому журналу сообщений, предоставляет доступ к текущей записи.

Методы:

constructor Create( AEventLog : TEventLog; ADirection : TLogIterateDirection ); AEventLog - Экземпляр класса TEventLog, для которого создается итератор ADirection - задает направление прохода по журналу. function IsEmpty : boolean; Возвращает true если журнал пуст. procedure Reset; Сбрасывает текущее состояние итератора и переходит, в зависимости от заданного направления обхода, к первой или последней записи в журнале. Вызов Reset необходим, например, в том случае, если было изменено имя журнала в соответствующем экземпляре класса TEventLog. function IsDone : boolean; function Next : boolean; Переход к следующей записи в журнале в соответствие с выбранным направлением обхода. function Seek( Number : DWORD ) : boolean; Переход к записи журнала с заданным номером.

свойства:

property Current : TEventLogRecordDecoder read GetCurrent; Дает доступ к текущей записи журнала. property EventLog : TEventLog read FEventLog write SetEventLog; Экземпляр класса TEventLog, с которой связан с данным экземпляром итератора. property Direction : TLogIterateDirection read FDirection write SetDirection; Направление, в котором идет перемещение по журналу при вызове Next.

Примечание:
при написании использовались модули из библиотеки Jedi WinAPI Library (JWA).
Библиотеку можно найти здесь

Скачать пример, иллюстрирующий работу классов: (10.7K)

Ссылки по теме:

Наследник TComboBox, показывающий Hint для строки в ListBox'овой части, не видимой целиком.

Раздел Сокровищница

рь Шевченко, дата публикации 17 апреля 2002г.

Ограничения: Компонент проверялся при работе с значением Style: csDropDown, csDropDownList. при остальных значениях работа не гарантируется :-) Компонент не тестировался в режиме design-time. История изменений: 16.04.2002 Исправлено поведение при закрытии, когда показан hint и ComboBox закрывается по клавише Enter, Escape или F4. Теперь hint убирается. Добавлено свойство HorizontalExtent, позволяющее устанавливать горизонтальный Scrollbar в списке ComboBox'a. По умолчанию свойство имеет значение -1, что запрещает установку горизонтального ScrollBar'а.

Скачать компонент (5 K)

Настройка DCOM при помощи DCOMCNFG.EXE

Закладка DefaultProperties

Элемент	Значение	9x	NT
Enable Distributed COM on this computer	True	+	+
Enable COM Internet Services on this computer	Не имеет значения	-	+
Default Authentication Level	None	+	+
Default Impersonation Level	Impersonate	+	+
Provide additional security for reference tracking	False	+	+

Закладка DefaultSecurity

Элемент	Значение	9x	NT
Enable remote connection	True	+	-
Default access permissions	Everyone = allow access	-	+
Default access permissions	The world = grant access	+	-
Default launch permissions	Everyone = allow launch	-	+

Закладка Applications Позиционироваться на сервер.exe. Кнопка "Properties..."

Закладка Location

Элемент	Значение	9x	NT
Run application on the computer where the data is located	False	+	+
Run application on this computer	True	+	+
Run application on the following computer	False	+	+

Закладка Security

Элемент	Значение	9x	NT
Use default access permissions	True	+	+
Use default launch permissions	True	-	+
Use custom configuration permissions	False	-	+

Закладка Identity

Элемент	Значение	9x	NT
Which user account do you want to use to run this application	The interactive user	-	+

Небольшое оступление.

В принципе, написать что-либо не так сложно, если имеешь в голове какую-то идею и если подойти к реализации этой идеи с верной стороны, сложно начинать писать с нуля. Весь пыл растрачивается еще на подступах - в процессе написания стартовой площадки.
Сама идея с написанием своего репорта, в общем-то, появилась легко: Нужен готовый компонент с окном предварительного просмотра с минимальным набором функций (в идеале умеющий только переключаться между просмотром/печатью и поддерживающий режим масштабирования изображения на "листе"). Нужен буфер, куда_будут_писаться/откуда_будут_считываться все объекты печати (линии, прямоугольники, текст, картинки...). Необходимы свобода действий и творчества. Желательна легкость расширения функций. Итааак, цель ясна, желание есть (а это самое главное) - зарываемся в архивы в поисках той самой стартовой площадки... И понимаем, что в следующий раз, создавая архивы, надо присваивать им (архивам) более конкретные имена, потому что память наотрез отказывается помнить все сокращения в именах файлов, назавая все это бессмысленным набором букв.
Пролистывая архивы с сокращениями типа "Rpt" и "Rep", натолкнулся на некий "PrnSvr", в комментариях которого обнаружил следующее: "Компонент предназначен для реализации всех функций, связанных с выводом на печать: выбор принтера, его настройка, предварительный просмотр и собственно печать." - ну вы поняли, да? - на блюдечке с голубой каемочкой. Остальное дело техники: берем его за основу, зачищаем; берем идею, набиваем ее на клавиатуре; привинчиваем к основе; красим и смотрим, что получилось - в общем получилось примерно то, что и задумывал. Слово за Вами, господа. Если не понравится удалим из королевства (буду сам пользоваться), если понравится - оставим. На ошибки и дополнения постараюсь отреагировать.

Несколько функций для работы со списками

Добавление группы в список TListView

procedure AddToListView(LV: TListView; Par: array of string); var NI : TListItem; i: integer; begin NI := LV.Items.Add; NI.Caption := Par[Low(Par)]; for i := 1 to (High(Par) - Low(Par)) do NI.SubItems.Append(Par[i]); end;

Удаление элемента из листа TList.

Достаточно универсальна, хотя требуется не так часто. procedure RemovePtrFromList(L: TList; P: pointer); var i: integer; begin if not Assigned(L) then Exit; i := L.IndexOf(P); if i >= 0 then L.Delete(i); end;

Добавить объект в список, если такого еще нет.

procedure IncludePtrToList(L: TList; P: pointer); var i: integer; begin if not Assigned(L) then Exit; i := L.IndexOf(P); if i < 0 then L.Add(P); end;

Алексей Еремеев

Но к делу

Взявшись оформлять этот пример для общественности, я понял, что меняются не только времена и люди, но и исходники лежащие в архиве. Да их не узнать! Да неужели это писал я? Да... точно... странно... Но ведь он все еще работает! Вдвойне странно... Так что если что - сильно не ругаться - я был молодой и временами делал некрасивости. Старинный закон гласит: последняя ошибка программы выявляется через 7 лет эксплуатации. Если вы заметили ошибку, которой не заметил я - то буду благодарен, если вы мне о ней напишите. Я, пожалуй, не буду следовать примеру Д. Кнута и высылать деньги за замеченные ошибки, но спасибо скажу :).

О компоненте TListView

В этом компоненте есть один недостаток - нет обычный средств для того, чтобы определить редактируется ли в данный момент один из пунктов этого компонента. Например в компоненте TStringGrid есть для этого свойство EditorMode. А тут вообще ничего нету. Поэтому, кстати, в прошлой версии программы производилась очень кривая проверка на этот счет. Я все-таки нашел как это можно узнать. Естественно на помощь приходит Api Windows. Там есть такая функция: ListView_GetEditControl, в качестве параметра которой нужно указать дескриптор окна TListView. Эта функция возвращает дескриптор компонента, в котором происходит редактирование пункта компонента TListView. Если же компонент не редактируется, то она возвращает ноль. Но это все описывается в справочной системе. Плюс там еще есть куча полезный функций этого же типа с соответствующими сообщениями, которые возможно будут полезны. Но большая их часть, конечно, реализована в компоненте TListView обычными дельфивскими методами или свойствами. Я на всякий случай приведу их полный список: LVM_ARRANGE ListView_Arrange LVM_CREATEDRAGIMAGE ListView_CreateDragImage LVM_DELETEALLITEMS ListView_DeleteAllItems LVM_DELETECOLUMN ListView_DeleteColumn LVM_DELETEITEM ListView_DeleteItem LVM_EDITLABEL ListView_EditLabel LVM_ENSUREVISIBLE ListView_EnsureVisible LVM_FINDITEM ListView_FindItem LVM_GETBKCOLOR ListView_GetBkColor LVM_GETCALLBACKMASK ListView_GetCallbackMask LVM_GETCOLUMN ListView_GetColumn LVM_GETCOLUMNWIDTH ListView_GetColumnWidth LVM_GETCOUNTPERPAGE ListView_GetCountPerPage LVM_GETEDITCONTROL ListView_GetEditControl LVM_GETIMAGELIST ListView_GetImageList LVM_GETISEARCHSTRING ListView_GetISearchString LVM_GETITEM ListView_GetItem LVM_GETITEMCOUNT ListView_GetItemCount LVM_GETITEMPOSITION ListView_GetItemPosition LVM_GETITEMRECT ListView_GetItemRect LVM_GETITEMSPACING ListView_GetItemSpacing LVM_GETITEMSTATE ListView_GetItemState LVM_GETITEMTEXT ListView_GetItemText LVM_GETNEXTITEM ListView_GetNextItem LVM_GETORIGIN ListView_GetOrigin LVM_GETSELECTEDCOUNT ListView_GetSelectedCount LVM_GETSTRINGWIDTH ListView_GetStringWidth LVM_GETTEXTBKCOLOR ListView_GetTextBkColor LVM_GETTEXTCOLOR ListView_GetTextColor LVM_GETTOPINDEX ListView_GetTopIndex LVM_GETVIEWRECT ListView_GetViewRect LVM_HITTEST ListView_HitTest LVM_INSERTCOLUMN ListView_InsertColumn LVM_INSERTITEM ListView_InsertItem LVM_REDRAWITEMS ListView_RedrawItems LVM_SCROLL ListView_Scroll LVM_SETBKCOLOR ListView_SetBkColor LVM_SETCALLBACKMASK ListView_SetCallbackMask LVM_SETCOLUMN ListView_SetColumn LVM_SETCOLUMNWIDTH ListView_SetColumnWidth LVM_SETIMAGELIST ListView_SetImageList LVM_SETITEM ListView_SetItem LVM_SETITEMCOUNT ListView_SetItemCount LVM_SETITEMPOSITION ListView_SetItemPosition LVM_SETITEMPOSITION32 ListView_SetItemPosition32 LVM_SETITEMSTATE ListView_SetItemState LVM_SETITEMTEXT ListView_SetItemText LVM_SETTEXTBKCOLOR ListView_SetTextBkColor LVM_SETTEXTCOLOR ListView_SetTextColor LVM_SORTITEMS ListView_SortItems LVM_UPDATE ListView_Update

Скачать: 97K
4K
1K

О назначении пользовательского TNotifyEvent

Раздел Сокровищница

ний Колеватов, дата публикации 14 мая 2002г.

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

Все просто стоит только обратить внимание что определение TNotifyEvent = procedure(Sender: TObject) of object; а сие значит что These types represent method pointers. A method pointer is really a pair of pointers; the first stores the address of a method, and the second stores a reference to the object the method belongs to. Given the declarations (Delphi help :)) главное не забыть что при обьявлении процедуры надо указать пару указателей procedure MyProcOnClick(P1,P2 :pointer); begin if P2<>nil then Showmessage(TComponent(P2).Name); end; procedure TForm1.Button1Click(Sender: TObject); begin @Button2.OnClick := @MyProcOnClick; end; Вот и все теперь при нажатии на кнопку два выполниться процедура MyProcOnClick, P2 указывает на обьект Button2

О нестандартном выводе в DBGrid и StringGrid

Раздел Сокровищница

1. Во многих FAQ-ах и книгах по Delphi приходилось видеть процедуры нестандартной закраски отдельных ячеек DBGrid. Однако при их исполнении текст отформатирован по левому краю и располагается по высоте ячейки не так, как в ячейках стандартного вывода. Ниже привожу пример обработчика события OnDrawColumnCell для сетки gAg: TDBGrid, где эти проблемы сняты для случая форматирования по правому краю:

procedure TfAg.gAgDrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState); var r: TRect; begin With gAg.Canvas do begin if not (gdFocused in State) and (Column.Field.AsString = '-1') and (Column.FieldName = 'PointN') then begin Brush.Color:= clRed; // цвет подложки - красный Font.Color:= clWhite; // цвет символов - белый FillRect(Rect); // закраска всей ячейки With Sender as TDBGrid do begin r:= KdnRect(Rect,0,2,-3,0); //уменьшенный и смещенный Rect //нестандартный вывод DrawText(Canvas.Handle, PChar(Column.Field.Text), Length(Column.Field.Text),r, DrawTextBiDiModeFlags(DT_RIGHT)); end; end else // стандартный вывод gAg.DefaultDrawColumnCell(Rect, DataCol, Column, State); end; end;

На Рисунок 1 приведен фрагмент сетки, сформированной этим обработчиком.

Рисунок 1. Фрагмент DBGrid с нестандартной закраской отдельных ячеек и форматированием их содержимого по правому краю и по высоте ячейки

Процедура выводит нестандартно только значения -1 в ячейки столбеца PointN сетки fAg. Суть состоит в использовании уменьшенного Rect-а, сформированного по базовому Rect с помощью функции KdnRect (текст приведен ниже) с последующей подгонкой уменьшенного Rect-а под формат стандартного вывода и рисованием содержимого ячейки по нужному формату выравнивания. Так, уменьшенный r смещен по отношению к Rect вниз на 2 (2), правая граница смещена влево на 3 (-3). Константа DT_RIGHT указывает на способ форматирования. Для того, чтобы вывести текст в центре ячейки следует константу DT_RIGHT заменить на DT_CENTER. При этом оператор формирования r лучше заменить на r:= KdnRect(Rect,0,2,0,0) с целью использования всей ширины ячейки.

function KdnRect(Rect: TRect; DLeft,DTop,DRight,DBottom: Integer): TRect; begin With Result do begin Left:= Rect.Left + DLeft; Top:= Rect.Top + DTop; Right:= Rect.Right + DRight; Bottom:= Rect.Bottom + DBottom; end; end;

Аналогичная проблема может быть решена

2. Аналогичная проблема может быть решена для StringGrid. Привожу пример обработчика события OnDrawCell. Он выводит нестандартно во все ячейки, а ячейку, координаты которой совпадают с внешними параметрами SgKritCol, SgKritRow, красит желтым цветом. Пример фрагмента сетки StringGrid показан на Рисунок 2.

procedure TfAg.SgKritDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); var r: TRect; begin With Sender as TStringGrid do begin With Canvas do begin if (SgKritCol = ACol) and (SgKritRow = ARow) then Brush.Color:= clYellow else Brush.Color := clWhite; Font.Color:= clBlack; FillRect(Rect); end; r:= KdnRect(Rect,0,4,-3,0); DrawText(Canvas.Handle, PChar(SgKrit.Cells[ACol, ARow]), Length(SgKrit.Cells[ACol, ARow]),r, DrawTextBiDiModeFlags(DT_RIGHT)); end; end;

Рисунок 2. Фрагмент StringGrid с нестандартной закраской ячейки и форматированием ее содержимого по правому краю и по высоте ячейки

Коднянко Владимир
Красноярск, 17.05.2002

Смотрите по теме: Компонент TStringGrid - назначение цвета для каждой строки, вывод содержимого ячейки в несколько строк

Обмен текстовой информацией между модулями проекта

й Перовский, дата публикации 20 февраля 2003г.

При написании программ я всегда старался четко отделять пользовательский интерфейс от алгоритма задачи.
С появленинием в Delphi ActionList'а стало гораздо проще писать алгоритмическую часть без оглядки на структуру пользовательского интерфейса.

Но осталась проблема отображения информации: в некоторой точке программы требуется вывести сообщение, а куда выводить неизвестно.
Разработчик интерфейса еще не решил, что выводить в StatusBar, что в MessageBox. Какую отладочную информацию поместить в логфайл. Я решаю эту проблему следующим образом — во всех существенных точках алгоритма вызывается процедура ToLog.
Два ее параметра определяют текст сообщения и ее предназначение. 256 "каналов" должны быть поделены между сообщениями об ошибках, отладочной информацией, информационными сообщениями и результатами.

Это единственное соглашение, которое должны соблюдать все участники проекта. Разработчик интерфейса решает для компонента - сообщения из каких каналов он должен отображать и регистрирует соответствующий объект (Log). "Расчетные" модули могут не ссылаться на модули с описанием форм и диалогов. Единственный модуль, через который они общаются - и на который обязаны ссылаться (причем в implementation разделе) это uLogs.

Модуль uLogs предназначен для передачи текстовых сообщений между различными модулями, визуальными компонентами и файлами. Для разделения сообщений различных типов введено 256 "каналов". Каждому сообщению должен быть сопоставлен номер канала, определяющий цель сообщения и технологию его обработки. Для протоколирования и/или визуализации сообщений предназначены специальные объекты "Логи" - наследники базового объекта TLog. Каждый "лог" может обрабатывать все сообщения из заданного множества каналов. Логи разных типов различаются способом фиксации или отображения информации.
В модуле описано 5 различных наследников абстрактного класса TLog. По их образцу легко создать классы для других способов обработки сообщений.

Обработка сообщений от мыши потомками собственного компонента

Проблема: имеем свой собственный компонент, который может содержать несколько объектов с собственным внешним видом, каждый из которых должен реагировать на перемещение мыши.
Например -- подсвечиваться.
Для гуру: ничего интересного вы здесь не найдёте, примерчик это не более, чем пропаганда использования стандартного оконного механизма в противовес различным самоизобретённым велосипедам.
Классы: класс TMyControl -- основной компонент; TMySubControl -- класс того объекта, который будет лежать на TMyControl и подсвечиваться.

Наследование от TGraphicControl необязательно. Фактически, можно выбирать из четырёх вариантов: TControl базовый класс всех элементов управления, не имеет виндовского Handle(дескриптора) окна, т.е. данный элемент Windows не считает окном; вся реализация сообщений, отрисовки и пр. выполняется в VCL; (+) -- меньше кушает ресурсов, (-) -- см. TWinControl TGraphicControl то же, что и TControl, но имеет свойство Canvas, при помощи которого удобно рисовать и метод Paint, в котором надо рисовать TWinControl это полноценное Windows-окно со всеми преимуществами перед TControl: (а) может получать фокус ввода, (б) может содержать "детей" -- другие окна на своей поверхности, (в) -- имеет дескриптор, св-во Handle TCustomControl наследник TWinControl, отличия между ними те же, что и между TControl и TGraphicControl Выбран TGraphicControl по причине отсутствия "детей" и наличия Canvas.

Данные, составляющие компонент: FItem: TCollectionItem входит в какую-либо коллекцию и, собственно, содержат смысловое наполнение элемента. Я встречал вариант, когда у TMyControl не определялись "дети", а в качестве реакции на WM_PAINT перебирались элементы некоторой коллекции, которые кроме смысловых данных хранили свой контур, координаты и пр. и ручками всё это рисовалось... Жуть! Собственно, мой пример -- антиреклама описанного подхода

Скачать файл (3K)

unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, Buttons, ComCtrls; type TMySubControl = class(TGraphicControl) private FSelected: Boolean; //флаг, отмечающий подсвеченность FItem: TCollectionItem; procedure SetMouseOver(Val: Boolean); procedure MsMove(var M: TWMMouseMove); message WM_MOUSEMOVE; { Реакция на перемещение мыши } protected procedure Paint(); override; //по этому сообщению надо перерисовывать public constructor Create(AOwner: TComponent); override; destructor Destroy(); override; property IsSelected: Boolean read FSelected write SetMouseOver; { Свойство, отмечащее факт "подсвеченности" } end; { "Главный" элемент управления. Собственную процедуру отрисовки я не определял, а "дети" есть. Поэтому -- TWinControl } TMyControl = class(TWinControl) private procedure MsMove(var M: TWMMouseMove); message WM_MOUSEMOVE; public constructor Create(AOwner: TComponent); override; end; { Класс основной формы. Ничего интересного } TMain = class(TForm) CloseButt: TBitBtn; Label1: TLabel; Label2: TLabel; procedure CloseWndExecute(Sender: TObject); procedure FormCreate(Sender: TObject); private public end; var Main: TMain; implementation {$R *.DFM} { По кнопочке "Закрыть" } procedure TMain.CloseWndExecute(Sender: TObject); begin Close(); end; { Создание элементов вручную. Главное: вызвать конструктор, задать размеры и положение, назначить "родителя". Поскольку пакеты не используются, то на автомате создать их не выйдет. } procedure TMain.FormCreate(Sender: TObject); var c: TMyControl; begin c := TMyControl.Create(Self); with c do begin SetBounds(8, 8, 240, 180); Color := clTeal; Parent := Self; //"родитель" -- формочка end; with TMySubControl.Create(Self) do begin SetBounds(3, 7, 49, 11); Parent := c; //у всех TMySubControl родитель -- TMyControl end; with TMySubControl.Create(Self) do begin SetBounds(140, 53, 94, 25); Parent := c; end; with TMySubControl.Create(Self) do begin SetBounds(38, 100, 88, 70); Parent := c; end; end; { Мониторинг перемещений мыши по основному control-у. Отметьте, что когда курсор над "детьми", control не получает данное сообщение. } procedure TMyControl.MsMove(var M: TWMMouseMove); begin inherited; Main.Label1.Caption := Format('%d:%d', [M.XPos, M.YPos]); end; { Добавляем стиль 3D-рамки. Её отрисовка производится стандартными средствами винды. } constructor TMyControl.Create(AOwner: TComponent); begin inherited; ControlStyle := ControlStyle + [csFramed]; end; { Перерисовка. Простой прямоугольник. Цвет -- стандартный или подсвеченный, в зависимости от IsSelected } procedure TMySubControl.Paint(); const a: array[Boolean] of TColor = (clWindow, clHighlight); begin inherited; Canvas.Brush.Color := a[IsSelected]; Canvas.FillRect(Canvas.ClipRect); with Canvas.ClipRect do //показываем -- какая именно часть перерисовывается Main.Label2.Caption := Format('(%d:%d) - (%d:%d)', [Left, Top, Right, Bottom]); end; { Смена значения свойства. Только один из TMySubControl может быть подсвеченным } procedure TMySubControl.SetMouseOver(Val: Boolean); var i: Integer; begin if Val <> FSelected then begin Invalidate(); //если изменилась подсветка, то надо перерисоваться if Val then //нас подсветили (Val = TRUE) for i := Parent.ControlCount - 1 downto 0 do //среди "братьев" ищем другие TMySubControl и снимаем им подсветку if (Parent.Controls[i] <> Self) and (Parent.Controls[i] is TMySubControl) then TMySubControl(Parent.Controls[i]).IsSelected := FALSE; FSelected := Val; end; end; procedure TMySubControl.MsMove(var M: TWMMouseMove); begin IsSelected := TRUE; //над нами переместили мышку -- значит подсветили end; constructor TMySubControl.Create(AOwner: TComponent); begin inherited; FItem := TCollectionItem.Create(nil {тут произвольный объект-коллекция, например его можно указать в параметрах конструктора}); end; destructor TMySubControl.Destroy(); begin FItem.Free(); inherited; end; end.

Общее

В прошлой статье я подробно описал программу, все ее возможности сохранились в полной мере и сейчас, появилось только несколько нововведений. Когда программа требует ввести какое-либо значение его можно вводить как угодно. То есть можно вводить любой сивол (в старой программе это тожно можно было сделать, но не во всех компонентах). Если он будет неправильным (нечисловой величиной), то она преобразуется в соответствующий Ansi код. В окне просмотра в компоненте ViewGrid в десятеричном режиме можно вводить любые тесковые символы, т.е. по сути писать текст, если надо. Плюс в этом же компоненте слева появился новый столбик в котором отображается адрес ближайшей к нему ячейки. Плюс некоторые мелкие доработки, как автоматическая фокусировка выбранной в ячейке в компоненте ViewGrid и т.д. Также в компонентах DataGrid и ListView (через точку с запятой) тоже можно также вводить произвольные значения. В форме просмотра появились компоненты типа TEdit в которых отображается текущая величина выбранно ячейки. Эти компоненты представляют собой числа величинами 8, 16, 32 бита в знаковом и беззнаковом вариантах. Чтобы изменить значения в ячейке, можно вводить данные прямо в соответствующий компонент типа TEdit.

Ограничения текущей версии

В ситуациях, когда входному выражению соответствует обратная польская запись вида: a b c d e f g h i + + + + + + + + , где число подряд идущих переменных больше восьми, а также в некоторых других неудачных случаях, модуль откажется генерировать код функции.

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

Кроме того, для нормальной работы придется отключить Tools/Debugger options/Language Exceptions/Stop on Delphi Exceptions, иначе будет довольно утомительно: при анализе исключения возникают десятками.

Описание программы "Репликатор"

Для начала, скачаем и установим программу "Репликатор", благо она распространяется свободно. Войдём в программу под именем и паролем администратора (SYSDBA). Входим в меню Репликация -> Генерация базы данных.

В верхней таблице перечисляются проекты и пути к базам данных. В нижней таблице перечисляется последовательность копируемых таблиц. Копируются те таблицы, у которых установлена галочка в поле И (Используется). Поле ID должно быть уникальным во всех проектах. Если указана галочка Блокировать все триггера, то перед копированием информации будут отключены триггера, а после копирования - опять включены. То же относится к индексам и ограничениям. Если стоит галочка Выполнять скрипты, то при копировании будут выполняться скрипты, названия файлов которых перечислены в закладке Файлы скриптов. Если у Вас имя и пароль администратора не совпадает с SYSDBA, masterkey, то Вам понадобится указать имена и пароли в закладке Пароли.

Определение установленных версий .NET Framework в системе

Определение установленных версий .NET Framework в системе. Пример на Delphi.

/// <summary> /// Enumerates all installed Common Language Runtime Engines. /// </summary> /// <param name="Index">Zero-based index of looked runtime record.</param> /// <returns>True if runtime with specified index found.</returns> function EnumInstalledRuntimes(Index: Integer; out VersionName: String): Boolean; var hkey: Windows.HKEY; hsubkey: Windows.HKEY; I: Cardinal; J: Cardinal; NameBuf: array[0..MAX_PATH] of Char; CNameBuf: Cardinal; lwt: TFileTime; vt: DWORD; AnyFound: Boolean; begin Result := False; VersionName := ''; if ERROR_SUCCESS = RegOpenKeyEx(HKEY_LOCAL_MACHINE, PChar('SOFTWARE\Microsoft\.NETFramework\policy'), 0, KEY_ENUMERATE_SUB_KEYS, hkey) then try I := 0; while True do begin AnyFound := False; CNameBuf := MAX_PATH + 1; if ERROR_SUCCESS <> RegEnumKeyEx(hkey, I, @NameBuf[0], CNameBuf,nil, nil, nil, @lwt) then begin Break; end; if (NameBuf[0] = 'v') and (NameBuf[1] in ['1'..'9']) then begin VersionName := String(NameBuf); if ERROR_SUCCESS = RegOpenKeyEx(hkey, @NameBuf[0], 0,KEY_QUERY_VALUE, hsubkey) then try J := 0; while true do begin CNameBuf := MAX_PATH + 1; if ERROR_SUCCESS <> RegEnumValue(hsubkey, J, @NameBuf[0],CNameBuf, nil, @vt, nil, nil) then begin Break; end; if (vt = REG_SZ) and (NameBuf[0] <> #0) then begin VersionName := VersionName + '.' + String(NameBuf); AnyFound := True; Break; end; Inc(J); end; finally RegCloseKey(hsubkey); end; end; Inc(I); if AnyFound then begin if Index = 0 then begin Result := True; Break; end; Dec(Index); end; end; finally RegCloseKey(hkey); end; end;

Для данного материала нет комментариев.

Ошибка в процедуре _AddRefArray в Delphi 5 и ее исправление

Мотов, дата публикации 10 января 2003г.

Эта ошибка была обнаружена и исправлена "за бугром" еще в 2000 г. Однако, когда в фидо возник вопрос по этому поводу, никто не привел метода решения этой проблемы. Эта ошибка исправлена в Delphi6, но так как многие еще продолжают использовать Delphi5, то в данном материале предлагается описание ошибки и метод ее исправления.

Итак...

В Delphi 5 есть ошибка в процедуре _AddRefArray в модуле System.pas. Если вы попробуете выполнить следующий код, то получите сообщение об ошибке: Invalid variant operation.

procedure func(p: array of variant); begin if Length(p) > -1 then ShowMessage(p[0]); end; procedure TForm1.Button1Click(Sender: TObject); begin func([]); end

Дело в том, что компилятор Delphi автоматически вставляет в код процедуры func вызов _AddRefArray, а эта процедура не может корректно работать с пустым массивом.

Исправить ошибку несложно, достаточно добавить проверку на количество элементов массива в процедуру _AddRefArray, которая находится в модуле system.pas. Исправленный текст _AddRefArray приведен ниже:

procedure _AddRefArray { p: Pointer; typeInfo: Pointer; elemCount: Longint}; asm { -> EAX pointer to data to be referenced } { EDX pointer to type info describing data } { ECX number of elements of that type } PUSH EBX PUSH ESI PUSH EDI TEST ECX,ECX JZ @@exit MOV EBX,EAX MOV ESI,EDX MOV EDI,ECX ...

Затем надо скомпилировать system.pas с отладочной информацией и без и заменить файлы Delphi5\lib\system.dcu и Delphi5\lib\Debug\system.dcu. Для этого я написал небольшой bat-файл, который надо поместить в каталог Delphi5\Source\Rtl и запустить его на выполнение.

del lib\system.dcu make copy lib\system.dcu ..\..\lib\system.dcu del lib\system.dcu make -DDEBUG copy lib\system.dcu ..\..\lib\Debug\system.dcu

Хочу заметить, что для компиляции требуется файл tasm32.exe, который не поставляется с Delphi.

После выполнения этих действий ошибка будет устранена. Однако остается одна нерешенная проблема - в проекте нельзя использовать пакет времени выполнения vcl50.bpl. Если собрать проект с использованием пакетов, то будет использована функция не из исправленного модуля system.dcu а из пакета vcl50.dcu. Ситуация усугубляется тем, что модуль vcl50.bpl нельзя корректировать.

Другой способ исправления _AddRefArray я нашел на , желающие могут обратиться по

Идея оказалась очень простой - раз нельзя исправить процедуру _AddRefArray в файле vcl50.bpl, значит ее нужно исправить в памяти программы во время работы. Ниже я привожу исходный текст, который я оставил практически без изменений:

unit PatchAddRefArray; interface implementation uses Windows; var NewAddRefArray: Pointer; OldAddRefArray: Pointer; procedure _NewAddRefArray { p: Pointer; typeInfo: Pointer; elemCount: Longint}; asm { -> EAX pointer to data to be referenced } { EDX pointer to type info describing data } { ECX number of elements of that type } { проверка на количество элементов в массиве} TEST ECX, ECX JZ @exit { старый код затертый командой перехода} PUSH EBX PUSH ESI PUSH EDI MOV EBX,EAX MOV ESI,EDX { продолжить выполнение процедуры _AddRefArray} JMP OldAddRefArray @exit: end; type TJumpDWord = packed record OpCode: Word; Distance: Pointer; end; PJumpDWord = ^TJumpDWord; PPointer = ^Pointer; const // Несколько инструкций из AddRefArray: // PUSH EBX, PUSH ESI и т.д. COrigARACode = $89D689C389575653; // JMP CJmpCode = $25FF; procedure PatchAddRef; var Jmp: TJumpDWord; Addr: ^TJumpDWord; OldProtect: DWORD; begin {Получить адрес процедуры AddRefArray} asm mov eax, offset System.@AddRefArray mov Addr, eax end; {Переход к телу процедуры AddRefArray} while Addr^.OpCode = CJmpCode do Addr := PPointer(Addr^.Distance)^; {Сравнить начало процедуры AddRefArray с ее "сигнатурой" если совпадает, значит это та процедура, которую мы ищем} if PInt64(Addr)^ = COrigARACode then begin OldAddRefArray := Pointer(Integer(Addr) + SizeOf(TJumpDWord) + 1); NewAddRefArray := @_NewAddRefArray; Jmp.OpCode := CJmpCode; Jmp.Distance := @NewAddRefArray; VirtualProtect(Addr, SizeOf(TJumpDWord), PAGE_READWRITE, OldProtect); Addr^ := Jmp; VirtualProtect(Addr, SizeOf(TJumpDWord), OldProtect, OldProtect); end; end; initialization PatchAddRef; end.

Исходный текст очевиден и не требует дополнительных комментариев.

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

Олег Мотов
январь 2003г.
домашняя страница материала нет комментариев.

Отдельное спасибо

(да я знаю, что благодарности помещают в конце, но там их редко кто читает :))
так вот отдельное спасибо:
Спасибо человеку, который сделал из меня программиста.
Спасибо Королеве Елене Филипповой. Если вы здесь, то вы знаете за что.:)
Эта программа написана в то время когда меня можно было легко "взять на "слабо"". Так вот спасибо тому кто меня подначил на ее написание :)

Открытие файлов DFM версий 5 и 6 в младших версиях

Раздел Сокровищница

Появление новых версий Delphi затруднило жизнь (программистскую) тех, кто остался верен версии 4: она не может открыть проект, созданный ее потомками.

Причина проста - файлы формы сохранили расширение (DFM), но принципиально изменили содержание: в версии 4 они имели двоичный формат, в следующих версиях - стали текстовыми. Однако разработчики отказались от использования стандартного для таких файлов расширения TXT (видимо, чтобы народ не пытался работать с ними в обычных текстовых редакторах - может плохо кончиться), и новое расширение ввести не решились (DFT, например). В результате открытие проекта, созданного под версией 5-6, в версии 4 сопровождается сообщением об ошибке создания формы из-за неверного формата потока - и форма не создается. Соответственно проект невозможно использовать.

Выход, однако, есть, и даже два. Один заложен в самой Delphi: в папке BIN есть утилита convert.exe, которая как раз и занимается переводом файла формы из двоичного формата (с расширением DFM) в текстовый (с расширением TXT) и обратно. Единственная тонкость - нужно вручную сменить расширение файла формы из проекта версий 5-6: вместо DFM должно стать TXT. Дальше утилита легко создаст файл формы в родном формате с нужным расширением.

Второй вариант (если менять расширение не хочется) - воспользоваться специальными утилитами: Утилита dfmconv.exe от Markus Stephany из Германии (, архив dfmconv.zip объемом 61 Кб содержит также исходные тексты утилиты): она бесплатно (по лицензии GNU) сделает все преобразования, причем исходный файл тоже сохранит. Утилита D4toD5 c сайта (zip-архив exe-файла утилиты объемом 240 К). Преобразует текстовое представление форм (DFM-файлы Delphi 5) в двоичное (Delphi 4) в указанном каталоге. Исходные тексты не предоставляются.

Таким образом, притормозившие на версии Delphi-4 вполне могут изучать самые современные проекты. Простая смена формата - вовсе не повод для огорчений или спешной закупки новой версии Delphi. Конечно, в версиях 5 и 6 огромное количество преимуществ и достоинств, но если версия 4 справляется со всеми вашими задачами - не надо тратить деньги.

Отображение длинных строк при движении мыши по списку для нескольких TListBox.

Раздел Сокровищница

анович Олег, дата публикации 19 марта 2002г.

При движении по списку TListBox содержимое каждой строки показывается с помощью Hint-а. Код поддерживает обработку нескольких TListBox на форме.

{Вставляем в раздел public вашей формы:} procedure ShowHint (var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); {Вставляем где нибудь после implementation:} procedure TForm1.ShowHint (var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); var ListRect,a: TRect; begin with HintInfo do begin {Здесь необходимо указать все ListBox на вашей форме, например в этом случае это ListBox1 и ListBox2} if (HintControl = ListBox1)or(HintControl = ListBox2) then with HintControl as TListBox do begin if (ItemAtPos(CursorPos,true)<>-1)and (Canvas.TextWidth(items.Strings[ItemAtPos(CursorPos,true)]) > ItemRect(ItemAtPos(CursorPos,true)).Right-2)then begin HintStr := items.Strings[ItemAtPos(CursorPos,true)]; ListRect := ClientRect; ListRect.Top := ListRect.Top + (ItemAtPos(CursorPos,true)-TopIndex)*ItemHeight; ListRect.Bottom := ListRect.Top + ItemHeight; CursorRect := ListRect; GetWindowRect(Handle,a); HintInfo.HintPos:=Point(ListRect.Left+a.Left+1,ListRect.Top+a.Top-1); end; end; end; end; {В обработчике FormShow формы прописываем:} Application.OnShowHint := ShowHint; Application.HintHidePause:=5000; //Время которое будет держаться Hint. Application.HintPause:=300; //Время перед появлением Hint'а. {В обработчике FormHide формы прописываем:} Application.HintHidePause:=2500; Application.HintPause:=500; Во всех ListBox'ах устанавливаем свойсто ShowHint в True

Агранович Олег

Смотрите по этой теме:

Отправка SMS на мобильные телефоны МТС

Раздел Сокровищница

Я долго мучался над этой проблемой, и наконец нашёл оптимальное ДЛЯ СЕБЯ решение: набрасываем NMHTTP nmhttp1.HeaderInfo.Referer:='www.mts.ru'; nmHTTP1.Get('http://www.mts.ru/sms/sent.html?Posted=1&To=ПОЛНЫЙ НОМЕР ТЕЛЕФОНА&Msg=СООБЩЕНИЕ&count=ДЛИНА СООБЩЕНИЯ БЕЗ ПРОБЕЛОВ&SMSHour=1&SMSMinute=16&SMSDay=12&SMSMonth=11&SMSYear=2001'); Буду рад, если это кому поможет.

Парсер комбинированных выражений

Раздел Сокровищница

рь Серебренников, дата публикации 22 января 2002г.

Долго искал парсер и компилятор комбинированных выражений, но так и не нашел - только математика. Пришлось сделать самому.

Парсер вычисляет любые выраженя, состоящие из констант, функций и знаков действий (операций) между ними. Костанты четырех типов - целочисленные, вещественные, строки и логические. Операции - какие душе угодно, функции - тоже. Результатом вычислений является запись - упрощенный аналог типа Variant (нужно было для переноса на C++).

Примеры выражений: 2**2+4 "Pi is "+3.14 'The bool expression is ' + iif(2>3 && !('A' < 'B'), "True", "False") "Html YELLOW is ""#" + Hex(0xff 1. Парсер работает с четырьмя типами выражений - число double (123.456) - число integer (123, 0xff) - булево true/false - строка ( "a string", 'a string', " a ""string""") 2. Парсер допускает вызов функций Опрерации, приоритеты Op U/B Pr Comment - U Изменение знака числа + B Сложение чисел, конкатенация строк - B Вычитание одного числа из другого * B Перемножение чисел / B Деление чисел ** B Возведение в степень % B Остаток от деления ~ U Побитная инверсия целого числа | B or двух целых чисел & B and двух целых чисел ^ B xor двух целых чисел >> B побитный сдвиг вправо B == B != B = B

Скачать исходные коды: (11K)

Перехват меню IE ( TWebBrowser ) и подмена его собственным PopupMenu

Раздел Сокровищница

рь Серебренников , дата публикации 29 августа 2001г.

После ответа на вопрос КС о блокировании контекстного меню IE (), получил кучку писем с просьбой выслать модуль, который это делает.
Думаю, такая информация полезна для народа.

Модуль просто подключается к проекту. После этого все меню (TWebBrowser.PopupMenu) начинают работать нормально.

unit WbPopup; interface // Для преобразования кликов правой кнопкой в клики левой, раскомментировать // {$DEFINE __R_TO_L} implementation uses Windows,Controls,Messages,ShDocVw; var HMouseHook:THandle; function MouseProc( nCode: Integer; // hook code WP: wParam; // message identifier LP: lParam // mouse coordinates ):Integer;stdcall; var MHS:TMOUSEHOOKSTRUCT; WC:TWinControl; {$ifdef __R_TO_L} P:TPoint; {$endif} begin Result:=CallNextHookEx(HMouseHook,nCode,WP,LP); if nCode=HC_ACTION then begin MHS:=PMOUSEHOOKSTRUCT(LP)^; if ((WP=WM_RBUTTONDOWN) or (WP=WM_RBUTTONUP)) then begin WC:=FindVCLWindow(MHS.pt); if (WC is TWebBrowser) then begin Result:=1; {$ifdef __R_TO_L} P:=WC.ScreenToClient(MHS.pt); if WP=WM_RBUTTONDOWN then PostMessage(MHS.hwnd,WM_LBUTTONDOWN,0,P.x + P.y shl 16); if WP=WM_RBUTTONUP then PostMessage(MHS.hwnd,WM_LBUTTONUP,0,P.x + P.y shl 16); {$endif} if (TWebBrowser(WC).PopupMenu<>nil) and (WP=WM_RBUTTONUP) then begin TWebBrowser(WC).PopupMenu.PopupComponent:=WC; TWebBrowser(WC).PopupMenu.Popup(MHS.pt.x,MHS.pt.y); end; end; end; end; end; initialization HMouseHook:=SetWindowsHookEx(WH_MOUSE,@MouseProc,HInstance,GetCurrentThreadID); finalization CloseHandle(HMouseHook); end.

Переименование группы файлов

Раздел Сокровищница

Приложение является доработкой примера из поставки Дельфи "X:\Program Files\Borland\Delphi6\Demos\ActiveX\ShellExt\" Потребность в данной программе возникла при необходимости переименовать группу выделенных файлов, с чем она прекрасно справляется.

Пример позволяете переименовывать группу файлов в проводнике Windows 95/98/ME. Поддерживается шаблонная операция [*] (звездочка). Приложение интегрируется в оболочку проводника и добавляет команду в контекстное меню. Поддерживает английский и русский язык автоматически (как мне кажется :-)).

Примеры шаблонов: 1. A.JPG - все выделенные файлы примут имя A.JPG, A1.JPG, A2.JPG и т.д. 2. T*.BMP - файлы примут имя с буквы T, а далее будет добавлено исходное имя файла. 3. D.* - расширение файла останется исходным, имена как (1). Тоже самое относится к расширению файла.

Вы можете доработать алгоритм шаблонной операции, чтобы сделать его более развернутым.

Все основные операции по переименованию в следующих методах (файл ZRFile.pas): procedure TContextMenu.RenameFiles; function TContextMenu.RenameTemplate(strTemplate, strName: String): String;

Скачать проект: (200 K)

Перенаправление вывода консольной программы

й, дата публикации 02 июня 2003г.

Понадобилось мне отобразить работу консольной программы в каком-нибудь Memo, а саму консоль не показывать. Поискал в инете - много кто ищет, мало кто предлагает готовые решения. Понял только, что плясать надо с "пайпами". Взял свой парадный бубен и... Вовремя подвернулась хорошая статья в тему на КД: рбань С.В. Но мне не нужен целый класс! Да и собственные наработки уже появились. Вообщем, не буду утомлять процессом поисков и метаний, просто скажу что получилось. А получилась следующая функция:

function RunAny(CommandLine: string; Str: TStrings): boolean; var I: byte; S: string; Flag: boolean; tRead, cWrite, dwRead, dwAvail: cardinal; SA: TSecurityAttributes; PI: TProcessInformation; SI: TStartupInfo; begin Result:=False; SA.nLength:=SizeOf(SECURITY_ATTRIBUTES); SA.bInheritHandle:=True; SA.lpSecurityDescriptor:=nil; if not CreatePipe(tRead, cWrite, @SA, 0) then Exit; ZeroMemory(@SI, SizeOf(TStartupInfo)); SI.cb:=SizeOf(TStartupInfo); SI.dwFlags:=STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW; SI.wShowWindow:=SW_HIDE; SI.hStdOutput:=cWrite; if CreateProcess(nil, PChar(CommandLine), nil, nil, True, 0, nil, nil, SI, PI) then begin CloseHandle(PI.hProcess); CloseHandle(PI.hThread); Str.Clear(); Flag:=True; while Flag do begin for I:=0 to 9 do begin PeekNamedPipe(tRead, nil, 0, nil, @dwAvail, nil); if (dwAvail>0) then begin Flag:=True; Break; end else Flag:=False; Sleep(100); end; //for I:= if dwAvail>0 then begin SetLength(S, dwAvail); ReadFile(tRead, PChar(S)^, Length(S), dwRead, Nil); OemToChar(PChar(S), PChar(S)); Str.Add(S); Application.ProcessMessages; Result:=True; end; // if dwAvail end; // while Flag end; // if CreateProcess end;

Вот. Может кому пригодится. Естественно пока не причесано, но спешу поделиться :-)

P.S. с format. Да, действительно, такая проблема существует. Под win98SE у меня так и не получилось с тем же format''ом и рядом архиваторов, таких как RAR 2.0 и ARJ 2.50. Однако, под WIN200 PROF RUS все решилось небольшим изменением: CommandLine:=''cmd.exe /c ''+CommandLine - и телемаркет!
Работает даже с bat-файлом.

---

---