Добавление IPERSISTPROPERTYBAG к активным элементам управления
Данный совет рассказывает о том, как можно добавить интерфейс IPersistPropertyBag к элементу управления ActiveX. Существует возможность установки свойств элемента управления ActiveX с помощью HTML тэгов PARAM. Добавление интерфейса IPersistPropertyBag в элемент управления ActiveX также позволяет изменять его свойства с помощью инструментов типа ActiveX Control Pad.
Добавление интерфейса IPersistPropertyBag к элементу управления ActiveX очень простая процедура. Все, что необходимо сделать, это добавить интерфейс к определению класса объекта и реализовать три метода интерфейса. Приведенный здесь пример покажет вам эту технологию шаг за шагом, где наш элемент управления ActiveX будет базироваться на TButton. Для упрощения примера мы покажем реализацию функциональности для свойства "Caption" (заголовок). Для реализации полной функциональности можно экстраполировать данный пример на все доступные свойства элемента управления.
Начнем с использования ActiveX Control Wizard и создадим элемент управления ActiveX на основе TButton.
Активизируйте пункт меню File|New и выберите в диалоге New Item (новый элемент) закладку ActiveX. Затем в списке выберите элемент "ActiveX Control". В появившемся диалоговом окне выберите TButton для VCL Class Name. Все остальные настройки можете не трогать и оставить как есть. После нажатия на кнопку OK Delphi сгенерирует базовый код для вашего элемента управления.
Следующим шагом будет добавление интерфейса IPersistPropertyBag к определению класса. Измените первую строку определения, декларирующую тип...
|
type TButtonX = class(TActiveXControl, IButtonX) |
на...
|
type TButtonX = class(TActiveXControl, IButtonX, IPersistPropertyBag) |
Теперь интерфейс IPersistPropertyBag добавлен к объявлению типа. Затем объявите необходимые методы, добавляя следующие строки в секцию protected:
| function IPersistPropertyBag.InitNew = PersistPropBagInitNew; function IPersistPropertyBag.Load = PersistPropBagLoad; function IPersistPropertyBag.Save = PersistPropBagSave; function PersistPropBagInitNew: HResult; stdcall; function PersistPropBagLoad(const pPropBag: IPropertyBag; const pErrorLog: IErrorLog): HResult; stdcall; function PersistPropBagSave(const pPropBag: IPropertyBag; fClearDirty: BOOL; fSaveAllProperties: BOOL): HResult; stdcall; |
Затем, конечно, реализуйте эти функции...
|
// -- реализация PersistPropBagInitNew function TButtonX.PersistPropBagInitNew: HResult; begin Result := S_OK; end; // -- реализация PersistPropBagLoad function TButtonX.PersistPropBagLoad(const pPropBag: IPropertyBag; const pErrorLog: IErrorLog): HResult; stdcall; var v: OleVariant; begin if pPropBag.Read('Caption', v, pErrorLog) = S_OK then FDelphiControl.Caption := v; Result := S_OK; end; // -- реализация PersistPropBagSave function TButtonX.PersistPropBagSave(const pPropBag: IPropertyBag; fClearDirty: BOOL; fSaveAllProperties: BOOL) : HResult; stdcall; var v: OleVariant; begin v:= FDelphiControl.Caption; pPropBag.Write('Caption', v); Result := S_OK; end; |
Добавлением этого кода завершается создание элемента управления. Продолжаем дальше: соберите (build) элемент управления ActiveX и разместите его в сети. Сделайте это с помощью мастера Web Delpoy Wizard. Просто сделайте необходимые настройки на странице Project|Web Delpoyment Options и разместите ActiveX через Project| Web Deploy.
Мастер Web Deployment Wizard создаст HTML-страницу, содержащую тэг OBJECT, которая должна выглядеть приблизительно так: <OBJECT classid="clsid:324EB783-20A4-11D1-AB11-0020AF3E6306" codebase="ActiveX/ButtonXControl.ocx" width=100 height=50 align=center hspace=0 vspace=0 > </OBJECT> Эта страница должна заработать без проблем. Тем не менее, теперь у вас имеется возможность задания заголовка для кнопок через HTML простым добавлением тэга PARAM. Вам измененный тэг OBJECT должен выглядеть таким образом: <OBJECT classid="clsid:324EB783-20A4-11D1-AB11-0020AF3E6306" codebase="ActiveX/ButtonXControl.ocx" width=100 height=50 align=center hspace=0 vspace=0 > <Param Name="Caption" Value="Привет"> </OBJECT> Заголовок кнопки теперь будет говорить вам "Привет". В нашем примере заголовок будет доступен только с помощью данного метода. Для того, чтобы рулить другими свойствами, следуйте нашему примеру и изменяйте имя свойства, которое вы хотите использовать. [001145]
Использование ChartFX
Это код, который я использую для установки chartfx.
|
chart1.Opendata[cod_values]:=makelong(no_of_series,no_of_classes);
{установка последовательных значений} chart1.closedata[cod_values]:=0; |
|
unit TstChart; interface uses=20 WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Menus, Dialogs, StdCtrls, Buttons, ExtCtrls, Tabs, ChartFX, {Похоже, действительно необходимо включить этот модуль в список, чтобы иметь доступ к константам, например к COD_VALUES} VBXCtrl, Chart2fx; type TF_Chart =3D class(TForm) SpeedPanel: TPanel; ExitBtn: TSpeedButton; NB: TNotebook; TB: TTabSet; Chart1: TChartFX; Chart2: TChartFX; procedure ExitItemClick(Sender: TObject); procedure FormCreate(Sender: TObject); procedure TBClick(Sender: TObject); procedure FormResize(Sender: TObject); private { Private declarations } public { Public declarations } Procedure Build1( Ch : TChartFX ); Procedure Build2( Ch : TChartFX ); end; var F_Chart: TF_Chart; implementation {$R *.DFM} procedure TF_Chart.ExitItemClick(Sender: TObject); begin Close; end; procedure TF_Chart.FormCreate(Sender: TObject); begin TB.Tabs :=3D NB.Pages; NB.PageIndex :=3D 0; Build1( Chart2 ); Build2( Chart2 ); {добавляем значения для Chart2: length... и т.д.} end; procedure TF_Chart.TBClick(Sender: TObject); begin NB.PageIndex :=3D TB.TabIndex; end; Procedure TF_Chart.Build1( Ch : TChartFX ); begin {Эта процедура изменяет свойства, которые могут устанавливаться во время разработки или временя выполнения. В коментариях подробно указано чем занимается метод Design} with Ch do begin Adm[ CSA_GAP ] :=3D 25.0; {Design: Используйте свойство AdmDlg для изменения координаты Y} pType :=3D BAR or CT_LEGEND; {Design: Изменяем свойство ChartType с 1 - line на 2 - bar.} DecimalsNum[ CD_YLEG ] :=3D 0; {Design: Изменяем свойство Decimals с 2 до 0} Stacked :=3D CHART_STACKED; {Design: Изменяем свойство Stacked с 0 - None на 1 - Normal} RightGap :=3D 20; {Design: Тоже} OpenData[ COD_COLORS ] :=3D 2; Color[ 0 ] :=3D clBlack; Color[ 1 ] :=3D clYellow; CloseData[ COD_COLORS ] :=3D 0; {Фу!!} {Design: Для изменения цветов 2 серий: 1) Убедитесь, что ThisSerie установлен в 0. Измените ThisColor на clBlack. 2) Установите ThisSerie в 1. Измените ThisColor на clYellow.} Title[ CHART_TOPTIT ] :=3D 'Статьи и заголовки'; Title[ CHART_LEFTTIT ] :=3D 'CCM'; Title[ CHART_BOTTOMTIT ] :=3D 'Карты'; {Design: щелкните на свойстве TitleDlg и установите верхний, левый и нижний заголовки} end; end; Procedure TF_Chart.Build2( Ch : TChartFX ); {Данная процедура устанавливает свойства, которые не могут (насколько я определил это) быть установлены в режиме разработки} const XAbbrevs : array[ 0..4 ] of string[ 4 ] =3D ( 'Acc', 'Bar', 'Mas', 'Amex', 'Din' ); SeriesTitles : array[ 0..1 ] of string[ 8 ] =3D ( 'Статьи', 'Заголовки' ); XTitles : array[ 0..4 ] of string[ 20 ] =3D ( 'Access', 'Barclaycard', 'Mastercard', 'American Express', 'Diners' ); {естественно, вы должны нормально читать из базы данных xTitles и значения} Values : array[ 0..1, 0..4 ] of double =3D ( ( 50, 60, 70, 80, 90 ), ( 30, 35, 25, 37, 42 ) ); var i, SerieNo : integer; begin with Ch do begin LegendWidth :=3D 120; {Установка количества серий, количества значений ******************} OpenData[ COD_INIVALUES ] :=3D MAKELONG( 2, 5 ); CloseData[ COD_INIVALUES ] :=3D 0; {*********************************************************} OpenData[ COD_VALUES ] :=3D 2; {если вы пропускаете приведенное выше утверждение, (в котором вы вводите номер SERIES и VALUES), и CloseData ниже, назначение значений не создает ошибки, но и не работает! Назначение значений Legend и KeyLeg работает без OpenData/CloseData} ThisSerie :=3D 0; for i :=3D 0 to 1 do SerLeg[ i ] :=3D SeriesTitles[ i ]; for i :=3D 0 to 4 do=20 begin Legend[ i ] :=3D XTitles[ i ]; KeyLeg[ i ] :=3D XAbbrevs[ i ]; end; SerieNo :=3D 0; for SerieNo :=3D 0 to 1 do=20 begin ThisSerie :=3D SerieNo; for i :=3D 0 to 4 do Value[ i ] :=3D Values[ SerieNo, i ]; end; CloseData[ COD_VALUES ] :=3D 0; end; end; procedure TF_Chart.FormResize(Sender: TObject); var w, h : longint; begin w :=3D NB.Width; H :=3D NB.Height; {при необходимости увеличиваем/уменьшаем размер диаграммы} Chart1.Width :=3D W - 18; Chart1.Height :=3D H - 12; Chart2.Width :=3D W - 18; Chart2.Height :=3D H - 12; {перемещаем кнопку выхода в правый угол} ExitBtn.Left :=3D SpeedPanel.Width - 32; end; end. |
[001149]
Использование CHARTFX.VBX
Хотя это можно было бы пообсуждать и здесь, но для ChartFX существует контекстно-зависимая подсказка. Киньте компонент на форму, выберите его и нажмите F1. [001157]
Как осуществить минимальный тест
Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch (и, следовательно, поддерживающих методы автоматизации)?
Nomadic советует:
Вызовите CreateRemoteComObject, передав GUID интерфейса и имя компьютера, к которому Вы пытаетесь подключиться. Если функция вернет ошибку, то наличествует проблема сервера, иначе возможная проблема относится к клиенту.
|
const MyGUID = '{444...111}'; //Whatever the guid is... var Unk: IUnknown; Disp: IDispatch; begin { Make sure this line works correctly } Unk := CreateRemoteComObject('server1', StringToGUID(MyGUID)); { If it does, then cast it to a IDispatch } Disp := Unk as IDispatch; end; |
Если этот кусок кода работает, а проблема остается, то Вам требуется шаг за шагом пройти через код клиента и найти, где он дает трещину. Если не сможете этого обнаружить, Вам придется запустить сервер под отладчиком и установить связь с клиентом, чтобы Вы могли произвести отладку рядом со местом, дающем слабину. [001435]
Лицензирование активных форм и ActiveX
Почему ACTIVEX и активные формы иногда не отображаются в INTERNET EXPLORER? Все, что появляется, это .HTM-страница с пустым квадратом и красным "X" в нем.
Вероятно, при создании ActiveForm вы выбрали опцию лицензирования и не поместили .LIC-файл в ваш .OCX-файл. Обычно с ActiveForms/ActiveXs лицензирование не используется, поскольку активные элементы в основном используются для повышения привлекательности Интернет-сервера и "распространяются" свободно. Чтобы выключить лицензию времени разработки (Design-Time Licensing), найдите секцию initialization в вашем ActiveForm XXXImpl-файле и замените предпоследний параметр вызова TActiveXControlFactory.Create на пустую строку:
| initialization TActiveXControlFactory.Create( ComServer, TAnimateX, TAnimate, Class_AnimateX, 1, '', 0); end. |
Так когда мне нужно будет использовать Design-Time Licensing?
Ваш элемент управления должен использовать design-time-лицензию только в случае, если вы продаете ActiveX или ActiveForm другим разработчикам, которые встраивают их в продаваемые ими приложения для конечных пользователей. То есть, элемент управления работает в среде разработки (например, Delphi, C++Builder, VB и пр.) только когда LIC-файл присутствует, но это не работает когда .LIC-файл отсутствует во время выполнения приложения без среды разработки (например, в приложении для конечного пользователя).
Если вы распространяете ваш ActiveX в Интернете, то вы должны задать режим разработки для конечного пользователя (в противоположность передачи другим разработчикам), и вам в этом случае не потребуется лицензия времени разработки.
Кроме того, для показа ActiveForm необходимо установить в Internet Explorer уровень "Active content security" (безопасность активного содержимого) в medium (средняя). Чтобы это сделать, войдите в Панель Управления и щелкните на иконке Internet. Перейдите на страницу безопасности и нажмите на кнопку "Safety Level" (уровень безопасности). Убедитесь в том, что уровень находится на отметке "средний".
Примечание: Данный совет отностится только если вы разрабатываете собственные элементы управления. Потенциально хакерские элементы ActiveX могут нанести вред компьютеру! [001143]
Ошибка 'EOLESYS..OPERATION UNAVAILABLE' (операция недоступна) при использовании GETACTIVEOLEOBJECT
Это происходит при использовании сервера автоматизации Delphi, или когда сервер автоматизации (например, word.basic) не запущен.
| procedure TForm1.Button1Click(Sender: TObject); var V: OleVariant; begin V := GetActiveOleObject('Word.Basic'); V.FileNew; V.Insert('тест'); end; |
GetActiveOleObject определен в ComObj.pas. Он преобразует имя класса в guid и передает его при вызове Windows api функции GetActiveObject.
| function GetActiveOleObject(const ClassName: string): IDispatch; var ClassID: TCLSID; Unknown: IUnknown; begin ClassID := ProgIDToClassID(ClassName); OleCheck(GetActiveObject(ClassID, nil, Unknown)); OleCheck(Unknown.QueryInterface(IDispatch, Result)); end; |
GetActiveOleObject использует интерфейс с именем IRunningObjectTable. Мы не регистрируем это автоматически в таблице, поэтому, чтобы воспользоваться его функциональным назначением, вы должны получить этот интерфейс и использовать его методы для регистрации. [001139]
Ошибка 'TACTIVEFORMX DECLARATION
Обычно это происходит при неправильном порядке изменения имени ActiveForm (смотри README.TXT). Если сначала изменяется имя CoClass, а затем делается обновление (refresh), возникает AV. При дальнейшей попытке изменить имя в Инспекторе Объектов вы получите ошибку "TActiveFormX declaration missing or incorrect" (определение TActiveFormX отсутствует или неправильно). Для решения проблемы откройте .DFM-файл и измените строчку:
| object ActiveFormX: TActiveFormX |
на
| object MyForm: TMyForm |
[001141]
CHARTFX
Документация, поставляемая с Delphi, слишком запутанна и тяжела, особенно если вы не пользователь VBX...
Следующий пример устанавливает некоторые значения и пр. для ChartFX:
|
{Код получает данные из базы данных и рисует их} begin MyTable.active := True; {открываем базу данных} MyTable.first; MyChart.title[CHART_BOTTOMTIT] := 'Заголовок по оси X'; MyChart.title[CHART_LEFTTIT] := 'Заголовок по оси Y'; MyChart.OpenData[COD_XVALUES] := MakeLong(numOfSeries,numofPoints); MyChart.OpenData[COD_VALUES] := MakeLong(numOfSeries, NumofPoints); MyChart.ThisSerie := SeriesNum; {начинаем с 0} While MyTable.EOF <> True do begin MyChart.value[i] := MyTable.FieldByName('SOMEFIELD').AsFloat; MyChart.Xvalue[i] := MyTable.FieldByName('SOMEOTHERFIELD').AsFloat; MyTable.next; i:=i+1; {естественно, вам необходимо определить и инициализировать 'i'} end; MyChart.CloseData[COD_Values] := 0; MyChart.CloseData[COD_XValues] := 0; MyTable.active := False; {закрываем базу данных} end; {Обратите внимание на то, что данный код отностится к диаграмме типа xy scatter. Если вы хотите сменить тип диаграммы ChartFX, вам не нужно устанавливать значения для COD_XVALUES} |
[001153]
Расскажите, как использовать ChartFX?
Nomadic советует:
Лyчше на пpостеньком пpимеpе.
|
unit Chart; ....................... with ChartFX do begin Visible := false; { Устанавливаем режим ввода значений } { 1 - количество серий (в нашем случае 1), 3 - количество значений } OpenData [COD_VALUES] := MakeLong(1,3); { Hомер текущей серии } ThisSerie := 0; { Value [i] - значение с индексом i } { Legend [i] - комментарий к этому значению } Value [0] := a; Legend [0] := 'Значение переменной A'; Value [1] := b; Legend [1] := 'Значение переменной B'; Value [2] := c; Legend [2] := 'Значение переменной C'; { Закрываем режим } CloseData [COD_VALUES] := 0; { Ширина поля с комментариями на экране (в пикселах) } LegendWidth := 150; Visible := true; end; end; end. |
[001210]
Управление свойством Font через сервер автоматизации
Данный документ предназначен главным образом тем программистам, кто использует OLE/COM и хочет встроить объект Font (типа Delphi-го TFont) в свой сервер автоматизации. Интерфейс IFontDisp для COM будет иметь ту же функциональность, что и Delphi-ий TFont. Например, если у вас имеется клиент автоматизации, содержащий объект со свойством Font, и в сервере автоматизации для изменения атрибутов текста вы хотите иметь те же методы (наприр, имя шрифта, жирное или наклонное начертание). Для хранения и управления шрифтом сервер автоматизации может применять реализацию интерфейса IFontDisp.
Приведенный ниже демонстрационный проект содержит элементы и шаги, необходимые для реализации интерфейса IFontDisp в сервере автоматизации COM, и осуществление взаимодействия между клиентом автоматизации COM и интерфейсом. Ниже вы найдете полный листинг исходных модулей, и некоторые комментарии относительно проекта.
Демонстрационный проект содержит следующие модули:
Project1_TLB: Паскалевская обертка для библиотеки типов, содержащей определение интерфейса.
Unit1: Реализация интерфейса: код, содержащий описание свойств интерфейса и реализующий его методы.
Unit2: Главная форма сервера автоматизации. Данный модуль не является обязательным, но он в ходе тестирования обеспечивает обратную связь, так что мы можем видеть как отрабатываются вызовы наших методов.
FontCli: Клиент автоматизации, получающий ссылку на интерфейс, и использующий его методы.
Ниже приведены общие шаги для достижения цели. Вы можете сравнить каждый из этих шагов с кодом модулей, приведенных ниже. Выберите пункт меню File|New|ActiveX|Automation Object и в Мастере Automation Object Wizard выберите в качестве имени класса MyFontServer. Создайте единственное свойство с именем MyFont и типом IFontDisp. Для получения дополнительной информции смотри Developer's Guide, chapter 42 (руководство разработчика, глава 42), там подробно описана работа с библиотеками типов и создание интерфейсов в редакторе библиотеки типов. В предыдущем шаге при добавлении интерфейса с помошью редактора библиотеки типов вы должны были получить паскалевский модуль-обертку (в нашем примере модуль имеет имя Unit1). Unit1 будет содержать обертку реализаций методов получения и назначения свойства MyFont. На данном этапе вы обеспечите хранение значений свойства MyFont в форме FFont (TFont) и добавите код реализации, наполняющий функциональностью методы получения и установки (get/set).
Unit1 использует Unit2. Unit2 содержит форму, компонент Memo и StatusBar для отображения каждого реализованного метода, для диагностических целей. Создайте Unit2, содержащий форму с компонентами TMemo и TStatusBar. Форма используется для отображения жизнедеятельности в модуле Unit1.pas. Это шаг не является строго обязательным, он помогает понять что происходит в данный момент между клиентом автоматизации и сервером. Создайте клиент автоматизации. В нашем случае модуль имеет имя FontCli, содержит метку, показывающую текущий шрифт и кнопку, устанавливающую MyFont на сервере.
|
unit Project1_TLB; { Данный файл содержит паскалевские декларации, импортированные из библиотеки типов. Данный файл записывается во время каждого импорта или обновления (refresh) в редакторе библиотеки типов. Любые изменения в данном файле будут потеряны в процессе очередного обновления. } { Библиотека Project1 } { Версия 1.0 } interface uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL; const LIBID_Project1: TGUID = '{29C7AC94-0807-11D1-B2BA-0020AFF2F575}'; const { GUID'ы класса компоненты } Class_MyFontServer: TGUID = '{29C7AC96-0807-11D1-B2BA-0020AFF2F575}'; type { Предварительные объявления: Интерфейсы } IMyFontServer = interface; IMyFontServerDisp = dispinterface; { Предварительные объявления: CoClasse'ы } MyFontServer = IMyFontServer; { Диспинтерфейс для объекта MyFontServer } IMyFontServer = interface(IDispatch) ['{29C7AC95-0807-11D1-B2BA-0020AFF2F575}'] function Get_MyFont: IFontDisp; safecall; procedure Set_MyFont(const Value: IFontDisp); safecall; property MyFont: IFontDisp read Get_MyFont write Set_MyFont; end; { Объявление диспинтерфейса для дуального интерфейса IMyFontServer } IMyFontServerDisp = dispinterface ['{29C7AC95-0807-11D1-B2BA-0020AFF2F575}'] property MyFont: IFontDisp dispid 1; end; { MyFontServerObject } CoMyFontServer = class class function Create: IMyFontServer; class function CreateRemote(const MachineName: string): IMyFontServer; end; implementation uses ComObj; class function CoMyFontServer.Create: IMyFontServer; begin Result := CreateComObject(Class_MyFontServer) as IMyFontServer; end; class function CoMyFontServer.CreateRemote(const MachineName: string): IMyFontServer; begin Result := CreateRemoteComObject(MachineName, Class_MyFontServer) as IMyFontServer; end; end. {--------------------------------------------------------------------} |
|
unit Unit1; interface uses ComObj, Project1_TLB, ActiveX, Graphics; type TMyFontServer = class(TAutoObject, IMyFontServer) private FFont: TFont; public procedure Initialize; override; destructor Destroy; override; function Get_MyFont: IFontDisp; safecall; procedure Set_MyFont(const Value: IFontDisp); safecall; end; implementation uses ComServ, AxCtrls, Unit2; procedure TMyFontServer.Initialize; begin inherited Initialize; FFont := TFont.Create; end; destructor TMyFontServer.Destroy; begin FFont.Free; inherited Destroy; end; function TMyFontServer.Get_MyFont: IFontDisp; begin FFont.Assign(Form2.Label1.Font); GetOleFont(FFont, Result); end; procedure TMyFontServer.Set_MyFont(const Value: IFontDisp); begin SetOleFont(FFont, Value); Form2.Label1.Font.Assign(FFont); end; initialization TAutoObjectFactory.Create(ComServer, TMyFontServer, Class_MyFontServer, ciMultiInstance); end. {--------------------------------------------------------------------} |
|
unit Unit2; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm2 = class(TForm) Label1: TLabel; end; var Form2: TForm2; implementation {$R *.DFM} end. {--------------------------------------------------------------------} |
|
unit FontCli1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, StdVCL, Project1_TLB; type TForm1 = class(TForm) Button1: TButton; Label1: TLabel; FontDialog1: TFontDialog; procedure Button1Click(Sender: TObject); procedure FormCreate(Sender: TObject); public MyFontServer: IMyFontServer; end; var Form1: TForm1; implementation uses ActiveX, AxCtrls; {$R *.DFM} procedure TForm1.Button1Click(Sender: TObject); var Temp: IFontDisp; begin if (FontDialog1.Execute) then begin Label1.Font.Assign(FontDialog1.Font); GetOleFont(Label1.Font, Temp); MyFontServer.Set_MyFont(Temp); end; end; procedure TForm1.FormCreate(Sender: TObject); begin MyFontServer := CoMyFontServer.Create; end; end. {--------------------------------------------------------------------} |
Так для чего нам Unit1, создающий реализацию интерфейса? Интерфейс Ole, такой как, например, IFontDisp, может считаться соглашением о том, что свойства и функции будут определены в заданном формате, а функции будут реализованы как определено (для получения дополнительной информации смотри Руководство Разработчика, главу 36, "An Overview of COM" (Обзор COM). Тот факт, что интерфейс определен, не означает, что он реализован. Например, чтобы заставить определенный вами интерфейс IFontDisp быть полезным, необходимо обеспечить хранение шрифта и механизм добавления и извлечения информации об атрибутах шрифта, таких, как имя шрифта, наклонное начертание, размер и пр.
Примечание:
GetOleFont и SetOleFont определены в AxCtrls.pas. IFontDisp определен в ActiveX.pas
[001155]
VBX в приложениях DELPHI: как распространять?
Чтобы использовать любые элементы управления VBX с компилированным Delphi EXE-файлом, вам необходимо распространить BIVBX11.DLL (расположен в каталоге \WINDOWS\SYSTEM - Borland при установке копирует его туда). [001159]
Читаем Adobe Acrobat PDF файлы из нашего приложения
Igor Nikolaev aKa The Sprite советует:
Adobe Acrobat PDF - хорошо извесный формат, который нравится многим пользователям. Давайте посмотрим, как можно заставить приложение на Delphi прочитать файл такого формата.
Совместимость: Delphi 3.x (или выше)
Итак, Вы должны быть уверены, что у вас проинсталлирован Acrobat Reader, елси таковой программы нет, то её можно скачать с www.adobe.com После этого необходимо проинсталировать типовую библиотеку для Acrobat (Project -> Import Type Library из меню Delphi) выберите "Acrobat Control for ActiveX (version x)". Где x - текущая версия библиотеки. Hажмите кнопку инсталяции. Теперь создайте новое приложение, поместите на форму проинсталлированный компонент TPDF, далее добавите OpenDialog, и в заключении кнопку, при на нажатии на которую будет вызываться процедура открытия файла:
|
procedure TForm1.Button1Click(Sender: TObject); begin if OpenDialog1.Execute then pdf1.src := OpenDialog1.FileName; end; |
в юните PdfLib_TLB вы можете найти интерфейс класса TPdf:
|
TPdf = class(TOleControl) private FIntf: _DPdf; function GetControlInterface: _DPdf; protected procedure CreateControl; procedure InitControlData; override; public function LoadFile(const fileName: WideString): WordBool; procedure setShowToolbar(On_: WordBool); procedure gotoFirstPage; procedure gotoLastPage; procedure gotoNextPage; procedure gotoPreviousPage; procedure setCurrentPage(n: Integer); procedure goForwardStack; procedure goBackwardStack; procedure setPageMode(const pageMode: WideString); procedure setLayoutMode(const layoutMode: WideString); procedure setNamedDest(const namedDest: WideString); procedure Print; procedure printWithDialog; procedure setZoom(percent: Single); procedure setZoomScroll(percent: Single; left: Single; top: Single); procedure setView(const viewMode: WideString); procedure setViewScroll(const viewMode: WideString; offset: Single); procedure setViewRect(left: Single; top: Single; width: Single; height: Single); procedure printPages(from: Integer; to_: Integer); procedure printPagesFit(from: Integer; to_: Integer; shrinkToFit: WordBool); procedure printAll; procedure printAllFit(shrinkToFit: WordBool); procedure setShowScrollbars(On_: WordBool); procedure AboutBox; property ControlInterface: _DPdf read GetControlInterface; property DefaultInterface: _DPdf read GetControlInterface; published property TabStop; property Align; property DragCursor; property DragMode; property ParentShowHint; property PopupMenu; property ShowHint; property TabOrder; property Visible; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnEnter; property OnExit; property OnStartDrag; property src: WideString index 1 read GetWideStringProp write SetWideStringProp stored False; end; |
в заключение можно добавить следующее: Если Вы не уверены, что у конечного пользователя Вашей программы установлен Acrobat Reader, то необходимо, чтобы приложение проверяло эту ситуацию, прежде чем будут производится различные манипуляции с компонентой TPdf. И второе, если файл PDF имеет различные связи, например с AVI файлами, то они не будут работать из Delphi.
Hадеюсь этот пример будет Вам полезен. [001471]
Аглоритм (уравнение) для определения восхода/захода солнца и луны (BASIC)
Я нашел алгоритм, написанный на BASIC и вычисляющий восход-заход солнца и восход-заход луны. Может кто-нибудь сможет перенести это на Pascal?
(в случае чего сообщите мне по адресу st_evil@mail.ru)
10 ' Восход-заход солнца 20 GOSUB 300 30 INPUT "Долгота (град)";B5,L5 40 INPUT "Часовая зона (час)";H 50 L5=L5/360: Z0=H/24 60 GOSUB 1170: T=(J-2451545)+F 70 TT=T/36525+1: ' TT = столетия, 80 ' начиная с 1900.0 90 GOSUB 410: T=T+Z0 100 ' 110 ' Получаем положение солнца 120 GOSUB 910: A(1)=A5: D(1)=D5 130 T=T+1 140 GOSUB 910: A(2)=A5: D(2)=D5 150 IF A(2)<A(1) THEN A(2)=A(2)+P2 160 Z1=DR*90.833: ' Вычисление зенита 170 S=SIN(B5*DR): C=COS(B5*DR) 180 Z=COS(Z1): M8=0: W8=0: PRINT 190 A0=A(1): D0=D(1) 200 DA=A(2)-A(1): DD=D(2)-D(1) 210 FOR C0=0 TO 23 220 P=(C0+1)/24 230 A2=A(1)+P*DA: D2=D(1)+P*DD 240 GOSUB 490 250 A0=A2: D0=D2: V0=V2 260 NEXT 270 GOSUB 820: ' Вывод информации? 280 END 290 ' 300 ' Константы 310 DIM A(2),D(2) 320 P1=3.14159265: P2=2*P1 330 DR=P1/180: K1=15*DR*1.0027379 340 S$="Заход солнца в " 350 R$="Восход солнца в " 360 M1$="В этот день солнце не восходит" 370 M2$="В этот день солнце не заходит" 380 M3$="Солнце заходит весь день" 390 M4$="Солнце восходит весь день" 400 RETURN 410 ' Получение часового пояса 420 T0=T/36525 430 S=24110.5+8640184.813*T0 440 S=S+86636.6*Z0+86400*L5 450 S=S/86400: S=S-INT(S) 460 T0=S*360*DR 470 RETURN 480 ' 490 ' Просматриваем возможные события на полученный час 500 L0=T0+C0*K1: L2=L0+K1 510 H0=L0-A0: H2=L2-A2 520 H1=(H2+H0)/2: ' Часовой угол, 530 D1=(D2+D0)/2: ' наклон в 540 ' получасе 550 IF C0>0 THEN 570 560 V0=S*SIN(D0)+C*COS(D0)*COS(H0)-Z 570 V2=S*SIN(D2)+C*COS(D2)*COS(H2)-Z 580 IF SGN(V0)=SGN(V2) THEN 800 590 V1=S*SIN(D1)+C*COS(D1)*COS(H1)-Z 600 A=2*V2-4*V1+2*V0: B=4*V1-3*V0-V2 610 D=B*B-4*A*V0: IF D<0 THEN 800 620 D=SQR(D) 630 IF V0<0 AND V2>0 THEN PRINT R$; 640 IF V0<0 AND V2>0 THEN M8=1 650 IF V0>0 AND V2<0 THEN PRINT S$; 660 IF V0>0 AND V2<0 THEN W8=1 670 E=(-B+D)/(2*A) 680 IF E>1 OR E<0 THEN E=(-B-D)/(2*A) 690 T3=C0+E+1/120: ' Округление 700 H3=INT(T3): M3=INT((T3-H3)*60) 710 PRINT USING "##:##";H3;M3; 720 H7=H0+E*(H2-H0) 730 N7=-COS(D1)*SIN(H7) 740 D7=C*SIN(D1)-S*COS(D1)*COS(H7) 750 AZ=ATN(N7/D7)/DR 760 IF D7<0 THEN AZ=AZ+180 770 IF AZ<0 THEN AZ=AZ+360 780 IF AZ>360 THEN AZ=AZ-360 790 PRINT USING ", азимут ###.#";AZ 800 RETURN 810 ' 820 ' Процедура вывода информации 830 IF M8=0 AND W8=0 THEN 870 840 IF M8=0 THEN PRINT M1$ 850 IF W8=0 THEN PRINT M2$ 860 GOTO 890 870 IF V2<0 THEN PRINT M3$ 880 IF V2>0 THEN PRINT M4$ 890 RETURN 900 ' 910 ' Фундаментальные константы 920 ' (Van Flandern & 930 ' Pulkkinen, 1979) 940 L=.779072+.00273790931*T 950 G=.993126+.0027377785*T 960 L=L-INT(L): G=G-INT(G) 970 L=L*P2: G=G*P2 980 V=.39785*SIN(L) 990 V=V-.01000*SIN(L-G) 1000 V=V+.00333*SIN(L+G) 1010 V=V-.00021*TT*SIN(L) 1020 U=1-.03349*COS(G) 1030 U=U-.00014*COS(2*L) 1040 U=U+.00008*COS(L) 1050 W=-.00010-.04129*SIN(2*L) 1060 W=W+.03211*SIN(G) 1070 W=W+.00104*SIN(2*L-G) 1080 W=W-.00035*SIN(2*L+G) 1090 W=W-.00008*TT*SIN(G) 1100 ' 1110 ' Вычисление солнечных координат 1120 S=W/SQR(U-V*V) 1130 A5=L+ATN(S/SQR(1-S*S)) 1140 S=V/SQR(U):D5=ATN(S/SQR(1-S*S)) 1150 R5=1.00021*SQR(U) 1160 RETURN 1165 ' 1170 ' Календарь --> JD 1180 INPUT "Год, Месяц, День";Y,M,D 1190 G=1: IF Y<1583 THEN G=0 1200 D1=INT(D): F=D-D1-.5 1210 J=-INT(7*(INT((M+9)/12)+Y)/4) 1220 IF G=0 THEN 1260 1230 S=SGN(M-9): A=ABS(M-9) 1240 J3=INT(Y+S*INT(A/7)) 1250 J3=-INT((INT(J3/100)+1)*3/4) 1260 J=J+INT(275*M/9)+D1+G*J3 1270 J=J+1721027+2*G+367*Y 1280 IF F>=0 THEN 1300 1290 F=F+1: J=J-1 1300 RETURN 1310 ' 1320 ' Программа вычисляет время восхода и захода 1330 ' солнца по дате (с точностью до минуты) в пределах 1340 ' нескольких текущих столетий. Производит корректировку, если географическая 1350 ' точка находится в арктичиском или антарктическом регионе, где заход или восход солнца 1360 ' на текущую дату может не состояться. Вводимые данные: положительная северная широта и 1370 ' отрицательная западная долгота. Часовой пояс указывается относительно Гринвича 1380 ' (например, 5 для EST и 4 для EDT). Алгоритм обсуждался в 1390 ' "Sky & Telescope" за август 1994, страница 84. [000014]Автоматический формат даты в компоненте Edit
|
PROCEDURE TForm1.Edit1Exit(Sender: TObject); BEGIN IF Edit1.Text<>'' THEN BEGIN TRY StrToDate(Edit1.Text); EXCEPT Edit1.SetFocus; MessageBeep(0); raise Exception.Create('"'+Edit1.Text +'" - некорректная дата'); END{try}; Edit1.Text:=DateToStr(StrToDate(Edit1.Text)); END{if}; END; |
Есть ли у кого алгоритм переноса русского текста по слогам?
Nomadic пишет:
Вот, когда-то писал для QuarkXPress, который русских переносов не понимает. Hе понимает сложные слова, но в 98% работает нормально.
|
{*********************************************************** * * * Hypernation for QuarkQPress * * written by Gorbunov A. A. * * acdc@media-press.donetsk.ua * * * ************************************************************} unit Hyper; interface uses Windows,Classes,SysUtils; Function SetHyph(pc:PChar;MaxSize:Integer):PChar; Function SetHyphString(s : String):String; Function MayBeHyph(p:PChar;pos:Integer):Boolean; implementation Type TSymbol=(st_Empty,st_NoDefined,st_Glas,st_Sogl,st_Spec); TSymbAR=array [0..1000] of TSymbol; PSymbAr=^TSymbAr; Const HypSymb=#$1F; Spaces=[' ', ',',';', ':','.','?','!','/', #10, #13 ]; GlasCHAR=['Й', 'й', 'У', 'у', 'Е', 'е','Ю', 'ю', 'А', 'а', 'О', 'о', 'Э', 'э', 'Я', 'я', 'И', 'и', { english } 'e', 'E', 'u', 'U','i', 'I', 'o', 'O', 'a', 'A', 'j', 'J' ]; SoglChar=['Г', 'г' , 'Ц', 'ц' ,'К', 'к' , 'Н', 'н' , 'Ш', 'ш' , 'щ', 'Щ' , 'З', 'з' , 'Х', 'х' ,'Ф', 'ф' , 'В', 'в' , 'П', 'п' , 'Р', 'р' , 'Л', 'л' , 'Д', 'д' ,'Ж', 'ж' , 'Ч', 'ч' , 'С', 'с' , 'М', 'м' , 'т', 'T' , 'б', 'Б' , { english } 'q', 'Q','w', 'W', 'r', 'R','t', 'T','y', 'Y','p', 'P','s','S', 'd', 'D','f', 'F', 'g', 'G','h', 'H','k', 'K','l', 'L','z','Z', 'x', 'X','c', 'C', 'v', 'V', 'b', 'B', 'n', 'N','m', 'M' ]; SpecSign= [ 'Ы', 'ы','Ь', 'ь', 'Ъ', 'ъ']; Function isSogl(c:Char):Boolean; begin Result:=c in SoglChar; end; Function isGlas(c:Char):Boolean; begin Result:=c in GlasChar; end; Function isSpecSign(c:Char):Boolean; begin Result:=c in SpecSign; end; Function GetSymbType(c:Char):TSymbol; begin if isSogl(c) then begin Result:=st_Sogl;exit;end; if isGlas(c) then begin Result:=st_Glas;exit;end; if isSpecSign(c) then begin Result:=st_Spec;exit;end; Result:=st_NoDefined; end; Function isSlogMore(c:pSymbAr;start,len:Integer):Boolean; var i:Integer; glFlag:Boolean; begin glFlag:=false; for i:=Start to Len-1 do begin if c^[i]=st_NoDefined then begin Result:=false;exit;end; if (c^[i]=st_Glas)and((c^[i+1]<>st_Nodefined)or(i<>Start)) then begin Result:=True; exit; end; end; Result:=false; end; { расставлялка переносов } Function SetHyph(pc:PChar;MaxSize:Integer):PChar; var HypBuff : Pointer; h : PSymbAr; i : Integer; len : Integer; Cur : Integer; { Tекущая позиция в разультирующем массиве} cw : Integer; { Номер буквы в слове} Lock: Integer; { счетчик блокировок} begin Cur:=0; len := StrLen(pc); if (MaxSize=0)OR(Len=0) then begin Result:=nil; Exit; end; GetMem(HypBuff,MaxSize); GetMem(h,Len+1); { заполнение массива типов символов} for i:=0 to len-1 do h^[i]:=GetSymbType(pc[i]); { собственно расстановка переносов} cw:=0; Lock:=0; for i:=0 to Len-1 do begin PChar(HypBuff)[cur]:=PChar(pc)[i];Inc(Cur); if i>=Len-2 then Continue; if h^[i]=st_NoDefined then begin cw:=0;Continue;end else Inc(cw); if Lock<>0 then begin Dec(Lock);Continue;end; if cw<=1 then Continue; if not(isSlogMore(h,i+1,len)) then Continue; if (h^[i]=st_Sogl)and(h^[i-1]=st_Glas)and(h^[i+1]=st_Sogl)and(h^[i+2]<>st_Spec) then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end; if (h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Sogl)and(h^[i+2]=st_Glas) then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end; if (h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Glas)and(h^[i+2]=st_Sogl) then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end; if (h^[i]=st_Spec) then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1; end; end; {} FreeMem(h,Len+1); PChar(HypBuff)[cur]:=#0; Result:=HypBuff; end; Function Red_GlasMore(p:Pchar;pos:Integer):Boolean; begin While p[pos]<>#0 do begin if p[pos] in Spaces then begin Result:=False; Exit; end; if isGlas(p[pos]) then begin Result:=True; Exit; end; Inc(pos); end; Result:=False; end; Function Red_SlogMore(p:Pchar;pos:Integer):Boolean; Var BeSogl,BeGlas:Boolean; begin BeSogl:=False; BeGlas:=False; While p[pos]<>#0 do begin if p[pos] in Spaces then Break; if Not BeGlas then BeGlas:=isGlas(p[pos]); if Not BeSogl then BeSogl:=isSogl(p[pos]); Inc(pos); end; Result:=BeGlas and BeSogl; end; Function MayBeHyph(p:PChar;pos:Integer):Boolean; var i:Integer; len:Integer; begin i:=pos; Len:=StrLen(p); Result:= (Len>3) AND (i>2) AND (i<Len-2) AND (not (p[i] in Spaces)) AND (not (p[i+1] in Spaces)) AND (not (p[i-1] in Spaces)) AND ( (isSogl(p[i])and isGlas(p[i-1])and isSogl(p[i+1])and Red_SlogMore(p,i+1)) OR ((isGlas(p[i]))and(isSogl(p[i-1]))and(isSogl(p[i+1]))and(isGlas(p[i+2]))) OR ((isGlas(p[i]))and(isSogl(p[i-1]))and(isGlas(p[i+1])) and Red_SlogMore(p,i+1) ) OR ((isSpecSign(p[i]))) ); end; Function SetHyphString(s : String):String; Var Res:PChar; begin Res:=SetHyph(PChar(S),Length(S)*2) Result:=Res; FreeMem(Res,Length(S)*2); end; end. |
[001606]
Функция бинарного поиска
|
function FoundByBinarySearch ( LowIdx, HighIdx : LongInt; var Result : LongInt; const GoalIs : CompareFunc; var Data; var Goal ) : Boolean; var CompVal : CompareResults; begin FoundByBinarySearch := FALSE; if HighIdx < LowIdx then Exit; Result := LowIdx + ((HighIdx-LowIdx) div 2); CompVal := GoalIs(Result, Data, Goal); if CompVal = BinEqual then FoundByBinarySearch := TRUE else if (LowIdx < HighIdx) then begin if CompVal = BinLess then HighIdx := Result-1 else {CompVal = BinGreater} LowIdx := Result+1; FoundByBinarySearch := FoundByBinarySearch( LowIdx, HighIdx, Result, GoalIs, Data, Goal) end else if (CompVal = BinLess) then Dec(Result) end; { function FoundByBinarySearch } |
[000406]
Генерация еженедельных списков задач
Мне необходима программа, которая генерировала бы еженедельные списки задач. Программа должна просто показывать количество недель в списке задач и организовывать мероприятия, не совпадающие по времени. В моем текущем планировщике у меня имеется 12 групп и планы на 11 недель.
Мне нужен простой алгоритм, чтобы решить эту проблему. Какие идеи?
Вот рабочий код (но вы должны просто понять алгоритм работы):
|
unit Unit1;
interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) ListBox1: TListBox; Edit1: TEdit; Button1: TButton; procedure Button1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const maxTeams = 100; var Teams: Array[1..maxTeams] of integer; nTeams,ix,week,savix: integer; function WriteBox(week: integer):string; var str: string; ix: integer; begin Result := Format('Неделя=%d ',[week]); for ix := 1 to nTeams do begin if odd(ix) then Result := Result+' ' else Result := Result+'v'; Result := Result+IntToStr(Teams[ix]); end; end; procedure TForm1.Button1Click(Sender: TObject); begin nTeams := StrToInt(Edit1.Text); if Odd(nTeams) then inc(nTeams); {должны иметь номера каждой группы} ListBox1.Clear; for ix := 1 to nTeams do Teams[ix] := ix; ListBox1.Items.Add(WriteBox(1)); for week := 2 to nTeams-1 do begin Teams[1] := Teams[nTeams-1]; {используем Teams[1] в качестве временного хранилища} for ix := nTeams downto 2 do if not Odd(ix) then begin savix := Teams[ix]; Teams[ix] := Teams[1]; Teams[1] := savix; end; for ix := 3 to nTeams-1 do if Odd(ix) then begin savix := Teams[ix]; Teams[ix] := Teams[1]; Teams[1] := savix; end; Teams[1] := 1; {восстанавливаем известное значение} ListBox1.Items.Add(WriteBox(week)); end; end; end. |
- Mike Orriss [001058]
Генерация случайного пароля
The_Sprite советует:
Вам понадобилось, чтобы Ваше приложение само создавало пароли ? Возможно данный способ Вам пригодится. Всё очень просто: пароль создаётся из символов, выбираемых случайным образом из таблицы.
Совместимость: Delphi 5.x (или выше)
Собственно сам исходничек: Пароль создаётся из символов, содержащихся в таблице.
Внимание: Длина пароля должна быть меньше, чем длина таблицы!
|
// запускаем генератор случайных чисел (только при старте приложения).
procedure TForm1.FormCreate(Sender: TObject); begin Randomize; end; function RandomPwd(PWLen: integer): string; // таблица символов, используемых в пароле const StrTable: string = '!#$%&/()=?@<>|{[]}\*~+#;:.-_' + 'ABCDEFGHIJKLMabcdefghijklm' + '0123456789' + 'ДЦЬдцьЯ' + 'NOPQRSTUVWXYZnopqrstuvwxyz'; var N, K, X, Y: integer; begin // проверяем максимальную длину пароля if (PWlen > Length(StrTable)) then K := Length(StrTable)-1 else K := PWLen; SetLength(result, K); // устанавливаем длину конечной строки Y := Length(StrTable); // Длина Таблицы для внутреннего цикла N := 0; // начальное значение цикла while N < K do begin // цикл для создания K символов X := Random(Y) + 1; // берём следующий случайный символ // проверяем присутствие этого символа в конечной строке if (pos(StrTable[X], result) = 0) then begin inc(N); // символ не найден Result[N] := StrTable[X]; // теперь его сохраняем end; end; end; procedure TForm1.Button1Click(Sender: TObject); var cPwd: string; begin // вызываем функцию генерации пароля из 30 символов cPwd := RandomPwd(30); // ... end; |
[001379]
Ханойская башня
"Ханойская башня" построена на очень простом алгоритме. Здесь я привожу этот алгоритм, который Вы сможете без труда воспроизвести.
|
type THanoiBin = 0..2; THanoiLevel = 0..9; |
|
procedure MoveDisc(FromPin, ToPin : THanoiPin; Level : THanoiLevel); // Это Вы должны сделать сами. Переместите один диск с одного штырька на другой. // Диск окажется наверху (естественно, выше него дисков не будет) |
Вы можете каким угодно образом перемещать диски 3-х пирамид. 3 пирамиды - наиболее простая разновидность алгоритма. Таким образом процедура переноса диска (MoveDisc) аналогична операции переноса диска на верхний уровень (MoveTopDisc): переместить диск наверх с одного штырька (FromPin) на другой штырек (ToPin) и передать указатель на штырек-приемник (MoveTower) вместе с уровнем расположения перемещенного диска. Другое решение заключается в использовании трех массивов [THanoiLevel] логического типа. В этом случае триггер "Истина (True)" означает наличие на пирамиде диска с размером, соответствующим порядковому номеру элемента массива THanoiLevel.
|
procedure MoveTower(FromPin, ToPin : THanoiPin; Level : THanoiLevel); begin if HanoiLevel <= High(THanoiLevel) then begin MoveTower(FromPin, 3 - FromPin - ToPin, Level + 1); MoveDisc(FromPin, ToPin, Level); MoveTower(3 - FromPin - ToPin, ToPin, Level + 1); end; end; |
Чтобы переместить пирамиду целиком, вы должны вызвать процедуру MoveTower следующим образом:
| MoveTower(0, 1, Low(THanoiLevel)); |
Icon
Извлечение из EXE-файла иконки и рисование ее в TImage.
Каким образом извлечь иконку из EXE- и DLL-файлов (ExtractAssociatedIcon) и отобразить ее на компоненте Timage или небольшой области на форме?
|
uses ShellApi; procedure TForm1.Button1Click(Sender: TObject); var IconIndex : word; h : hIcon; begin IconIndex := 0; h := ExtractAssociatedIcon(hInstance, 'C:\WINDOWS\NOTEPAD.EXE', IconINdex); DrawIcon(Form1.Canvas.Handle, 10, 10, h); end; |
Instance
Как не допустить запуск второй копии программы?
Решение 1
Алгоритм, применяемый мною:
В блоке begin..end модуля .dpr:
|
begin if HPrevInst <>0 then begin ActivatePreviousInstance; Halt; end; end; |
Реализация в модуле:
|
unit PrevInst; interface uses WinProcs, WinTypes, SysUtils; type PHWnd = ^HWnd; function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; export; procedure ActivatePreviousInstance; implementation function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; var ClassName : array[0..30] of char; begin Result := true; if GetWindowWord(Wnd, GWW_HINSTANCE) = HPrevInst then begin GetClassName(Wnd, ClassName, 30); if STRIComp(ClassName,'TApplication')=0 then begin TargetWindow^ := Wnd; Result := false; end; end; end; procedure ActivatePreviousInstance; var PrevInstWnd: HWnd; begin PrevInstWnd := 0; EnumWindows(@EnumApps,LongInt(@PrevInstWnd)); if PrevInstWnd <> 0 then if IsIconic(PrevInstWnd) then ShowWindow(PrevInstWnd,SW_Restore) else BringWindowToTop(PrevInstWnd); end; end. |
Решение 2
Предоставленное разработчиками Delphi 2 Пачекой (Pacheco) и Тайхайрой (Teixeira) и значительно переработанное.
|
unit multinst; { Применение: Необходимый код в исходном проекте if InitInstance then begin Application.Initialize; Application.CreateForm(TFrmSelProject, FrmSelProject); Application.Run; end; Это все понятно (я надеюсь) } interface uses Forms, Windows, Dialogs, SysUtils; const MI_NO_ERROR = 0; MI_FAIL_SUBCLASS = 1; MI_FAIL_CREATE_MUTEX = 2; { Проверка правильности запуска приложения с помощью описанных ниже функций. } { Количество флагов ошибок MI_* может быть более одного. } function GetMIError: Integer; Function InitInstance : Boolean; implementation const UniqueAppStr : PChar; {Различное для каждого приложения} var MessageId: Integer; WProc: TFNWndProc = Nil; MutHandle: THandle = 0; MIError: Integer = 0; function GetMIError: Integer; begin Result := MIError; end; function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint): Longint; StdCall; begin { Если это - сообщение о регистрации... } if Msg = MessageID then begin { если основная форма минимизирована, восстанавливаем ее } { передаем фокус приложению } if IsIconic(Application.Handle) then begin Application.MainForm.WindowState := wsNormal; ShowWindow(Application.Mainform.Handle, sw_restore); end; SetForegroundWindow(Application.MainForm.Handle); end { В противном случае посылаем сообщение предыдущему окну } else Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam); end; procedure SubClassApplication; begin { Обязательная процедура. Необходима, чтобы обработчик } { Application.OnMessage был доступен для использования. } WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC, Longint(@NewWndProc))); { Если происходит ошибка, устанавливаем подходящий флаг } if WProc = Nil then MIError := MIError or MI_FAIL_SUBCLASS; end; procedure DoFirstInstance; begin SubClassApplication; MutHandle := CreateMutex(Nil, False, UniqueAppStr); if MutHandle = 0 then MIError := MIError or MI_FAIL_CREATE_MUTEX; end; procedure BroadcastFocusMessage; { Процедура вызывается, если уже имеется запущенная копия Вашей программы. } var BSMRecipients: DWORD; begin { Не показываем основную форму } Application.ShowMainForm := False; { Посылаем другому приложению сообщение и информируем о необходимости } { перевести фокус на себя } BSMRecipients := BSM_APPLICATIONS; BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE, @BSMRecipients, MessageID, 0, 0); end; Function InitInstance : Boolean; begin MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr); if MutHandle = 0 then begin { Объект Mutex еще не создан, означая, что еще не создано } { другое приложение. } ShowWindow(Application.Handle, SW_ShowNormal); Application.ShowMainForm:=True; DoFirstInstance; result := True; end else begin BroadcastFocusMessage; result := False; end; end; initialization begin UniqueAppStr := Application.Exexname; MessageID := RegisterWindowMessage(UniqueAppStr); ShowWindow(Application.Handle, SW_Hide); Application.ShowMainForm:=FALSE; end; finalization begin if WProc <> Nil then { Приводим приложение в исходное состояние } SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc)); end; end. |
Решение 3
|
VAR MutexHandle:THandle; Var UniqueKey : string; FUNCTION IsNextInstance:BOOLEAN; BEGIN Result:=FALSE; MutexHandle:=0; MutexHandle:=CREATEMUTEX( NIL,TRUE, UniqueKey); IF MutexHandle<>0 THEN BEGIN IF GetLastError=ERROR_ALREADY_EXISTS THEN BEGIN Result:=TRUE; CLOSEHANDLE(MutexHandle); MutexHandle:=0; END; END; END; begin CmdShow:=SW_HIDE; MessageId:=RegisterWindowMessage(zAppName); Application.Initialize; IF IsNextInstance THEN PostMessage(HWND_BROADCAST, MessageId,0,0) ELSE BEGIN Application.ShowMainForm:=FALSE; Application.CreateForm(TMainForm, MainForm); MainForm.StartTimer.Enabled:=TRUE; Application.Run; END; IF MutexHandle<>0 THEN CLOSEHANDLE(MutexHandle); end. |
В MainForm вам необходимо вставить обработчик внутреннего сообщения
|
PROCEDURE TMainForm.OnAppMessage( VAR M:TMSG; VAR Ret:BOOLEAN ); BEGIN IF M.Message=MessageId THEN BEGIN Ret:=TRUE; // Поместить окно наверх !!!!!!!! END; END; INITIALIZATION ShowWindow(Application.Handle, SW_Hide); END. |
Как вычислить расстояние, имея широту и долготу.
Попробуйте следующий код. Я им пользуюсь продолжительное время.
Входные данные:
StartLat (начальная широта) = Градусы и сотые доли
StartLong (начальная долгота) = Градусы и сотые доли
EndLat (конечная широта) = Градусы и сотые доли
EndLong (конечная долгота) = Градусы и сотые доли
Выходные данные:
Distance (расстояние) = Расстояние в метрах
Bearing (смещение) = Смещение в градусах
Не забудьте включить модуль Math в список используемых (USES) модулей.
|
var // Передаваемые широта/долгота в градусах и сотых долях StartLat: double; // Начальная широта StartLong: double; // Начальная долгота EndLat: double; // Конечная широта EndLong: double; // Конечная долгота // Переменные, используемые для вычисления смещения и расстояния fPhimean: Double; // Средняя широта fdLambda: Double; // Разница между двумя значениями долготы fdPhi: Double; // Разница между двумя значениями широты fAlpha: Double; // Смещение fRho: Double; // Меридианский радиус кривизны fNu: Double; // Поперечный радиус кривизны fR: Double; // Радиус сферы Земли fz: Double; // Угловое расстояние от центра сфероида fTemp: Double; // Временная переменная, использующаяся в вычислениях Distance: Double; // Вычисленное расстояния в метрах Bearing: Double; // Вычисленное от и до смещение End const // Константы, используемые для вычисления смещения и расстояния D2R: Double = 0.017453; // Константа для преобразования градусов в радианы R2D: Double = 57.295781; // Константа для преобразования радиан в градусы a: Double = 6378137.0; // Основные полуоси b: Double = 6356752.314245; // Неосновные полуоси e2: Double = 0.006739496742337; // Квадрат эксцентричности эллипсоида f: Double = 0.003352810664747; // Выравнивание эллипсоида begin // Вычисляем разницу между двумя долготами и широтами и получаем среднюю широту fdLambda := (StartLong - EndLong) * D2R; fdPhi := (StartLat - EndLat) * D2R; fPhimean := ((StartLat + EndLat) / 2.0) * D2R; // Вычисляем меридианные и поперечные радиусы кривизны средней широты fTemp := 1 - e2 * (Power(Sin(fPhimean),2)); fRho := (a * (1 - e2)) / Power(fTemp, 1.5); fNu := a / (Sqrt(1 - e2 * (Sin(fPhimean) * Sin(fPhimean)))); // Вычисляем угловое расстояние fz := Sqrt(Power(Sin(fdPhi/2.0),2)+Cos(EndLat*D2R)*Cos(StartLat*D2R)*Power(Sin(fdLambda/2.0),2)) ; fz := 2 * ArcSin(fz); // Вычисляем смещение fAlpha := Cos(EndLat * D2R) * Sin(fdLambda) * 1 / Sin(fz); fAlpha := ArcSin(fAlpha); // Вычисляем радиус Земли fR := (fRho * fNu) / ((fRho * Power(Sin(fAlpha),2)) + (fNu * Power(Cos(fAlpha),2))); // Получаем смещение и расстояние Distance := (fz * fR); if((StartLat < EndLat) and (StartLong < EndLong)) then Bearing := Abs(fAlpha * R2D) else if ((StartLat < EndLat) and (StartLong > EndLong)) then Bearing := 360 - Abs(fAlpha * R2D) else if ((StartLat > EndLat) and (StartLong > EndLong)) then Bearing := 180 + Abs(fAlpha * R2D) else if ((StartLat > EndLat) and (StartLong < EndLong)) then Bearing := 180 - Abs(fAlpha * R2D); end; |
Лирическое отступление автора: в качестве входных параметров используются ШИРОТЫ (в множественном числе, ударение на втором слоге), ведь их две. Но хмммм.... долгота(ы???) тоже две, а как будет звучать множественное число? Загадка. Наверное не существует такой формы. (P.S. зато я знаю как будет множественное число от слова ДНО! Слабо?) [000161]
Манипулирование битами
Ок, я покажу как можно это сделать на примере 4 битов. Битовые маски обычно используются в некоторых специфических свойствах.
Для 4-битных чисел максимальное значение равно 1+2+4+8 = 15 (или 1111). Если свойство будет использовать биты как флажки ( 1 = True, 0 = False), то для каждой комбинации флажков результирующее число будет всегда уникальным.
Теперь поставим перед собой задачу определения статуса отдельного бита. Довольно муторным выглядит для такой задачи преобразования битов в десятичное число. Пойдем другим путем. Возьмем число, скажем 7 (0111), и попробуем выставить ему третий справа бит. Значение для проверки - 0100 (4 десятичное).
Итак, мы сравниваем две величины - 0100 и 0111, бит за битом. Вот некоторая "кухня" работы операторов, выполняющих битовые команды: 0100 0111 4 AND 7 = 0100 (4) (=4, т.к. бит, который мы хотим выставить, устанавливается в 1) 4 OR 7 = 0111 (7) (не так много в этом примере) 4 XOR 7 = 0011 (3) Если вы следуете за ходом моей мысли, то вы поймете, почему я начал с операции AND. Так как мы точно знаем, что идет проверка на выставленность единственного бита, который должен быть установлен в сравниваемом значении, то возможный результат может быть только 0 или (как в показанном примере) 4.
Итак, ваш код должен быть следующим: If (YourCheckVar AND 4) = 4 Then 3-й бит установлен Else 3-й бит не установлен; [001992]
Парсер печатных текстовых форм
Slava Kostin пишет:
Для себя недавно написал. А вдруг, кому пригодится? Часто приходится генерировать формы в текстовые файлы, заполнять поля кучей всяких значений. Приведенный ниже модуль помогает мне упростить свою жизнь. Для удобства использования я все оформил в виде одной функции.
Сначала приведу пример формы с комментариями для ее использования, затем - собственно юнит PrintForm.
Итак, форма: ;Строки комментариев должны начинаться со знака ";". ;В одной строке не должно быть более одной команды ;Секции могут следовать в любом порядке. ;Конечный вид формы будет сформирован путем конкатенации всех секций !FORM. ;Значения полей будут подставляться в форму в том порядке, в котором они ;встречаются в тексте файла-определения формы. При этом играет роль только ;порядок перечисления полей, а располагать эти описания можно в любом месте ;формы. В поля форму будут подставляться параметры, определенные в виде ; !FIELD[n](a) ; где n - порядковый номер параметра ; a - выравнивание (может принимать значения "c", "l", "r") ;Знакоместа для полей просматриваются слева направо и сверху вниз !DEFINE Mask="$" !FORM----------------------------------------------------------------- !FORM¬ Бланк учета отгрузки товара За $$ месяц ¬ !FORM¬ ¬ !FORM¬ Товар: $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ¬ !FORM¬ Стоимость единицы товара: $$$$$$$$$$ ¬ !FIELD[1](l) ;Месяц является первым из параметров !FIELD[2](l) ;Наименование товара !FIELD[3](c) ;Стоимость выравниваем по правому краю ;Предположим, что в дальнейшей части формы необходимо вывести символ "$" ;Для этого переопределим маску: !DEFINE Mask="#" ;И продолжаем определение формы: !FORM¬ Количество единиц товара: ###### штук ¬ !FORM¬ Общая сумма в рублях: ######## руб. ¬ !FORM¬ Общая сумма в долларах: ###### $ ¬ !FORML---------------------------------------------------------------- !FIELD[4](r) ;Количество единиц товара !FIELD[5](r) ;Общая сумма в рублях !FIELD[6](r) ;Общая сумма в долларах А это сам unit:
|
unit PrintForm; interface uses SysUtils; {Процедура, осуществляющая запись формы, определенной пользователем. Данные для заполнения этой формы берутся из архива FormData. FormFile - файл с шаблоном формы, оформленным особым образом (см. файл printform.frm) OutFile - файл, в котором будет сохранена заполненная форма Пример использования функции: var FormData: array [0..6] of String; begin FormData[1] := '03'; FormData[2] := 'Потники сушеные в контейнерах'; CharToOem(PChar(FormData[2]), PChar(FormData[2])); FormData[3] := '10000'; FormData[4] := '9'; FormData[5] := '90000'; FormData[6] := '69,23'; PrnForm(FormData, 'D:\MyProg\Forms\fillform.frm', 'D:\MyProg\Forms\_out.frm'); end. } function PrnForm(FormData: array of String; FormFile, OutFile: String): Integer; implementation {Автор: Slava Kostin} {Возвращаемые значения: 0 - все в порядке 1 - не найден файл формы 2 - обнаружена неизвестная команда 3 - неверный числовой параметр 4 - некорректный символ выравнивания -255 - произошла какая-то непонятная ошибка } function PrnForm(FormData: array of String; FormFile, OutFile: String): Integer; const COMMENT = ';'; //Символ комментария const INT_MASK = 0; //Внутренний (для функции) символ, считающийся //маской. Шаблон формы не должен содержать //ни одного символа с кодом, равным INT_MASK. const COMMANDS_QUANTITY = 3; //Количество обрабатываемых команд //Массив имен обрабатываемых команд в теле шаблона формы: const COMMANDS: array [0..COMMANDS_QUANTITY - 1] of String = ( '!DEFINE', '!FORM', '!FIELD' ); var frm_f, out_f: TextFile; i, fld_idx: Integer; isDigit: Boolean; msg, str, param: String; Mask: Char; outform, flds: array of String; align: array of Char; //Функция, возвращающая подстроку строки str, заключенную между //последовательностями символов LeftDelim слева и RightDelim справа function GetWordLimited(str: String; LeftDelim, RightDelim: String): String; begin Result := Copy(str, Pos(LeftDelim, str) + 1, LastDelimiter(RightDelim, str) - Pos(LeftDelim, str) - 1); end; //Данная процедура заменяет текущие символы маски в строке str //на внутренние символы маски для дальнейшей обработки procedure ReplaceMask(var str: String; Mask: Char); var i: Integer; begin for i := 1 to Length(str) do if str[i] = Mask then str[i] := Char(INT_MASK); end; //Центрирование строки str. Длина строки, которая должна быть //получена, задается параметром w. function CenterString(str: String; w: Integer): String; var i: Integer; begin Result := str; if w <= Length(str) then Exit; for i := 1 to (Trunc(w / 2)) do begin Insert(' ', str, 1); str := str + ' '; end; if Length(str) > w then SetLength(str, w); Result := str; end; //Функция, осуществляющая выравнивание содержимого поля //в соответствии с типом выравнивания: // L - по левому краю, // R - по правому краю, // C - по центру function AlignField(fld_idx, w: Integer): String; begin Result := ''; if fld_idx >= Length(flds) then Exit; case align[fld_idx] of 'L': Result := Format('%-' + IntToStr(w) + 's', [flds[fld_idx]]); 'R': Result := Format('%' + IntToStr(w) + 's', [flds[fld_idx]]); 'C': Result := CenterString(flds[fld_idx], w); else Exception.Create('1'); end; end; //Данная функция заменяет первую маску в строке на значение //соответствующего поля. Если строка не содержит маски, //функция возвращает false. При успешной замене - true function PutOneField(var str: String; fld_idx: Integer): Boolean; var first, last: Integer; begin Result := false; first := Pos(Char(INT_MASK), str); if (fld_idx >= Length(flds)) or (first = 0) then Exit; last := first; while (last < Length(str)) and (str[last] = Char(INT_MASK)) do Inc(last); str := Copy(str, 1, first - 1) + AlignField(fld_idx, last - first) + Copy(str, last, Length(str) - last + 1); Result := true; end; //Тело основной функции begin Result := 0; Mask := Char(INT_MASK); try if not FileExists(FormFile) then Exception.Create('1'); AssignFile(frm_f, FormFile); Reset(frm_f); AssignFile(out_f, OutFile); if not FileExists(OutFile) then Rewrite(out_f) else Append(out_f); while not Eof(frm_f) do begin ReadLn(frm_f, str); if Pos(COMMENT, str) <> 0 then //Обрубаем комментарии SetLength(str, Pos(COMMENT, str) - 1); str := Trim(str); if Length(str) > 0 then begin i := 0; while i < COMMANDS_QUANTITY do //Определение команды begin if UpperCase(Copy(str, 1, Length(COMMANDS[i]))) = COMMANDS[i] then Break; Inc(i); end; param := ''; //Когда команда определена, совершаем необходимые действия, //выбор которых производится в зависимости от порядкового //номера данной команды в массиве команд case i of 0: begin //Обработка команды !DEFINE param := UpperCase(Trim(Copy(str, Length(COMMANDS[i]) + 1, Pos('=', str) - Length(COMMANDS[i]) - 1))); if param = 'MASK' then Mask := GetWordLimited(str, '"', '"')[1]; end; 1: begin //Обработка команды !FORM Delete(str, 1, Length(COMMANDS[i])); ReplaceMask(str, Mask); SetLength(outform, Length(outform) + 1); outform[Length(outform) - 1] := str; end; 2: begin //Обработка команды !FIELD Delete(str, 1, Length(COMMANDS[i])); SetLength(flds, Length(flds) + 1); flds[Length(flds) - 1] := FormData[StrToInt(GetWordLimited(str, '[', ']'))]; SetLength(align, Length(align) + 1); align[Length(align) - 1] := UpperCase(GetWordLimited(str, '(', ')'))[1]; end; else Exception.Create('2'); //Если код команды не опознан - выходим с исключением end; end; end; //Шаблон формы и значения полей в том порядке, в котором //они встречаются в шаблоне, считаны целиком. //Далее производится подстановка значений полей на места масок //в шаблоне формы и запись формы в выходной файл: fld_idx := 0; for i := 0 to Length(outform) - 1 do begin while PutOneField(outform[i], fld_idx) do Inc(fld_idx); WriteLn(out_f, outform[i]); end; Close(out_f); Close(frm_f); except //Обработка ошибок, возникших при работе функции on E: EConvertError do //Ошибка преобразования типов begin Result := 3; end; //Все остальные типы ошибок идентифицируются по номеру. //Функция по окончании работы возвращает номер ошибки //(или 0, если в процессе работы не было ошибок) on E: Exception do begin msg := String(E.Message); isDigit := true; for i := 1 to Length(msg) do if not (msg[i] in [Char('0')..Char('9')]) then begin isDigit := false; Break; end; if not isDigit then begin Result := -255; Exit; end; Result := StrToInt(msg); end; end; end; end. |
[001897]
Проверка ISBN
ISBN (или International Standard Book Numbers, международные стандартные номера книг) - мистические кодовые числа, однозначно идентифицирующие книги. Цель этой статьи заключается в том, чтобы убрать покров таинственности, окружающий структуру ISBN, и в качестве примера разработать приложение, проверяющее правильность создания кода-кандидата на ISBN.
ISBN имеет длину тринадцать символов, которые ограничиваются в использовании символами-цифрами от "0" до "9", дефисом, и буквой "X". Этот тринадцатисимвольный код состоит из четырех частей (между которыми располагается дефис): идентификатор группы, идентификатор издателя, идентификатор книги для издателя, и контрольная цифра. Первая часть (идентификатор группы) используется для обозначения страны, географического региона, языка и пр.. Вторая часть (идентификатор издателя) однозначно идентифицирует издателя. Третья часть (идентификатор книги) однозначно идентифицирует данную книгу среди коллекции книг, выпущенных данным издателем. Четвертая, заключительная часть (контрольная цифра), используется в коде алгоритме другими цифрами для получения поддающегося проверке ISBN. Количество цифр, содержащееся в первых трех частях, может быть различным, но контрольная цифра всегда содержит один символ (расположенный между "0" и "9" включительно, или "X" для величины 10), а само ISBN в целом имеет длину тринадцать символов (десять чисел плюс три дефиса, разделяющих три части ISBN).
ISBN 3-88053-002-5 можно так разложить на части: Группа: 3 Издатель: 88053 Книга: 002 Контрольная цифра: 5 ISBN можно проверить на правильность кода, используя простой математический алгоритм. Суть его в следующем: нужно взять каждую из девяти цифр первых трех частей ISBN (пропуская нечисловые дефисы), умножить каждую отдельную цифру на число цифр, стоящих слева от позиции числа ISBN (оно всегда будет меньше одинадцати), сложить все результаты умножения, прибавить контрольную цифру, после чего разделить получившееся число на одиннадцать. Если после деления на одинадцать никакого остатка не образуется (т.е., число по модулю 11 делится без остатка), кандидат на ISBN является верным числом ISBN. К примеру, используем предыдущий образец ISBN 3-88053-002-5: ISBN: 3 8 8 0 5 3 0 0 2 5 Множитель: 10 9 8 7 6 5 4 3 2 1 Продукт: 30+72+64+00+30+15+00+00+04+05 = 220 Поскольку 220 на одинадцать делится без остатка, расмотренный нами кандидат на IDBN является верным кодом ISBN.
Данный алгоритм проверки легко портируется в код Pascal/Delphi. Для извлечения контрольной цифры и кода из ISBN номера используются строковые функции и процедуры, после чего они передаются в функцию проверки. Контрольная цифра преобразуется в тип целого, на основе ее формируется стартовое значение составной переменной, состоящей из добавляемых цифр, умноженных на их позицию в коде ISBN (отдельные цифры, составляющие первые три части ISBN). Для последовательной обработки каждой цифры используется цикл For, в котором мы игнорируем дефисы и умножаем текущую цифру на ее позицию в коде ISBN. В заключение, значение этой составной переменной проверяется на делимость без остатка на одиннадцать. Если остатка после деления нет, код ISBN верен, если же остаток существует, то код кандидат на ISBN имеет неправильный код.
Вот пример этой методики, изложенной на языке функций Delphi:
|
function IsISBN(ISBN: String): Boolean; var Number, CheckDigit: String; CheckValue, CheckSum, Err: Integer; i, Cnt: Word; begin {Получаем контрольную цифру} CheckDigit := Copy(ISBN, Length(ISBN), 1); {Получаем остальную часть, ISBN минус контрольная цифра и дефис} Number := Copy(ISBN, 1, Length(ISBN) - 2); {Длина разницы ISBN должны быть 11 и контрольная цифра между 0 и 9, или X} if (Length(Number) = 11) and (Pos(CheckDigit, '0123456789X') > 0) then begin {Получаем числовое значение контрольной цифры} if (CheckDigit = 'X') then CheckSum := 10 else Val(CheckDigit, CheckSum, Err); {Извлекаем в цикле все цифры из кода ISBN, применяя алгоритм декодирования} Cnt := 1; for i := 1 to 12 do begin {Действуем, если только текущий символ находится между "0" и "9", исключая дефисы} if (Pos(Number[i], '0123456789') > 0) then begin Val(Number[i], CheckValue, Err); {Алгоритм для каждого символа кода ISBN, Cnt - n-й обрабатываемый символ} CheckSum := CheckSum + CheckValue * (11 - Cnt); Inc(Cnt); end; end; {Проверяем делимость без остатка полученного значения на 11} if (CheckSum MOD 11 = 0) then IsISBN := True else IsISBN := False; end else IsISBN := False; end; |
Это примитивный пример, сильно упрощенный для лучшего понимания алгоритма декодирования кода ISBN. В реальной жизни (приложении) имеется немало мелочей, которые необходимо учесть для нормальной работы. Для примера, описанная выше функция требует от кандидата ISBN строку паскалевского типа с дефисами, разделяющими четыре части кода. В качестве дополнительной функциональности можно проверять кандидата ISBNs на наличие дефисов. Другой полезной вещью могла бы быть проверка на наличие трех дефисов на нужных позициях, а не простая проверка на наличие необходимых одиннадцати символов-цифр. [001546]
Управление битами
Существует ли "человеческий" способ гашения и выставления битов?
|
{****************************************** Параметр TheBit считается в пределах 0..31 ******************************************} unit Bitwise; interface function IsBitSet(const val: longint; const TheBit: byte): boolean; function BitOn(const val: longint; const TheBit: byte): LongInt; function BitOff(const val: longint; const TheBit: byte): LongInt; function BitToggle(const val: longint; const TheBit: byte): LongInt; implementation function IsBitSet(const val: longint; const TheBit: byte): boolean; begin result := (val and (1 shl TheBit)) <> 0; end; function BitOn(const val: longint; const TheBit: byte): LongInt; begin result := val or (1 shl TheBit); end; function BitOff(const val: longint; const TheBit: byte): LongInt; begin result := val and ((1 shl TheBit) xor $FFFFFFFF); end; function BitToggle(const val: longint; const TheBit: byte): LongInt; begin result := val xor (1 shl TheeBit); end; end. |
[000624]
Задание псевдонима программным путем Эта информация поможет вам разобраться в вопросе создания и использования ПСЕВДОНИМОВ баз данных в ваших приложениях.
Вне Delphi создание и конфигурирование псевдонимов осуществляется утилитой BDECFG.EXE. Тем не менее, применяя компонент TDatabase, вы можете в вашем приложении создать и использовать псевдоним, не определенный в IDAPI.CFG.
Важно понять, что создав псевдоним, использовать его можно только в текущем сеансе вашего приложения. Псевдонимы определяеют расположение таблиц базы данных и параметры связи с сервером баз данных. В конце концов, вы получаете преимущества использования псевдонимов в пределах вашего приложения без необходимости беспокоиться о наличии их в конфигурационном файле IDAPI.CFG в момент инициализации приложения.
Некоторые варианты решения задачи:
Пример #1: Пример #1 создает и конфигурирует псевдоним для базы данных STANDARD (.DB, .DBF). Псевдоним затем используется компонентом TTable.
Пример #2: Пример #2 создает и конфигурирует псевдоним для базы данных INTERBASE (.gdb). Псевдоним затем используется компонентом TQuery для подключения к двум таблицам базы данных.
Пример #3: Пример #3 создает и конфигурирует псевдоним для базы данных STANDARD (.DB, .DBF). Демонстрация ввода псевдонима пользователем и его конфигурация во время выполнения программы.
Пример #1: Используем базу данных .DB или .DBF (STANDARD) Создаем новый проект. Располагаем на форме следующие компоненты: - TDatabase, TTable, TDataSource, TDBGrid, and TButton. Дважды щелкаем на компоненте TDatabase или через контекстное меню (правая кнопка мыши) вызываем редактор базы данных. Присваиваем базе данных имя 'MyNewAlias'. Это имя будет выполнять роль псевдонима в свойстве DatabaseName для компонентов типа TTable, TQuery, TStoredProc. Выбираем в поле Driver Name (имя драйвера) пункт STANDARD. Щелкаем на кнопке Defaults. Это автоматически добавляет путь (PATH=) в секцию перекрытых параметров (окно Parameter Overrides). Устанавливаем PATH= to C:\DELPHI\DEMOS\DATA (PATH=C:\DELPHI\DEMOS\DATA). Нажимаем кнопку OK и закрываем окно редактора. В компоненте TTable свойству DatabaseName присваиваем 'MyNewAlias'. В компоненте TDataSource свойству DataSet присваиваем 'Table1'. В компоненте DBGrid свойству DataSource присваиваем 'DataSource1'. Создаем в компоненте TButton обработчик события OnClick.
| procedure TForm1.Button1Click(Sender: TObject); begin Table1.Tablename:= 'CUSTOMER'; Table1.Active:= True; end; |
| procedure TForm1.Button1Click(Sender: TObject); begin Database1.DatabaseName:= 'MyNewAlias'; Database1.DriverName:= 'STANDARD'; Database1.Params.Clear; Database1.Params.Add('PATH=C:\DELPHI\DEMOS\DATA'); Table1.DatabaseName:= 'MyNewAlias'; Table1.TableName:= 'CUSTOMER'; Table1.Active:= True; DataSource1.DataSet:= Table1; DBGrid1.DataSource:= DataSource1; end; |
| procedure TForm1.Button1Click(Sender: TObject); begin Query1.SQL.Clear; Query1.SQL.ADD( 'SELECT DISTINCT * FROM CUSTOMER C, SALES S WHERE (S.CUST_NO = C.CUST_NO) ORDER BY C.CUST_NO, C.CUSTOMER'); Query1.Active:= True; end; |
Этот пример выводит диалоговое окно и создает псевдоним на основе информации, введенной пользователем.
Директория, имя сервера, путь, имя базы данных и другая необходимая информация для получения псевдонима может быть получена приложением из диалогово окна или конфигурационного .INI файла.
Выполняем шаги 1-11 из примера #1. Пишем следующий обработчик события OnClick компонента TButton:
|
procedure TForm1.Buttton1Click(Sender: TObject); var NewString: string; ClickedOK: Boolean; begin NewString := 'C:\'; ClickedOK := InputQuery('Database Path', 'Path: --> C:\DELPHI\DEMOS\DATA', NewString); if ClickedOK then begin Database1.DatabaseName:= 'MyNewAlias'; Database1.DriverName:= 'STANDARD'; Database1.Params.Clear; Database1.Params.Add('Path=' + NewString); Table1.DatabaseName:= 'MyNewAlias'; Table1.TableName:= 'CUSTOMER'; Table1.Active:= True; DataSource1.DataSet:= Table1; DBGrid1.DataSource:= DataSource1; end; end; |
Добавление псевдонима с помощью функции DbiAddAlias
|
var
pszAliasName : PChar; { Имя псевдонима }
pszDriverType : PChar; { Тип драйвера для псевдонима }
pszParams : PChar; { Дополнительные параметры }
bPersist : Bool; { Постоянный или временный псевдоним }
dbiRes : Integer; {Возвращаемый код }
begin
pszAliasName := strAlloc(25); pszDriverType := strAlloc(25); pszParams := strAlloc(100); try bPersist := True; strPcopy(pszAliasName, 'Lance'); strPcopy(pszDriverType, 'PARADOX'); strPcopy(pszParams, 'PATH:'+'c:\Paradox\'); dbiRes := DbiAddAlias(nil, pszAliasName, pszDriverType, pszParams,bPersist); finally strDispose(pszAliasName); strDispose(pszDriverType); strDispose(pszParams); end; |
- Tom Stickle [000765]
Имитация псевдонима PdoxWIN 'PRIV'
| var d : TDataBase; begin d := TDataBase.Create(Application); d.DataBaseName := 'PRIV'; d.DriverName := 'STANDARD'; d.Params.Add('PATH='+Session.PrivateDir); d.Connected := True; end; |
...теперь вы имеете псевдоним с именем 'PRIV', указывающий на частный каталог.
- Eryk Bottomley [000871]
Информация о псевдонимах BDE
Как через конфигурацию IDAPI получить физический каталог расположения базы данных, зная ее псевдоним?
Обратите внимание на метод GetAliasParams класса TSession.
Возвращенная строка будет содержать искомый путь.
Я пользуюсь следующей функцией:
|
uses DbiProcs, DBiTypes; function GetDataBaseDir(const Alias : string): String; (* Возвращает каталог расположения базы данных по заданному псевдониму (без обратного слеша) *) var sp : PChar; Res : pDBDesc; begin try New(Res); sp := StrAlloc(length(Alias)+1); StrPCopy(sp,Alias); if DbiGetDatabaseDesc(sp,Res) = 0 then Result := StrPas(Res^.szPhyName) else Result := ''; finally StrDispose(sp); Dispose(Res); end; end; |
Информация о псевдониме BDE
|
var MyAliasPath: string; const AliasName='MyAlias'; {**** Получаем из BDE путь MyAlias} ParamsList:= TStringList.Create; try with Session do begin Session.GetAliasNames(ParamsList); Session.GetAliasParams(AliasName,ParamsList); MyAliasPath:=Copy(ParamsList[0],6,50)+'\'; end; finally ParamsList.Free; end; |
|
uses DbiProcs, DBiTypes; function GetDataBaseDir(const Alias : string): String; (* Возвращает каталог базы данных для псевдонима (без завершающего обратного слеша) *) var sp : PChar; Res : pDBDesc; begin try New(Res); sp := StrAlloc(length(Alias)+1); StrPCopy(sp,Alias); if DbiGetDatabaseDesc(sp,Res) = 0 then Result := StrPas(Res^.szPhyName) else Result := ''; finally StrDispose(sp); Dispose(Res); end; end; |
[001217]
Изменение каталога псевдонима во время выполнения приложения
Я делаю это все время. У меня есть INI-файл, который сообщает, где можно найти таблицы и каталоги их расположения. Вот как я это делаю:
| procedure CheckTable( var Table : TTable; var TName : string ); var ChangePath : boolean; Path : string; ActiveState : Boolean; begin if ( TName = '' ) then TName := Table.TableName else with Table do begin ActiveState := Active; Close; Path := ExtractFilePath( TName ); ChangePath := HasAttr( DatabaseName, faDirectory ) or ( CompareText( DatabaseName, Path ) <> 0 ); if ( Length ( Path ) > 0 ) and ChangePath then DatabaseName := Path; if ( CompareText( ExtractFileName( Tname ), TableName ) <> 0 ) then TableName := ExtractFileName( Tname ); Active := ActiveState; end; end; |
[001225]
Изменение псевдонима во время выполнения программы
Тема: Установить путь псевдонима?
От: Vicar Hernandez 71610,3303
К: Eryk Bottomley 100271,47
Как с помощью DELPHI попроще изменить путь псевдонима (Alias Path)?
Вы можете создать виртуальный псевдоним (т.е. не сохраняемый в IDAPI.CFG) с помощью компонента TDataBase... и затем изменить ассоциированный DOS-путь на нужный вам.
Для примера:
| var d : TDatabase; begin d := TDatabase.Create(Application); d.DataBaseName := 'TEST_ALIAS'; d.DriverName := 'STANDARD'; d.Params.Add('PATH=C:\DBDEMOS'); d.Connected := True; end; |
...приведенный код может быть и бесполезен, но он показывает как это можно сделать. Также это можно сделать во время разработки приложения с помощью Инспектора Объектов.
Eryk [000707]
Отображение всех псевдонимов в ComboBox
Письмо от читателя:
Для отображения всех алиасов в ComboBox1:
|
//Для этого надо в Uses добавить ExtCtrls Session.GetAliasNames(ComboBox1.Items); |
С уважением,
Громов Роман
GromovRV@Bashneft.Bashnet.ru
[000640]
Получение пути псевдонима и таблицы I
Есть три способа сделать это... No1 годится только для постоянных псевдонимов BDE. No2 работает с BDE и локальными псевдонимами, и No3 работает с BDE и локальными псевдонимами, используя "тяжелый" путь, через вызовы DBI.
|
function GetDBPath1(AliasName: string): TFileName;
var ParamList: TStringList;
begin
ParamList := TStringList.Create;
with Session do
try
GetAliasParams(AliasName,ParamList);
Result := UpperCase(ParamList.Values['PATH'])+'\';
finally
Paramlist.Free;
end;
end;
function GetDBPath2(AliasName: string): TFileName; var ParamList: TStringList; i: integer; begin ParamList := TStringList.Create; with Session do try try GetAliasParams(AliasName,ParamList); except for i:=0 to pred(DatabaseCount) do if (Databases[i].DatabaseName = AliasName) then ParamList.Assign(Databases[i].Params); end; Result := UpperCase(ParamList.Values['PATH'])+'\'; finally Paramlist.Free; end; end; function GetDBPath3(ATable: TTable): TFileName; var TblProps: CURProps; pTblName, pFullName: DBITblName; begin with ATable do begin AnsiToNative(Locale, TableName, pTblName, 255); Check(DBIGetCursorProps(Handle, TblProps)); Check(DBIFormFullName(DBHandle, pTblName, TblProps.szTableType, pFullName)); Result := ExtractFilePath(StrPas(pFullName)); end; end; |
- Reinhard Kalinke [001020]
Получение пути псевдонима и таблицы II
Вот маленький примерчик того, как в Delphi можно получить информацию о псевдонимах. Для начала создайте новый проект с ListBox и тремя метками (с именамиListBox1, Label1, Label2 и Label3). Затем создайте обработчик события формы OnCreate с примерно следующим кодом:
|
procedure TForm1.FormCreate(Sender: TObject); begin Session.GetAliasNames(ListBox1.Items); end; |
Теперь создайте обработчик OnClick для ListBox:
|
procedure TForm1.ListBox1Click(Sender: TObject); var tStr: array[0..100] of char; Desc: DBDesc; begin if ListBox1.Items.Count = 0 then exit; StrPLCopy(tStr, ListBox1.Items.Strings[ListBox1.ItemIndex], High(tStr)); DbiGetDatabaseDesc(tStr, @Desc); with Desc do begin Label1.Caption := StrPas(Desc.szName); Label2.Caption := StrPas(Desc.szPhyName); Label3.Caption := StrPas(Desc.szDbType); end; end; |
Добавьте следующие модули в секцию 'uses' в верхней части модуля:
| DB, DBTables, DBITypes, DBIProcs; |
Теперь вы можете увидеть путь для всех ваших стандартных псевдонимов (Paradox и dBase). [001287]
Получение пути псевдонима и таблицы III
Используйте Session.GetAliasParams. В ответ вы получите объект Tstrings, откуда вы можете получить значение для переменной 'PATH". Для получения дополнительной информации обратитесь к электронной справке к разделу, описывающему TSession. Объект Session объявлен в модуле DB.
|
uses db; var aliaspath : string[128]; begin aliaspath := Session.GetAliasParams['MyAlias'].values['PATH']; end; |
|
uses SysUtils,DbiProcs, DBiTypes; ... function GetDataBaseDir(const Alias : string): String; (* Возвращает каталог базы данных, на которую ссылается псевдним (без конечного обратного слеша) *) var sp : PChar; Res : pDBDesc; begin try New(Res); sp := StrAlloc(length(Alias)+1); StrPCopy(sp,Alias); if DbiGetDatabaseDesc(sp,Res) = 0 then Result := StrPas(Res^.szPhyName) else Result := ''; finally StrDispose(sp); Dispose(Res); end; end; |
[001316]
Получение пути псевдонима и таблицы IV
Nomadic советует: По таблице (фактически по Database) получить физическое местонахождение. Примечание: Database можно создать явно, если нет, Дельфи сама его создаст, доступ к ней по Table(Query).Database
|
uses DbiProcs; function GetDirByDatabase( Database: TDatabase ): string; var pszDir: PChar; begin pszDir := StrAlloc( 255 ); try DbiGetDirectory( Database.Handle, True, pszDir ); Result := StrPas( pszDir ); finally StrDispose( pszDir ); end; end; |
По алиасу.
|
function GetPhNameByAlias( sAlias: string ): string; var Database: TDatabase; pszDir: PChar; begin Database := TDatabase.Create( nil ); {allocate memory} pszDir := StrAlloc( 255 ); try Database.AliasName := sAlias; Database.DatabaseName := 'TEMP'; {requires a name -- is ignored} Database.Connected := True; {connect without opening any table} DbiGetDirectory( Database.Handle, True, pszDir ); {get the dir.} Database.Connected := False; {disconnect} Result := StrPas( pszDir ); {convert to a string} finally Database.Free; {free memory} StrDispose( pszDir ); end; end; |
[001357]
Псевдоним на лету
Попробуйте это:
|
type TDataMod = class(TDataModule) Database: TDatabase; public procedure TempAlias(NewAlias, NewDir: String); end; procedure TDataMod.TempAlias(NewAlias, NewDir: String); begin with Session do if not IsAlias(NewAlias) then begin ConfigMode := cmSession; (* NewAlias будет ВРЕМЕННЫМ *) try AddStandardAlias(NewAlias, NewDir, 'PARADOX'); Database.Close; Database.AliasName := NewAlias; Database.Open; finally ConfigMode := cmAll; end; end; end; |
Комментарии:
a) Поместите компонент Database на форму DataModule;
b) Задайте свойству DatabaseName имя базы данных, например, 'TempDB';
c) Задайте свойству DatabaseName компонента TTable значение = 'TempDB'
d) Для получения дополнительной информации ознакомьтесь с примером MastApp, поставляемым вместе с D2.
[001209]
Псевдонимы
Попробуйте следующий код:
|
var theStrList : TStringList; GPath : String; begin theStrList := TStringList.Create; {Используем GetAliasParams для получения псевдонимов и ассоциированных с ними путей} Session.GetAliasParams(<Здесь псевдоним из выпадающего списка>,theStrList); {Удаляем первые шесть символов, которые всегда равны "PATH="} GPath := copy(theStrList[0],6,length(theStrList[0])) theStrList.Free; |
[001211]
Синтаксис функции DbiAddAlias
DbiAddAlias (пропущено в BDE.HLP & Руководстве пользователя)
Синтаксис: DBIResult DbiAddAlias( [hCfg], pszAliasName, pszDriverType, pszParams, bPersistent ); Описание: DbiAddAlias добавляет псевдоним в конфигурационный файл, связанный с текущим сеансом. Параметры: hCfg Type: hDBICfg (Входящий) Для BDE 2.5 данный параметр должен быть NULL. Указывает, что конфигурация действует в течение текущего сеанса. Другие значения для BDE 2.5 не поддерживаются. pszAliasName Type: pCHAR (Входящий) Указатель на имя псевдонима. Это имя нового псевдонима, который должен быть добавлен. pszDriverType Type: pCHAR (Входящий) Указатель на тип устройства. Это тип устройства для добавляемого псевдонима. Если данный параметр NULL, псевдоним будет добавлен для базы данных STANDARD. Если указан szPARADOX, szDBASE или szASCII, будет добавлена запись в генератор псевдонимов базы данных STANDARD для указания того, что данный тип будет предпочтительным типом устройства. Если указано имя устройства, то оно должно существовать в измененном файле конфигурации. pszParams Type: pCHAR (Входящий) Указатель на список дополнительных параметров. Данный список определяется следующим образом: "AliasOption: Option Data[;AliasOption: Option Data][;...]". AliasOption должен соответствовать одному из значений, возвращаемому DbiOpenCfgInfoList. Для псевдонимов базы данных STANDARD, единственно необходимый параметр - PATH, остальные игнорируются (без ошибок). Пример 1: Чтобы установить путь для использования базы данных STANDARD: "PATH:c:\mydata" Пример 2: Чтобы установить имя сервера и имя пользователя для использования драйвера SQL: "SERVER NAME: server:/path/database;USER NAME: myname" bPersistent Type: BOOL (Входящий) Определяет область действия нового псевдонима. TRUE Сохраняется в файле конфигурации для будующих сеансов. FALSE Для использования только в течение текущего сеанса. Псевдоним удаляется в конце сеанса (или при выходе из программы). Использование: Созданный данной функцией псевдоним будет иметь параметры по умолчанию, хранимые в списке параметров драйверов "DB OPEN", если только оне не перекрыты в параметре pszParams. Вы можете использовать DbiOpenCfgInfoList, чтобы изменить значение по умолчанию после добавления псевдонима с помощью DbiAddAlias. Для псевдонимов стандартной базы данных все параметры pszParams за исключением PATH игнорируются. Предварительные условия: DbiInit должен вызываться до вызова DbiAddAlias. Возвращаемые значения DBIResult: DBIERR_INVALIDPARAM Имя псевдонима Null или один из следующих типов pszDriverType: szASCII, szDBASE, szPARADOX. В последнем случае используйте NULL pszDriverType для указания на базу данных STANDARD. DBIERR_NONE Псевдоним был успешно добавлен. DBIERR_NAMENOTUNIQUE Существует другой псевдоним с тем же именем (работает когда bPersistent равен TRUE). DBIERR_OBJNOTFOUND Один (или более) из дополнительных параметров, указанных в pszParams не соответствуют правильным типам в секции драйверов конфигурационного файла. DBIERR_UNKNOWNDRIVER Имя устройства в конфигурационном файле при сопоставлении с pszDriverType не найдено. Смотри также: DbiInit, DbiOpenCfgInfoList [000714]
Какие есть рекомендации по использованию Apollo SDE?
Nomadic советует:
При работе с Аполло (если у тебя базы используются и досовскими задачами) - то в dbgrid'e поставь значение Font->Charset = OEM_Charset. И не забудь сразу после открытия базы вызывать метод Apollo1.SetTranslate(True). Если твое приложение будет работать с базами одновременно с досовскими, то советую перед открытием баз вызывать метод Apollo1.SysProp( SDE_SP_SETOBUFFER, Pointer( 0 ) ); для отключения буферизации операций чтения/записи в базы.
Если ты пишешь приложение, которое будет использовать базы только в кодировке Windows (CP1251), то тебе достаточно будет указать в dbgrid'e значение Font->Charset = Russian_Charset. Если базы в 866 кодиpовке, то: Использование TTable + TApollo:
=== Cut ====
|
TTable.Open; TApollo.SetTranslate(True); TTable.Refresh; |
=== Cut ====
Использование TApTable:
=== Cut ====
|
TApTable.Open; TApTable.SetTranslate(True); TApTable.Refresh; |
=== Cut ====
И вместо закоpючек бyдyт pодные pyсские бyквы. Пpавда, только пpи выполнении пpогpаммы. В дизайнеpе на этапе пpоектиpования псевдогpафика так и останется. [001301]
Arrayindelphi
Массив в Delphi
Раздел 1
Вот несколько функций для операций с двухмерными массивами. Самый простой путь для создания собственной библиотеки. Процедуры SetV и GetV позволяют читать и сохранять элементы массива VArray (его Вы можете объявить как угодно). Например:
|
type VArray : Array[1..1] of double; var X : ^VArray; NR, NC : Longint; begin NR := 10000; NC := 100; if AllocArray(pointer(X), N*Sizeof(VArray)) then exit; SetV(X^, NC, 2000, 5, 3.27); { X[2000,5] := 3.27 } end; function AllocArray(var V : pointer; const N : longint) : Boolean; begin {распределяем память для массива V размера N} try GetMem(V, N); except ShowMessage('ОШИБКА выделения памяти. Размер:' + IntToStr(N)); Result := True; exit; end; FillChar(V^, N, 0); {в случае включения длинных строк заполняем их нулями} Result := False; end; procedure SetV(var X : Varray;const N,ir,ic : LongInt;const value : double); begin {заполняем элементами двухмерный массив X размером ? x N : X[ir,ic] := value} X[N*(ir-1) + ic] := value; end; function GetV(const X : Varray; const N, ir,ic : Longint) : double; begin {возвращаем величины X[ir,ic] для двухмерного массива шириной N столбцов} Result := X[N*(ir-1) + ic]; end; |
Раздел 2
Самый простой путь - создать массив динамически
| Myarray := GetMem(rows * cols * sizeof(byte,word,single,double и пр.) |
сделайте функцию fetch_num типа
| function fetch_num(r,c:integer) : single; |
| result := pointer + row + col*rows |
и затем вместо myarray[2,3] напишите
| myarray.fetch_num(2,3) |
поместите эти функции в ваш объект и работа с массивами станет пустячным делом. Я экспериментировал с многомерными (вплоть до 8) динамическими сложными массивами и эти функции показали отличный результат.
Раздел 3
Вот способ создания одно- и двухмерных динамических массивов:
|
(* -- -- модуль для создания двух очень простых классов обработки динамических массивов -- TDynaArray : одномерный массив -- TDynaMatrix : двумерный динамический массив -- *) unit DynArray; INTERFACE uses SysUtils; Type TDynArrayBaseType = double; Const vMaxElements = (High(Cardinal) - $f) div sizeof(TDynArrayBaseType); {= гарантирует максимально возможный массив =} Type TDynArrayNDX = 1..vMaxElements; TArrayElements = array[TDynArrayNDX] of TDynArrayBaseType; {= самый большой массив TDynArrayBaseType, который мы может объявить =} PArrayElements = ^TArrayElements; {= указатель на массив =} EDynArrayRangeError = CLASS(ERangeError); TDynArray = CLASS Private fDimension : TDynArrayNDX; fMemAllocated : word; Function GetElement(N : TDynArrayNDX) : TDynArrayBaseType; Procedure SetElement(N : TDynArrayNDX; const NewValue : TDynArrayBaseType); Protected Elements : PArrayElements; Public Constructor Create(NumElements : TDynArrayNDX); Destructor Destroy; override; Procedure Resize(NewDimension : TDynArrayNDX); virtual; Property dimension : TDynArrayNDX read fDimension; Property Element[N : TDynArrayNDX] : TDynArrayBaseType read GetElement write SetElement; default; END; Const vMaxMatrixColumns = 65520 div sizeof(TDynArray); {= построение матрицы класса с использованием массива объектов TDynArray =} Type TMatrixNDX = 1..vMaxMatrixColumns; TMatrixElements = array[TMatrixNDX] of TDynArray; {= каждая колонка матрицы будет динамическим массивом =} PMatrixElements = ^TMatrixElements; {= указатель на массив указателей... =} TDynaMatrix = CLASS Private fRows : TDynArrayNDX; fColumns : TMatrixNDX; fMemAllocated : longint; Function GetElement( row : TDynArrayNDX; column : TMatrixNDX) : TDynArrayBaseType; Procedure SetElement( row : TDynArrayNDX; column : TMatrixNDX; const NewValue : TDynArrayBaseType); Protected mtxElements : PMatrixElements; Public Constructor Create(NumRows : TDynArrayNDX; NumColumns : TMatrixNDX); Destructor Destroy; override; Property rows : TDynArrayNDX read fRows; Property columns : TMatrixNDX read fColumns; Property Element[row : TDynArrayNDX; column : TMatrixNDX] : TDynArrayBaseType read GetElement write SetElement; default; END; IMPLEMENTATION (* -- -- методы TDynArray -- *) Constructor TDynArray.Create(NumElements : TDynArrayNDX); BEGIN {==TDynArray.Create==} inherited Create; fDimension := NumElements; GetMem( Elements, fDimension*sizeof(TDynArrayBaseType) ); fMemAllocated := fDimension*sizeof(TDynArrayBaseType); FillChar( Elements^, fMemAllocated, 0 ); END; {==TDynArray.Create==} Destructor TDynArray.Destroy; BEGIN {==TDynArray.Destroy==} FreeMem( Elements, fMemAllocated ); inherited Destroy; END; {==TDynArray.Destroy==} Procedure TDynArray.Resize(NewDimension : TDynArrayNDX); BEGIN {TDynArray.Resize==} if (NewDimension < 1) then raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [NewDimension]); Elements := ReAllocMem(Elements, fMemAllocated, NewDimension*sizeof(TDynArrayBaseType)); fDimension := NewDimension; fMemAllocated := fDimension*sizeof(TDynArrayBaseType); END; {TDynArray.Resize==} Function TDynArray.GetElement(N : TDynArrayNDX) : TDynArrayBaseType; BEGIN {==TDynArray.GetElement==} if (N < 1) OR (N > fDimension) then raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [N]); result := Elements^[N]; END; {==TDynArray.GetElement==} Procedure TDynArray.SetElement(N : TDynArrayNDX; const NewValue : TDynArrayBaseType); BEGIN {==TDynArray.SetElement==} if (N < 1) OR (N > fDimension) then raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [N]); Elements^[N] := NewValue; END; {==TDynArray.SetElement==} (* -- -- методы TDynaMatrix -- *) Constructor TDynaMatrix.Create(NumRows : TDynArrayNDX; NumColumns : TMatrixNDX); Var col : TMatrixNDX; BEGIN {==TDynaMatrix.Create==} inherited Create; fRows := NumRows; fColumns := NumColumns; {= выделение памяти для массива указателей (т.е. для массива TDynArrays) =} GetMem( mtxElements, fColumns*sizeof(TDynArray) ); fMemAllocated := fColumns*sizeof(TDynArray); {= теперь выделяем память для каждого столбца матрицы =} for col := 1 to fColumns do BEGIN mtxElements^[col] := TDynArray.Create(fRows); inc(fMemAllocated, mtxElements^[col].fMemAllocated); END; END; {==TDynaMatrix.Create==} Destructor TDynaMatrix.Destroy; Var col : TMatrixNDX; BEGIN {==TDynaMatrix.Destroy;==} for col := fColumns downto 1 do BEGIN dec(fMemAllocated, mtxElements^[col].fMemAllocated); mtxElements^[col].Free; END; FreeMem( mtxElements, fMemAllocated ); inherited Destroy; END; {==TDynaMatrix.Destroy;==} Function TDynaMatrix.GetElement( row : TDynArrayNDX; column : TMatrixNDX) : TDynArrayBaseType; BEGIN {==TDynaMatrix.GetElement==} if (row < 1) OR (row > fRows) then raise EDynArrayRangeError.CreateFMT('Индекс строки вышел за границы диапазона : %d', [row]); if (column < 1) OR (column > fColumns) then raise EDynArrayRangeError.CreateFMT('Индекс столбца вышел за границы диапазона : %d', [column]); result := mtxElements^[column].Elements^[row]; END; {==TDynaMatrix.GetElement==} Procedure TDynaMatrix.SetElement( row : TDynArrayNDX; column : TMatrixNDX; const NewValue : TDynArrayBaseType); BEGIN {==TDynaMatrix.SetElement==} if (row < 1) OR (row > fRows) then raise EDynArrayRangeError.CreateFMT('Индекс строки вышел за границы диапазона : %d', [row]); if (column < 1) OR (column > fColumns) then raise EDynArrayRangeError.CreateFMT('Индекс столбца вышел за границы диапазона : %d', [column]); mtxElements^[column].Elements^[row] := NewValue; END; {==TDynaMatrix.SetElement==} END. |
----Тестовая программа для модуля DynArray----
|
uses DynArray, WinCRT; Const NumRows : integer = 7; NumCols : integer = 5; Var M : TDynaMatrix; row, col : integer; BEGIN M := TDynaMatrix.Create(NumRows, NumCols); for row := 1 to M.Rows do for col := 1 to M.Columns do M[row, col] := row + col/10; writeln('Матрица'); for row := 1 to M.Rows do BEGIN for col := 1 to M.Columns do write(M[row, col]:5:1); writeln; END; writeln; writeln('Перемещение'); for col := 1 to M.Columns do BEGIN for row := 1 to M.Rows do write(M[row, col]:5:1); writeln; END; M.Free; END. |
Arrays
Динамические массивы
Очень простой пример...
|
Const MaxBooleans = (High(Cardinal) - $F) div sizeof(boolean); Type TBoolArray = array[1..MaxBooleans] of boolean; PBoolArray = ^TBoolArray; Var B : PBoolArray; N : integer; BEGIN N := 63579; {= получение памяти под динамический массив.. =} GetMem(B, N*sizeof(boolean)); {= работа с массивом... =} B^[3477] := FALSE; {= возвращение памяти в кучу =} {$IFDEF VER80} FreeMem(B, N*sizeof(boolean)); {$ELSE} FreeMem(B); {$ENDIF} END. |
Заполнения массива случаными неповторяющимися значениями Письмо от читателя...
Здравствуйте, Валентин. Огромное Вам спасибо за сбор и систематизацию советов по Delphi. Предлагаю Вам интересное решение заполнения массива случаными неповторяющимися значениями. Думаю этот алгоритм небесполезен.
|
type arr= array [1..255] of integer; procedure FillArray(var A: arr; n: integer); var i: integer; s: string; q: byte; begin randomize; s:=''; for i:=1 to n do begin q:=random(i); insert(chr(i),s, q); end; for i:=1 to n do begin A[i]:=ord(s[i]); end; end; |
e-mail: dedokv@mail.ru
He вступая в дискуссию, цитирую следующее письмо:
Заполнять ЦЕЛОЧИСЛЕННЫЙ массив, используя строки -- ЭТО ПОШЛО!
Приведу стандартную процедуру, работает в шесть раз быстрее, не имеет ограничений, да и кода поменьше :)
|
procedure FillArray(var A: array of Integer); var I, S, R: Integer; begin for I := 0 to High(A) do A[I] := I; for i := High(A) downto 0 do begin R := Random(I); S := A[R]; A[R] := A[I]; A[I] := S; end; end; |
e-mail: theodor_iv@mail.ru [000300]
Динамические массивы II В. Возможно создавать динамически-изменяющиеся массивы в Delphi?
О. Да. Для начала вам необходимо создать тип массива, использующего самый большой размер, который вам, вероятно, может понадобиться. В действительности, при создании типа никакой памяти не распределяется. Вот когда вы создаете переменную этого типа, тогда компилятор пытается распределить для вас необходимую память. Вместо этого создайте переменную, являющуюся указателем на этот тип. Этим вы заставите компилятор распределить лишь четыре байта, необходимые для размещения указателя.
Прежде, чем вы сможете пользоваться массивом, вам необходимо распределить для него память. Используя AllocMem, вы можете точно управлять выделяемым размером памяти. Для того, чтобы определить необходимое количество байт, которые вы должны распределить, просто умножьте размер массива на размер отдельного элемента массива. Имейте в виду, что самый большой блок, который вы сможете распределить в любой момент в 16-битной среде равен 64Kб. Самый большой блок, который вы можете в любой момент распределить в 32-битной среде равен 4Гб. Для определения максимального числа элементов, которые вы можете иметь в вашем конкретном массиве (в 16-битной среде), разделите 65,520 на размер отдельного элемента. Например: 65520 div SizeOf(LongInt)
Пример объявления типа массива и указателя:
|
type ElementType = LongInt; const MaxArraySize = (65520 div SizeOf(ElementType)); (* в 16-битной среде *) type MyArrayType = array[1..MaxArraySize] of ElementType; var P: ^MyArrayType; const ArraySizeIWant: Integer = 1500; |
| procedure AllocateArray; begin if ArraySizeIWant <= MaxArraySize then P := AllocMem(ArraySizeIWant * SizeOf(LongInt)); end; |
Вот процедура, которая с помощью цикла устанавливает величину каждого члена:
| procedure AssignValues; var I: Integer; begin for I := 1 to ArraySizeIWant do P^[I] := I; end; |
Помните также о том, что после использования массива всю распределенную память необходимо освободить. Вот пример того, как избавиться от этого массива:
| procedure DeallocateArray; begin P := AllocMem(ArraySizeIWant * SizeOf(LongInt)); end; |
|
unit Unit1;
interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type ElementType = Integer; const MaxArraySize = (65520 div SizeOf(ElementType)); { в 16-битной среде } type { Создаем тип массива. Убедитесь в том, что вы установили максимальный диапазон, который вам, вероятно, может понадобиться. } TDynamicArray = array[1..MaxArraySize] of ElementType; TForm1 = class(TForm) Button1: TButton; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; { Создаем переменную типа указатель на ваш тип массива. } P: ^TDynamicArray; const { Это типизированные константы. В действительности они являются статическими переменными, инициализирующимися во время выполнения указанными в исходном коде значениями. Это означает, что вы можете использовать типизированные константы точно также, как и любые другие переменные. Удобство заключается в автоматически инициализируемой величине. } DynamicArraySizeNeeded: Integer = 10; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin { Распределяем память для нашего массива. Будь внимательны и распределяйте размер, в точности необходимый для размещения нового массива. Если вы попытаетесь записать элемент, выходящий за допустимый диапазон, компилятор не ругнется, но объект исключения вам обеспечен. } DynamicArraySizeNeeded := 500; P := AllocMem(DynamicArraySizeNeeded * SizeOf(Integer)); { Как присвоить значение пятому элементу массива. } P^[5] := 68; end; procedure TForm1.Button1Click(Sender: TObject); begin { Вывод данных. } Button1.Caption := IntToStr(P^[5]); end; procedure TForm1.FormDestroy(Sender: TObject); begin { Освобождаем распределенную для массива память. } FreeMem(P, DynamicArraySizeNeeded * SizeOf(Integer)); end; end. |
Delphi 1
Пример массива констант (Array of Const) I " Array of const" это массив переменных, декларированных как константы. Непосредственно они представлены структурой TVarRec. Скобки просто ограничивают массив. Массив констант дает вам возможность передавать процедуре переменное количество параметров type-safe (безопасным) способом. Вот пример:
|
type
TVarRec = record
Data: record case Integer of
0: (L: LongInt);
1: (B: Boolean);
2: (C: Char);
3: (E: ^Extended);
4: (S: ^String);
5: (P: Pointer);
6: (X: PChar);
7: (O: TObject);
end;
Tag: Byte;
Stuff: array[0..2] of Byte;
end;
function PtrToStr(P: Pointer): String; const HexChar: array[0..15] of Char = '0123456789ABCDEF'; function HexByte(B: Byte): String; begin Result := HexChar[B shr 4] + HexChar[B and 15]; end; function HexWord(W: Word): String; begin Result := HexByte(Hi(W)) + HexByte(Lo(W)); end; begin Result := HexWord(HiWord(LongInt(P))) + ':' + HexWord(LoWord(LongInt(P))); end; procedure Display(X: array of const); var I: Integer; begin for I := 0 to High(X) do with TVarRec(X[I]), Data do begin case Tag of 0: ShowMessage('Integer: ' + IntToStr(L)); 1: if B then ShowMessage('Boolean: True') else ShowMessage('Boolean: False'); 2: ShowMessage('Char: ' + C); 3: ShowMessage('Float: ' + FloatToStr(E^)); 4: ShowMessage('String: ' + S^); 5: ShowMessage('Pointer: ' + PtrToStr(P)); 6: ShowMessage('PChar: ' + StrPas(X)); 7: ShowMessage('Object: ' + O.ClassName); end; end; end; procedure TForm1.Button1Click(Sender: TObject); var P: array[0..5] of Char; begin P := 'Привет'#0; Display([-12345678, True, 'A', 1.2345, 'ABC', Ptr($1234, $5678), P, Form1]); end; |
Delphi 1
Работа с большими массивами Распределите память кучи с помощью GetMem. Если вы имеете:
| var a, b: array [0..30000]: Integer; |
|
type
TBigArray = array [0..30000] of Integer;
var a, b: ^TBigArray; |
| GetMem(a, SizeOf(TBigArray)); GetMem(b, SizeOf(TBigArray)); |
| a[0] := xxx; |
| a^[0] := xxx; |
Использование многомерного массива
|
type RecType = integer; {<-- здесь задается тип элементов массива}
const MaxRecItem = 65520 div sizeof(RecType); type = MyArrayType = array[0..MaxRecItem] of RecType; type = MyArrayTypePtr = ^MyArrayType; var MyArray : MyArrayTypePtr; begin ItemCnt := 10; { количество элементов массива, которые необходимо распределить} GetMem(MyArray,ItemCnt*sizeof(MyArray[1])); {распределение массива} MyArray^[3] := 10; {доступ к массиву} FreeMem(MyArray,ItemCnt*sizeof(MyArray[1])); {освобождаем массив после работы с ним} end; |
Массив без ограничения типа и размера Пришло от читателя письмо:
Я тут посмотрел Ваши советы, и понял: это здорово! мне понравилось. Но в них я не нашел (может невнимательно смотрел?) возможности работать с массивами неограниченными по размеру и типу и вообще. Это работает начиная с Delphi 4
|
//к примеру опишем свой тип type MyType=record zap1:longword; zap2:char; zap3:string[10]; end; //опишем НЕОГРАНИЧЕННЫЙ массив переменный типа MyType //хотя, может использоваться абсолютно любой var m:array of MyType; .... procedure TForm1.Button1Click(Sender: TObject); var i:byte; begin for i:=0 to 9 do // нумерация элементов начинается с нуля! begin SetLength(m,Length(m)+1); // увеличение длины массива на 1 m[i].zap1:=i; // присвоение m[i].zap2:=chr(i); // полям m[i].zap3:=inttostr(i); // значений end; end; .... SetLength(m,0); // освобождение памяти end. |
Сергей Дьяченко, sd@arzamas.nnov.ru [000729]
Delphi 1
Динамические массивы III Вот "демо-модуль", демонстрирующий три различных способа ( далеко не все) создания динамических массивов. Все три способа для распределения достаточного количества памяти из кучи используют GetMem, tList используют для добавления элементов в список массива и используют tMemoryStream для того, чтобы распределить достаточно памяти из кучи и иметь к ней доступ, используя поток. Старый добрый GetMem вполне подходит для такой задачи при условии, что массив не слишком велик (<64K).
PS. Я не стал ловить в коде исключения (с помощью блоков Try...Finally}, которые могли бы мне помочь выявить ошибки, связанные с распределением памяти. В реальной системе вы должны быть уверены в своем грациозном владении низкоуровневыми операциями с памятью.
|
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{ Форма, демонстрирующая различные методы создания массива с }
{ динамически изменяемым размером. Разместите на форме четыре кнопки,}
{ компоненты ListBox и SpinEdit и создайте, как показано ниже, }
{ обработчики событий, возникающие при нажатии на кнопки. Button1, }
{ Button2 и Button3 демонстрируют вышеуказанных метода. Button4 }
{ очищает ListBox для следующего примера. }
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
unit Dynarry1;
interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Spin; type TForm1 = class(TForm) Button1: TButton; Button2: TButton; Button3: TButton; SpinEdit1: TSpinEdit; ListBox1: TListBox; Button4: TButton; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); procedure Button4Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} Type pSomeType = ^SomeType; SomeType = Integer; procedure TForm1.Button1Click(Sender: TObject); Type pDynArray = ^tDynArray; tDynArray = Array[1..1000] Of SomeType; Var DynArray : pDynArray; I : Integer; begin { Распределяем память } GetMem ( DynArray, SizeOf(SomeType) * SpinEdit1.Value ); { Пишем данные в массив } For I := 1 to SpinEdit1.Value Do DynArray^[I] := I; { Читаем данные из массива } For I := SpinEdit1.Value DownTo 1 Do ListBox1.Items.Add ( 'Элемент ' + IntToStr(DynArray^[I]) ); { Освобождаем память } FreeMem ( DynArray, SizeOf(SomeType) * SpinEdit1.Value ); end; procedure TForm1.Button2Click(Sender: TObject); Var List : tList; Item : pSomeType; I : Integer; begin { Создаем список } List := tList.Create; { Пишем данные для списка } For I := 1 to SpinEdit1.Value Do Begin { Распределяем уникальный экземпляр данных } New ( Item ); Item^ := I; List.Add ( Item ); End; { Читаем данные из списка - базовый индекс списка 0, поэтому вычитаем из I единицу } For I := SpinEdit1.Value DownTo 1 Do ListBox1.Items.Add ( 'Элемент ' + IntToStr(pSomeType(List.Items[I-1])^) ); { Освобождаем лист } For I := 1 to SpinEdit1.Value Do Dispose ( List.Items[I-1] ); List.Free; end; procedure TForm1.Button3Click(Sender: TObject); Var Stream : tMemoryStream; Item : SomeType; I : Integer; begin { Распределяем память потока } Stream := tMemoryStream.Create; Stream.SetSize ( SpinEdit1.Value ); { Пишем данные в поток } For I := 1 to SpinEdit1.Value Do { Stream.Write автоматически отслеживает позицию записи, поэтому при записи данных за ней следить не нужно } Stream.Write ( I, SizeOf ( SomeType ) ); { Читаем данные из потока } For I := SpinEdit1.Value DownTo 1 Do Begin Stream.Seek ( (I-1) * SizeOf ( SomeType ), 0 ); Stream.Read ( Item, SizeOf ( SomeType ) ); ListBox1.Items.Add ( 'Элемент ' + IntToStr(Item) ); End; { Освобождаем поток } Stream.Free; end; procedure TForm1.Button4Click(Sender: TObject); begin ListBox1.Items.Clear; end; end. |
Delphi 1
Создание многомерного массива
|
type
PRow = ^TRow;
TRow = array[0..16379] of Single;
PMat = ^TMat; TMat = array[0..16379] of PRow; var Mat: PMat; X, Y, Xmax, Ymax: Integer; begin Write('Задайте размер массива: '); ReadLn(Xmax, Ymax); if (Xmax <= 0) or (Xmax > 16380) or (Ymax <= 0) or (Ymax > 16380) then begin WriteLn('Неверный диапазон. Не могу продолжить.'); Exit; end; GetMem(Mat, Xmax * SizeOf(PRow)); for X := 0 to Xmax - 1 do begin GetMem(Mat[X], Ymax * SizeOf(Single)); for Y := 0 to Ymax - 1 do Mat^[X]^[Y] := 0.0; end; WriteLn('Масси инициализирован и готов к работе.'); WriteLn(' Но эта программа закончила свою работу.'); end. |
Delphi 1
Запись массива на диск Скажем, ваша структура данных выглядит следующим образом:
| type TMyRec = record SomeField: Integer; SomeOtherField: Double; TheRest: array[0..99] of Single; end; |
| var Stream: TBlobStream; begin Stream := TBlobStream.Create(MyBlobField, bmWrite); Stream.Write(MyRec, SizeOf(MyRec)); Stream.Free; end; |
| var Stream: TBlobStream; begin Stream := TBlobStream.Create(MyBlobField, bmRead); Stream.Read(MyRec, SizeOf(MyRec)); Stream.Free; end; |
Сохранение массива c изображениями Я решил проблему записи массива TBitmap в файл и его повторного чтения.
Идея заключается в загрузке каждого TBitmap во временный TMemoryStream. Член TMemoryStream.Size информирует о размере данных, которые нужно сохранить на диске. Затем мы пишем размер и сопровождаем его данными типа TFileStream. Эту манипуляцию мы проделываем для каждого TBitmap в массиве.
Для процедуры чтения сначала мы должны считать из потока размер данных TBitmap. Затем мы распределяем область для типа TMemoryStream полученного размера и считываем данные. Затем переписываем из TFileStream в TMemoryStream. И, наконец, мы читает из TMemoryStream сам TBitmap. Эту манипуляцию мы проделываем для каждого TBitmap в массиве.
Ниже я привел код, который я реально использовал. Код из игры Bingo, которую я разрабатываю, имеет сетку 5x5, чьи ячейки содержат изображение.
Реализация алгоритма весьма медленна, поэтому если вы имеете или найдете более быстрый алгоритм, пожалуйста, уведомите меня об этом. Если у вас есть любые вопросы, пожалуйста, свяжитесь со мной.
|
procedure TMainForm.SaveBoard;
var
MemoryStream: TMemoryStream;
FileStream : TFileStream;
Writer : TWriter;
Buffer : Pointer;
Size : Longint;
Column : Integer;
Row : Integer;
begin
MemoryStream := TMemoryStream.Create;
FileStream := TFileStream.Create (SaveFilename, fmCreate);
Writer := TWriter.Create (FileStream, $1000);
try
for Column := 0 to 4 do for Row := 0 to 4 do
begin
MemoryStream.Clear;
Bitmaps[Column, Row].SaveToStream (MemoryStream);
Buffer := MemoryStream.Memory;
Size := MemoryStream.Size;
Writer.WriteInteger (Size);
Writer.Write (Buffer^, Size);
end;
finally
Writer.Free;
FileStream.Free;
MemoryStream.Free;
end;
end;
procedure TMainForm.Open1Click(Sender: TObject); var MemoryStream: TMemoryStream; FileStream : TFileStream; Buffer : Pointer; Reader : TReader; Column : Integer; Row : Integer; Size : Longint; begin OpenDialog2.Filename := SaveFilename; if not OpenDialog2.Execute then Exit; MemoryStream := TMemoryStream.Create; FileStream := TFileStream.Create (OpenDialog2.Filename, fmOpenRead); Reader := TReader.Create (FileStream, $1000); try for Column := 0 to 4 do for Row := 0 to 4 do begin Size := Reader.ReadInteger; MemoryStream.SetSize (Size); Buffer := MemoryStream.Memory; Reader.Read (Buffer^, Size); Bitmaps[Column, Row].LoadFromStream (MemoryStream); end; finally Reader.Free; FileStream.Free; MemoryStream.Free; end; DrawGrid1.Repaint; SaveFilename := OpenDialog2.Filename; Caption := 'Bingo-создатель - ' + ExtractFilename (SaveFilename); end; |
Delphi 1
Пример массива констант (Array of Const) II Как использовать "array of const"?
Массив констант ( array of const) фактически является открытым массивом TVarRec (описание предекларированных типов Delphi вы можете найти в электронной справке). Приведенный ниже "псевдокод" на языке Object Pascal может послужить скелетом для дальнейшего развития:
|
procedure AddStuff( Const A: Array of Const );
Var i: Integer;
Begin
For i:= Low(A) to High(A) Do
With A[i] Do
Case VType of
vtExtended: Begin
{ добавляем натуральное число, все real-форматы
автоматически приводятся к extended }
End;
vtInteger: Begin
{ добавляем целое число, все integer-форматы автоматически приводятся к LongInt } End; vtObject: Begin If VObject Is DArray Then With DArray( VObject ) Do Begin { добавляем массив double-типа } End Else If VObject Is IArray Then With IArray( VObject ) Do Begin { добавляем массив integer-типа } End; End; End; { Case } End; { AddStuff } |
[000937]
Динамические массивы IV Виталий пишет:
Я хочу написать об использовании динамических массивов. Для того чтобы с ними работать можно использовать два вида объявлния в типах
|
type DAr = array of real; var A: DAr; |
| var A:array of real; |
| SetLength(A,7) |
| I:=High(A); |
|
var a,b: array of integer; begin SetLength(a,2); SetLength(b,2); a[0]:=2; b[0]:=3; a:=b; b[0]:=4; end; |
Я надеюсь что это кому-нибудь поможет в работе.
Всего наилучшего. Виталий
P.S. Не советую изменять длину массивов в DLL, у меня при этом возникала ошибка Acess violation побороть ее мне так и не удалось. [000943]
Delphi 1
Массив констант во время выполнения приложения ...хорошо, непосредственно это синтаксис не поддерживает, поскольку массив констант Array of Const подобен открытым массивам, главным образом в части характеристик времени компиляции. Но вы можете обойти этот неприятный момент, обладая хотя бы начальными знаниями того, как реализован открытый массив. Что нам для этого необходимо: динамически размещенный массив array of TVarRec, который "принимает" ваши параметры, и "псевдоним" (alias) функции Format, позволяющий работать с таким массивом без "ругани" со стороны компилятора.
|
Type
{ объявляем тип для динамического массива array of TVarRecs }
TVarArray = Array [0..High(Word) div Sizeof(TVarRec)-1] of TVarRec;
PVarArray = ^TVarArray;
{ Объявляем alias-тип для функции Format. Передаваемые параметры будут иметь в стеке тот же самый порядок вызова, что и при нормальном вызове Format } FormatProxy = Function( Const aFormatStr: String; Var aVarRec: TVarRec; highIndex: Integer ): String; { AddVarRecs копирует параметры, передаваемые в массиве A в pRecs^, начиная с pRecs^[atIndex]. highIndex - самый большой доступный индекс pRecs, число распределенных элементов - 1. } Procedure AddVarRecs( pRecs: PVarArray; atIndex, highIndex: Integer; Const A: Array of Const ); Var i: Integer; Begin If pRecs <> Nil Then For i := 0 To High(A) Do Begin If atIndex <= highIndex Then Begin pRecs^[atIndex] := A[i]; Inc(atIndex); End { If } Else Break; End; { For } End; { AddVarRecs } procedure TScratchMain.SpeedButton2Click(Sender: TObject); Var p: PVarArray; S: String; Proxy: FormatProxy; begin { распределяем массив для четырех параметров, индексы - 0..3 } GetMem(p, 4*Sizeof(TVarRec)); try { добавляем параметры последующими вызовами AddVarRecs } AddVarRecs( p, 0, 3, [12, 0.5, 'Шаблон']); AddVarRecs( p, 3, 3, ['Тест'] ); { получаем полномочия Format } @Proxy := @SysUtils.Format; { Вызов с динамически сгенерированным массивом параметров. Естественно, строка формата может также быть сформирована и во время выполнения программы. } S := Proxy('Целое: %d, Реальное: %4.2f, Строки: %s, %s', p^[0], 3 ); { выводим результат } ShowMessage(S); finally FreeMem( p,4*Sizeof(TVarRec)); end; end; |
Тестировалось только в Delphi 1.0!
- Peter Below [000955]
Шаблон массива переменной длины Может ли кто мне подсказать как динамически создать массив записей и получить доступ к отдельным элементам?
Определите тип массива, которым может содержать максимальное количество записей, затем определите тип, являющийся указателем на массив. Идея заключается в том, чтобы не создавать экземпляр самого большого массива; а вместо этого использовать указательный тип и GetMem для распределения памяти для необходимого вам количества записей.
Я разработал то, что я называю шаблоном массива переменной длины "для бедных людей"...
|
unit %s; { ----------------------------------------------------------- ШАБЛОН МАССИВА ПЕРЕМЕННОЙ ДЛИНЫ Вы можете использовать этот шаблон для создания массива переменной длины любого типа данных. Для того, чтобы превратить шаблон с модуль, прогоните его через текстовый процессор, выполните во всем файле операцию поиска/замены для замены знака процента на ваш тип данных. ----------------------------------------------------------- } interface const %MaxCapacity = High( Cardinal ) div SizeOf( % ); type T%Index = 0..%MaxCapacity - 1; T%s = array[ T%Index ] of %; P%s = ^T%s; function %sSize( Capacity: T%Index ): Cardinal; function Get%s( Capacity: T%Index ): P%s; function Resize%s( var P: P%s; OldCapacity, NewCapacity: T%Index ): P%s; procedure Free%s( var P: P%s; Capacity: T%Index ); implementation uses SysUtils; function %sSize( Capacity: T%Index ): Cardinal; begin Result := Capacity * SizeOf( % ); end; function Get%s( Capacity: T%Index ): P%s; begin GetMem( Result, %sSize( Capacity )); end; function Resize%s( var P: P%s; OldCapacity, NewCapacity: T%Index ): P%s; begin ReAllocMem( P, %sSize( OldCapacity ), %sSize( NewCapacity )); end; procedure Free%s( var P: P%s; Capacity: T%Index ); begin FreeMem( P, %sSize( Capacity )); P := nil; end; end. |
Вот модуль, использующий после операции поиска и замены (см. выше) тип записи 'MyRecord', содержащий также определение этой записи. Поскольку "MyRecords" было очень длинным для имени модуля, я укоротил его. Имейте в виду, что PMyRecords - тип вашего переменного массива, если вы используете этот модуль.
|
unit MyRecs; interface type MyRecord = record AnInt: Integer; AString: string[ 10 ]; end; const MyRecordMaxCapacity = High( Cardinal ) div SizeOf( MyRecord ); type TMyRecordIndex = 0..MyRecordMaxCapacity - 1; TMyRecords = array[ TMyRecordIndex ] of MyRecord; PMyRecords = ^TMyRecords; function MyRecordsSize( Capacity: TMyRecordIndex ): Cardinal; function GetMyRecords( Capacity: TMyRecordIndex ): PMyRecords; function ResizeMyRecords( var P: PMyRecords; OldCapacity, NewCapacity: TMyRecordIndex ): PMyRecords; procedure FreeMyRecords( var P: PMyRecords; Capacity: TMyRecordIndex ); implementation uses SysUtils; function MyRecordsSize( Capacity: TMyRecordIndex ): Cardinal; begin Result := Capacity * SizeOf( MyRecord ); end; function GetMyRecords( Capacity: TMyRecordIndex ): PMyRecords; begin GetMem( Result, MyRecordsSize( Capacity )); end; function ResizeMyRecords( var P: PMyRecords; OldCapacity, NewCapacity: TMyRecordIndex ): PMyRecords; begin ReAllocMem( P, MyRecordsSize( OldCapacity ), MyRecordsSize( NewCapacity )); end; procedure FreeMyRecords( var P: PMyRecords; Capacity: TMyRecordIndex ); begin FreeMem( P, MyRecordsSize( Capacity )); P := nil; end; end. |
|
procedure TForm1.Button1Click( Sender: TObject ); var P: PMyRecords; begin P := GetMyRecords( 10 ); try P^[ 0 ].AnInt := 2001; P^[ 0 ].AString := 'Космическая одиссея'; finally FreeMyRecords( P, 10 ); end; end; |
Динамические массивы V SottNick пишет:
Если хочется, чтобы в многомерном массиве был разный размер у разных измерений например: VarArray: array[1..2, 1..?] of TType , где ? зависит от "строки" массива (1..2)
То дозволяется сделать так: Объявление
|
Var VarArray: array of array of array............ |
|
SetLength (VarArray, Razmernost1); // У первого измерения SetLength (VarArray[1], Razmernost2); // У второго измерения первой "строки" SetLength (VarArray[2], Razmernost3); // У второго измерения второй "строки" SetLength (VarArray[n], Razmernost4); // У второго измерения n-ной "строки" SetLength (VarArray[1][1], Razmernost5); // У третьего измерения первой "строки" первого "столбца" SetLength (VarArray[1][2], Razmernost6); // У третьего измерения первой "строки" второго "столбца" SetLength (VarArray[n][m], Razmernost7); // У третьего измерения n-ной "строки" m-ного "столбца" |
Все можно изменять в процессе естественно.
Получение длин
|
Razmernost1:=Length (VarArray); // У первого измерения (количество строк) Razmernost2:=Length (VarArray[1]); // У второго измерения первой "строки" (количество столбцов) Razmernost3:=Length (VarArray[2]); // У второго измерения второй "строки" (количество столбцов) Razmernost4:=Length (VarArray[n]); // У второго измерения n-ной "строки" (количество столбцов) Razmernost5:=Length (VarArray[1][1]); // У третьего измерения первой "строки" первого "столбца" Razmernost6:=Length (VarArray[1][2]); // У третьего измерения первой "строки" второго "столбца" Razmernost7:=Length (VarArray[n][m]); // У третьего измерения n-ной "строки" m-ного "столбца" |
| SetLength (VarArray, 0); // Всех сразу |
Delphi 1
Пример массива констант (Array of Const) III
|
procedure foo(a : array of const); implementation var var1 : longint; var2 : pointer; var3 : integer; begin var1 := 12345678; var2 := @var1; var3 := 1234; foo([var1, var2, var3]); |
Определите тип, например, так:
|
TYPE NAME1 = Array[1..4,1..10] of Integer; |
|
NAME2 : NAME1 = ((1,2,3,4,5,6,7,8,9,10), (1,2,3,4,5,6,7,8,9,10), (1,2,3,4,5,6,7,8,9,10), (1,2,3,4,5,6,7,8,9,10)); |
Delphi 1
Массив объектов-изображений Вы не сможете сделать это напрямую и "визуально", но если вы не возражаете против нескольких строк кода, то я покажу как это может быть просто:
|
type TForm1 = class(TForm) ... public images: array [1..10] of TImage; ... end; procedure TForm1.FormCreate(...); var i: integer; begin ... for i := 1 to 10 do begin images[i] := TImage.Create(self); with images[i] do begin parent := self; tag := i; { это облегчит идентификацию изображения } ... установите другие необходимые свойства, например: OnClick := MyClickEventHndlr; end; end; ... end; |
Delphi 1
Массив TPOINT
|
Const ptarr : Array[0..4] Of TPoint = ((x:0; y:4), . . (x:4; y:4)); |
Delphi 1
Динамические массивы VI Например, если вам необходимо сохранить "GIZMOS" в вашем массиве, сделайте следующее:
|
CONST MaxGIZMOS = $FFFF Div (SizeOf(GIZMOS)) { или что- то другое, смотря какой максимальный размер GIZMOS вы планируете...} TYPE pGIZMOArray = ^GIZMOArray; GIZMOArray = Array[1..MaxGIZMOS] of GIZMOS; VAR TheGIZMOS: pGIZMOArray; GIZMOcount: integer; BEGIN GetMem(TheGIZMOS,(GIZMOcount+1)*SizeOf(GIZMO)); {Нужна дополнительная единица, поскольку массив GetMem ведет отсчет с нуля...} TheGIZMOS^[index] := Whatever; ну и так далее... |
Delphi 1
Создание больших массивов В 16- битной версии Delphi нельзя сделать это непосредственно. В новой, 32-битной версии, это как-то можно сделать, но за два месяца колупания я так и не понял как. (Некоторые бета-тестеры знают как. Не могли бы они сообщить нам всю подноготную этого дела?)
В 16-битной версии Delphi вам необходимо работать с блоками по 32K или 64K и картой. Вы могли бы сделать приблизительно следующее:
|
type chunk: array[0..32767] of byte; pchunk: ^chunk; var BigArray: array[0..31] of pChunk; |
| for i := 0 to high(bigArray) do new (bigArray[i]); |
| bigArray[n shr 15]^[n and $7FFF] := y; x := bigArray[n shr 15]^[n and $7fff]; |
n должен находиться в диапазоне [0..32*32*1024] = [0..1024*1024] = [0..1048576].
Для освобождения массива после его использования необходимо сделать следующее:
| for i := 0 to high(bigArray) do dispose (bigArray[i]); |
Delphi 1
Динамические массивы VII Существует несколько способов сделать это. Применять тот или иной способ зависит от того, какой массив вы используете - массив строк или массив чисел (целые, натуральные и пр.). Если вам необходим простой динамический одномерный массив строк, я предлагаю вам взглянуть на компонент tStringList, он сам заботится о функциях управления и легок в использовании.
Если вам необходим динамический многомерный массив строк, вы также можете воспользоваться tStringList (в случае, если число элементов вашего массива не превышает лимит для tStringList, я полагаю он равен 16,000). Чтобы сделать это, создайте функцию линейного распределения как показано ниже:
Допустим у вас есть трехмерный массив строк, текущее измерение [12,80,7], и вы хотите найти элемент [n,m,x]. Вы можете найти этот элемент в приведенном одномерном массиве с помощью формулы ((n-1)*80*7 + (m-1)*80 + x). Затем вы можете использовать это в качестве индекса в tStringList. Для диманического изменения одной из границ массива, используйте метод tStringList Move, служащий как раз для таких целей. (Метод состоит из некоторых технологических внутренних циклов, но выполняются они очень быстро, поскольку tStringList манипулирует не с самими строками, а с указателями на них.)
Если вам необходим динамический одномерный массив чисел, то в общих словах я приведу его ниже, но есть масса мелких деталей. Объявите указатель на тип массива, имеющего максимальное количество элементов данного типа (помните о том, что Delphi-16 позволяет иметь типам область памяти, ограниченной 64K), например так:
| type bigArray: array[1..32000] of integer; {или ^double, или что-то еще} pMyArray: ^bigArray; |
| getMem (pMyArray, sizeof(integer) * n); |
| pMyArray^[51] |
Изменить размер массива, определить новый указатель, перераспределить или обменяться с другим массивом можно так:
|
pTemp: ^bigArray;
getMem (pTemp, sizeof(integer) * newnumelements); memcopy (pTemp, pMyArray, sizeof(integer)*n); {n - количество элементов в pMyArray} freeMem (pMyArray, sizeof(integer)*n); pMyArray := pTemp; |
Если для вашего массива необходим участок памяти больше чем 64K, вам необходимо разработать список указателей на участки памяти, но эта тема выходит за рамки данной статьи.
Лично я инкапсулировал все в своем объекте. Я использую, как я это называю, "Basic String Object" (BSO), базовый строковый объект, который осуществляет динамическое распределение и освобождение памяти для строк любого размера. Непосредственно это PChar, указывающий на распределенную память. У меня существует два внешних свойства: AsString и AsPChar. Также у меня есть различные свойства и методы, позволяющие иметь различные способы доступа и манипулировать строками.
Я написал свои собственные malloc(), calloc() и realloc(), используя частные методы объекта TString для сканирования распределенной памяти. Это классно работает, когда мне нужно "захватить" блок памяти.
С помощью двух методов я могу распределить необходимую мне память (блоками, так что это не занимает много процессорного времени), и освобождать ее (когда существует определенный резерв -- и снова так, чтобы не тратить много процессорного времени).
О другой идее я уже рассказывал (открытый массив). Если вам нужна проверка выхода за границы и/или динамическое изменение размера массива, вы можете использовать метод, аналогичный методу работы со строковым объектом (описанный мною выше), но вам необходимо будет интегрировать свойство-массив по умолчанию, чтобы иметь к нему простой доступ. Это позволит вам иметь индексы и использовать нужный вам тип.
|
TMyDynamicObject = ... PROPERTY Array[ idx :LONGINT ]:TMyType READ GetArray WRITE PutArray DEFAULT; ... VAR Mine :TMyDynamicObject; ... Mine := TMyDynamicObject.Create; FOR i := 10 TO 20 DO Mine[i] := {значение} {ЧУДОВИЩНАЯ РАСТРАТА ПАМЯТИ - если вы действительно используете такие большие массивы и хэш-таблицы } Mine[-100000] := {значение} Mine[+100000] := {значение} |
Для того, чтобы хранить все, что вы хотите, вы можете использовать TList (или TStringList.Objects)! TList.Items хранят указатели на объекты или записи, но они ничего не могут сделать с ними, поэтому вы можете привести их к типу longint, и больше о них не беспокоиться! Вот пример хранения в TList списка целых:
|
var aList: TList; I : Integer; L : Longint; begin aList := TList.Create; L := 93823; aList.Add(Pointer(L)); aList.Add(Pointer(83293)); for I := 1 to aList.Count do L := L + Longint(aList.Items[I-1]); aList.Free; end; |
|
type PMyRec = TMyRec; TMyRec = record Name: string[40]; Addr : string[25]; Comments: string; salary: Double; end; var aList: TList; aRecPtr: PMyRec; I : Integer; begin aList := TList.Create; New(aRecPtr); with aRecPtr^ do begin Name := 'Валентин'; Addr := 'неизвестен'; Comments := 'Автор Советов по Delphi'; Salary := 999000.00; end; aList.Add(aRecPtr); aList.Add(... ); ... for I := 1 to aList.Count do begin aRecPtr := PMyRec(aList.Items[I-1]); {что-то делаем с записью} end; {теперь избавляемся от всех записей и самого списка-объекта} for I := 1 to aList.Count do Dispose(PMyRec(aList.Items[I-1])); aList.Free; end; |
Динамические массивы VIII Иногда разработчик, работая с массивами, не знает какого размера массив ему нужен. Тогда Вам пригодится использование динамических массивов.
|
var intArray : array of integer; |
|
begin intArray:=(New(IntArray,100); //Размер массива? 100 end; |
Delphi 1
Массивы размером более 64К Не существует способа непосредственного доступа к массиву размером свыше 65520. Или вы пользуетесь для распределения памяти GlobalAlloc или TMemoryStream, и создаете специализированный класс для доступа к элементам массива, или вы делаете это непосредственно вручную. Добраться до следующих сегментов GlobalAlloc-ого объекта можно, строя указатели с помощью SelectorInc. Самый легкий путь заключается в использовании TMemoryStream.
|
Type Tmyarr = Class buffer : TMemoryStream; elsize : LongInt; Constructor Create(esize, number : Word); Destructor Free; Procedure SetElement(index : Word; p : Pointer); Procedure GetElement(index : Word; p : Pointer); End; Implementation Constructor Tmyarr.Create(esize, number : Word); Var size : LongInt; Begin Inherited Create; buffer := TMemoryStream.Create; elsize := esize; size := esize * number; buffer.SetSize(size); End; Procedure Tmyarr.Free; Begin If Self <> Nil Then Begin buffer.Free; Destroy; End; End; Procedure GetElement(index : Word; p : Pointer); Begin buffer.Seek(elsize * index, 0); buffer.Read(p^, elsize); End; Procedure SetElement(index : Word; ptr : Pointer); Begin buffer.Seek(elsize * index, 0); buffer.Write(p^, elsize); End; |
Delphi 1
Массивы элементов управления Вы без проблем сможете иметь массив объектов, но он не будет создаваться для вас автоматически визуальным дизайнером. Ограничений здесь никаких нет. Во всех случаях, где я его использовал, у меня было более одного элемента управления (в одной реальной задаче у меня получался динамический массив из 26 компонентов Image, каждый из которых имел изображение, свой размер, текст всплывающей подсказки, и обрамление) и их координат, которые обычно более сложны в описании, чем вектора (в моем примере они располагались в двумерном массиве, который зависел от текущего размера области окна клиента и имел "обратную связь" с такими параметрами, как размер окна, набор аппаратных устройств и каталогов общего доступа).
Мое предложение заключается в создании единственного прототипа в виде сложного элемента управления, который располагается на форме, невидим, и не включен (enabled). Для этого необходимо определить наследника TObject, который может представлять содержащиеся в массиве компоненты, этот шаг можно опустить, если структура компонента имеет собственный иерархический объект верхнего уровня подобно TPanel). Наконец, определите массив для этого компонента, и поместите на форму переменную такого типа.
Во время выполнения приложения для добавления элементов массива вам необходимо будет создавать компоненты (используйте прототип для инициализации большинства свойств) и устанавливать атрибуты для их выравнивания относительно формы. Не забывайте для динамически создаваемых компонентов задавать родителя, в противном случае они просто не появятся на форме (владелец прототипа для включения новых элементов управления). Это может показаться довольно сложным на слух, но в реальности все просто и требует очень небольшого кодирования. Данный способ предоставляет больше возможностей, чем это может сделать массив VB -- в таких ключевых моментах и кроется разница между языками типа ObjectPascal и RAP-инструментами типа VB. [001990]
Советы по Delphi
Есть некоторая таблица и требуется
Nomadic отвечает:
Удобней всего, напpимеp, так -
|
with bmovMyBatchMove do begin Mode := bmCopy; RecordCount := 1; Execute;R Destination.Delete; end; |
Где bmovMyBatchMove - экземпляр класса TBatchMove из VCL.
Hеправда Ваша! ;)
Этот загадочный BatchMove имеет одну очень неприятную особенность (по крайней мере при работе с DBF-таблицами и в Delphi 1.0x), как-то:
увеличивает в создаваемых таблицах в полях типа NUMBER количество значащих цифр после запятой (не помню - возможно, что и до), если там указаны небольшие (около 1-3 цифр) значения :(.
Я эту особенность побороть не сумел, а мириться с ней в условиях нашей конторы (когда приходится бороться за место под солнцем с программистами на Clipper и FoxPro совершенно неприемлемо.
Кроме того, в предложенном выше варианте еще и запись удалять приходится...:)
Решалась же эта проблема следующим способом:
|
procedure CopyStruct( SrcTable, DestTable: TTable; cpyFields: array of string ); var i: Integer; bActive: Boolean; SrcDatabase,DestDatabase: TDatabase; iSrcMemSize,iDestMemSize: Integer; pSrcFldDes: PFldDesc; CrtTableDesc: CRTblDesc; bNeedAllFields: Boolean; begin SrcDatabase := Session.OpenDatabase( SrcTable.DatabaseName ); try DestDatabase := Session.OpenDatabase( DestTable.DatabaseName ); try bActive := SrcTable.Active; SrcTable.FieldDefs.Update; iSrcMemSize := SrcTable.FieldDefs.Count * SizeOf( FLDDesc ); pSrcFldDes := AllocMem( iSrcMemSize ); if pSrcFldDes = nil then begin raise EOutOfMemory.Create( 'Не хватает памяти!' ); end; try SrcTable.Open; Check( DbiGetFieldDescs( SrcTable.Handle, pSrcFldDes ) ); SrcTable.Active := bActive; FillChar( CrtTableDesc, SizeOf( CrtTableDesc ), 0 ); with CrtTableDesc do begin StrPcopy( szTblName, DestTable.TableName ); StrPcopy( szTblType, 'DBASE'); if ( Length( cpyFields[0] ) = 0 ) or ( cpyFields[0] = '*' ) then begin bNeedAllFields := True; SrcTable.FieldDefs.Update; iFldCount := SrcTable.FieldDefs.Count; end else begin bNeedAllFields := False; iFldCount := High( cpyFields ) + 1; end; iDestMemSize := iFldCount * Sizeof( FLDDesc ); CrtTableDesc.pFLDDesc := AllocMem( iDestMemSize ); if CrtTableDesc.pFLDDesc = nil then begin raise EOutOfMemory.Create( 'Не хватает памяти!' ); end; end; try if bNeedAllFields then begin for i := 0 to CrtTableDesc.iFldCount - 1 do begin Move( PFieldDescList( pSrcFldDes )^[i], PFieldDescList( CrtTableDesc.pFLDDesc )^[i], SizeOf( FldDesc ) ); end; end else begin for i:=0 to CrtTableDesc.iFldCount-1 do begin Move( PFieldDescList( pSrcFldDes )^[SrcTable.FieldDefs.Find( cpyFields[i] ).FieldNo - 1], PFieldDescList( CrtTableDesc.pFLDDesc )^[i], SizeOf( FldDesc ) ); end; end; Check( DbiCreateTable( DestDatabase.Handle, True, CrtTableDesc ) ); finally FreeMem( CrtTableDesc.pFLDDesc, iDestMemSize ); end; finally FreeMem( pSrcFldDes, iSrcMemSize ); end; finally Session.CloseDatabase( DestDatabase ); end; finally Session.CloseDatabase( SrcDatabase ); end; end; |
[001393]
Пересборка индексов с помощью TBatchMove
... вы все делаете правильно. BatchMove не может пересобирать индексы. Тем не менее, следующая процедура все же поможет вам сделать это (создать индексы заново). Задайте ей необходимые параметры (.DBF. Name, исходная и целевая таблица, Source и Target) и попробуйте ее в деле!
|
procedure TForm1.FormCreate(Sender: TObject); var x : integer ; begin BatchMove1.Execute ; Source.Open ; Target.Exclusive := True ; Target.Open ; Source.IndexDefs.Update ; for x := 0 to Source.IndexDefs.Count - 1 do Target.AddIndex(Source.IndexDefs[x].Name, Source.IndexDefs[x].Fields, Source.IndexDefs[x].Options) ; Source.Close ; Target.Close ; end; |
[001331]
Альтернатива кнопкам в Delphi
Alex Polyanskiy пишет:
Вместо компонентов TButton, TBitBtn и т.д. можно исвользовать компоненты TImage расположив их по 2 или по 3 один над одним, в них помещаются рисунки заменяющие кнопки
1- простое изображение
2- подсвеченное изображение
3- имитирующее нажатие
свойству 2 и 3 компонентов Visible присвоить False;
|
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin Image1.Visible:=False;//При наведении указателя мыши появляется второе изображение Image2.Visible:=True; end; procedure TForm1.Image2MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin Image2.Visible:=False;// При нажати ЛКМ пояпляется третье изображение Image3.Visible:=True; end; procedure TForm1.Image2MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin Image2.Visible:=False;//При отпускании ЛКМ активизируется подсвеченное изображение Image3.Visible:=True; end; |
И вконце при перемещении указателя манипулятора на форму активизация первого изображения
|
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin Image2.Visible:=False; Image3.Visible:=False; Image1.Visible:=True; end; |
[000969]
Какая кнопка Sender?
...я полагаю, что вы могли бы воспользоваться свойством панели PopupMenu и использовать событие кнопки MouseDown чтобы делать то, что вы делали выше. Также, я полагаю, вы должны выключить свойство Auto. Затем поместите в обработчик события OnMouseDown следующий код:
|
procedure TForm1.BitBtn1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var P: TPoint; begin with Sender as TBitBtn do if Button = mbRight then begin P := Self.ClientToScreen ( Point (Left + (Width div 2), Top + (Height div 2))); PopupMenu1.Popup (P.X,P.Y); end; end; |
[001639]
Кнопка с несколькими строчками текста I
Приведу способ, как сделать кнопку с тремя (или более) строчками текста. Разместите на форме компонент TBitBtn и задайте ему достаточно длинный заголовок. Не волнуйтесь о том, что такой длинный заголовок "раздувает" кнопку налево и направо. Создайте обработчик формы OnCreate как показано ниже:
| VAR R : TRect; N : Integer; Buff : ARRAY[0..255] OF Char; ... WITH BitBtn1 DO BEGIN Glyph.Canvas.Font := Self.Font; Glyph.Width := Width-6; Glyph.Height := Height-6; R := Bounds(0,0,Glyph.Width,0); StrPCopy(Buff, Caption); Caption := ''; DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER OR DT_WORDBREAK OR DT_CALCRECT); OffsetRect(R, (Glyph.Width-R.Right) DIV 2, (Glyph.Height - R.Bottom) DIV 2); DrawText(Glyph.Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER OR DT_WORDBREAK); END; |
Теперь у вас есть замечательная кнопка, которая научилась переносить текст!
- Neil [000636]
Кнопка с несколькими строчками текста II
Я создал удобный компонент, инкапсулирующий обычную кнопку, но с возможностью многострочного заголовка. В *действительности* - это TBitBtn, чей Glyph *нарисован* в виде заголовка с переносом текста. Реальный заголовок невидим. Это работает! Попробуйте с этим поэкспериментировать и сообщите мне о ваших новых находках. Я был удивлен, что это свойство оказалось легко *подавить*. Тем более, что это свойство public/published, а не какой-то кот в мешке. Все это так, но вы можете перекрыть свойство другим с таким же именем и с атрибутом READ ONLY. И вы можете ссылать на свойство предка, как, например, "Inherited Glyph". ООП!
- Neil Rubenking
|
unit C_wrapb;
interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons; type TWrapBtn = class(TBitBtn) private { Private declarations } FUNCTION GetGlyph: String; function GetMargin: Integer; function GetSpacing: Integer; function GetKind: TBitBtnKind; function GetLayout: TButtonLayout; function GetNumGlyphs: TNumGlyphs; procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED; procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; procedure WMSize(var Msg: TWMSize); message WM_SIZE; procedure CaptionGlyph; protected { Protected declarations } public { Public declarations } published { Published declarations } Property Glyph: String Read GetGlyph; Property Margin: Integer Read GetMargin; property Spacing: Integer Read GetSpacing; property Kind: TBitBtnKind Read GetKind; property Layout: TButtonLayout Read GetLayout; property NumGlyphs: TNumGlyphs Read GetNumGlyphs; end; procedure Register; implementation procedure TWrapBtn.CaptionGlyph; VAR GP : TBitmap; R : TRect; Buff: ARRAY[0..255] OF Char; begin GP := TBitmap.Create; try WITH GP DO BEGIN Canvas.Font := Self.Font; StrPCopy(Buff, Caption); Inherited Margin := 0; Inherited Spacing := GetSpacing; Width := Self.Width - GetSpacing; Height := Self.Height - GetSpacing; R := Bounds(0,0,Width,0); DrawText(Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER OR DT_WORDBREAK OR DT_CALCRECT); OffsetRect(R, (Width-R.Right) DIV 2, (Height - R.Bottom) DIV 2); DrawText(Canvas.Handle, Buff, StrLen(Buff), R, DT_CENTER OR DT_WORDBREAK); END; Inherited Glyph := GP; Inherited NumGlyphs := 1; finally GP.Free; end; end; FUNCTION TWrapBtn.GetGlyph: String; BEGIN Result := '(Н/Д)'; END; procedure TWrapBtn.CMTextChanged(var Message: TMessage); begin Inherited; CaptionGlyph; end; procedure TWrapBtn.CMFontChanged(var Message: TMessage); begin Inherited; CaptionGlyph; end; procedure TWrapBtn.WMSize(var Msg: TWMSize); begin Inherited; CaptionGlyph; end; function TWrapBtn.GetMargin: Integer; begin Result := 0; end; function TWrapBtn.GetSpacing: Integer; begin {$IFDEF Win32} Result := 12; {$ELSE} Result := 6; {$ENDIF} end; function TWrapBtn.GetKind: TBitBtnKind; BEGIN Result := bkCustom; END; function TWrapBtn.GetLayout: TButtonLayout; begin Result := blGlyphLeft; end; function TWrapBtn.GetNumGlyphs: TNumGlyphs; begin Result := 1; end; procedure Register; begin RegisterComponents('FAQ', [TWrapBtn]); end; end. |
[000722]
