Советы по Delphi. Версия 1.4.3 от 1.1.2001 [Валентин Озеров] (fb2) читать онлайн
[Настройки текста] [Cбросить фильтры]
[Оглавление]
Что такое "Советы по Delphi"?
«Советы по Delphi» — коллекция ответов на нетрадиционные вопросы программирования на Delphi, нестандартных решений, хитростей и интересных идей. Для практической пользы дела приведены конкретные примеры кода, позволяющие донести идею или полностью ответить на заданный вопрос. Автором предусматривается попытка на периодичность издания, подписаться на уведомления о выходе новых версий можно здесь. При составлении «Советов» не ставилась цель включить ВСЕ материалы, отбирались лишь самые интересные. Источником «Советов» служили многочисленные западные источники (FAQ), кропотливо отобранные и переведенные на русский язык. Учитывая плачевное состояние наших линий, «Советы» практически не содержат графики. Весь приведенный код отформатирован таким образом, чтобы вы могли скопировать его прямо со странички в свое приложение. По этой же причине отсутствует online-версия «Советов». Так, если Вы обладаете интересной информацией, и ее нет в «Советах», не поленитесь, пришлите ее мне. Пожалуйста не задавайте мне вопросов по электронной почте. У меня есть работа и я занятый человек. Помещайте свои вопросы в группу новостей, я попытаюсь ответить на них там. Шлите примеры, советы, полезности, статьи и давайте ссылки на свои и не свои сайты. От вас самих зависит наполняемость советов. Авторы! Дайте вторую жизнь вашим произведениям! Присылайте статьи и переводы! Не удивляйтесь, если в «Советах» Вы обнаружите код для Delphi1 или даже для TurboPascal'я. Сам Паскаль практически не изменился, а идеи, реализация и технология живы до сих пор. Для описания какой-либо функции можно заглянуть в электронную справку, а для поиска идеи — в «Советы».Предупреждение
Я не отвечаю за последствия применения приведенного кода. Используйте его на свой страх и риск. Не нужно меня обвинять и слать гневные письма, если Ваш компьютер взорвется из-за какого-нибудь «Совета». Тем не менее, если Ваш компьютер все-таки взорвался, сообщите мне пожалуйста об этом и я просмотрю код в поисках ошибки.
Алгоритмы
Преобразования
Преобразование дробной и целой части REAL-числа в два целых
Я написал программу, которая делает это. Это DOS-программа. Вы вызываете ее с десятичным числом, передаваемым в качестве параметра. После чего программка выведет 3 колонки, в первой будет находиться исходное число, две остальные будут содержать числитель и знаменатель. Вы можете преобразовать программу в функцию и применять ее в своих приложениях, но, думаю, это несложно, и с этим вы справитесь сами. Для ее запуска достаточно в подсказке DOS набрать ее имя и число:CONTFRAC 3.141592654
program contfrac; { непрерывные дроби }
{$N+}
const
order = 20;
var
y, lasterr, error, x: extended;
a: array [0..order] of longint;
i, j, n: integer;
op, p, q: longint;
begin
lasterr := 1e30;
val(paramstr(1), y, n);
if n <> 0 then halt;
x := y;
a[0] := trunc(x);
writeln;
writeln(a[0]:20, a[0]:14, 1:14);
{ это может вызвать резкую головную боль и галлюцинации }
for i := 1 to order do begin
x := 1.0 / frac(x);
a[i] := trunc(x);
p := 1;
q := a[i];
for j := pred(i) downto 0 do begin
op := p;
p := q;
q := a[j] * q + op;
end;
error := abs(y – int(q) / int(p));
if abs(error) >= abs(lasterr) then halt;
writeln(a[i]:20, q:14, p:14, error:10);
if error < 1e-18 then halt;
lasterr := error;
end;
end.
Теперь попытаюсь объяснить мой алгоритм (он, по-моему, достаточно быстрый). Вот схема:
Допустим, мы используем число 23.56.
Берем наше натуральное число и производим целочисленное деление на 1.
23.56 div 1 = 23
Теперь вычитаем результат из числа, с которого мы начали.
23.56 – 23 = .56
Для преобразования значения в целое мы просто умножаем его на 100, и, при необходимости, приводим его к целому.
valA := (val div 100);
valB := (valA – val);
or
valB := (valA – val) * 100;
val = 23.56
ValA = 23
ValB = .56 or 56
Есть ли функция, выполняющая пpеобpазование пеpеменной real в integer?
Nomadic советует: Hа самом деле есть две функции — Round и Trunc (округление и отсечение дробной части соответственно). Кстати, функции эти были уже в самых ранних версиях Паскаля. Так что мой совет — изучите Паскаль — полезно. Hy, если yж дело идет к изyчению списка фyнкций :), то yпомянy еще Ceil и Floor. Unit Math; Кстати, втоpая из них мне очень пpигодилась для полyчения экспоненты числа. Имеется в видy экспонента: X=1E 13 [001193]Почему непpавильно pаботает функция StrToFloat?
Nomadic советует: Пишу даже прямо StrToFloat('32.34'), к примеру, получаю исключение «'32.34' is not valid float». Если пишу число без десятичной точки, то все ОК. А какой у тебя DecimalSeparator? В Russian settings почему-то по умолчанию считается, что разделитеь дроби – запятая. Пеpеустанови пpи запуске пpогpаммыDecimalSeparator := '.';
Или пользуйся этой функцией так:
StrToFloat('32,24');
Число строкой X
Сергей AKA WildSery прислал свой вариант: Привожу мой вариант, написал для своего приложения за 20 минут. В силу специфики приложения не утруждал себя прописью полностью "рублей" и "копеек", а ограничился "руб." и "коп.", а также не было необходимости в знаке числа, по это все добавляется буквально 3-4 строками.function currency2str (value: double): string;
const hundreds: array [0..9] of string = ('',' сто',' двести',' триста',' четыреста',' пятьсот',' шестьсот',' семьсот',' восемьсот',' девятьсот');
tens: array [0..9] of string = ('','',' двадцать',' тридцать',' сорок',' пятьдесят',' шестьдесят',' семьдесят',' восемьдесят',' девяносто');
ones: array [0..19] of string = ('','','',' три',' четыре',' пять',' шесть',' семь',' восемь',' девять',' десять',' одиннадцать',' двенадцать',' тринадцать',' четырнадцать',' пятнадцать',' шестнадцать',' семнадцать',' восемнадцать',' девятнадцать');
razryad: array [0..6] of string = ('',' тысяч',' миллион',' миллиард',' триллион',' квадриллион',' квинтиллион');
var s: string; i: integer; val: int64;
function shortnum(s: string; raz: integer): string;
begin
Result:=hundreds[StrToInt(s[1])];
if strtoint(s)=0 then exit;
if s[2]<>'1' then begin
Result:=Result+tens[StrToInt(s[2])];
case strtoint(s[3]) of
1: if raz=1 then result:=result+' одна' else result:=result+' один';
2: if raz=1 then result:=result+' две' else result:=result+' два';
else result:=result+ones[strtoint(s[3])];
end;
Result:=Result+razryad[raz];
case strtoint(s[3]) of
0,5,6,7,8,9: if raz>1 then result:=result+'ов';
1: if raz=1 then result:=result+'а';
2,3,4: if raz=1 then result:=result+'и' else if raz>1 then result:=result+'а';
end;
end else begin
Result:=Result+ones[StrToInt(Copy(s,2,2))];
Result:=Result+razryad[raz];
if raz>1 then result:=result+'ов';
end;
end;
begin
val:=Trunc(value);
if val=0 then begin result:='ноль'; exit; end;
s:=IntToStr(val); Result:=''; i:=0;
while length(s)>0 do begin
Result:=shortNum(Copy('00'+s,Length('00'+s)-2,3),i)+Result;
if length(s)>3 then s:=copy(s,1,length(s)-3) else s:='';
inc(i);
end;
s:=IntToStr(Trunc((value-val)*100+0.5));
Result:=Result+' руб. '+s+' коп.';
end;
Даты
Добавление даты и времени в компонент Memo
Delphi 1
{ Следующий код вставляет значение даты/времени в memo-поле. }
Var
s : string;
begin
s := DateToStr( Date ) + ' ' + TimeToStr( Time ) + ' :';
Memo1.Lines.Insert(0, s);
Memo1.SetFocus;
Memo1.SelStart := Length(s);
Memo1.SelLength := 0;
Вычисление даты Пасхи II
Delphi 1
function easter (year: integer): tdatetime;
{----------------------------------------------------------------}
{ Вычисляет и возвращает день Пасхи определенного года. }
{ Идея принадлежит Mark Lussier, AppVision <MLussier@best.com>. }
{ Скорректировано для предотвращения переполнения целых, если по }
{ ошибке передан год с числом 6554 или более. }
{----------------------------------------------------------------}
var
nMonth, nDay, nMoon, nEpact, nSunday,
nGold, nCent, nCorx, nCorz: Integer;
begin
{ Номер Золотого Года в 19-летнем Metonic-цикле: }
nGold := (Year mod 19) + 1;
{ Вычисляем столетие: }
nCent := (Year div 100) + 1;
{ Количество лет, в течение которых отслеживаются високосные года… }
{ для синхронизации с движением солнца: }
nCorx := (3 * nCent) div 4 – 12;
{ Специальная коррекция для синхронизации Пасхи с орбитой луны: }
nCorz := (8 * nCent + 5) div 25 – 5;
{ Находим воскресенье: }
nSunday := (Longint(5) * Year) div 4 – ncorx – 10;
{ ^ Предохраняем переполнение года за отметку 6554}
{ Устанавливаем Epact – определяем момент полной луны: }
nEpact := (11 * nGold + 20 + nCorz – nCorx) mod 30;
if nepact < 0 then nEpact := nEpact + 30;
if ((nepact = 25) and (ngold > 11)) or (nepact = 24) then nEpact := nEpact + 1;
{ Ищем полную луну: }
nMoon := 44 – nEpact;
if nmoon < 21 then nMoon := nMoon + 30;
{ Позиционируем на воскресенье: }
nMoon := nMoon + 7 – ((nSunday + nMoon) mod 7);
if nmoon >l 31 then
begin
nMonth := 4;
nDay := nMoon – 31;
end
else
begin
nMonth := 3;
nDay := nMoon;
end;
Easter := EncodeDate(Year, nMonth, nDay);
end; {easter}
Преобразование даты в количество секунд
Delphi 1EncodeDate возвращает объект TDateTime, который просто является double-числом. Для получения количества миллисекунд с даты 1/1/0001, умножьте результат на 86400000.0 Но чтобы избежать переполнения, лучше пользоваться более поздней датой.
Преобразование даты в неделю
Delphi 1
procedure TForm1.Button1Click(Sender: TObject);
var frstDay,toDay : TDateTime; week : Integer;
begin
frstDay := StrToDate('1/1/96');
toDay := StrToDate(Edit1.Text);
week := Trunc((toDay - frstDay) / 7) + 1;
Label1.Caption := IntToStr(week);
end;
Преобразование даты
Delphi 1
procedure TForm1.Button1Click(Sender: TObject);
var
st,formatsave : string;
DT : TDateTime;
begin
st := Edit1.text; // '1996-06-03 00.00.00'
formatsave := ShortDateFormat;
ShortDateFormat := 'yyyy.mm.dd hh.mm.ss';
while pos ('-', st) > 0 do st [pos ('-', st)] := '.';
DT := StrToDateTime(st);
ShortDateFormat := formatsave;
Label1.Caption := DateTimeToStr(DT);
end;
Преобразование даты — добавление столетия
Delphi 1
LongDate := FormatDateTime('ddmmyyyy', StrToDate(ShortDate));
Данный код преобразует дату, переданную в формате, определенном в виде короткой даты в Панели Управления (типа DD/MM/YY) в формат, заданный в строке Format (в нашем примере DDMMYYYY).
Если DD/MM/YY — входное поле, а DDMMYYYY — поле базы данных, то приведенный выше код может сослужить пользователю хорошую службу, если он вдруг захочет использовать другой формат даты, с его соответствующим переопределением в Панели Управления.
(Естественно, YYYYMMDD для поля базы данных при обычных обстоятельствах будет лучше чем DDMMYYYY, поскольку в настоящее время используется метод последовательной сортировки).
Приведение даты
Delphi 1
procedure TForm1.MaskEdit1Exit(Sender: TObject);
var
y, m, d : word;
begin
decodedate(strtodate(maskedit1.text) + 11, y, m, d);
maskedit2.text := inttostr(m) + '/' + inttostr(d) + '/' + inttostr(y);
end;
Даты и недели
Delphi 1У меня есть программа, которая делает примерно то, что вы хотите. Она сообщает для даты текущую неделю и день недели. Вам необходимо лишь реализовать вычисление предела для дат недели. Кроме того, формат в этом коде для дат задан в виде "06/25/1996". Вы должны создать форму с именем "Forma", компонентом TEdit с именем "Edit1", четырьмя метками и кнопкой с именем "GetWeekBtn". Убедитесь в том, что обработчиком события формы OnCreate является метод FormCreate. Надеюсь, что помог вам.
unit Forma;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,Forms, Dialogs, StdCtrls;
type
TForma1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
GetWeekBtn: TButton;
Label4: TLabel;
procedure GetWeekBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private { Private declarations }
Function HowManyDays(pYear,pMonth,pDay:word):integer;
public { Public declarations }
end;
var
Forma1: TForma1;
implementation
{$R *.DFM}
Uses Inifiles;
procedure TForma1.FormCreate(Sender: TObject);
var WinIni:TInifile;
begin
WinIni:=TIniFile.Create('WIN.INI');
WinIni.WriteString('intl','sShortDate','MM/dd/yyyy');
WinIni.Free;
end;
Function TForma1.HowManyDays(pYear,pMonth,pDay:word):integer;
var Sum:integer;
pYearAux:word;
begin
Sum:=0;
if pMonth>1 then Sum:=Sum+31;
if pMonth>2 then Sum:=Sum+28;
if pMonth>3 then Sum:=Sum+31;
if pMonth>4 then Sum:=Sum+30;
if pMonth>5 then Sum:=Sum+31;
if pMonth>6 then Sum:=Sum+30;
if pMonth>7 then Sum:=Sum+31;
if pMonth>8 then Sum:=Sum+31;
if pMonth>9 then Sum:=Sum+30;
if pMonth>10 then Sum:=Sum+31;
if pMonth>11 then Sum:=Sum+30;
Sum:=Sum + pDay;
if ((pYear - (pYear div 4)*4)=3D0) and (pMonth>2) then inc(Sum);
HowManyDays:=Sum;
end; { HowManyDays }
procedure TForma1.GetWeekBtnClick(Sender: TObject);
var
ADate: TDateTime;EditAux:String;
Week,year,month,day:Word;
begin
EditAux:=Edit1.Text;
ADate := StrToDate(EditAux);
Label1.Caption := DateToStr(ADate);
DecodeDate(Adate,Year,Month,Day);
Case DayOfWeek(ADate) of
1: Label4.Caption:='Воскресенье';
2: Label4.Caption:='Понедельник';
3: Label4.Caption:='Вторник';
4: Label4.Caption:='Среда';
5: Label4.Caption:='Четверг';
6: Label4.Caption:='Пятница';
7: Label4.Caption:='Суббота';
end
Week:=(HowManyDays(year,month,day) div 7) +1;
Label3.Caption:='Неделя No. '+IntToStr(Week);
end;
end.
Количество дней между двумя датами I
Delphi 1ПЕРЕМЕННЫЕ:
Year1, Month1, Day1,
Year2, Month2, Day2,
YearResult, MonthResult, DayResult: Word;
TDay1, TDay2, DateDiff: TDateTime;
КОД:
TDay1 := EncodeDate(Year1, Month1, Day1);
TDay2 := EncodeDate(Year2, Month2, Day2);
DateDiff := TDay2 – TDay1; {предположим, что TDay2 позднее, чем TDay1}
DecodeDate(DateDiff, YearResult, MonthResult, DayResult);
DateDiff имеет тип LongInt (хотя и является объектом TDateTime), и содержит количество дней между датами.
Количество дней между двумя датами II
Delphi 1Для DateDiff: Вы смотрели на функцию DecodeDate? Это не точно именно то, что вам нужно, но на ее основе можно сделать вашу функцию именно с нужной вам функциональностью. Для величины Present:
function PresentValue(const cashflows : array of double; { отсортированные транзакции, начальный индекс - cashflows[0] }
n : integer; { количество транзакций в массиве }
rate : double; { оценочный процент за истекший период }
atbegin : boolean) : double; { true, если транзакция была в начале периода,false если в конце }
var
i: integer;
factor: double;
begin
factor := (1 + rate / 100.0);
result := 0;
for i := n - 1 downto 0 do result := (result + cashflows[n]) / factor;
if atbegin then result := result * factor;
end;
Конвертирование даты
Delphi 1
TheDateField.AsString := TheDateString;
TheDateString := TheDateField.AsString;
это делает преобразование подобно DateToStr и StrToDate. Аналогично:
TheDateField.AsDateTime := StrToDate(TheDateString);
TheDateString := DateToStr(TheDateField.AsDateTime);
Число текущей недели
Delphi 1Здесь включены 2 вспомогательные функции, необходимые для работы вашей функции. Одна проверяет високосный год, другая возвращает число дней месяца (с проверкой високосного года), третья, ту, что вы хотели, возвращает текущую неделю года.
{***************************************************************************}
function kcIsLeapYear(nYear: Integer): Boolean;
begin
Result := (nYear mod 4 = 0) and ((nYear mod 100 <> 0) or (nYear mod400 = 0));
end;
{***************************************************************************}
function kcMonthDays(nMonth, nYear: Integer): Integer;
const
DaysPerMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31,31, 30, 31, 30, 31);
begin
Result := DaysPerMonth[nMonth];
if (nMonth = 2) and kcIsLeapYear(nYear) then Inc(Result);
end;
{***************************************************************************}
function kcWeekOfYear(dDate: TDateTime): Integer;
var
X, nDayCount: Integer;nMonth, nDay, nYear: Word;
begin
nDayCount := 0;
deCodeDate(dDate, nYear, nMonth, nDay);
For X := 1 to (nMonth - 1) do nDayCount := nDayCount + kcMonthDays(X, nYear);
nDayCount := nDayCount + nDay;
Result := ((nDayCount div 7) + 1);
end;
Разница во времени
Delphi 1…я не знаю, когда вы выполняете TimeTaken… Вы делали какую-нибудь паузу перед запуском TimeTaken после выполнения SetTimeStart? Если не делали, то удивительно, что tt=Now… Я пробовал ваш код с несколькими незначительными изменениями… и я всегда получал разницу между Now и TimeStart. Но я объявляю tt как TDateTime, а не как Double, и использую событие OnTimer для запуска процедуры TimeTaken. Вы можете проверить это, запустив пример, приведенный ниже.
{*******************************************************************
ФАЙЛ : TIMEEX.PAS
ПРИМЕЧАНИЕ : Создайте форму, содержащую 1 TTimer и 6 TLabel. Установите событие OnTimer у TTimer на TForm.Timer1.Timer
********************************************************************}
unit Time;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,Forms, Dialogs, ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Timer1: TTimer;
Label1: TLabel; {Caption : 'Старт :'}
Label2: TLabel;
Label3: TLabel; {Caption : 'Время : '}
Label4: TLabel;
Label5: TLabel; {Caption : 'Истекшее время:'}
Label6: TLabel;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private { Private declarations }
TimeStart : TDateTime;
public { Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
TimeStart := Now;
Label2.Caption := TimeToStr(Now);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
tt : TDateTime;
begin
Label4.Caption := TimeToStr(Now);
tt:= Now - TimeStart;
Label6.Caption:= TimeToStr(tt);
end;
end.
Проблема со временем
Delphi 1…я нашел Time24Hour в файлах помощи, как вы и советовали. Но… вот код для EncodeTime в SysUtils.Pas file:
function DoEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;
begin
Result := False;
if (Hour < 24) and (Min < 60) and (Sec < 60) and (MSec < 1000) then begin
Time := (LongMul(Hour * 60 + Min, 60000) + Sec * 1000 + MSec) / MSecsPerDay;
Result := True;
end;
end;
function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;
begin
if not DoEncodeTime(Hour, Min, Sec, MSec, Result) then ConvertError(LoadStr(STimeEncodeError));
end;
Как вы можете видеть, проверка Time24Hour присутствует. Я думал в Browser все будет также. Ничего подобного! Я уж грешным делом подумал, что Time24Hour объявили устаревшим, исключили из поддержки, выбросили частично из кода, но забыли почистить файл помощи. Вы так не думаете?
Переменная времени
Delphi 1Используйте переменную типа TDateTime.
procedure TForm1.XXXXXXXClick(Sender: TObject);
var StartTime, EndTime, ElapsedTime :TDateTime;
begin
StartTime := Now;
{Здесь поместите свой код}
EndTime := Now;
ElapsedTime := EndTime - StartTime;
Label1.Caption := TimeToStr(ElapsedTime);
end;
{теперь все это в памяти, но в нашем случае это хорошее место. }
var
before,after,elapsed : TDateTime;
Ehour, Emin, Esec, Emsec : WORD;
…
before := now;
some_process();
after := now;
elapsed := after - before;
decodetime(elapsed, Ehour, Emin, Esec, Emsec);
теперь Ehour:Emin:Esec.Emsec будет содержать истекшее время.
Это то, что я хотел. fStartWhen содержит дату/время начала процесса. (fStartWhen := NOW). OneSecond — константа, определенная как 1/24/3600. (Да, эта программа может выполняться для нескольких дней. Но даже самый быстрый P5 может не справиться с большим количеством данных!)
PROCEDURE TformDBLoad.UpdateTime;
VAR Delta: TDateTime
BEGIN
fLastUpdate := NOW
IF ABS(fStartWhen - fLastUpdate ) < OneSecond THEN EXIT
Delta := fLastUpdate - fStartWhendoElapsedTime.Caption := FORMAT('%1. дней из %s', [INT(Delta),FORMATDATETIME('hh:nn:ss', FRAC(Delta))])
END;
Математика
Как научить Delphi делать правильное округление дробных чисел?
Nomadic советует: Целая коллекция способов - Для решения этой проблемы мною написана функция, которую можно модифицировать для всех случаев. Смысл заключается в том, что рассматривается строка. После этого все проблемы с округлением снялись.Function RoundStr(Zn:Real;kol_zn:Integer):Real;
{Zn-значение; Kol_Zn-Кол-во знаков после запятой}
Var
snl,s,s0,s1,s2:String;
n,n1:Real;
nn,i:Integer;
begin
s:=FloatToStr(Zn);
if (Pos(',',s)>0) and (Zn>0) and (Length(Copy(s,Pos(',',s)+1,length(s)))>kol_zn) then begin
s0 := Copy(s,1,Pos(',',s)+kol_zn-1);
s1 := Copy(s,1,Pos(',',s)+kol_zn+2);
s2 := Copy(s1,Pos(',',s1)+kol_zn,Length(s1));
n := StrToInt(s2)/100;nn := Round(n);
if nn >= 10 then begin
snl := '0,';
For i := 1 to kol_zn - 1 do snl := snl + '0';
snl := snl+'1';
n1 := StrToFloat(Copy(s,1,Pos(',',s)+kol_zn))+StrToFloat(snl);
s := FloatToStr(n1);
if Pos(',',s) > 0 then s1 := Copy(s,1,Pos(',',s)+kol_zn);
end else s1 := s0 + IntToStr(nn);
if s1[Length(s1)]=',' then s1 := s1 + '0';
Result := StrToFloat(s1);
end else Result := Zn;
end;
Все-таки работа со строками здесь излишество -
function RoundEx( X: Double; Precision : Integer ): Double;
{Precision : 1 - до целых, 10 - до десятых, 100 - до сотых...}
var
ScaledFractPart, Temp : Double;
begin
ScaledFractPart := Frac(X)*Precision;
Temp := Frac(ScaledFractPart);
ScaledFractPart := Int(ScaledFractPart);
if Temp >= 0.5 then ScaledFractPart := ScaledFractPart + 1;
if Temp <= -0.5 then ScaledFractPart := ScaledFractPart - 1;
RoundEx := Int(X) + ScaledFractPart/Precision;
end;
Разное
Генерация еженедельных списков задач
Мне необходима программа, которая генерировала бы еженедельные списки задач. Программа должна просто показывать количество недель в списке задач и организовывать мероприятия, не совпадающие по времени. В моем текущем планировщике у меня имеется 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
Генерация случайного пароля
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;
Проверка ISBN
Delphi 1ISBN (или 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 на одинадцать делится без остатка, расмотренный нами кандидат на ISBN является верным кодом ISBN.
Данный алгоритм проверки легко портируется в код Pascal/Delphi. Для извлечения контрольной цифры и кода из ISDN номера используются строковые функции и процедуры, после чего они передаются в функцию проверки. Контрольная цифра преобразуется в тип целого, на основе ее формируется стартовое значение составной переменной, состоящей из добавляемых цифр, умноженных на их позицию в коде ISBN (отдельные цифры, составляющие первые три части ISBN). Для последовательной обработки каждой цифры используется цикл For, в котором мы игнорируем дефисы и умножаем текущую цифру на ее позицию в коде ISDN. В заключение, значение этой составной переменной проверяется на делимость без остатка на одиннадцать. Если остатка после деления нет, код 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 на наличие дефисов. Другой полезной вещью могла бы быть проверка на наличие трех дефисов на нужных позициях, а не простая проверка на наличие необходимых одиннадцати символов-цифр.
API
Переменные среды
Как раскрыть строки с подстановками вида '%SystemRoot%\IOSUBSYS\'?
Nomadic советует: Используй вызовExpandEnvironmentStrings(LPCTSTR lpSrc, LPTSTR lpDst, DWORD nSize);
Изменение системного времени из Delphi II
Delphi 1Можно. Попробуйте следующий код:
Procedure settime(hour, min, sec, hundreths : byte); assembler;
asm
mov ch, hour
mov cl, min
mov dh, sec
mov dl, hundreths
mov ah, $2d
int $21
end;
Procedure setdate(year : word; month, day : byte); assembler;
asm
mov cx, year
mov dh, month
mov dl, day
mov ah, $2b
int $21
end;
Завершение работы Windows
Определение завершения работы Windows
НОМЕР ДОКУМЕНТА: TI3133 ПРОДУКТ: Delphi Версия: 1.0 ОС: Windows Дата: 1 октября, 1996 Тема: Определение завершения работы WindowsСуществует ли возможность определения завершения работы Windows для нормального завершения работы работающего приложения Delphi? Самым простым решением является создание обработчика события главной формы OnCloseQuery. Данное событие возникает как результат сообщения WM_QUERYENDSESSION, которое посылается всем работающим приложениям Windows в момент инициализации процесса окончания работы Windows. Логическая переменная CanClose, передаваемая обработчику как var-параметр, может позволить программе (и Windows) завершить свою работу, если имеет значение True, значение же False не позволит программе завершить свою работу. Следующий код демонстрирует как можно воспользоваться данным событием. Демонстрационный код
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
{Спрашиваем пользователя, если инициировано завершение работы.}
if MessageDlg('Вы уверены?', mtConfirmation, mbYesNoCancel, 0) = mrYes then CanClose := true {Разрешаем завершение работы.}
else CanClose := false; {Не разрешаем завершение работы.}
end;
Как консольное приложение может узнать, что Винды завершаются?
Nomadic рекомендует следующий код: Все процессы получают сигналы CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT и CTRL_SHUTDOWN_EVENT. А делается это (грубо говоря :) так:BOOL Ctrl_Handler(DWORD Ctrl) {
if ((Ctrl == CTRL_SHUTDOWN_EVENT) || (Ctrl == CTRL_LOGOFF_EVENT)) {
// Вау! Юзер обламывает!
} else {
// Тут что-от другое можно творить. А можно и не творить :-)
}
return TRUE;
}
function Ctrl_Handler(Ctrl: Longint): LongBool;
begin
if Ctrl in [CTRL_SHUTDOWN_EVENT, CTRL_LOGOFF_EVENT] then begin
// Вау, вау
end
else begin
// Am I creator?
end;
Result := true;
end;
А где-то в программе:
SetConsoleCtrlHandler(Ctrl_Handler, TRUE);
Таких обработчиков можно навесить кучу. Если при обработке какого-то из сообщений обработчик возвращает FALSE, то вызывается следующий обработчик. Можно настроить таких этажерок, что ого-го :-)))
Короче, смотри описание SetConsoleCtrlHandler — там всё есть.
Как корректно перехватить сигнал выгрузки операционной системы, если в моей программе нет окна?
Nomadic рекомендует следующий способ: Используй GetMessage(), в качестве HWND окна пиши NULL (на Паскале — 0). Если в очереди сообщений следующее — WM_QUIT, то эта функция фозвращает FALSE. Если ты пишешь программу для Win32, то запихни это в отдельный поток, организующий выход из программы.Постепенное умирание
The_Sprite пишет: Вопрос: А как реализовать в одном компоненте такие функции как выключение компьютера, перезагрузка, завершение сеанса работы пользователя, Eject CD, выключение питания монитора и т.д.? Ответ: предлагаем посмотреть следующий пример… Совместимость: все версии Delphi Пример:procedure TForm1.Button1Click(Sender: TObject);
begin
PowerControl1.Action:=actCDEject;// Или...
actLogOFF, actShutDown...
PowerControl1.Execute;
end
Component Code:
unit
PowerControl;
interface
uses WinTypes, WinProcs, Messages, SysUtils, Classes, Controls,Forms, Graphics,MMSystem;
type
TAction =(actLogOFF,actShutDown,actReBoot,actForce,actPowerOFF,
actForceIfHung,actMonitorOFF,actMonitorON,actCDEject,actCDUnEject);
type TPowerControl = class(TComponent)
private
FAction : TAction;
procedure SetAction(Value : TAction); protected
public
function Execute :Boolean;
published
property Action :TAction read FAction write SetAction;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('K2',[TPowerControl]);
end;
procedure TPowerControl.SetAction(Value : TAction);
begin
FAction := Value;
end;
function TPowerControl.Execute : Boolean;
begin
with (Owner as TForm) do case FAction of
actLogOff: ExitWindowsEx(EWX_LOGOFF, 1);
actShutDown: ExitWindowsEx(EWX_SHUTDOWN, 1);
actReBoot:ExitWindowsEx(EWX_REBOOT, 1);
actForce:ExitWindowsEx(EWX_FORCE, 1);
actPowerOff:ExitWindowsEx(EWX_POWEROFF, 1);
actForceIfHung:ExitWindowsEx(EWX_FORCEIFHUNG, 1);
actMonitorOFF:SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
actMonitorON: SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);
actCDEject: mciSendstring('SET CDAUDIO DOOR OPEN WAIT', nil, 0, Handle);
actCDUnEject: mciSendstring('SET CDAUDIO DOOR CLOSED WAIT', nil, 0, Handle);
end; {Case}
Result := True;
end;
end.
Разное
Как не допустить запуск второй копии программы VIII
Игорь Пролис рекомендует следующий код:{*******************************************************}
{ }
{ HTMLCoolEdit }
{ }
{ Copyright (c) 1999-2000 PROFOX }
{ }
{*******************************************************}
unit multinst;
interface
uses Forms, Windows, Dialogs, SysUtils;
const
MI_NO_ERROR = 0;
MI_FAIL_SUBCLASS = 1;
MI_FAIL_CREATE_MUTEX = 2;
function GetMIError: Integer;
function InitInstance : Boolean;
implementation
uses RegWork, FileWork;
var
UniqueAppStr : PChar;
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
Result := 1;
if Msg = MessageID then begin
if IsIconic(Application.Handle) then OpenIcon(Application.Handle)
else SetForegroundWindow(Application.Handle);
FileWork.LoadFileName(RegWork.RWGetParamStr1);
end
else Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;
procedure SubClassApplication;
begin
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;
begin
Application.ShowMainForm := False;
PostMessage(HWND_BROADCAST, MessageId, 0, 0);
end;
function InitInstance : Boolean;
begin
MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
if MutHandle = 0 then begin
ShowWindow(Application.Handle, SW_ShowNormal);
Application.ShowMainForm:=True;
DoFirstInstance;
result := True;
end
else begin
RegWork.RWSetParamStr1;
BroadcastFocusMessage;
result := False;
end;
end;
initialization
begin
UniqueAppStr := PChar(Application.ExeName);
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.
Как не допустить запуск второй копии программы IX
YoungHacker рекомендует следующий код: Был взят из кулибы и доработан, поскольку возникали ситуации когда программа, по HotKey назначенным на ярлык, запускалась дважды и более раз. Связано с тем что поиск мутекса и его создание разнесены во времени и пока в одном приложении мутекс не нашелся но еще не создался второе приложение тоже не находит мутекса и инициирует его создание Поиск окон и создание их нарываются на те-же проблемы. Из RxLib Функция тоже не обходит этой ситуации. Мой вариант немного дорабатывает уже значительно переработанное то что предоставили разработчики Delphi 2 Пачека (Pacheco) и Тайхайра (Teixeira). и находится в файле TPrevInstUnit. В файле проекта пишется следующий вызов:begin
//– Найти предыдущую версию программы
if (initinstance) then begin
…
Application.Initialize;
…
Application.CreateForm(…);
…
Application.Run;
end;
end.
Файл TPrevInstUnit
unit TPrevInstUnit;
interface
uses Forms, Windows, Dialogs, SysUtils;
function InitInstance : Boolean;
implementation
const
UniqueAppStr : PChar = #0; // Различное для каждого приложения
// Но одинаковое для каждой копии программы
var
MessageId : Integer;
OldWProc : TFNWndProc = Nil;
MutHandle : THandle = 0;
SecondExecution : Boolean = False;
function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint): Longint; StdCall;
begin
//- Если это - сообщение о регистрации... }
if (Msg = MessageID) then begin
//- если основная форма минимизирована
if IsIconic(Application.Handle) then begin
//- восстанавливаем
ееApplication.Restore;
end
else begin
//- вытаскиваем на перед
ShowWindow(Application.Handle, SW_SHOW);
SetForegroundWindow(Application.Handle);
Application.BringToFront;
end;
Result := 0;
end
else
{ В противном случае посылаем сообщение предыдущему окну }
Result := CallWindowProc(OldWProc, Handle, Msg, wParam, lParam);
end;
function InitInstance : Boolean;
var
BSMRecipients: DWORD;
begin
Result := False;
//- пробуем открыть MUTEX созданный предыдущей копией программы
MutHandle := CreateMutex(Nil, True, UniqueAppStr);
//- Мутекс уже был создан ?
SecondExecution := (GetLastError = ERROR_ALREADY_EXISTS);
if (MutHandle = 0) then begin
ShowMessage('Ошибка создания Mutex.');
Exit;
end;
if Not (SecondExecution) then begin
//- назначаем новый обработчик сообщений приложения, а старый сохраняем
OldWProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC, Longint(@NewWndProc)));
//- если обработчик не найден устанавливаем ошибку
if (OldWProc = Nil) then begin
ShowMessage('Ошибка поиска стандартного обработчика сообщений приложения.');
Exit;
end;
//- Установить "нормальный" статус основного окна приложения
ShowWindow(Application.Handle, SW_ShowNormal);
//- покажем основную форму приложения
Application.ShowMainForm := True;
//- все нормально мама трын тин тин тин тири тын тын
Result := True;
end
else begin
//- установить статус окна приложения "невидимый"
ShowWindow(Application.Handle, SW_Hide);
//- Не покажем основную форму приложения
Application.ShowMainForm := False;
//- Посылаем другому приложению сообщение и информируем о необходимости
// перевести фокус на себя
BSMRecipients := BSM_APPLICATIONS;
BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE, @BSMRecipients, MessageID, 0, 0);
end;
end;
initialization
begin
//- Создать ункальную строку для опознания приложения
UniqueAppStr := PChar('YoungHackerNetworkDataBaseProgramm');
//- Зарегистрировать в системе уникальное сообщение
MessageID := RegisterWindowMessage(UniqueAppStr);
end;
finalization
begin
if (OldWProc <> Nil) then
{ Приводим приложение в исходное состояние }
SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(OldWProc));
end;
end.
Как не допустить запуск второй копии программы X
Nomadic рекомендует следующий код: FindWindow является неполным решением (если меняется заголовок окна или если есть другая программа с таким же заголовком или типом окна). Вторично: Это работает медленно. Правильно — использовать обьекты синхронизации Win32 API. Лениво пользовать семафоры, покажу на именованных мутексах (семафоры с двумя состояниями).Unit OneInstance32;
interface
implementation
uses
Forms;
var
g_hAppMutex: THandle;
function OneInstance: boolean;
var
g_hAppCritSecMutex: THandle;
dw: Longint;
begin
g_hAppCritSecMutex := CreateMutex(nil, true, PChar(Application.Title + '.OneInstance32.CriticalSection'));
// if GetLastError - лениво писать
g_hAppMutex := CreateMutex(nil, false, PChar(Application.Title + 'OneInstance32.Default'));
dw := WaitForSingleObject(g_hAppMutex, 0);
Result := (dw <> WAIT_TIMEOUT);
ReleaseMutex(g_hAppCritSecMutex); // необязательно вследствие последующего закрытия
CloseHandle(g_hAppCritSecMutex);
end;
initialization
g_hAppMutex := 0;
finalization
if LongBool(g_hAppMutex) then begin
ReleaseMutex(g_hAppMutex); // необязательно
CloseHandle(g_hAppMutex);
end;
end.
Как не допустить запуск второй копии программы XI
Михаил Чумак рекомендует следующий код: Есть такая штука Atom (см. Help).program SelfCheck;
uses
Windows,Forms,Unit1 in 'Unit1.pas' {Form1};
const
AtStr='MyProgram';
function CheckThis : boolean;
var
Atom: THandle;
begin
Atom:= GlobalFindAtom(AtStr);
Result:= Atom <> 0;
if not result then GlobalAddAtom(AtStr);
end;
begin
if not CheckThis then begin
// Запуск программмы
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
GlobalDeleteAtom(GlobalFindAtom(AtStr));
// !!!
end
else begin
MessageBox(0,'Нельзя запустить две копии','Моя программа',0);
end;
end.
Элегантно и работает однозначно. Спасибо Славе Шубину.
Как не допустить запуск второй копии программы XII
Nomadic рекомендует следующее: A: Воспользуйтесь функцией ActivatePrevInstance из библиотеки rxLib. Для завершения второго экземпляра используйте Application.Terminate. (AS): Другой вариант: X:\DELPHI2\DEMOS\IPCDEMOS\ipcthrd.pas, функция IsMonitorRunning().Как правильно завершить некое приложение?
Nomadic рекомендует следующий код: Если не принудительно, то можно послать на его Instance сообщение WM_QUIT. Если же необходимо принудительно терминировать приложение, то смотрите ниже — под Windows NT процесс можно терминировать через специально предназначенный для этого хэндл. Иначе гарантии нет. Предположим, что процесс создаем мы, ожидая его завершения в течение maxworktime. Тогда —var
dwResult: Longint; // This example was converted from C source.
begin
// Not tested. Some 'nil' assignments must be applied
// as zero assignments in Pascal. Some vars need to
// be declared (maxworktime, si, pi). AA.
if CreateProcess(nil, CmdStr, nil, nil, FALSE,CREATE_NEW_CONSOLE, nil, nil, si, pi) then begin
CloseHandle(pi.hThread);
dwResult := WaitForSingleObject(pi.hProcess, maxworktime*1000*60);
CloseHandle(pi.hProcess);
if dwResult <> WAIT_OBJECT_0 then begin
pi.hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, pi.dwProcessId);
if pi.hProcess <> nil then begin
TerminateProcess(pi.hProcess, 0);
CloseHandle(pi.hProcess);
end;
end;
end;
end;
Как отчитывать промежутки времени с точностью, большей чем 60 мсек?
Nomadic рекомендует следующий код: Для начала описываешь процедуру, которая будет вызываться по сообщению от таймера :procedure FNTimeCallBack(uTimerID, uMessage: UINT;dwUser, dw1, dw2: DWORD); stdcall;
begin
//// Тело процедуры.
end;
а дальше в программе (например по нажатию кнопки) создаешь Таймер и вешаешь на него созданную процедуру
uTimerID:=timeSetEvent(10, 500, @FNTimeCallBack, 100, TIME_PERIODIC);
Подробности смотри в Help. Hу и в конце убиваешь таймер
timeKillEvent(uTimerID);
И все. Точность этого способа до 1 мсек. минимальный интервал времени можно задавать 1 мсек.
Обратите внимание на то, что все CALLBACK-функции, вызываемые Windows, должны использовать соглашение о вызовах stdcall.
Как сделать чтобы при событиях моя программа отпpавляла кому-либо сообщение на мой компьютеp?
Nomadic рекомендует следующий код: Если только послать, то проще всего, пожалуй… W32: F1 «NetMessageBufferSend»; Win16: Почему-то не описан, но руками наковырял…function NetMessageBufferSend(Zero1, Zero2: Word; WhoTo: PChar; Buffer: PChar; BufSize: Word): Integer; external 'netapi' index 525;
«Кому» может быть '*' == всем.
Что нужно давать WSAAsyncSelect в качестве параметра handle, если тот запускается и используется в dll (init), и никакой формы (у которой можно было бы взять этот handle) в этой dll не создается?
Nomadic рекомендует следующий код:const WM_ASYNCSELECT = WM_USER+0;
type TNetConnectionsManager = class(tobject)
protected
FWndHandle : HWND;
procedure WndProc(var MsgRec : TMessage);
…
end;
constructor TNetConnectionsManager.Create
begin
inherited Create;
FWndHandle := AllocateHWnd(WndProc);
…
end;
destructor TNetConnectionsManager.Destroy;
begin
…
if FWndHandle<>0 then DeallocateHWnd(FWndHandle);
inherited Destroy;
end;
procedure TNetConnectionsManeger.WndProc(var MsgRec : TMessage);
begin
with MsgRec do
if Msg = WM_ASYNCSELECT then WMAsyncSelect(MsgRec)
else DefWindowProc(FWndHandle, Msg, wParam, lParam);
end;
Hо pекомендую посмотpеть WinSock2, в котоpом можно:
WSAEventSelect(FSocket, FEventHandle, FD_READ or fd_close);
WSAWaitForMultipleEvents(…);
WSAEnumNetworkEvents(FSocket, FEventHandle, lpNetWorkEvents);
То есть, обойтись без окон и без очеpеди сообщений windows, а заодно иметь возможность pаботать и с IPX/SPX, и с netbios.
Вызов других программ
VRSLazy@mail.ru пишет: Доброго времени суток, Вот посмотрел Ваше произведение Советы по делфи, мне очень понравилось :-) Правда в вопросе/решении запустить другую программу просто обалдел :-( Я как то долго мучился с этим самым ShellExecute пока не пришёл к следующему:uses …ToolWin, Windows …
procedure Run(App: String);
var
ErrStr : String;
PMSI: TStartupInfo;
PMPI: TProcessInformation;
begin
try
CreateProcess(nil, @App[1] , nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, PMSI, PMPI);
except
ErrStr := 'Fault run process: '''+App+'''';
Application.MessageBox(@ErrStr[1],'Failure process', MB_OK+MB_ICONERROR);
end;
разумеется это одно из самых корявых решений, но всё же работает, как вариант сойдет?
Получение списка запущеных приложений
Igor Nikolaev aKa The Sprite предлагает следующий код:procedure TForm1.Button1Click(Sender: TObject);
VAR
Wnd : hWnd;
buff: ARRAY [0..127] OF Char;
begin
ListBox1.Clear;
Wnd := GetWindow(Handle, gw_HWndFirst);
WHILE Wnd <> 0 DO BEGIN {Hе показываем:}
IF (Wnd <> Application.Handle) AND {-Собственное окно}
IsWindowVisible(Wnd) AND {-Hевидимые окна}
(GetWindow(Wnd, gw_Owner) = 0) AND {-Дочернии окна}
(GetWindowText(Wnd, buff, sizeof(buff)) <> 0)
THEN BEGIN
GetWindowText(Wnd, buff, sizeof(buff));
ListBox1.Items.Add(StrPas(buff));
END;
Wnd := GetWindow(Wnd, gw_hWndNext);
END;
ListBox1.ItemIndex := 0;
end;
Как мне запустить какую-нибудь программу? А как подождать, пока эта программа не отработает? Как выяснить, работает ли программа или уже завершилась? Как принудительно закрыть выполняющуюся программу?
Nomadic рекомендует следующее: A: WinExec() или ShellExecute. У второй больше возможностей. (SO): CreateProcess() в параметре process info возвращает handle запущенного процесса. Вот и делаешь WaitForSingleObject(pi.hProcess, INFINITE); (AA): (Win16) Delay можно взять из rxLib.handle := WinExec(…);
if handle >= 32 then
while GetModuleUsage(handle) > 0 do Delay(nn);
else raise …
(AM): Чтобы выяснить, работает ли программа, используйте GetProcessTimes(), параметр lpExitTime.
(Win32) Для принудительного завершения процесса — TerminateProcess.
(Win16) (RR): Надо послать программе сообщение WM_QUIT:
Handle := Winexec(App, 0);
PostMessage(Handle, WM_QUIT, 0, 0);
Открытие выбранного файла в работающем приложении
Пангин Дмитрий Викторович прислал письмо следующего содержания: При программировании MDI-приложений возникает следующая задача: Если пользователь кликнул на файле, тип которого поддерживается создаваемым приложением, то, если приложение уже запущено, не нужно запускать новую копию приложения, а нужно открыть выбранный файл в уже работающем приложении. Я сделал это так (возможно есть более красивое решение):\\ В файле проекта:
var
i: integer;
hMainForm:hwnd;
copyDataStruct:TCopyDataStruct;
ParamString:string;
WParam,LParam:integer;
begin
\\ ищем главное окно приложения, вместо Caption - nil,
\\ поскольку к заголовку главного окна может добавиться заголовок MDIChild
\\ (нужно позаботиться об уникальности имени класса главной формы)
hMainForm:= FindWindow('TMainForm', nil);
if hMainForm = 0 then begin
Application.Initialize;
Application.CreateForm(TFrmMain, frmMain);
for i:=1 to ParamCount do TMainForm(Application.MainForm).OpenFile(ParamStr(i));
Application.Run;
end
else begin
ParamString:='';
for i:=1 to ParamCount do begin
\\ запихиваем все параметры в одну строку с разделителями ?13
ParamString:=ParamString+ParamStr(i)+ #13;
end;
\\ создаем запись типа TCopyDataStruct
CopyDataStruct.lpData:=PChar(ParamString);
CopyDataStruct.cbData:=Length(ParamString);
CopyDataStruct.dwData:=0;
WParam:=Application.Handle;
LParam:=Integer(@CopyDataStruct);
\\ отсылаем сообщение WM_COPYDATA главному окну открытого приложения
SendMessage(hMainForm,WM_CopyData,WParam,LParam);
Application.Terminate;
end;
end.
\\ Обработчик сообщения WM_COPYDATA
procedure TMainForm.CopyData(var Msg: TWMCopyData);
var
ParamStr:string;
CopyDataStructure:TCopyDataStruct;
i:integer;
len:integer;
begin
CopyDataStructure:= Msg.CopyDataStruct^;
ParamStr:='';
len:= CopyDataStructure.cbData;
for i:=0 to len-1 do begin
ParamStr:=ParamStr+(PChar(CopyDataStructure.lpData)+i)^;
end;
i:=0;
while not(Length(ParamStr)=0) do begin
if isDelimiter(#13,ParamStr,i) then begin
OpenFile(Copy(ParamStr,0,i-1));
ParamStr:=Copy(ParamStr,i+1,Length(ParamStr)-i-1);
end;
inc(i);
end;
inherited;
end;
Убиваем активное приложение
The_Sprite прислал письмо следующего содержания: Данная функция позволяет завершить выполнение любой активной программы по её classname или заголовку окна. Совместимость: Все версии Delphi Исходный код функцииprocedure KillProgram(Classname : string; WindowTitle : string);
const
PROCESS_TERMINATE = $0001;
var
ProcessHandle : THandle;
ProcessID: Integer;
TheWindow : HWND;
begin
TheWindow := FindWindow(Classname, WindowTitle);
GetWindowThreadProcessID(TheWindow, @ProcessID);
ProcessHandle := OpenProcess(PROCESS_TERMINATE, FALSE, ProcessId);
TerminateProcess(ProcessHandle, 4);
end;
Комментарии
Xianguang Li=(22 Октября 2000) В Delphi 5, при компиляции получается следующая ошибка:Incompatible types: 'String' and 'PChar'.
После изменения выражения
TheWindow := FindWindow(ClassName, WindowTitle)
на
TheWindow := FindWindow(PChar(ClassName), PChar(WindowTitle))
Нормально откомпилировалось.
И ещё: если мы не знаем ClassName или WindowTitle программы, которую мы хотим убить, то мы не сможем её завершить. Причина в том, что нельзя вызвать функцию в виде:
KillProgram(nil, WindowTitle)
или
KillProgram(ClassName, nil)
Компилятор не позволяет передать nil в переменную типа String.
Итак, я изменил объявление
KillProgram(ClassName: string; WindowTitle: string)
на
KillProgram(ClassName: PChar; WindowTitle: PChar),
вот теперь функция действительно может завершить любое приложение, если вы не знаете ClassName или WindowTitle этого приложения.
Pascal
Объекты
Проблема циклических ссылок
У меня имеется объект A и объект B, и им обоим нужно вызывать методы друг друга…Объявите абстрактный базовый класс, определяющий интерфейс класса для того, чтобы другие классы могли его видеть. Используйте виртуальные абстрактные методы и свойства. Затем объявите другие классы подклассами базового класса (при необходимости). Данный метод существенно поможет в структурировании вашего приложения.Mike Scott.
Создание множества экземпляров
Delphi 1
list:=Tlist.create;
For i:= 1 to 1000 do begin
SSObject:=TSSObject.create;
{поместите куда-нибудь ссылку на созданный объект - например, в Tlist}
list.add(SSObject);
end;
Параметры
Передача функции как параметра
Delphi 1В нашем случае лучшим решением будет использование процедурного типа. Допустим, что DllFunction() на входе хочет получить определенную функцию, поясним это на примере кода:
type TMyFuncType = function: integer;
var MyFunc : TMyFuncType;
function foo: integer;
begin
result := 1;
end;
begin
MyFunc := foo;
DllFunction(longint(MyFunc));
Вы можете это сделать и так:
DllFunction(longint(@foo));
Все же я не уверен в вопросах корректности использования таким образом в вызовах DLL памяти (для меня пока неясна работа с памятью, находящейся в другом сегменте), как в этом примере, так что возможно для корректной работы вам придется объявить foo с директивой far, экспортировать ее в модуле, или что-то еще.
Также, в зависимости от того, как написана DllFunction(), вы можете в вызове подразумевать приведение типа:
function DllFunction(p: TMyFuncType): Integer; far; external 'mydll';
В этом случае вам не нужна будет переменная MyFunc или оператор @.
В Delphi/Pascal вы можете передавать функции как параметры. Тем не менее, чтобы этим воспользоваться, необходимо для компилятора установить тип. Попробуйте следующий код (я реально его компилил и тестировал):
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private { Private declarations }
public { Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
IntFunc = function: integer;
function DllFunction(iFunc: IntFunc): integer; far;
begin
DllFunction := iFunc; {Обратите внимание на то, что это вызов функции}
end;
function iFoo: integer; far;
begin
iFoo := 1;
end;
procedure TestIFunc;
var
i: integer;
begin
i := DllFunction(iFoo);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TestIFunc;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Close;
end;
end.
Вы можете сделать две вещи. Во-первых, если вы хотите использовать для передачи longint, напишите следующий код:
i := longint(@foo)
Другая вещь, которую вы можете сделать — исключить работу с longint и вызывать функцию dll следующим образом:
DLLfunction(@foo);
Имейте в виду, что если вы собираетесь вызывать foo из DLL, то необходимо предусмотреть вопросы совместимости, для получения дополнительной информации почитайте описание функции MakeProcInstance.
Проблема передачи записи
Delphi 1Может это не то, что вы ищете, но идея такая: Определите базовый класс с именем, скажем, allrecs:
tAllrecs = class
function getVal(field: integer): string; virtual;
end;
Затем создаем классы для каждой записи:
recA = class(tAllrecs)
this: Integer;
that: String;
the_other: Integer;
function getVal(field: integer): string; virtual;
end;
Затем для каждой функции класса определите возвращаемый результат:
function recA.getVal(field: integer); string;
begin
case field of
1: getVal := intToStr(this);
2: getVal := that;
3: getVal := intToStr(the_other);
end;
end;
Затем вы можете определить
function myFunc(rec: tAllrecs; field: integer);
begin
label2.caption := allrecs.getVal(field);
end;
затем вы можете вызвать myFunc с любым классом, производным от tAllrecs, например:
myFunc(recA, 2);
myFunc(recB, 29);
(getVal предпочтительно должна быть процедурой (а не функцией) с тремя var-параметрами, возвращающими имя, тип и значение.)
Все это работает, т.к. данный пример я взял из моего рабочего проекта.
[Sid Gudes, cougar@roadrunner.com]
Если вы хотите за один раз передавать целую запись, установите на входе ваших функций/процедур тип 'array of const' (убедитесь в правильном приведенни типов). Это идентично 'array of TVarRec'. Для получения дополнительной информации о системных константах, определяемых для TVarRec, смотри электронную справку по Delphi.
Указатели
Указатель на функцию I
Delphi 1Это то, что я нашел при создании простой машины состояний: Ниже приведен простой пример для Borland Delphi, использующий указатели функций для управления программным потоком. Просто создайте простую форму с единственной кнопкой и скопируйте код из Unit1 во вновь созданный модуль. Добавьте к проекту Unit2 и скомпилируйте проект. Дайте мне знать, если у вас возникнут какие-либо проблемы.
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private { Private declarations }
public { Public declarations }
end;
var
Form1: TForm1;
CurrProc : LongInt;
MyVal : LongInt;
implementation
uses Unit2;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
NewProc : LongInt;
MyString : string;
begin
CurrProc := 2; { начальная точка в таблице методов }
MyVal := 0; { вспомогательная переменная }
NewProc := 0; { возвращаемое значение для следующего индекса в таблице методов }
while CurrProc < 6 do begin
{ выполняем текущий индекс в таблице методов и получаем следующую процедуру }
NewProc := ProcTable[CurrProc](MyVal);
{ просто показываем значения NewProc и CurrProc }
FmtStr(MyString, 'NewProc [%d] CurrProc [%d]', [NewProc, CurrProc]);
MessageDlg(MyString, mtInformation, [mbOK], 0);
{ присваиваем текущую процедуру возвращаемой процедуре }
CurrProc := NewProc;
end;
end;
end.
{ Это простой пример, определяющий массив указателей на функции }
interface
type
{ определяем Procs как функцию }
Procs = function(var ProcNum : LongInt): LongInt;
var
{ объявляем массив указателей на функции }
ProcTable : Array [1..5] of Procs;
{ определения интерфейсов функций }
function Proc1(var MyVal : LongInt) : LongInt; far;
function Proc2(var MyVal : LongInt) : LongInt; far;
function Proc3(var MyVal : LongInt) : LongInt; far;
function Proc4(var MyVal : LongInt) : LongInt; far;
function Proc5(var MyVal : LongInt) : LongInt; far;
implementation
uses Dialogs;
function Proc1(var MyVal : LongInt) : LongInt;
begin
MessageDlg('Процедура 1', mtInformation, [mbOK], 0);
Proc1 := 6;
end;
function Proc2(var MyVal : LongInt) : LongInt;
begin
MessageDlg('Процедура 2', mtInformation, [mbOK], 0);
Proc2 := 3;
end;
function Proc3(var MyVal : LongInt) : LongInt;
begin
MessageDlg('Процедура 3', mtInformation, [mbOK], 0);
Proc3 := 4;
end;
function Proc4(var MyVal : LongInt) : LongInt;
begin
MessageDlg('Процедура 4', mtInformation, [mbOK], 0);
Proc4 := 5;
end;
function Proc5(var MyVal : LongInt) : LongInt;
begin
MessageDlg('Процедура 5', mtInformation, [mbOK], 0);
Proc5 := 1;
end;
initialization
{ инициализируем содержание массива указателей на функции }
@ProcTable[1] := @Proc1;
@ProcTable[2] := @Proc2;
@ProcTable[3] := @Proc3;
@ProcTable[4] := @Proc4;
@ProcTable[5] := @Proc5;
end.
Я думаю это можно сделать приблизительно так: объявите в каждой форме процедуры, обрабатывающие нажатие кнопки, типа процедуры CutButtonPressed(Sender:TObject) of Object; затем просто назначьте события кнопок OnClick этим процедурам при наступлении событий форм OnActivate. Этот способ соответствует концепции ОО-программирования, но если вам не нравится это, то вы все еще можете воспользоваться указателями функций, которая предоставляет Delphi.
Объявите базовый класс формы с объявлениями абстрактных функций для каждой функции, которую вы хотите вызывать из вашего toolbar. Затем наследуйте каждую вашу форму от базового класса формы и создайте определения этих функций.
Пример: (Здесь может встретиться пара синтаксических ошибок — я не компилил это)
type
TBaseForm = class(TForm)
public
procedure Method1; virtual; abstract;
end;
type
TDerivedForm1= class(TBaseForm)
public
procedure Method1; override;
end;
TDerivedForm2= class(TBaseForm)
public
procedure Method1; override;
end;
procedure TDerivedForm1.Method1;
begin
…
end;
procedure TDerivedForm2.Method1;
begin
…
end;
{Для вызова функции из вашего toolbar, получите активную в настоящий момент форму и вызовите Method1}
procedure OnButtonClick;
var
AForm: TBaseForm;
begin
AForm := ActiveForm as TBaseForm;
AForm.Method1;
end
Указатель на функцию II
Delphi 1Что лично я использую, чтобы вызвать какую-то функцию из DLL: 1. Объявите тип:
type TYourDLLFunc = function(Parm1: TParm1; Parm2: TParm2): TParm3;
2. Объявите переменную этого типа:
var YourDllFunc: TYourDLLFunc;
3. Получаем дескриптор DLL:
DLLHandle := LoadLibrary('YourDLL.DLL');
Получаем адрес функции:
@YourDLLFunc := GetProcAddress(DLLHandle, 'YourDLLFuncName');
Для использования функции теперь используйте переменную YourDLLFunc, например:
Parm3 := YourDLLFunc(Parm1, Parm2);
Использование указателей на целое
Delphi 1Сначала вы должны создать тип:
Type Pinteger: ^Integer;
Var MyPtr: Pinteger;
Мне кажется, что в начале вы использовали плохой пример, имеет смысл использовать 32-битный указатель для 16-битной величины или распределять 10 байт для переменной.
Pascal позволяет вам использовать методы NEW и DISPOSE, которые автоматически распределяют и освобождают правильные размеры блока.
Например,
NEW(MyPtr) = GetMem(MyPtr, Sizeof(MyPtr)).
Возможно, вы захотите подсчитать количество целочесленных переменных. В этом случае ознакомьтесь с возможностями TList. Пока лучше используйте линейный массив (или указатель на первый элемент, чтобы вычислить их количество, достаточно разделить количество занимаемой массивом памяти на количество элементов).
Для полноты, это должно быть:
NEW(MyPtr) = GetMem(MyPtr, SizeOf(MyPtr^));
SizeOf(MyPtr) всегда будет равен 4 байта, как 16-битный указатель.
Если я правильно разобрался в том, что вы хотите (динамический массив целых, количество элеметнов которого может быть известно только во время выполнения приложения), вы можете сделать так:
Type
pIntArr = ^IntArr;
IntArr = Array[1..1000] of Integer;
Var
MyPtr : pIntArr;
Begin
GetMem(MyPtr, 10); { 10 = SizeOf(Integer) * 5 !!}
{ MyPtr[2]:=1; }
<<<< Заполняем массив >>>>
MyPtr[2]^:=1;
FreeMem(MyPtr,10);
End;
Технология похожа на ту, которуя Delphi использует при работе с pchar. Синтаксис очень похож:
type intarray = array[0..20000] of integer;
procedure TForm1.Button1Click(Sender: TObject);
var
xptr: ^IntArray;
begin
GetMem(xptr, 10);
xptr^[idx] := 1; { где idx от 0 до 4, поскольку мы имеем 10 байте = 5 целых }
FreeMem(xptr, 10);
end;
Обратите внимание на то, в вам в действительности нет необходимости распределять массив для 20,000 элементов, но проверка диапазона Delphi не будет работать, если диапазон равен 20,000. (Предостережение будущим пользователям!)
Память
Функция MemAvail для Delphi2?
Delphi 2В Delphi 1, для того, чтобы получить самый большой возможный участок памяти, мы могли использовать функцию MemAvail, существует ли эквивалент этой функции в Delphi 2? Нет. Но чтобы получить аппроксимированную сумму доступной памяти, можно воспользоваться функцией API GlobalMemoryStatus (через поле dwAvailVirtual возвращаемой структуры TMemoryStatus). Steve Schafer
Как работать с блоками памяти размером более 64K?
Nomadic советует: Так можно помещать в один блок памяти записи из TList (TCollection):imlementation
{ To use the value of AHIncr, use Ofs(AHIncr). }
procedure AHIncr; far; external 'KERNEL' index 114;
const
NEXT_SELECTOR: string[13] = 'NEXT_SELECTOR';
function WriteData: THandle;
var
DataPtr: PChar;
i: Integer;
begin
Result := GlobalAlloc(GMEM_SHARE or GMEM_ZEROINIT, {pазмеp большого блока});
if Result = 0 then Exit;
DataPtr := GlobalLock(Result);
{записываем кол-во эл-тов}
Inc(DataPtr, {pазмеp счетчика эл-тов})
for i := 0 to {некий}Count-1 do begin
if LongInt(PtrRec(DataPtr).Ofs) + {pазмеp подблока} >l= $FFFF then begin
Move(NEXT_SELECTOR, DataPtr^, SizeOf(NEXT_SELECTOR)); {некая константа}
{ коppекция сегмента }
PtrRec(DataPtr).Seg := PtrRec(DataPtr).Seg + Ofs(AHIncr);
PtrRec(DataPtr).Ofs := $0;
end;
Inc(DataPtr, {pазмеp нового блока});
end; { for i }
GlobalUnlock(Result);
end;
procedure ReadData(DataHdl: THandle);
var
DataPtr : PObjectCfgRec;
RecsCount: Integer;
i: Integer;
begin
if DataHdl = 0 then Exit;
DataPtr := GlobalLock(DataHdl);
RecsCount := PInteger(DataPtr)^;
Inc(PInteger(DataPtr));
for i := 1 to RecsCount do begin
{ обpаботать данные }
Inc(DataPtr);
if PString(DataPtr)^ = NEXT_SELECTOR then begin
PtrRec(DataPtr).Seg := PtrRec(DataPtr).Seg + Ofs(AHIncr);
PtrRec(DataPtr).Ofs := $0;
end;
end; { for i }
GlobalUnlock(DataHdl);
end;
События
Назначение обработчика события OnClick пункту меню, созданному во время выполнения программы
Delphi 1Поскольку метод OnClick является свойством, то при динамическом создании элемента меню вы можете назначить имя метода обработчику OnClick:
theMenuitem.OnClick := TheOnClickHandler;
Затем, в обработчике OnClick, вы приводите sender к TMenuItem и читаете имя:
procedure theform.TheOnClickHandler(Sender: TObject);
var
fName: String;
begin
fName := TMenuItem(Sender).name;
…
end;
События для компонентов, созданных во время работы программы I
Delphi 1Вы должны вручную создать метод, который будет иметь тот же самый набор параметров, как и у события, которое вы хотите обработать. Затем вы должны вручную установить свойство OnXXX, чтобы она указывала на метод, который вы создали. Пример:
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FMyButton: TButton;
protected
procedure Button1Click(Sender: TObject);
{Кодируем это вручную,для соответствия}
{структуреTNotifyEvent}
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FMyButton := TButton.Create;
{Здесь устанавливаем позицию, заголовок и все остальное}
FMyButton.OnClick := MyButtonClick;
end;
procedure TForm1.MyButtonClick(Sender: TObject);
begin
ShowMessage('Эй! Ты нажал на мою кнопку!');
end;
События для компонентов, созданных во время работы программы II
Delphi 1Вот простейший код для нового проекта с одной кнопкой и меню. (Надеюсь, в этом ничего сложного нет ... :)
procedure TForm1.Button1Click(Sender: TObject);
var
NewItem: TMenuItem;
begin
NewItem := TMenuItem.Create(Form1);
NewItem.Caption := 'Динамический элемент ...';
NewItem.OnClick := xyz;MainMenu1.Items.Insert(0, NewItem); ←Примечание: рекомендую бегло ознакомиться с Delphi-примером для команды Insert…
end;
{Любая старая 'xyz'-процедура (в настоящее время может быть определена одна, например, Form1.DblClick)}
procedure TForm1.xyz(Sender: TObject);
begin
showmessage('Запусти эту процедуру !!');
end;
Примечание: Если вы пользуетесь неопределенной процедурой, вам понадобиться объявить ее. Лично я все это сделал в «верхнем правом углу» объявления типа формы, примерно так:
private
{ Private declarations }
public
{ Public declarations }
procedure xyz(Sender: TObject); ←К этой процедуре могут иметь доступ не только события Form1 …
Установите свойство обработчика события (например, OnClick, OnDblClick, OnMouseDown и пр.) на процедуру, которую вы создали для обработки этого события. Вам нужно убедиться в том, что параметры в точности соответствуют параметрам ожидаемого заданного обработчика события.
Например:
MySpeedButton.OnClick := MyClickEventHandler;
где…
procedure MyClickEventHandler(Sender: TObject);
begin
end;
Массивы
Динамические массивы V
SottNick пишет: Если хочется, чтобы в многомерном массиве был разный размер у разных измерений например: VarArray: array[1..2, 1..?] of TType , где ? зависит от "строки" массива (1..2) То дозволяется сделать так: 1. ОбъявлениеVar VarArray: array of array of array…………
2. Установка длин
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-ного «столбца»
т.д.
Все можно изменять в процессе естественно.
3. Получение длин
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-ного «столбца»
4. Обращение
VarArray[n][m][o][p][r]:=1; // :Integer // К элементу n-ной «строки», m-ного «столбца», // o-того «?», p-того «?», r-того «?»
5. Обнуление (освобождение памяти)
SetLength (VarArray, 0); // Всех сразу
Динамические массивы VI
Delphi 1Например, если вам необходимо сохранить «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;
ну и так далее…
TList — такой динамический массив. Для получения дополнительной информации обратитесь к электронной справке. Если вы хотите это делать сами, то вам необходимо использовать GetMem для получения указателя на распределенную динамическую память, и затем FreeMem для освобождения памяти, занятой динамическим массивом. Tlist сделает это за вас самым надежным образом.
Динамические массивы VII
Delphi 1Существует несколько способов сделать это. Применять тот или иной способ зависит от того, какой массив вы используете — массив строк или массив чисел (целые, натуральные и пр.). 1. Если вам необходим простой динамический одномерный массив строк, я предлагаю вам взглянуть на компонент tStringList, он сам заботится о функциях управления и легок в использовании. 2. Если вам необходим динамический многомерный массив строк, вы также можете воспользоваться tStringList (в случае, если число элементов вашего массива не превышает лимит для tStringList, я полагаю он равен 16,000). Чтобы сделать это, создайте функцию линейного распределения как показано ниже: Допустим у вас есть трехмерный массив строк, текущее измерение [12,80,7], и вы хотите найти элемент [n,m,x]. Вы можете найти этот элемент в приведенном одномерном массиве с помощью формулы ((n-1)*80*7 + (m-1)*80 + x). Затем вы можете использовать это в качестве индекса в tStringList. Для диманического изменения одной из границ массива, используйте метод tStringList Move, служащий как раз для таких целей. (Метод состоит из некоторых технологических внутренних циклов, но выполняются они очень быстро, поскольку tStringList манипулирует не с самими строками, а с указателями на них.) 3. Если вам необходим динамический одномерный массив чисел, то в общих словах я приведу его ниже, но есть масса мелких деталей. Объявите указатель на тип массива, имеющего максимальное количество элементов данного типа (помните о том, что Delphi-16 позволяет иметь типам область памяти, ограниченной 64K), например так:
type
bigArray: array[1..32000] of integer; {или ^double, или что-то еще}
pMyArray: ^bigArray;
затем распределите сам массив:
getMem (pMyArray, sizeof(integer) * n);
где n — количество элементов. После этого вы можете ссылаться на элементы массива следующим образом:
pMyArray^[51]
Не забудьте освободить массив с помощью FreeMem после того, как вы его использовали.
Изменить размер массива, определить новый указатель, перераспределить или обменяться с другим массивом можно так:
pTemp: ^bigArray;
getMem(pTemp, sizeof(integer) * newnumelements);
memcopy(pTemp, pMyArray, sizeof(integer)*n);
{n – количество элементов в pMyArray}
freeMem(pMyArray, sizeof(integer)*n);
pMyArray := pTemp;
4. Если вам необходим многомерный массив чисел, скомбинируйте технику, описанную в пункте (3), с функцией распределения, описанной в пункте (2).
5. Если для вашего массива необходим участок памяти больше чем 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] := {значение}
Если в вашем распоряжении находится «редкозаполненный» массив, использование хэш-таблицы дало бы существенный выигрыш. Я преобразую индексные значения в строки, а все остальное перепоручаю TStrings, но не из-за того, что я такой ленивый, а из-за того, что он сделает это лучше меня, мне нужно всего лишь осуществить преобразование в строки.
Для того, чтобы хранить все, что вы хотите, вы можете использовать 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;
В TList и TStringList вы можете иметь до 16380 элементов. А теперь обещанный пример того, как можно хранить в TList записи (или объекты), вернее, указатели на них:
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;
Igor Nikolaev aKa The Sprite
Пример массива констант (Array of Const) III
Delphi 1
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]);
В действительности, массив array of const более корректным было бы назвать массивом array of tvariant. Tvariant — множественный выбор типов переменной, в которой можно задать номер типа. В Visual Basic у него имеется наследник. Delphi также позволяет использовать имена.
Определите тип, например, так:
TYPE NAME1 = Array[1..4,1..10] of Integer;
Затем, в вашей секции CONST:
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;
Для того, чтобы убедиться, что все модули в секции «uses» установлены правильно, бросьте на форму один такой динамический компонент, и затем удалите его, или установите его видимость в False. Более сложный способ заключается в разработке собственного компонента, делающего описанное выше.
Массив TPOINT
Delphi 1
Const ptarr : Array[0..4] Of TPoint =((x:0; y:4), … (x:4; y:4));
Создание больших массивов
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]);
Для получения доступа к n-ному байту в пределах массива (n должен иметь тип longint):
bigArray[n shr 15]^[n and $7fff] := y;
x := bigArray[n shr 15]^[n and $7fff];
Это даже осуществляет проверку выхода за границы диапазона, если вы установили в ваших настройках опцию «range checking»!
n должен находиться в диапазоне [0..32*32*1024] = [0..1024*1024] = [0..1048576].
Для освобождения массива после его использования необходимо сделать следующее:
for i := 0 to high(bigarray) do dispose (bigArray[i]);
Свойства
Редактор свойств для точки
TPoint не имеет информацию о типе, следовательно, вы не можете зарегистрировать для него редактор свойства. Вы можете иметь редактор свойств только для строк, реальных, порядковых чисел или указателей на объекты. Дело в том, что редактор свойств имеет только следующие методы, чтобы иметь доступ к свойствам через RTTI: GetValue/SetValue для строк (strings) GetFloatValue/SetFloatValue для натуральных чисел (floats) GetOrdValue/SetOrdValue для порядковых (и указателей) Решением может быть создание класса TPersistentPoint, являющегося наследником TPersistent и имеющего те же свойства, что и TPoint. Вы можете просто «обернуть» TPoint для хранения значений, или создать явные поля. Непосредственное использование TPoint сделает использование метода Assign легким и быстрым для кодирования. Для процедур чтения и записи вы можете использовать поля записи, как показано ниже:type TPersistentPoint = class(TPersistent)
private
FPoint: TPoint;
published
property X : integer read FPoint.X write FPoint.X;
property Y : integer read FPoint.Y write FPoint.Y;
end;
– Mike Scott
Хитрость вызова редактора свойств
Я пишу редактор для свойства TStrings. В зависимости от значений других свойств, я хотел бы показывать или свой редактор свойства, или редактор свойства TStringListProperty, заданный по умолчанию, но я не знаю как передавать управление TStringListProperty...Сделайте ваш редактор свойства наследником TStringListProperty (добавьте STREDIT в список используемых модулей) и согласно вашим обстоятельствам вызывайте метод предка Edit:
Unit MyEditor;
interface
uses STREDIT;
type TMyStringListProperty = class(TStringListProperty)
procedure Edit; override;
end;
implementation
procedure TMyStringListProperty.Edit;
begin
if { какие-то условия } then { что-то делаем }
else inherited Edit;
end;
end.
- Pat Ritchey
Как убрать публичное свойство компонента/формы из списка видимых/редактируемых свойств в Инспекторе Обьектов?
Nomadic советует: Из TForm property не убиpал, но из TWinControl было дело. А дело было так:interface
type TMyComp = class(TWinControl)
…
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('MyPage', [TMyComp]);
RegisterPropertyEditor(TypeInfo(String),TMyComp,'Hint',nil);
end;
[ и т.д.]
Тепеpь property 'Hint' в Object Inspector не видно. Рад, если чем-то помог. Если будут глюки, умоляю сообщить. Такой подход у меня сплошь и pядом.
Свойство FileName в невизуальном компоненте
Следующий код взят из dsgnintf.pas (иногда стоит покопаться в файлах!) для свойства TMPLayer.filename, с помощью C.Calvert… В заголовке модуля компонента…TFileNameProperty = class(TStringProperty)
public
function getattributes: TPropertyattributes; override;
procedure Edit; override;
end;
добавьте функцию регистрации…
RegisterPropertyEditor(Typeinfo(String), TMyComponent, 'Filename', TFileNameProperty);
и код…
function TFileNameProperty.GetAttributes;
begin
Result := [paDialog];
end;
Procedure TFilenameProperty.edit;
var
MFileOpen: TOpenDialog;
begin
MFileOpen := TOpenDialog.Create(Application);
MFileOpen.Filename := GetValue;
MFileOpen.Filter := 'Правильный тип файлов|*.*'; (* Поместите здесь ваш собственный фильтр...*)
MFileOpen.Options := MFileOpen.Options + [ofPathMustExist,ofFileMustExist];
try
if MFileOpen.Execute then SetValue(MFileOpen.Filename);
finally
MFileOpen.Free;
end;
end;
Записи
Пример переменной записи
В Delphi 2.0 я пытаюсь прочесть текстовый файл и получаю проблему. Текстовый файл, который я хочу прочесть, имеет записи фиксированной длины, но в самих записях могут располагаться различные типы с различной длиной, и оканчиваться в различных позициях, в зависимости от типа. Файл выглядит примерно так: TFH.......<First record type, первый тип записи> TBH.......<Second record type, второй тип записи> TAB........<Third record type, третий тип записи> TAA........<Fourth record type, четвертый тип записи> Вы можете поймать больше одного зайца в случае объявления переменной записи, но если сделаете это правильно.Type
TDataTag = Array [1..3] of Char;
TDataTags = Array [0..NumOfTags-1] of TDataTag;
TDataRec = packed Record
tagfield: TDataTag;
case integer of
0: ( поля для тэга TFH );
1: ( поля для тэга TBH );
2: …
…
end;
TMultiRec = packed Record
Case Boolean of
false: (строка: Array [0..1024] of Char);
{ должно установать строку максимально возможной длины }
true : ( data: TDataRec );
End;
Const DataTags: TDataTags = ('TFH', 'TBH', …);
var rec: TMultirec;
ReadLn(datafile, rec.line);
Case IndexFromDataTag(rec.data.tagfield) Of
0: …
1: …
IndexFromDataTag должен искать передаваемый тэг поля в массиве DataTags. Определите все поля в TDataRec как Array [1..someUpperBound] of Char.
– Peter Below
Передача массива записей символов в Memo
Delphi 1Тема: Передача массива записей символов в Memo. Обработка больших строк в 16-битной версии Delphi задача далеко непростая. Особенно когда строки являются частью структуры записи и вы хотите передать их в TMemo. В данном совете показано как создать структуру записи размером 1000 символов, прочесть в нее содержимое Memo и затем записать ее обратно в Memo. Основной метод, который мы здесь используем — метод Memo GetTextBuf. Используемая структура записи представляет собой простую строку и массив из 1000 символов, но структура могла бы быть сложнее.
unit URcrdIO;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,Forms, Dialogs, StdCtrls,dbtables;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private { Private declarations }
public { Public declarations }
end;
type
TMyRec = record
MyArray: array [1..1000] of char;
mystr: string;
end;
var
Form1: TForm1;
MyRec : TMyRec;
mylist : TStringlist;
PMyChar : PChar;
myfile : file;
mb : TStream;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
assignfile(myfile, 'c:\testblob.txt');
rewrite(myfile,1);
fillchar(MyRec.MyArray,sizeof(MyRec.MyArray),#0);
pmychar:=@MyRec.MyArray;
StrPCopy(pmychar,memo1.text);
Blockwrite(MyFile,MyRec,SizeOf(MyRec));
closefile(MyFile);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
assignfile(myfile, 'c:\testblob.txt');
reset(myfile,1);
fillchar(MyRec.MyArray, sizeof(MyRec.MyArray),#0);
Blockread(MyFile, MyRec, SizeOf(MyRec));
pmychar:=@MyRec.MyArray;
Memo1.SetTextBuf(pmychar);
end;
end.
Освобождение записей
Delphi 1Для начала необходимо привести объект к нужному типу, например, так:
var
i: integer;
begin
…
for
i := 0 to MyList.Count - 1 do dispose(PMyRecord(MyList[i]));
MyList.Free;
end;
или
begin
for i := 0 to MyList.Count - 1 do dispose(PMyRecord(MyList.items[i]));
MyList.Free;
end;
Items — свойство по умолчанию, поэтому вам нет необходимости определять это, хотя обратное не помешает.
Теперь можно заняться созданием работоспособной и полезной функцией. В форме:
var p : ^mystruct;
begin
new(p);
…
dispose(p);
end;
операторы new() и dispose() в точности соответствуют процедурам getmem() и freemem(), за исключением того, что компилитор распределяет количество байт под размер структуры, на которую ссылается переменная-указатель. По этой причине указатель должен быть типизированным указателем, и следущий код неверен:
var
p: pointer;
begin
new(p);
end;
поскольку невозможно установить размер памяти, на которую должен ссылаться указатель. С другой стороны, если вы используете getmem() и freemem(), вы можете распределять байты для нетепизированного указателя, например:
var p : pointer;
begin
getmem(p, 32767);
…
freemem(p, 32767);
end;
Строки
StrTok для Delphi 2
Delphi 2Я передалал это для работы в Delphi 2.0, код приведен ниже (эта функция первоначально была написана John Cooper 76356,3601 и модифицирована мной для адаптации под Delphi 2.0). …вот этот код:
function StrTok(Phrase: Pchar; Delimeter: PChar): Pchar;
const
tokenPtr: PChar = nil;
workPtr: PChar = nil;
var
delimPtr: Pchar;
begin
if (Phrase <> nil) then workPtr := Phrase
else workPtr := tokenPtr;
if workPtr = nil then begin
Result := nil;
Exit;
end;
delimPtr := StrPos(workPtr, Delimeter);
if (delimPtr <> nil) then
begin
delimPtr^ := Chr(0);
tokenPtr := delimPtr + 1
end else tokenPtr := nil;
Result := workPtr;
end;
– Ralph Friedman
Как мне перекодировать строки из Win-кодировки в Dos-кодировку и наоборот?
Одной строкойКак мне перекодировать строки из Win-кодировки в Dos-кодировку и наоборот? Nomadic отвечает: A: CharToOEM, OEMToChar, CharToOEMBuff, OEMToCharBuff. Заметьте однако, что эти функции не умеют делать таких, например, вещей, как koi8-r в DOS и т. п.
Типы
У меня константы могут иметь значение, отличное от заданного. Как лечить?
Nomadic советует: DX.Bug: Const из другого unit'а дает неверное значение. Симптоматика –Unit Main;
Interface
Uses VData;
Const Wko=0.9;
…
Unit VData;
…Implementation
Uses Main;
Procedure ...;
Begin
{ вот здесь Wko=...E+230 - наверное, бесконечность }
End;
Похоже, это действительно bug, причем ОСОБО ОПАСНЫЙ, т.к. может исказить результаты расчетов, не вызвав заметных нарушений работы программы.
В общем так. Эксперимент показал, что любая вещественная константа, определенная в интерфейсе модуля, может быть неверно (и не обязательно очень неверно – например, вместо 0.7 может появиться 0.115) прочитана в другом модуле. Баг особенно опасен тем, что он неустойчив и может пропадать и возникать без видимых причин (например, возникнуть, если предыдущая компиляция была неудачной и исчезнуть после использования константы в модуле, где она определена).
Лечится (вpоде бы) указанием типа
const Wko: double = 0.9;
правда, теперь это уже не совсем константа…
Значение вычисляемого поля Paradox вместо 25.55 становится 24.5499999…
Delphi 1Значение вычисляемого поля вместо 25.55 у меня выводится как 24.5499999. Скажите, что я делаю неправильно? Вы не виноваты в ошибке калькуляции! Я обнаружил ту же проблему в пакете учета, который я сейчас создаю. Мне кажется, что Borland сам делает в своем коде некий перерасчет значений. Вы можете обойти проблему с помощью функции Round:
SalesIncVAT:=round(SalesIncVAT*100)/100; {дает вам два десятичных порядка}
ничего экстраординарного, это основное свойство математики плавающей точки, которая обеспечивает точность только в заданном интервале десятичных цифр. Точнее говоря, тип float точен для промежуточных целых чисел и для долей, которые представляют собой сумму компонентов в степени 2, любое другое число округляется исходя из переменной точности (7 цифр для «одинарной» точности, 15 для двойной и 20 для расширенной). Можно использовать процедуру Round или str:
var s : string;
begin
str(SalesIncVat:10:2,s); {10 символов для целой части (с точкой) и 2 десятичных цифры}
Label1.Caption:=s;
В справке написано, что функция FloatToStr преобразует число в строку с 15 десятичными цифрами – вот почему ваше число отображается столь причудливым образом, попробуйте эту функцию с числами типа 25.5, 25.25, 25.125 или подобными, которые имеют конечное представление в двоичной нотации, и эта проблема должна у вас исчезнуть.
Или используйте функцию FloatToStrF, которой в параметрах необходимо указать общую длину строки и количество десятичных цифр.
Классовые/статические/переменные общего доступа
Delphi 1Здесь кроется небольшая хитрость: получение эквивалентной функциональности с помощью классового метода. Просто объявите NodeCount как регулярную типизированную константу в секции implementation вашего файла.
type TNode = class
public
NodeCount: Integer = 0; {ЭТО НЕ ДОПУСКАЕТСЯ}
constructor Create;
Class Function GetNodeCount : word;
{другой необходимый код}
end;
implementation
const
NodeCount : word = 0;
TNode.Create;
begin
inherited Create;
Inc(NodeCount);
end;
Function TNode.GetNodeCount : word;
begin
result := NodeCount;
end;
Итак, теперь ваш код может выглядеть так, как вы хотели:
SampleNode := TNode.Create;
x := SampleNode.GetNodeCount;
следующая строка также корректна:
x := TNode.GetNodeCount;
Чем отличается тип String в Delphi 2 и выше от аналогичного в Delphi 1?
Nomadic советует: B D2 и выше на самом деле используется тип LongString вместо String, а старый тип тепеpь обзывается ShortString (о чем, кстати, написано в help). Из того же help можно узнать, что указатель LongString указывает на nullterminated string и потому возможно обычное приведение типа LongString к PChar (о чем я и написал), которое сводится просто к смене вывески. Там же можно узнать, что длина строки хранится в dword перед указателем. Есть также намек на то, что при присваивании другой строке информация не копируется, а увеличивается только счетчик ссылок. Более подробную информацию можно почерпнуть из system.pas:
type StrRec = record
allocSiz: Longint;
refCnt: Longint;
length: Longint;
end;
От себя добавлю:
Сама переменная LongString указывает на байт, непосредственно следующий за этой процедурой, там же находится собственно значение строки. Значение '' (пустая строка) представляется как указатель nil, кстати, поэтому сpавнение str='' это быстpая операция.
Теперь подробнее о счетчике ссылок. Я уже говорил, что при присваивании копирования не происходит, а только увеличивается счетчик. Когда он уменьшается? Ну, очевидно, когда в результате операции значение строки меняется, то для старого значения счетчик уменьшается. Это понятно. Более непонятно, когда освобождаются значения, на которые ссылаются поля некого класса. Это происходит в System. TObject.FreeInstance пpи вызове _FinalizeRecord, а информация берется из vtInitTable (кстати, здесь же очищаются Variant). Ещё более непонятно, когда освобождаются переменые String, которые описаны как локальные в пpоцедурах/функциях/методах. Здесь работает компилятор, которые вставляет эти неявные операции в код этой функции.
Тепеpь о типе PString. Hа самом деле переменные этого типа указывают на такие же значения, как и LongString, но для переменных этого типа для всех опеpаций по созданию/копиpованию/удалению нужно помнить об этих самых счетчиках ссылок. Иногда без этого типа не обойтись. Вот опеpации для этого типа (sysutils.pas):
{ String handling routines }
{ NewStr allocates a string on the heap. NewStr is provided for backwards compatibility only. }
function NewStr(const S: string): PString;
{ DisposeStr disposes a string pointer that was previously allocated using NewStr.DisposeStr is provided for backwards compatibility only. }
procedure DisposeStr(P: PString);
{ AssignStr assigns a new dynamically allocated string to the given string pointer.AssignStr is provided for backwards compatibility only. }
procedure AssignStr(var P: PString; const S: string);
Можно отметить, что явно задать использование long strings можно декларацией
var
sMyLongString: AnsiString; // long dinamically allocated string
sMyWideString: WideString; // wide string (UNICODE)
sMyShortString1: ShortString; // old-style string
sMyShortString2: String[255]; // old-style string, no more than 255 chars
Хотелось бы также предупредить наиболее частные ошибки при использовании длинных строк:
• Если Вы передаёте указатель PChar на буфер, взятый от длинной строки, в функцию, которая может изменить содержание буфера, то убедитесь, что на этот буфер указывает только одна строка. Это верно в случаях сложения строк, вызова UniqueString или SetLength и некоторых других;
• Если Вы используете длинные строки как аргументы или результаты для функций, располагающихся в DLL, то в DLL надо использовать модуль ShareMem;
• Не используйте длинные строки как члены структур типа record. Используйте там короткие строки или array[0..n] of char. Также нельзя использовать в структурах типа record динамические массивы. Данные ограничения отсутствуют для классов.
Различия TMEMOFIELD
Delphi 1Во-первых, если аргумент size у GetMem равен нулю, GetMem устанавливает указатель в nil (не отбрасывайте такой способ, но разумней самому установить его в nil). Также в отладчике вы могли бы проверять значение DataSize (или getTextLen) перед самим вызовом. (Проигнорируйте следующий параграф, если Table1Notes не Memo.) Во-вторых, если Table1Notes — Memo-поле, вы, вероятно, захотите использовать Table1Notes.getTextLen, не DataSize, поскольку DataSize возвращает размер сегмента буфера записи (0-254), тогда как getTextLen возвратит вам реальный размер Memo. (Для строкового поля DataSize работать будет, но очень странно, поскольку возвращает ноль.) Также вы можете воспользоваться getTextBuf вместо getData, не знаю точно почему, но мои многочисленные экспериметны показали, что getTextBuf работает правильно и устойчиво, а getData нет. Поскольку "wordwrapping" (перенос слов) доступен в вашем приложении, вы можете заменить символы #10 (перевод строки) и #13 (возврат каретки) на пробелы, например так:
cursor: pchar;
cursor := ваш буфер;
while cursor^ <> #0 do if (cursor^ = #13) or (cursor^ = #10) then cursor^ := ' ';
Данный способ прост, поскольку нам нет нужды перемещать текст из переменной в переменную, хотя и не без недостатка, поскольку в конце каждой строки мы получаем два пробела, что может неправильно интерпретироваться при переносе строк. В качестве альтернативы, вместо пробела вы можете применить другой служебный символ, который ваш текстовый процессор воспримет в качестве прерывания строки, или проигнорирует его (например, символ #8). Если вам нужно просто избавиться от символов перевода строки, воспользуйтесь двумя курсорами как показано ниже (извините, не тестировал):
out, in: pchar;
out := ваш буфер;
in := out;
while in^ <> #0 do begin
if (in^ <> #10) and (in^ <> #13) then begin
out^ := in^;
inc(out);
end;
inc(in);
end;
out^ := #0;
Если вместо этого вы хотите заменить каждую пару CR-LF или отдельный CR или LF единичным пробелом, попробуйте это:
out, inn: PChar;
out := ваш буфер;
inn := out;
while in^ <> #0 do begin
if (in^ = #10) then begin
end
else if (in^ = #13) then begin
if (in+1)^
Если вместо этого вы хотите заменить каждую пару CR-LF или отдельный CR или LF единичным пробелом, попробуйте это:
out, inn: PChar;
out := buf;
inn := out;
while inn^ <> #0 do begin
if (inn^ = #10) or ((inn^ = #13) and ((inn+1)^ <> #10)) then begin
out^ := ' ';
Inc(out);
end
else if (inn^ = #13) then
{ только CR, игнорируем }
else begin
out^ := inn^;
Inc(out);
end;
Inc(inn);
end;
out^ := #0;
{ буфер теперь закрыт }
Непроверенное: эффект уменьшения размера (путем установки терминатора #0) этого PChar позволит уменьшить время компиляции массивов и буферов GetMem, что же будет при использовании StrAlloc/StrDispose?
Вот конечный код после учета всех мелочей! Например, нам, в конечном счете, нужно сообщить указателю о необходимости возвратиться к началу своей новой строки.
procedure TForm1.RemoveSpaces(var InBuf: PChar; Size: Word);
var
Input, OutPut, Orig: PChar;
begin
GetMem(Output, Size);
input := Inbuf;
Orig := Output;
while input^ <> #0 do begin
if (input^ <> #10) and (input^ <> #13) then begin
output^ := input^;
inc(output);
end;
inc(input);
end;
Output^ := #0;
Output := Orig;
InBuf := Output;
end;
Я все еще немало удивлен тому как работает GetData! Я все еще не хочу использовать TMemo! Если кто-то может решить эту проблему, я буду очень рад! Пока же я готовлю для вас материал, включающий новые процедуры печати! Наведем порядок в беспорядке! Я уже имею реализацию вывода текста с любым шрифтом и в любой позиции, выраженной в дюймах, и это только начало! Но что я думаю действительно классно вышло, так это диманическая сетка! Вы можете создавать сетку с любым количеством строк и колонок. Назначьте текст и ячейку, установите горизонтальное и вертикальное выравнивание, выберите стиль границы для каждой ячейки и изучите множество других способов манипулирования и печати сетки!
Функция, возвращающая тип
Delphi 1Вы можете сделать это в C++. В ObjectPascal это также можно сделать, смотрите пример:
// функция Chameleon, возвращающая тип сгенерированного исключения
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls;
type
MyBoolean = class
public
Value : boolean;
end;
MyInteger = class
public
Value : integer;
end;
MyClass = class
public
Value : TStrings;
end;
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private { Private declarations }
public { Public declarations }
procedure MyProc;
function Chameleon : boolean;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function TForm1.Chameleon : boolean;
var
b : MyBoolean;
i : MyInteger;
c : MyClass;
r : integer;
begin
r := Random(3);
case r of
0 : begin
b := MyBoolean.Create;
raise b;
end;
1 : begin
i := MyInteger.Create;
raise i;
end;
2 : begin
c := MyClass.Create;
raise c;
end;
end;
end;
procedure TForm1.MyProc;
begin
try
Chameleon;
excepton MyBoolean do ShowMessage('Функция возвратила класс MyBoolean');
on MyInteger do ShowMessage('Функция возвратила класс MyInteger');
on MyClass do ShowMessage('Функция возвратила класс MyClass');
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Chameleon;
end;
end.
Взгляните на тип данных Variant в D2: следующий код
function AnyType(const TypeParm: integer): Variant;
begin
case TypeParm of
1: Result := 1;
2: Result := 2.0;
3: Result := 'Три';
4: Result := StrToDate('4/4/1944');
end;
end;
абсолютно бестолковый, но полностью корректный!
Следующий код содержит объявление трех функций, принимающих на входе один и тот же параметр, но выдающих результаты различных типов (результат физичиски один и тот же, и занимает он 4 байта). Я не думаю, что можно одурачить delphi, чтобы с помощью этого метода возвратить строку. Это может привести к разрушению менеджера кучи. Вместо этого вызывайте необходимую вам функцию. Каждый вызов передается MyFuncRetAnything, а P1 определяет возвращаемый тип. Если хотите, можете написать другую обертку, делающую для вас еще и приведение типов.
3 вызова, 1 код.
Я понимаю, что это в действительности не то, что нужно, по я просто хотел продемонстрировать другой способ. (вы можете возвращать строки как тип PChar, который также занимает 4 байта). Вы должны использовать некоторую память, распределяемую вызовом процедуры (может быть передавать результаты как P2?).
{моя форма имеет 3 метки, одну кнопку и этот код}
var
MyFuncRetInt : Function(P1, P2 : Integer) : Integer;
MyFuncRetBool : Function (P1, P2 : Integer) : LongBool;
MyFuncRetPointer : Function (P1, P2 : Integer) : Pointer;
function MyFuncRetAnything (P1, P2 : Integer) : Integer;
var
RetPointer : Pointer;
RetBool : LongBool;
RetInteger : Integer;
begin
RetPointer := nil;
RetBool := False;
RetInteger := 4711;
case P1 of
1 : Result := Integer (RetPointer);
2 : Result := Integer (RetBool);
3 : Result := RetInteger;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if MyFuncRetBool (2, 1900) then Label1.Caption := 'True'
else Label1.Caption := 'False';
Label2.Caption := IntToStr(MyFuncRetInt(3, 1900));
Label3.Caption := IntToHex(Integer(MyFuncRetPointer(1, 1900)), 16);
end;
initialization
MyFuncRetInt := @MyFuncRetAnything;
MyFuncRetBool := @MyFuncRetAnything;
MyFuncRetPointer := @MyFuncRetAnything;
end.
Преобразование формата MS BINARY в IEEE
Delphi 1«Использование, независимое от машинного уровня» не так просто в реализации с процессорами, выпущенными до Intel-го математического сопроцессора 80x87. Я не уверен в том, что процессоры 80x86 имели какие-либо родные инструкции для выполнения операций с плавающей точкой. По-видимости, поэтому Microsoft создал свой собственный формат для чисел с плавающей точкой; он сам осуществлял всю арифметику с помощью библиотеки времени выполнения. Сегодня 80x87 осуществляет такую арифметику автоматически, и IEEE теперь стандарт. Delphi хранит следующие типы чисел с плавающей точкой в формате IEEE:
Single | 4 байт |
Double | 8 байт |
Extended | 10 байт |
MKSMBF$(выражение-единичной-точности!)
MKDMBF$(выражение-двойной-точности#)
CVSMBF (4-байтовая-числовая-строка)
CVDMBF (8-байтовая-числовая-строка)
Функция | Возвращаемое значение |
---|---|
MKSMBF$ | 4-байтовая строка, содержащая число в формате Microsoft-Binary-format |
MKDMBF$ | 8-байтовая строка, содержащая число в формате Microsoft-Binary-format |
CVSMBF | Число единичной точности в формате IEEE |
CVDMBF | Число двойной точности в формате IEEE |
Переменные
Статические переменные
Delphi 1Да, это работает. Объявите переменную в секции const, например:
procedure p;
const MyVariable : Integer = 0;
begin
Inc(MyVariable);
end;
В нашем примере переменная MyVariable содержит количество вызовов P.
Тем не менее, это лучшее решение, чем использование взамен какого-либо поля объекта (если это возможно).
Разное
Переключение ключей компилятора
Быстрый и легкий путь вкл/выкл директив компилятора. Весь Borland pascal.
{$R+,L+} {Это директива компилятора плюс комментарий}
{{$R+,L+} {Эта строка – два комментария, похоже на картинку?}
Аналогично:
{$DEFINE DEVEL}
{$IFDEF DEVEL}
……
{$ELSEIF}
Переключение с «devel» компиляции на не-«devel» версию происходит простым прибавлением второй скобки в первой строке. Единственное нажатие клавиши позволит переключать вам ключи компилятора.
Также для скоростных манипулиций и кратковременных изменений отлично подойдут комментарии, расположенные за строкой:
if i=0 then inc(i); {выражение+комментарий}
ср.
{ if i=0 then inc(i); {закомментарена вся строка}
Сравните – два нажатия клавиш для установки фигурной скобки или десяток нажатий для установки (* *) до и после строки. Клавиша Del поможет вам вернуться в предыдущее состояние.
– P Gallagher
Получение ссылки на класс из объекта I
Мне необходимо получить ссылку на класс из объекта. Например, если у меня есть ссылка на объект (например, указатель на экземпляр TLabel), то мне необходимо получить ссылку на класс (например, ссылка на класс TLabel) для того, чтобы мне еще создать необходимое количество объектов данного класса. Другими словами, мне нужно дублировать экземпляры классов, создаваемые кем-то еще. Класс, о котором идет речь, в Delphi не зарегистрирован (его нет в палитре), поэтому GetClass('TLabel') не работает, даже если экземпляры класса существуют, работать с ними можно только через RTTI. Вдобавок к этому, у меня нет даже кода класса, поэтому работа через RTTI - единственный выход. Вот пример, который получает ссылку на класс и назначает значения новому классу того же типа. Имейте в виду, что вам необходимо сделать некоторое преобразование типов, чтобы с полученным типом класса можно было сделать что-либо полезное, поскольку возвращаемый класс имеет тип TClass.type TLabelClass = class of TLabel;
procedure TForm1.Button1Click(Sender: TObject);
var
Ref : TLabelClass;
New : TLabel;
begin
Ref := TLabelClass(Label1.ClassType);
New := Ref.Create(Self);
New.Parent := Self;
New.Caption := 'Фантастика!';
end;
Реплицирование класса может быть осуществлено одним из двух способов. Во-первых, вы можете воспользоваться методом Assign (который требует, чтобы ваши классы были наследниками TPersistent). Данный способ заключается в использовании метода Assign, работающего с TPersistentClass:
New.Assign(Label1);
Второй способ заключается в использовании автоматической поточности компонента (этот способ требует, чтобы ваши классы являлись наследниками TComponent, и чтобы они были зарегистрированы для потоковой системы).
В вашем вопросе вы исходили из неправильного предположения; классы могут регистрироваться потоковой системой И НЕ регистрироваться в Палитре Компонентов; обычно эти две вещи связаны, но не обязательно. Например, скажем, у вас имеется следующий класс:
TCustomer =class(TComponent)
private
FCompany: string;
FPhone : LongInt;
published
property Company: string read FCompany write FCompany;
property Phone: LongInt read FPhone write FPhone;
end;
Вы можете зарегистрировать класс для потоковой системы следующим образом:
RegisterClass(TCustomer);
который позволяет знать как осуществлять поточность для TCustomer, но не регистрирует его в Палитре Компонентов.
После регистрации классов, вы можете реплицировать их следующим образом:
procedure TForm1.Button1Click(Sender: TObject);
var
Ref: TComponentClass;
New: TComponent;
Stream: TMemoryStream;
begin
Ref := TComponentClass(Label1.ClassType);
New := Ref.Create(Self);
Stream := TMemoryStream.Create;
try
Stream.WriteComponent(Label1);
Stream.Position := 0;
Stream.ReadComponent(New);
finally
Stream.Free;
end;
end;
– Rick Rogers
Получение ссылки на класс из объекта II
Мне необходимо получить ссылку на класс из объекта…TObject.ClassType
var
ClassRef: TComponentClass;
NewComp: TComponent;
begin
TClass(ClassRef) := Sender.ClassType;
NewComp := ClassRef.Create(Self);
…
– Pat Ritchey
Работа с комментариями в большом куске кода
Delphi 1В Паскале существует 2 способа обозначить комментарии – {} и (* *). Вы можете вставлять один комментарий в другой (осуществлять вложенность). Следовательно, вставляя (* в начале вашего блока, и *) в конце, вы все еще можете работать с вложенными комментариями типа { }.
Базы данных
Калькуляция
Код определения возраста
Delphi 1Вызовите диалог редактирования полей (Fields Editor), дважды щелкнув на компоненте TTable или TQuery, расположенном на вашей форме (или выбрав в контекстном меню пункт Fields Editor). Добавьте все поля, с которыми вы хотите работать в форме (даже если вы хотите, чтобы они были невидимы, но вам необходим к ним доступ – для таких полей установите свойство visible в false). Затем щелкните на «Define…» (определить) для добавления вычисляемого поля. Введите имя вычисляемого поля, отличающееся от имен других полей таблицы, выберите тип (вероятно, StringField) и задайте длину (20 будет в самый раз). Убедитесь в том, что напротив поля 'calculated' стоит галочка. Затем создайте для вашего объекта TTable или TQuery обработчик события 'OnCalcFields'. В этом обработчике вы берете значения реальных полей таблицы, делаете вычисления, и помещаете результаты в объект вычисляемого поля, который вы только что создали. После этого значение выводится в TDBGrid, или в элементе управления TDBText, если вы решили использовать форму вместо табличной сетки. Наша функция должна достичь цели, обрабатывая значения лет и месяцев. Поскольку не все месяцы имеют одно и то же количество дней, я просто брал среднее число, поэтому результат может быть не очень точен, но большинство людей это удовлетворяет:
function AgeStr(aDate: TDateTime): string;
var
DaysOld: Double;
Years, Months: Integer;
begin
DaysOld:= Date – aDate;
Years:= Trunc(DaysOld / 365.25);
DaysOld:= DaysOld – (365.25 * Years);
Months:= Trunc(DaysOld / 30.41);
Result:= Format('%d лет, %d месяцев',[Years, Months]);
end;
В моем случае метод OnCalcFields выглядит так:
procedure TEntryForm.TableNameOrderCalcFields(DataSet: TDataset);
begin
TableNameOrderAge.AsString := AgeStr(TableNameOrderDateOfBirth.AsDateTime);
end;
Как пересчитать все вычисляемые поля (Calculated fields) без переоткрытия TDataSet?
Одной строкойNomadic отвечает:
Resync([rmExact, rmCenter]);
Как создать вычисляемые поля во время исполнения программы (Calculated fields at RunTime)?
Nomadic отвечает: Смотрите книгу "Developing Custom Delphi Components" от Рэя Конопки. Здесь немного исправленный пример из этой книги
function TMyClass.CreateCalcField(const AFieldName: string; AFieldClass: TFieldClass; ASize: Word): TField;
begin
Result := FDataSet.FindField( AFieldName ); // Field may already exists!
if Result<>nil then Exit;
if AFieldClass = nil then
begin
DBErrorFmt( SUnknownFieldType, [AFieldName] );
end;
Result := FieldClass.Create( Owner );
with Result do
try
FieldName := AFieldName;
if (Result is TStringField) or (Result is TBCDField) or (Result is TBlobField) or (Result is TBytesField) or (Result is TVarBytesField) then
begin
Size := ASize;
end;
Calculated := True;
DataSet := FDataset;
Name := FDataSet.Name + AFieldName;
except
Free; // We must release allocated memory on error!
raise;
end;
end;
Доступ
Хитрости многопользовательского доступа к БД
Вот некоторые хитрости, могущие помочь в разработке баз многопользовательского доступа: В модуле DBIPROCS Delphi 1.0 и в BDE.INT 2.0 существует классная функция с именем DBISETLOCKRETRY(n). Синтаксис – DBISetLockRetry(n), где n – количество секунд ожидания перед повторной попыткой вставки, редактирования или другой операцией с таблицей. DBISetLockRetry(-1) будет бесконечно пытаться получить доступ к вашей таблице. Хорошее место для вызова функции – обработчик события TableAfterOpen. В этом случае все, что вам нужно сделать, это:DBISetLockRetry(x);
Если вы используете Delphi 1.0, не забудьте включить в вашу программу DBIProcs. В Delphi 2.0 включите BDE.
Мой заказчик и я разработали многопользовательскую базу данных по вашему рецепту, до этого наши пользователи получали сообщения «File is Locked» (файл заблокирован), «Table is Busy» (таблица занята), «Record Locked» (запись заблокирована) и др. Мы также пробовали Session.Netdir, но он не помог нам. Поскольку мы добавили в код эту строку, никаких блокировок не было. Частота обращений пользователей к базе достаточно велика (80 kpm). Мы разработали «измеритель скорости доступа» с 2 открытыми сессиями на двух компьютерах в сети Novell 4.1. Две сессии занимались вставкой, две другие редактированием, а мы сами занимались посылкой данных с частотой около 65 записей в минуту в течение операций редактирования и 85 в течение вставки. Сеть чуть не захлебнулась от такой работы. Утилизация файлового сервера была до нас около 60%. Не плохо для всего! Я думаю Borland необходимо задокументировать такой подход, чтобы другие не становились хакерами типа нас! :)Эти требования обязательны при разработке многопользовательских приложений Delphi с использованием файлов Dbase или Paradox. – Ted Bulmanski
Выполнение запросов к базе данных в фоне
Delphi 2Тема: Выполнение запросов к базе данных в фоновом потоке Данный документ объясняет как выполнить запрос в фоновом режиме, используя класс TThread. Для получения общей информации о классе TThread, пожалуйста обратитесь к документации Borland и электронной справке. Для понимания данного документа вам необходимо иметь представление о том, как работать с компонентами для работы с базами данных, поставляемых в комплекте с Delphi 2.0. Для осуществления потокового запроса необходимо выполнение двух требований. Во-первых, потоковый запрос должен находиться в своей собственной сессии с использованием отдельного компонента TSession. Следовательно, на вашей форме должен находиться компонент TSession, имя которого должно быть назначено свойству SessonName компонента TQuery, используемого для выполнения потокового запроса. Для каждого используемого в потоке компонента TQuery вы должны использовать отдельный компонент TSession. При использовании компонента TDataBase, для отдельного потокового запроса должен также использоваться отдельный TDataBase. Второе требование заключается в том, что компонент TQuery, используемый в потоке, не должен подключаться в контексте это потока к TDataSource. Это должно быть сделано в контексте первичного потока. Приведенный ниже пример кода иллюстрирует описываемый процесс. Данный модуль демонстрирует форму, которая содержит по два экземпляра следующих компонентов: TSession, TDatabase, TQuery, TDataSource и TDBGrid. Данные компоненты имеют следующие значения свойств:
Session1
Active True;
SessionName "Ses1"
DataBase1
AliasName "IBLOCAL"
DatabaseName "DB1"
SessionName "Ses1"
Query1
DataBaseName "DB1"
SessionName "Ses1"
SQL.Strings "Select * from employee"
DataSource1
DataSet ""
DBGrid1
DataSource DataSource1
Session2
Active True;
SessionName "Ses2"
DataBase2
AliasName "IBLOCAL"
DatabaseName "DB2"
SessionName "Ses2"
Query2
DataBaseName "DB2"
SessionName "Ses2"
SQL.Strings "Select * from customer"
DataSource2
DataSet ""
DBGrid1
DataSource DataSource2
Обратите внимание на то, что свойство DataSet обоих компонентов TDataSource первоначально никуда не ссылается. Оно устанавливается во время выполнения приложения, и это проиллюстрировано в коде.
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls,Forms, Dialogs,StdCtrls, Grids, DBGrids, DB, DBTables;
type
TForm1 = class(TForm)
Session1: TSession;
Session2: TSession;
Database1: TDatabase;
Database2: TDatabase;
Query1: TQuery;
Query2: TQuery;
DataSource1: TDataSource;
DataSource2: TDataSource;
DBGrid1: TDBGrid;
DBGrid2: TDBGrid;
GoBtn1: TButton;
procedure GoBtn1Click(Sender: TObject);
end;
TQueryThread = class(TThread)
private
FSession: TSession;
FDatabase: TDataBase;
FQuery: TQuery;
FDatasource: TDatasource;
FQueryException: Exception;
procedure ConnectDataSource;
procedure ShowQryError;
protected
procedure Execute; override;
public
constructor Create(Session: TSession; DataBase: TDatabase; Query: TQuery; DataSource: TDataSource); virtual;
end;
var Form1: TForm1;
implementation
constructor TQueryThread.Create(Session: TSession; DataBase: TDatabase; Query: TQuery; Datasource: TDataSource);
begin
inherited Create(True); // Создаем поток c состоянием suspendend
FSession := Session; // подключаем все privat-поля
FDatabase := DataBase;
FQuery := Query;
FDataSource := Datasource;
FreeOnTerminate := True; // Устанавливаем флаг освобождения потока после его завершения
Resume; // Продолжение выполнения потока
end;
procedure TQueryThread.Execute;
begin
try
{ Выполняем запрос и подключаем источник данных к компоненту TQuery, вызывая ConnectDataSource из основного потока(для этой цели используем Synchronize)}
FQuery.Open;
Synchronize(ConnectDataSource);
except
{ Ловим исключение (если оно происходит) и его дескриптор в контексте основного потока (для этой цели используемSynchronize). }
FQueryException := ExceptObject as Exception;
Synchronize(ShowQryError);
end;
end;
procedure TQueryThread.ConnectDataSource;
begin
FDataSource.DataSet := FQuery; // Подключаем DataSource к TQuery
end;
procedure TQueryThread.ShowQryError;
begin
Application.ShowException(FQueryException); // Обрабатываем исключение
end;
procedure RunBackgroundQuery(Session: TSession; DataBase: TDataBase; Query: TQuery; DataSource: TDataSource);
begin
{ Создаем экземпляр TThread с различными параметрами. }
TQueryThread.Create(Session, Database, Query, DataSource);
end;
{$R *.DFM}
procedure TForm1.GoBtn1Click(Sender: TObject);
begin
{ Запускаем два отдельных запроса, каждый в своем потоке }
RunBackgroundQuery(Session1, DataBase1, Query1, Datasource1);
RunBackgroundQuery(Session2, DataBase2, Query2, Datasource2);
end;
end.
Метод TForm1.GoBtn1Click является обработчиком события нажатия кнопки. Данный обработчик события дважды вызывает процедуру RunBackgroundQuery, это случается при каждой передаче новых параметров компонентам для работы с базой данных. RunBackgroundQuery создает отдельный экземпляр класса TQueryThread, передает различные компоненты для работы с базой данных в его конструктор, который, в свою очередь, назначает их закрытым полям TQueryThread.
TQueryThread содержит две определенные пользователем процедуры: ConnectDataSource и ShowQryError. ConnectDataSource связывает FDataSource.DataSet с FQuery. Тем не менее, это делается в первичном потоке с помощью метода TThread.Synchronize. ShowQryError обрабатывает исключение в контексте первиного потока, также используя метод Synchronize. Конструктор Create и метод Execute снабжены подробными комментариями.
Получение физического пути к таблице
Delphi 2Тема: Получение физического пути к таблице Отправлено: Август 13, 1996 Автор: Xavier Pacheco Если ссылка на таблицу получена через псевдоним, получить физический путь к ней не так просто. Для получения этого пути необходимо использовать функцию BDE DbiGetDatabaseDesc. Данной функции в качестве параметров передаются имя псевдонима и указатель на структуру DBDesc. Структура DBDesc будет заполнена информацией, относящейся к этому псевдониму. Определение структуры:
pDBDesc = ^DBDesc;
DBDesc = packed record 2{ Описание данной базы данных }
szName : DBINAME; { Логическое имя (или псевдоним) }
szText : DBINAME; { Описательный текст }
szPhyName : DBIPATH; { Физическое имя/путь }
szDbType : DBINAME; { Тип базы данных }
end;
Физическое имя/путь будет содержаться в поле szPhyName структуры DBDesc.
Возможные значения, возвращаемые функцией DBIGetDatbaseDesc:
DBIERR_NONE Описание базы данных для pszName было успешно извлечено. DBIERR_OBJNOTFOUND База данных, указанная в pszName, не была обнаружена.
Приведенный ниже пример кода показывает как можно получить физический путь для компонента TTable, использующего псевдоним DBDemos:
var
vDBDesc: DBDesc;
DirTable: String;
begin
Check(DbiGetDatabaseDesc(PChar(Table1.DatabaseName), @vDBDesc));
DirTable := Format('%s\%s', [vDBDesc.szPhyName, Table1.TableName]);
ShowMessage(DirTable);
end;
Cancel в связанных таблицах
Delphi 1В книге 'Delphi unleashed' на странице 520 автор написал: '…, вы можете делать откат все время до тех пор, пока прямо или косвенно не сделаете постинг данных.' Моя проблема дважды возникала в случае ExTable.Edit в различных процедурах. Код был примерно таким:
Procedure1 …
begin
ExTable.Edit;
ExTable.FieldByName('…').asstring := …;
…
end;
procedure2 …
begin
ExTable.Edit;
…
end;
Процедура CancelSpdBtnClick была вызвана после этих двух процедур. Действительно, прежде, чем делать откат, постинг был косвенно вызван между двумя вызовами ExTable.Edit. Теперь после такой модификации все работает как часы.
Отображение формы ввода в БД CUSTOMER из рабочей формы ORDER
Delphi 1В моем проекте имеется подобная функция, определяющая количество элементов: В обработчике события OnClick я создаю форму ввода данных и вывожу ее командой .ShowModal. Затем я проверяю результат .ModalResult – и, если он равен mrOk, я передаю запись, в противном случае делаю отмену. Я поместил имя модуля с формой ввода данных в список используемых модулей главной формы. Вот базовая схема моего кода:
procedure TFrmItemNav.BtnChangeLocClick(Sender: TObject);
{var DlgItemLoc: TDlgItemLoc;}
begin
DlgItemLoc := TDlgItemLoc.Create(FrmItemNav);
DlgItemLoc.ShowModal;
if DlgItemLoc.ModalResult = mrOk then
{делаем все, что необходимо для постинга данных}
else
{очищаем и делаем Cancel};
DlgItemLoc.Free;
end;
Отображение определенных полей БД
Delphi 1Вот что можно сделать во время выполнения программы:
Table1.FieldByName(RemovedFieldName).Visible := False;
или
Table1.Field[removedFieldNumber-1].Visible := false;
Из базы данных в переменные
Delphi 1Примерно так вы можете программным путем извлечь содержимое поля:
aValue := TMyTable.FieldByName('SomeField').AsText;
или
aValue := TMyTable.FieldByName('SomeField').AsInteger;
или
aValue := TMyTable.Fields[1].AsFloat;
В действительности здесь вы получаете объект TField от объекта TTable (или TQuery), и затем вызываете соответствующий метод объекта TField для получения самих данных. Вы можете также изменить значение самого поля, но только в случае, если объект TTable находится в режиме вставки (Insert) или редактирования (Edit). Члены AsFloat, AsInteger, AsDateTime и AsString в действительности являются свойствами, и как таковые также могут принимать значения. С помощью Редактора Полей (Fields Editor, для вызова которого достаточно дважды щелкнуть на объекте TTable или TQuery) также возможно создание объектов-полей. Эти объекты могут быть использованы вместо получения их каждый раз от объекта TTable или TQuery.
Получение информации о таблице
Вам нужно воспользоваться свойством FieldDefs. В следующем примере список полей и их соответствующий размер передается компоненту TMemo (расположенному на форме) с именем Memo1:procedure TForm1.ShowFields;
var
i : Word;
begin
Memo1.Lines.Clear;Table1.FieldDefs.Update; { должно быть вызвано, если Table1 не активна }
for i:= 0 to Table1.FieldDefs.Count - 1 do With Table1.FieldDefs.Items[i] do Memo1.Lines.Add(Name + ' - ' + IntToStr(Size));
Memo1.Lines.Add(Name + ' – ' + IntToStr(Size));
end;
Если вам просто нужны имена полей (FieldNames), то используйте метод TTable GetFieldNames:
GetIndexNames для получения имен индексов:
var FldNames, IdxNames : TStringList
begin
FldNames := TStringList.Create;
IdxNames := TStringList.Create;
If Table1.State = dsInactive then Table1.Open;
Table1.GetFieldNames(FldNames);
Table1.GetIndexNames(IdxNames);
{…… используем полученную информацию ……}
FldNames.Free; {освобождаем stringlist}
IdxNames.Free;
end;
Для получения информации об определенном поле вы должны использовать FieldDef.
Обмен данными между TMemoField и TMemo
Delphi 1
Procedure TMemoToTMemoField;
begin
TMemoField.Assign(TMemo.Lines);
end;
Procedure TMemoFieldToTMemo;
VAR aBlobStream : TBlobStream;
begin
aBlobStream := TBlobStream.Create(TMemoField, bmRead);
TMemo.Lines.LoadFromStream(aBlobStream);
aBlobStream.Free;
end;
Если в транзакции изменена какая-то таблица, то для другого пользователя блокируется вся таблица, до окончания транзакции. Как лечить?
Nomadic отвечает: По умолчанию, оператор UPDATE в MS SQL Server пытается поставить эксклюзивную табличную блокировку. Вы можете обойти это, используя ключевое слово FROM в сочетании с опцией PAGLOCK для использования MS SQL Server страничных блокировок вместо эксклюзивной табличной блокировки:UPDATE orders SET customer_id=NULL FROM orders(PAGLOCK) WHERE customer_id=32;
Блокиpовка на всю таблицу пpи UPDATE ставится только в том случае, если по предикату нет индекса. Так, можно просто проиндексировать таблицу orders по полю customer_id, и не забывать делать UPDATE STATISTIC, хотя будет работать и с PAGLOCK. Просто не факт, что UPDATE всегда делает табличную блокировку.
Форма Мастер-Деталь
Delphi 1…это нормально в двух случаях: 1. Эксперт баз данных по умолчанию создает запрос, где RequestLive установлен в False; если вы хотите что-либо изменить, установите RequestLive в True. 2. При отношениях «один к многим», из-за правил сохранения целостности, вам дозволяется делать изменения только на форме «многих», а не на форме «один». BTW: правильно, что вы об этом задумались. Предположим, что вы имеете отношение «один к многим», где «один» — ваши клиенты, а «многие» — их счета-фактуры: естественно, счетов, относящихся к клиенту, может быть больше, чем один. Если ваша система позволяет редактировать информацию о клиентах, например, удалять записи, то вскоре вы можете обнаружить, что некоторые счета не будут иметь отношения к кому бы то ни было.
Подскажите как правильно показать на экpане и сохранить в базе картинку формата JPEG?
Nomadic отвечает: Я делал так (это кусок компонента):if Picture.Graphic is TJPegImage then
begin
bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
Picture.Graphic.SaveToStream(bs);
bs.Free;
end
else if Picture.Graphic is TBitmap then
begin
Jpg:=TJPegImage.Create;
Jpg.CompressionQuality:=…;
Jpg.PixelFormat:=…;
Jpg.Assign(Picture.Graphic);
Jpg.JPEGNeeded;
bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
Jpg.SaveToStream(bs);
bs.Free;
Jpg.Free;
end else Field.Clear;
Как исключить показ поля P_RECNO?
Delphi 1Вы можете сделать: 1. отредактируйте TTable для исключения P_RECNO или 2. установите
TableX.FieldbyName('P_RECNO').Visible := False;
Это можно сделать также и с помощью редактора полей (Fields Editor), который связан не с DBGrid, а напрямую с компонентом Table. Для вызова редактора щелкните правой кнопкой мыши на компоненте Table и выберите самый верхний пункт контекстного меню. Добавьте все поля в список полей и выделите то поле, которое вы не хотите показывать в DBgrid. Найдите в Инспекторе Объектов свойство Visible, и установите его в False.
//
Если у вас имеется компонент TTable, дважды щелкните на иконке компонента (расположенной на форме), и вы получите в диалоге список полей, имеющих отношение к соответствующей таблице щелкните на одном из полей и проверьте в Инспекторе Объектов свойство Visible, оно должно быть установлено в False.
//
Информация из одной таблицы и набора данных на двух формах
1. Добавьте на вторую форму (form2) компонент TTable 2. В режиме разработки присвойте этой таблице такие же значения, как и у таблицы, расположенной на form1 3. В секции IMPLEMENTATION у form2 создайте следующий фрагмент кода:unit form2;
interface
{…}
implementation
uses form1;
{…}
4. Подключите процедуру к OnCreate-событию в form2 (через Инспектор Объектов)
5. Добавьте к этой процедуре следующую строку:
table1 := form1.table1;
В режиме разработки свяжите все компоненты с table1, расположенным на form1.
Остается только решить проблему синхронизации. Попробуйте следующее:
- На Form1
разместите Table1
разместите DataSource1
установите DataSource1.DataSet := Table1
разместите DataGrid
установите DataSource := DataSource1
Ну это все просто и стандартно. Поехали дальше:
- На Form2
разместите DataSource1 (#1 для этой формы)
разместите любые другие необходимые вам БД-компоненты;
укажите у них в качестве источника данных DataSource1
В обработчике события OnCreate для этой формы (например, FormCreate), поместите следующий код:
With Form1 do
begin
Form2.DataSource1.DataSet := Table1;
end;
Данный код подключает Table1 на Form1 к DataSource от Form2.
После таких действий данные будут отображены на Form2 и будут «синхронизированы» с данными, отображаемыми на Form1 (поскольку в действительности используется одна таблица).
Единственное здесь предостережение – если вы используете TDatabase, так как это может быть не то, что вы хотите. Компонент TDatabase не обязателен для получения доступа к базам данных, но, тем не менее, он обеспечивает вас дополнительным контролем в приложениях класса клиент/сервер.
Таким образом, если приложение не работает в среде клиент/сервер, нет необходимости использовать TDatabase. Все, что вам нужно – TDataSource, TTable и компоненты для работы с базами данных.
Как при вводе информации в БД автоматически вставлять SEQUENCE?
Nomadic отвечает: Если добавление через оператор INSERT ( в TQuery), то прямо там пишешь, как в плюсе («… Values (My_seq.nextval, …»). Если добавление идет через TQuery c RequestLive=true, то в BeforeInsert сделай запрос через TQuery (select myseq.nextval from dual) и заноси значение в свое поле.Помещение переменной в Memo-поле
Delphi 1Если я правильно понял ваш вопрос, вам нужно сделать приблизительно так (для ПОЛУЧЕНИЯ данных):
Memos := TStringList.Create;
Memos.Assign(Table1Memo);
yourvariable_0 := Memos[0];
yourvariable_1 := Memos[1];
……………………
yourvariable_n := Memos[n];
Memos.Free;
или так (для УСТАНОВКИ данных):
Memos := TStringList.Create;
Memos.Add(yourvariable_0);
Memos.Add(yourvariable_1);
……………………
Memos.Add(yourvariable_n);
Table1Memo.Assign(Memos);
Memos.Free;
Индикатор прогресса выполнения запроса
Delphi 1Невозможно. Идея заключалась в том, чтобы с помощью объекта TQuery выполнять запросы, SQL сервер их в фоне обрабатывал бы, а мы смотрели бы на это дело на локальной машине с помощью линейки прогресса. Но из приложения никоим образом нельзя узнать, что делает TQuery, так что линейка прогресса, по идее, должна была бы получать текущую позицию непосредственно с SQL сервера. Но, поскольку большинство SQL серверов не публикуют такой информации, эту идею можно торжественно схоронить… Если вы используете Paradox или DBase, то, я думаю, для этой цели вы можете воспользоваться функцией DBIRegisterCallback:
Использование: Обратные вызовы (Callbacks) используются в случае, когда клиентскому приложению необходимо получить (возвратить) информацию о ходе выполнения операции. Функция DBIRegisterCallback позволяет клиенту зарегистрировать обратную связь с BDE, после чего BDE может извещать клиента о наступлении событий.Лично я никогда этим не пользовался, поэтому на смогу поделиться деталями.Из руководства пользователя DBE
Обновление данных БД из модальной формы
Delphi 1Возможно следующий код позволит вам использовать ту же самую таблицу и источник данных в модальной форме, что и в вашей главной форме. Попробуйте изменить код модальной формы следующим образом:
unit myModalF;
interface
{…}
implementation
{…}
uses
MainForm; {Имя файла родительской формы для вашей модальной формы}
MyModalForm.OnCreate(Sender: TObject);
begin
DBGrid1.DataSource := MyMainForm.DataSource1;
end;
Как записать в BLOB-поле большой текст (>255 байт) из Delphi?
Nomadic отвечает: Можно так –var
S: TBlobStream;
B: pointer;
c: integer;
…
Table1.Edit;
S := TBlobStream.Create(Table1BlobField as TBlobField, bmWrite); {кажется, так}
C := S.Write(B, C);
Table1.Post;
S.Destroy;
или так –
var
S: TMemoryStream;
B: pointer;
C: integer;
…
S := TMemoryStream.Create;
…
Table1.Edit;
S.Clear;
S.SetSize(C);
C := S.Write(B,C);
(Table1BlobField as TBlobField).LoadFromStream(S);
S.Clear;
Table1.Post;
…
S.Destroy;
Блокировка таблицы
…когда вы получаете эту, или аналогичную ошибку, вы можете прервать процесс следующим образом (в предположении, что вы пытаетесь запостить запись):try
Table1.Post;
except
MessageDlg ('Ошибка постинга записи', прочее…
Table1.Cancel;
end;
В противном случае вы не получите ошибку в случае, если текущую запись «рассматривает» другой пользователь (если вы пользуетесь базой данных Paradox, поставляемой с Delphi), если, конечно, вы правильно это установили. Paradox сам создает в сетевом каталоге файл с именем pdxusers.lck, видимый всеми пользователями, так что каждый BDE на каждой локальной машине может запирать запись, таким образом запрещая другим пользователям постить запись до снятия блокировки. Я не знаю, каким образом вы получаете эту ошибку, поэтому существует вероятность того, что я ошибаюсь в своих предположениях.
Каким драйвером пользуется TDATABASE?
Delphi 1Вы можете использовать вызов IDAPI dbiGetDatabaseDesc. Вот быстрая справка (не забудьте добавить DB в список используемых модулей):
var
pDatabase: DBDrsc:
begin
{ pAlias – PChar, содержащий имя псевдонима}
dbiGetDatabaseDesc(pAlias, @pDatabase);
Для получения дополнительной информации обратитесь к описанию свойства pDatabase.szDbType.
Как создать новый запрос и скопировать туда точно такие же описания полей?
Nomadic отвечает: Копируешь FieldDefs. Проходишь циклом по FieldDefs.Items[i].CreateField(Owner);Запись потока в BLOB-поле
Delphi 1Вся хитрость заключается в использовании StrPcopy (помещения вашей строки в PChar) и записи буфера в поток. Вы не сможете передать это в PChar непосредственно, поскольку ему нужен буфер, поэтому для получения необходимого размера буфера используйте <BufferName>[0] и StrLen(). Вот пример использования TMemoryStream и записи его в Blob-поле:
var
cString: String;
oMemory: TMemoryStream;
Buffer: PChar;
begin
cString := 'Ну, допустим, хочу эту строку!';
{ СОздаем новый поток памяти }
oMemory := TMemoryStream.Create;
{!! Копируем строку в PChar }
StrPCopy(Buffer, cString);
{ Пишем =буфер= и его размер в поток }
oMemory.Write(Buffer[0], StrLen(Buffer));
{Записываем это в поле}
<Blob/Memo/GraphicFieldName>.LoadFromStream(oMemory);
{ Необходимо освободить ресурсы}
oMemory.Free;
end;
Как я могу выбрать на клиента только часть данных с определенной позиции из набора данных на сервере?
Nomadic отвечает: Наиболее приемлемым является использование TQuery и Provider.SetParams. Но также Вы можете сделать это иначе: Сперва на клиенте Вам нужно считать с сервера только метаданные для набора данных. Это можно сделать, установив PacketRecords в 0, и затем вызвав Open. Затем Вы должны вызвать метод сервера (Вы должны определить этот метод на сервере), который спозиционирует курсор на первую нужную запись. И, наконец, установите PacketRecords в нужное значение, большее нуля, и вызовите GetNextPacket.Отследить изменение данных?
Предположим, что пользователь изменил строковое поле в Null. Как тогда я в обработчике OnUpdateData смогу определить, изменилось ли это поле на строку Null, или поле просто не было изменено? Nomadic отвечает: Используйте свойство NewValue класса TField при чтении второй записи (той, которая содержит изменения). Если возвращаемое значение (variant) пусто или не назначено, тогда поле не было модифицировано. Здесь немного иллюстрирующего кода:var NewVal: Variant;
begin
NewVal := DataSet.FieldByName('MyStrField').NewValue;
if VarIsEmpty(NewVal) then ShowMessage('Field was not edited')
else if VarIsNull(NewVal) then ShowMessage('Field was blanked out')
else ShowMessage('New Field Value: ' + String(NewVal));
end;
Если Вы взглянете на исходники формы RecError (в репозитории), то Вы увидите, как она использует эту информацию для вывода строки ' ' при показе ошибок синхронизации данных. На сервере Вы добавляете ограничения уровня записи, используя свойство Constraints Вашего TQuery/TTable или ограничения уровня поля, используя постоянные обьекты TField (с помощью FieldsEditor либо на CustomConstraint, либо ImportedConstraint). Если Вы используете ограничения уровня поля, они вступают в силу, когда данныеотправляются в поле (например, когда Вы уходите из органа управления, связанного с этим полем (типа TDBEdit)).
Как достучаться до методов сервера приложений из TClientDataSet?
Nomadic отвечает: Вот так:RemoteServer.AppServer.MyMethod
AppServer – свойство только для чтения, возвращающее интерфейс удаленного сервера, возвращаемый провайдером сервера приложений. Клиентские приложения могут общаться напрямую с сервером приложений через этот интерфейс.
Я включил dbclient.dll в секцию `additional files` опций распространения по web, но этот файл никогда не загружается на клиента. Как это исправить?
Nomadic отвечает: Ваш INF-файл должен включать в себя строки наподобие:[Add.Code]
dbclient.dll=dbclient.dll
[dbclient.dll]
file=http://yoursite.com/dbclient.cab
clsid={9E8D2F81-591C-11D0-BF52-0020AF32BD64}
RegisterServer=yes
FileVersion=4,0,0,36
Замените «yoursite» Вашим HTTP-адресом, где находится cab-файл. FileVersion – это версия файла в Вашем cab-файле (проверьте информацию о версии DBCLIENT, чтобы быть уверенным в соответствии). Убедитесь, что FileVersion относится к версии Вашего DBCLIENT.DLL. Вы можете положить dbclient.dll в cab-файл, используя утилиту CABARC, которую Вы найдете в папке delphi\bin. Примерная команда вызова CABARC может выглядеть примерно так:
CABARC N DBCLIENT.CAB DBCLIENT.DLL
Как можно использовать TClientDataSet в локальном приложении с таблицами Paradox, без использования компонент TProvider и TRemoteServer?
Nomadic отвечает: Вы не сможете отделаться от Провайдера (хотя бросать его на форму/модуль данных не придется), но Вы сможете использовать TClientDataSet в одно-точечном (single-tier) приложении. Для того, чтобы открыть client dataset, Вы должны назначить Провайдера Данных вручную.{ CDS = TClientDataSet }
{ Table1 = TTable }
CDS.Provider := Table1.Provider;
CDS.Open;
Также Вы должны включить модуль BDEProv в предложение uses.
Hе получается открыть таблицу, созданную в InterBase с DEFAULT CHARACTER SET WIN1251. Оно говорит, что `WIN1251 undefined`
Nomadic отвечает: A: (AA): Ставьте Interbase в каталог с путем, соответствующим DOS-овским соглашениям об именах (8+3).Создание
Функции редактора полей во время выполнения программы
Возможен ли вызов функций редактора полей (Fields Editor) во время выполнения программы? Да. Если вы определили поля во время разработки приложения, то во время выполнения можно менять их свойства (например, Size). Например, следующий код изменяет каждый размер поля TField.Size так, чтобы соответствовать фактическому размеру поля открываемого набора данных:procedure SetupFieldsAndOpenDataset(DataSet: TDataSet);
var FieldNum, DefNum: Integer;
begin
with DataSet do
begin
if Active then Close;
FieldDefs.Update;
{набор данных должен быть закрыт}
{ищем каждое предопределенное TField в DataSet.FieldDefs:}
for FieldNum := FieldCount - 1 downto 0 do with Fields[FieldNum] do
begin
DefNum := FieldDefs.IndexOf(FieldName);
if DefNum < 0 then raise Exception.CreateFmt('Поле "%s" не найдено в наборе данных "%s"',[FieldName, Dataset.Name]);
{устанавливаем свойство size:}
Size := FieldDefs[DefNum].Size;
end;
Open;
end;
end;
– Lindsay Reichmann
Производная TIntegerField
Я думал о производной, новом варианте компонента TIntegerfield, но я не могу понять как мне его получить во время разработки, ведь он не устанавливается в палитру компонентов. Это то, что вы хотите. Создайте следующий молуль: MICRON.PAS:
unit micron;
interface
uses DB, DBTables, Classes;
type
TMicronField = class(TIntegerField)
public
function IsValidChar(Ch: Char): Boolean; override;
end;
procedure Register;
implementation
function TMicronField.IsValidChar(Ch: Char): Boolean;
begin
Result := Ch in ['+', '-', '0'..'9','.'];
end;
procedure Register;
begin
RegisterFields([TMicronField]);
end;
end.
Поместите данный модуль в ваш каталог lib и добавьте это поле, используя диалог установки компонент. Затем, используя «DataSet designer», свяжите TMicronField с нужными вам полями, после чего вы увидите, что список типов полей включает теперь «Micron». (для отображения полей на новый тип поля, сначала вам необходимо удалить все TIntegerFields).
Другое решение, более простое (но так-же работающее), заключается в изменении исходного кода DBTables и простой замене существующей функции IsValidChar на TIntegerField.
– Mark Edington
Создание новой таблицы на основе структуры другой таблицы
Delphi 1На ум сразу приходит операция присваивания значения свойству (стоящему с левой стороны от ':='), при которой Delphi в своих недрах вызывает метод 'write' и передает ему в виде единственного параметра все то, что находится в правой части выражения. Если свойство не имеет метода write, оно предназначено только для чтения. Вот определение свойства FieldDefs объекта TDataSet в файле DB.PAS:
property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs
Как вы можете видеть, у него есть метод write. Следовательно, код:
Destination.FieldDefs := Source.FieldDefs;
в действительности делает такую операцию:
Destination.SetFieldDefs(Source.FieldDefs);
(за исключением того, что вы не можете использовать эту строку, поскольку SetFieldDefs определен в секции Private.)
Вот определение свойства IndexDefs объекта TTable в файле DBTABLES.PAS file:
property IndexDefs: TIndexDefs read FIndexDefs;
В этом случае метод write отсутствует, поэтому свойство имеет атрибут только для чтения. Тем не менее, для самого объекта TIndexDefs существует метод Assign. Следовательно, следующий код должен работать:
Source.IndexDefs.Update;
Destination.IndexDefs.Assign(Source.IndexDefs);
Перед вызовом Assign для Source.IndexDefs вызывайте метод Update, чтобы быть уверенным в том, что вы получите то, что хотите.
Метод SetFieldDefs является процедурой с одной строкой кода, в которой вызывается метод FieldDefs Assign.
Также можно проверить, определен ли реально индекс, и, если нет, то при вызове IndexDefs.Assign вы можете получить исключение типа «List Index Out Of Bounds» (или что-то типа этого). Например, так:
if Source.IndexDefs.Count > 0 then…
Вам нужно будет это сделать, поскольку метод TIndexDefs.Assign не проверяет это перед копированием индекс-информации. Также вам нет необходимости вызывать Clear до работы с IndexDefs, поскольку метод Assign сделает это и без вашего участия.
Создание уникального ID для новой записи
Delphi 1Существует несколько способов задавать в таблице уникальный ID. 1. Вы можете использовать поле с автоприращением Этот метод не очень надежен. Если ваша таблица каким-то образом испортится, и вам понадобиться ее пересобрать, автоинкрементальные поля будут перенумерованы. Хотя это легкий способ для ситуации, когда вы не ссылаетесь на id таблицы в других таблицах, но это не очень мудрое решение в других случаях.
2. Вы можете использовать ID-таблицу Если у вас имеется приложение, где нескольким таблицам необходимы уникальные ID, создайте ID-таблицу с двумя полями: Table Name A (первичный ключ) Last Id NВ методе BeforePost таблицы, которой необходим уникальный ID, делайте примерно так:
TableBeforePost(Sender: TObject)
var Id: Integer;
begin
with TTable(Sender) do
begin
{проверяем, существует ли ID для этой записи}
if Field[0].AsInteger=0 then
begin
{ищем имя таблицы в ID-Таблице}
IDTable.FindKey[Name]
{извлекаем последний Id – подразумеваем блокировку записи}
Id := IDTable.FieldByName['Last Id'].AsInteger;
Inc(Id);
{записываем новый Id в ID-таблицу – подразумеваем разблокировку таблицы}
IDTable.FieldByName['Last Id'].AsInteger := Id;
IDTable.Post;
{записываем извлеченный ID в вашу таблицу}
Field[0].AsInteger := Id;
end;
end;
end;
end;
Если вы поместите этот код в обработчик события таблицы BeforePost, вы убедитесь в том, что все ID будут последовательными (без «дырок»). Недостаток: если пользовать во время попытки добавления новой записи вдруг передумает, вы будете иметь запись с заполненным только полем ID.
В случае, если вы решили воспользоваться данным способом (последовательные ID), поместите приведенный выше код в обработчик события таблицы OnNewRecord.
3. Вы можете использовать ID-файл
Используйте те же принципы, что и в предыдущем способе, но вместо ID-таблицы используется ID-Файл. Это дает преимущество за счет более высокой скорости работы, но в многопользовательской среде вы должны сами заботиться о блокировке записей.
Динамическое создание таблицы и полей во время выполнения программы
Delphi в режиме разработки позволяет быстро добавлять и настраивать в вашем проекте компоненты для работы с базами данных, но есть ситуации, когда вам нужно создавать и конфигурировать объекты во время выполнения программы. Например, во время выполнения программы вам может понадобиться добавить колонку с вычисляемым полем (используя алгоритмы пользователя). Поэтому вопрос: как, не используя среды разработки, Инспектора Объектов и редактора TFields, создавать и сконфигурировать TField и другие компоненты для связки данных? Вследующем примере показано динамическое создание TTable, таблицы базы данных в связке с TTable, TFieldDefs, TFields, вычисляемых полей и подключение обработчика для события OnCalc. Для начала выберите пункт New Application меню File. Будет создан новый проект с пустой формой, на которой мы и будет создавать на лету наши компоненты. В секцию interface вашего модуля формы добавьте, как показано ниже, объявление обработчика события OnCalcFields и поля TaxAmount. Позже мы создадим TTable и назначим этот обработчик событию TTable OnCalcFields, который позволит при чтении каждой записи вызывать событие OnCalcFields, которое, в свою очередь, выполнит нашу процедуру TaxAmountCalc.
type TForm1 = class(TForm)
procedure TaxAmountCalc(DataSet: TDataset);
private
TaxAmount: TFloatField;
end;
В секции implementation создайте обработчик события OnCalc как показано ниже:
procedure TForm1.TaxAmountCalc(DataSet: TDataset);
begin
Dataset['TaxAmount'] := Dataset['ItemsTotal'] * (Dataset['TaxRate'] / 100);
end;
Создайте обработчик формы OnCreate как показано ниже (для получения дополнительной информации о создании обработчиков событий обратитесь к Delphi Users Guide, Chapter 4 «Working With Code»).
procedure TForm1.FormCreate(Sender: TObject);
var
MyTable: TTable;
MyDataSource: TDataSource;
MyGrid: TDBGrid;
begin
{ Создаем компонент TTable -- связанная таблица базы данных будет создана ниже. }
MyTable := TTable.Create(Self);
with MyTable do
begin
{ Определяем основную базу данных и таблицу. Примечание: Test.DB пока не существует. }
DatabaseName := 'DBDemos';
TableName := 'Test.DB';
{ Назначаем TaxAmountCalc обработчиком события, чтобы использовать его при наступлении события OnCalcFields в MyTable. }
OnCalcFields := TaxAmountCalc;
{ Создаем и добавляем определения полей к массиву TTableFieldDefs, затем создаем TField с использованием информации из определения поля. }
with FieldDefs do
begin
Add('ItemsTotal', ftCurrency, 0, false);
FieldDefs[0].CreateField(MyTable);
Add('TaxRate', ftFloat, 0, false);
FieldDefs[1].CreateField(MyTable);
TFloatField(Fields[1]).DisplayFormat := '##.0%';
{ Создаем вычисляемое TField, назначаем свойства, и добавляем поле к массиву определений MyTable. }
TaxAmount := TFloatField.Create(MyTable);
with TaxAmount do
begin
FieldName := 'TaxAmount';
Calculated := True;
Currency := True;
DataSet := MyTable;
Name := MyTable.Name + FieldName;
MyTable.FieldDefs.Add(Name, ftFloat, 0, false);
end;
end;
{ Создаем в базе данных новую таблицу, используя в качестве основы MyTable. }
MyTable.CreateTable;
end;
{ Создаем компонент TDataSourceи назначаем его MyTable. }
MyDataSource := TDataSource.Create(Self);
MyDataSource.DataSet := MyTable;
{ Создаем табличную сетку, отображаемна форме, и назначаем MyDataSource дляполучения доступа к данным из MyTable. }
MyGrid := TDBGrid.Create(Self);
with MyGrid do
begin
Parent := Self;
Align := alClient;
DataSource := MyDataSource;
end;
{ Запускаем нашу конструкцию! }
MyTable.Active := True;
Caption := 'Новая таблица ' + MyTable.TableName;
end;
Ниже приведен полный исходный код проекта:
unit gridcalc;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,Forms, Dialogs, Grids, DBGrids, ExtCtrls, DBCtrls, DB,DBTables, StdCtrls;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure TaxAmountCalc(DataSet: TDataset);
private
TaxAmount: TFloatField;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.TaxAmountCalc(DataSet: TDataset);
begin
Dataset['TaxAmount'] := Dataset['ItemsTotal'] *(Dataset['TaxRate'] / 100);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
MyTable: TTable;
MyDataSource: TDataSource;
MyGrid: TDBGrid;
begin
MyTable := TTable.Create(Self);
with MyTable do
begin
DatabaseName := 'DBDemos';
TableName := 'Test.DB';
OnCalcFields := TaxAmountCalc;
with FieldDefs do
begin
Add('ItemsTotal', ftCurrency, 0, false);
FieldDefs[0].CreateField(MyTable);
Add('TaxRate', ftFloat, 0, false);
FieldDefs[1].CreateField(MyTable);
TFloatField(Fields[1]).DisplayFormat := '##.0%';
TaxAmount := TFloatField.Create(MyTable);
with TaxAmount do
begin
FieldName := 'TaxAmount';
Calculated := True;
Currency := True;
DataSet := MyTable;
Name := MyTable.Name + FieldName;
MyTable.FieldDefs.Add(Name, ftFloat, 0, false);
end;
end;
MyTable.CreateTable;
end;
MyDataSource := TDataSource.Create(Self);
MyDataSource.DataSet := MyTable;
MyGrid := TDBGrid.Create(Self);
with MyGrid do
begin
Parent := Self;
Align := alClient;
DataSource := MyDataSource;
end;
MyTable.Active := True;
Caption := 'Новая таблица ' + MyTable.TableName;
end;
end.
Проблема с AddIndex
Delphi 1Я использую таблицу paradox на своей локальной машине. Я использую следующие команды:
Table.DatabaseName := 'ABC';
Table.TableName := 'TEST';
Table.CreateTable;
Table.AddIndex('Primary','ID',[ixPrimary]); (работает как часы)
Table.AddIndex('Number_IDX','NUMBER',[ixUnique]); (здесь я получаю ошибку времени выполнения)
ID – LongInt поле
NUMBER – поле типа char[15]
Как создать БД в кодировке CP1251?
Nomadic отвечает: Вот такая конструкция проходит на DB2 2.1.2/NT и UDB5/NT…CREATE DATABASE Efes2
USING CODESET 1251 TERRITORY RU
COLLATE USING IDENTITY;
Таблицы в памяти
Delphi 1Вот пример InMemoryTable. Свободен для использования, модификации и всего остального. Ну и как в отношении других вещей: я не даю никаких гарантий. Я не несу никакой ответственности за ущерб, который может причинить код. Позвольте, я повторю это: ВНИМАНИЕ! ДАННЫЙ КОД НЕ ПРЕДУСМАТРИВАЕТ НИКАКИХ ГАРАНТИЙ! ИСПОЛЬЗУЙТЕ ЕГО НА СВОЙ СТРАХ И РИСК - ВЫ ЕДИНСТВЕННЫЙ ЧЕЛОВЕК, ОТВЕТСТВЕННЫЙ ЗА ЛЮБОЙ УЩЕРБ, КОТОРЫЙ МОЖЕТ ПОВЛЕЧЬ ЗА СОБОЙ ИСПОЛЬЗОВАНИЕ ДАННОГО КОДА — Я ВАС ПРЕДУПРЕДИЛ! Благодарю Steve Garland <72700.2407@compuserve.com> за предоставленную помощь. Он создал свой собственный "in-memory" табличный компонент, который послужил мне толчком для написания сего кода. InMemory-таблицы являются характеристикой Borland Database Engine (BDE). InMemory-таблицы создаются в RAM и удаляются при их закрытии. Работают они значительно быстрее и очень полезны в случае, если вам нужны быстрые операции в небольших таблицах. Данный пример использует вызов функции BDE DbiCreateInMemoryTable. Данный объект должен работать наподобии простой регулярной таблицы, за исключением того, что InMemory-таблицы не поддерживают некоторые характеристики (типа проверка целостности, вторичные индексы и BLOB-поля), и в настоящее время данный код не содержит механизма обработки ошибок. Вероятно, вы получите ошибку при попытке создания memo-поля. Если у вас есть любые замечания, шлите их по адресу grisha@mira.com.
unit Inmem;
interface
uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils;
type TInMemoryTable = class(TTable)
private
hCursor: hDBICur;
procedure EncodeFieldDesc(var FieldDesc: FLDDesc; const Name: string; DataType: TFieldType; Size: Word);
function CreateHandle: HDBICur; override;
public
procedure CreateTable;
end;
implementation
{ Эта функция виртуальная, так что я смог перекрыть ее. В оригинальном VCL-коде для TTable эта функция реально открывает таблицу, но, поскольку мы уже имеем дескриптор таблицы, то мы просто возвращаем его }
function TInMemoryTable.CreateHandle;
begin
Result := hCursor;
end;
{ Эта функция получена ее простым копированием из исходного кода VCL. Я должен был это сделать, поскольку это было объявлено в секции private компонента TTable, поэтому отсюда у меня не было к этому досупа. }
procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc; const Name: string; DataType: TFieldType; Size: Word);
const
TypeMap: array[TFieldType] of Byte = (fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
begin
with FieldDesc do
begin
AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
iFldType := TypeMap[DataType];
case DataType of
ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:
iUnits1 := Size;
ftBCD:
begin
iUnits1 := 32;
iUnits2 := Size;
end;
end;
case DataType of
ftCurrency: iSubType := fldstMONEY;
ftBlob: iSubType := fldstBINARY;
ftMemo: iSubType := fldstMEMO;
ftGraphic: iSubType := fldstGRAPHIC;
end;
end;
end;
{ Вот кухня, где все это происходит. Я скопировал эту функцию из исходников VCL и затем изменил ее для использования DbiCreateInMemoryTable вместо DbiCreateTable. Поскольку InMemory-таблицы не поддерживают индексы, я удалил весь соответствующий код. }
procedure TInMemoryTable.CreateTable;
var
I: Integer;
pFieldDesc: pFLDDesc;
szTblName: DBITBLNAME;
iFields: Word;
Dogs: pfldDesc;
begin
CheckInactive;
if FieldDefs.Count = 0 then for I := 0 to FieldCount - 1 do with Fields[I] do if not Calculated then FieldDefs.Add(FieldName, DataType, Size, Required);
pFieldDesc := nil;
SetDBFlag(dbfTable, True);
try
AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
iFields := FieldDefs.Count;
pFieldDesc := AllocMem(iFields * SizeOf(FLDDesc));
for I := 0 to FieldDefs.Count - 1 do with FieldDefs[I] do
begin
EncodeFieldDesc(PFieldDescList(pFieldDesc)^[I], Name,DataType, Size);
end;
{ тип драйвера nil, т.к. поля логические }
Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc, nil, nil, pFieldDesc));
{ здесь hCursor получает свое значение }
Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc, hCursor));
finally
if pFieldDesc <> nil then FreeMem(pFieldDesc, iFields * SizeOf(FLDDesc));
SetDBFlag(dbfTable, False);
end;
end;
end.
{Данный код взят из файлов помощи Ллойда!}
Поиск
FindKey для нескольких полей
Delphi 1
with Table1 do
begin
SetKey;
FieldByName('State').AsString := 'CA';
FieldByName('City').AsString := 'Scotts Valley';
GotoKey;
end;
Вы не можете использовать Findkey с файлами DBase более чем для одного поля.
oEmetb.indexName:='PrimaryKey';
if oEmeTb.findkey([prCLient,prDiv,prEme]) then
где findkey передаются параметры для Primary Keyfields.
Я обращаю ваше внимание на то, что имя индекса (Index) чувствительно к регистру, так что будьте внимательны.
Вы можете также воспользоваться oEmeTb.indexfieldnames, но убедитесь в том, что ваш список ключевых полей в точности соответствуют ключевым полям, которые вы ищете.
oEmetb.indexfieldNames:='EmeClient;EmeDiv;EmeNo';
if oEmeTb.findkey([123,'a',96]) then
Поиск существующей записи перед тем, как она будет вставлена
Если вы находитесь в режиме редактирования (Edit) или вставки (Insert), то при изменении режима вы автоматически делаете постинг записи. И, естественно, при наличие дубликата (неуникальности) записи, вы получите ошибку. Способ обойти это – использовать другой компонент TTable, связанный с той же таблицей, и осуществляющий по ней поиск. Этот путь самый простой и эффективный. Воспользуйтесь двумя компонентами TTable (оба должны указывать на одну и ту же таблицу). Используйте один для поиска, а второй для редактирования. Ваша «ключевая» таблица BDE будет автоматически генерировать исключения, если пользователь будет пытаться послать созданный им дублирующий ключ. Для установки таблицы используйте Database Desktop. Создайте на основе поля первичный индекс (Primary Index). Затем создайте какой-то обработчик DB-исключения для нашего «нарушения уникальности». Моя технология заключается в следующем: в отдельной форме я предлагаю пользователям ввести часть записи, которая должна быть уникальна (обычно одно поле). Затем для проверки существования я делал FindKey. Если он находился, через MessageDlg я информировал пользователя, и возвращал его на форму редактирования, не создавая новой записи. Помните, что если FindKey ничего не находит, dbCursor никуда не перемещается, и закладка не нужна. Если запись найдена, она немедленно будет отображена на форме редактирования для того, чтобы пользователь смог увидеть ее содержимое. В противном случае происходит следующее:Table.Append;
Table.FieldByName('KeyField').AsString := UserEntry;
{ … позволяем пользователю редактировать все остальные поля записи … }
{ в это время кнопка Cancel должна быть активной для того, чтобы дать возможность пользователю отменить ввод новой записи. }
В моей форме редактирования поле с уникальном ключем выключается (disabled) и показывается с другим цветом. Целостность соблюдена :-).
Поиск фраз и записей переменной длины
Delphi 1Для текста переменной длины вы можете использовать DBmemo. Большинство людей это делают сканированием «на лету» (когда оператор постит запрос), но для реального ускорения процесса можно попробовать способ пре-сканирования, который делают «большие мальчики» (операторы больших баз данных): 1. при внесении в базу данных новой записи она сканируется на предмет определения ключевых слов (это может быть как предопределенный список ключевых слов, так и всех слов, не встречающиеся в стоп-листе [пример: «the», «of», «and"]) 2. ключевые слова вносятся в список ключевых слов со ссылкой на номер записи, например, «hang»,46 или «PC»,22. 3. когда пользователь делает запрос, мы извлекаем все записи, где встречается каждое из ключевых слов, например, «hang» может возвратить номера записей 11, 46 и 22, тогда как «PC» — записи с номерами 91, 22 и 15. 4. затем мы объединяем числа из всех списков c помощью какого-либо логического оператора, например, результатом приведенного выше примера может быть запись под номером 22 (в случае логического оператора AND), или записи 11, 15, 22, 46 и 91 (в случае оператора OR). Затем извлекайте и выводите эти записи. 5. для синонимов определите таблицу синонимов (например, «hang»,"kaput»), и также производите поиск синонимов, добавляя их к тому же списку как и оригинальное слово. 6. слова, имеющие общие окончания (например, «hang» и «hanged»), можно также сделать синонимами, или, как это делает большинство систем, производить анализ окончаний слов, вычисляя корень по их перекрытию (например, слову «hang» соответствует любое слово, чьи первые 4 буквы равны «hang»). Конечно, есть множестно технических деталей, которые необходимо учесть, например, организация списков, их эффективное управление и объединение. Оптимизация этой характеристики может вам дать очень быстрое время поиска (примером удачный реализаций могут служить двигатели поиска Nexus, Lycos или WebCrawler, обрабатывающие сотни тысяч записей в течение секунды).
dBase
Текущий номер записи набора данных
Delphi 1
{Извлекает физический номер записи xBase. Требует наличие модулей DBITYPES, DBIPROCS, и DBIERRS в списке используемых модулей. Функция требует на входе один аргументтипа TTable (например, Table1).}
function Form1.Recno(oTable: TTable): Longint;
var
rError: DBIResult;
rRecProp: RECprops;
szErrMsg: DBIMSG;
begin
Result := 0;
try
oTable.UpdateCursorPos;
rError := DbiGetRecord(oTable.Handle, dbiNOLOCK, nil, @rRecProp);
if rError = DBIERR_NONE then Result := rRecProp.iPhyRecNum
else case rError of
DBIERR_BOF: Result := 1;
DBIERR_EOF: Result := oTable.RecordCount + 1;
else
begin
DbiGetErrorString(rError, szErrMsg);
ShowMessage(StrPas(szErrMsg));
end;
end;
excepton
E: EDBEngineError do ShowMessage(E.Message);
end;
end;
Как открыть индексированную таблицу dBase, если отсутствует файл индекса?
Nomadic советует: Для dBase-таблицы встроенными средствами ты не перестроишь индекс, если его нет. Для этой цели мне пришлось написать процедуру для физического удаления признака индексации в самом dbf-файле и после её применения добавлять индексы заново. Для этого в заголовок файла dbf по смещению 28(dec) записываешь 0. По другому никак не выходит(я долго бился) — вот для Paradox таблиц все Ok. С помощью BDE Callbacks. Пример для Delphi 2.0, на первом не проверял: === Callback.pas ===unit Callback;
interface
uses BDE, Classes, Forms, DB, DBTables;
type
TForm1 = class(TForm)
Table1: TTable;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
CBack: TBDECallback; // опpеделение BDE CallBack
CBBuf: CBInputDesc; // пpосто буфеp
function CBFunc(CBInfo: Pointer): CBRType; // Callback-функция
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Session.Open; // В это вpемя сессия ещё не откpыта
CBack := TBDECallback.Create(Session {Hапpимеp}, nil, cbINPUTREQ, @CBRegBuf, SizeOf(CBBuf), CBFunc, False); // Опpеделили Callback
Table1.Open;
//^^^^^^^^^^^ - здесь возможна ошибка с индексом, etc.
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
CBack.Free; // Освобождаем CallBack
end;
function TForm1.CBFunc(CBInfo: Pointer): CBRType;
begin
with PCBInputDesc(CBInfo)^ do case eCbInputId of
cbiMDXMissing {, cbiDBTMissing - можно ещё и очищать BLOB-поля}:
begin
iSelection := 3; // Hомеp ваpианта ответа (1-й - откpыть только
// для чтения, 2-й - не откpывать, 3-й - отсоединить индекс).
// Возможный источник непpиятностей: а вдpуг в последующих веpсиях
// BDE номеpа будут дpугими?
Result := cbrCHKINPUT; // Обpабатывать введённый ответ
end;
end;
end;
end.
=== Callback.pas ===
PS: конечно, это лишь пример, делающий минимум необходимого. В рамках данного письма невозможно дать какое-то описание BDE Callbacks. Информацию я взял из BDE32.HLP, BDE.INT и DB.PAS. В VCL.HLP совсем ничего нет по этому поводу.
Вообще, руки бы оторвал тем, кто писал справку по Дельфям: я неделю мучался с сабжем, пока случайно не набрёл на Callbacks.
Определение удаления записей в .DBF
Delphi 1Взято из "Dtopics Database 1.10 from 3K computer Consultancy": Dbase в BDE имеет большее количество ситуаций 'особого случая', чем таблицы SQL и Paradox, поскольку данный формат поддерживает выражения в индексах и прочие характеристики, например: 1. Создание и пересоздание индекса
– DbiRegenIndexes( Table1.Handle ); { Регенерация всех индексов }
– создание индекса (зависит от того, существует ли выражение или нет)
if ((Pos('(',cTagExp) + Pos('+',cTagExp)) > 0) then Table1.AddIndex(cTagName, cTagExp, [ixExpression]) ( <– ixexpression – _литерал_)
else Table1.AddIndex(cTagName, cTagExp, []);
2. Связки Master/Detail в выражениях дочерних индексов
– вызов процедуры BDE DbiLinkDetailToExp() вместо обычной DbiLinkDetail()
3. Пакование таблиц
with Table1 do StrPCopy(TName, TableName);
Result := DBIPackTable(DbHandle, Handle, TName, szDBASE, TRUE);
4. Задание видимости удаленных записей – вкл/выкл (например, dBase SET DELETED ON/OFF)
DbiSetProp( hDBIObj(Table1.Handle), curSOFTDELETEON, LongInt(bValue));
5. Задание частичного/полного соответствия символов – вкл/выкл (например, dBase SET EXACT ON/OFF)
DbiSetProp( hDBIObj(Table1.Handle), curINEXACTON, LongInt(bValue));
<– Конец –>
Ну и теперь сами вопросы:
<– Начало –>
«Как мне увидеть записи dBASE, помеченные для удаления?»В обработчике события AfterOpen вызовите приведенную ниже функцию. Включите DBITYPES, DBIERRS, DBIPROCS в список используемых модулей. Для вызова функции передайте ей в качестве аргумента имя TTable и TRUE/FALSE в зависимости от необходимости показа/скрытия удаленных записей. Пример:
procedure TForm1.Table1AfterOpen(DataSet: TDataset);
begin
SetDelete(Table1, TRUE);
end;
procedure SetDelete(oTable:TTable; Value: Boolean);
var
rslt: DBIResult;
szErrMsg: DBIMSG;
begin
try
Table.DisableControls;
try
rslt := DbiSetProp(hDBIObj(oTable.Handle), curSOFTDELETEON,LongInt(Value));
if rslt <> DBIERR_NONE then
begin
DbiGetErrorString(rslt, szErrMsg);
raise Exception.Create(StrPas(szErrMsg));
end;
excepton E: EDBEngineError do ShowMessage(E.Message);
on E: Exception do ShowMessage(E.Message);
end;
finally
Table.Refresh;
Table.EnableControls;
end;
end;
«Могу ли я создать в табличной сетке колонку, в которой будут показываться записи, помеченные для удаления из таблицы dBASE?»
Создайте вычисляемое поле, затем в обработчике события таблицы OnCalcField замените его таким образом:
procedure TForm1.Table1CalcFields(DataSet: TDataset);
var
RCProps : RecProps;
Result : DBIResult;
begin
Result := DbiGetRecord(Table1.Handle, dbiNo
Рукописи не горят…
Определение номера записи в таблице dBASE
Таблицы dBASE применяют довольно статическую систему нумерации записей. Номер записи для данной записи (извините за тавтологию) отражает физическую позицию в табличном файле. Эти номера записей не изменяются вследствие фильтрации, упорядочивания данных или сортировки. К примеру, первая запись, хранящаяся в .DBF файле, будет иметь номер записи 1. Возможно, после некоторого упорядочивания индекса, запись будет последней из 100 записей. В этом случае запись должна оставаться с тем же номером, а не номером 100, отражающим новую позицию в сортированном наборе данных. Это противоречит таблицам Paradox, где соблюдается последовательная нумерация. Последовательная нумерация Paradox похожа на нумерацию записей dBASE, за исключением большей гибкости и отражению в номере записи ее текущей позиции в наборе данных. То есть, запись может не всегда иметь номер, установленный для нее фильтром набора данных, уменьшившим общее число записей, или при активном индексе, из-за чего может измениться отображаемый порядок записи. В приложениях для работы с базами данных, созданных с помощью Delphi и Borland Database Engine (BDE), DB-компонентами не предусмотрено извлечение и определение записи таблицы dBASE. Такая операция, тем не менее, возможна с помощью вызова из вашего приложения функций BDE. Существует несколько функций BDE, возвращающих информацию о текущей записи dBASE, например, ее номер. На самом деле, любая функция, заполняющая структуру BDE pRECProps, вполне достаточна. Например, функции BDE DbiGetRecord, DbiGetNextRecord и DbiGetPriorRecord. Естественно, только первая из них реально позволяет получить информацию о текущей записи. Две других перемещают при вводе указатель на запись, подобно методам Next и Prior компонентов TTable и TQuery. Структура pRECProps состоит из следующих полей: iSeqNum: тип LongInt; определяет текущий номер записи (относительно набора данных, включая фильтрацию и сортировку индекса); используется, если тип таблицы поддерживает последовательную нумерацию (только Paradox). iPhyRecNum: тип LongInt; определяет номер записи; используется, если тип таблицы поддерживает физические номера записи (только dBASE). bRecChanged: тип Boolean; в настоящее время не используется. bSeqNumChanged: тип Boolean; в настоящее время не используется. bDeleteFlag: тип Boolean; указывает на удаленную запись; используется, если тип таблицы поддерживает "мягкое" удаление (только dBASE). Одна из этих BDE-функций может быть вызвана из вашего приложения для заполнения данной структуры, из которой затем может быть извлечен физический номер записи. Ниже - пример использования для этой цели функции DbiGetRecord.function RecNo(ATable: TTable): LongInt;
var
R: RECProps;
rslt: DbiResult;
Error: array [0..255] of Char;
begin
ATable.UpdateCursorPos;
rslt := DbiGetRecord(ATable.Handle, dbiNoLock, nil, @R);
if rslt = DBIERR_NONE then Result := R.iPhyRecNum
else begin
DbiGetErrorString(rslt, Error);
ShowMessage(StrPas(Error));
Result := -1;
end;
end;
Для вызова любой BDE-функции из приложения Delphi, модули-обертки BDE DbiTypes, DbiErrs и DbiProcs должны быть включены в секцию Uses модуля, из которого они будут вызываться (секция Uses здесь не показана). Для того, чтобы сделать функции более транспортабельными, они не имеют прямой ссылки на компонент TTable, но указатель на TTable передается как параметр. Если эта функция используется в модуле, который не ссылается на модули Delphi DB и DBTables, они должны быть добавлены, иначе ссылки на компонент TTable будут недействительными.
Метод TTable UpdateCursorPos вызывается для гарантии синхронизации номера текущей записи в компоненте TTable и связанной с ним таблицы.
В случае ошибок BDE функций, исключительная ситуация ими не генерируется. Вместо этого они возвращают значение BDE-типа DbiResult, указывающее на успешное завершение или ошибку операции. Возвращаемое значение должно быть получено и обработано внешним приложением, с выполнением соответствующих действий. Любой результат, кроме DBIERR_NONE, указывает на неудачное выполнение функции. В этом случае может быть осуществлено дополнительное действие (как в примере выше), где с помощью BDE функции DbiGetErrorString код ошибки переводится в удобночитаемое сообщение. В этом примере возвращаемое в DbiGetRecord значение сохраняется в переменной rslt, а затем для определения успешности вызова функции сравнивается с DBIERR_NONE.
Если вызов DbiGetRecord был успешным, физический номер записи из поля iPhyRecNum структуры pRECProps сохраняется в переменной Result, которая является возвращаемой функцией величиной. Чтобы указать на то, что функция потерпела неудачу (т.е., вызов фунции DbiGetRecord окончился неудачно), вместо номера записи возвращается отрицательная величина. Значение ее может быть произвольным (отрицательная величина совместимого типа) и отдается на усмотрение программисту.
Пакование таблиц dBASE II
Упаковка таблиц dBASE требует вызова BDE функции DbiPackTable. Пример ее использования показан ниже, включая проверку на ошибки. Чтобы воспользоваться функцией DbiPackTable, вызывающий модуль должен в своей секции uses иметь модули-обертки BDE DbiTypes, DbiErrs и DbiProcs. При неудачном вызове DbiPackTable, сообщение об ошибке не генерится. Для того, чтобы понять как функция сработала, вам необходимо проверить возвращаемое ею значение. В случае успешного выполнения возвращаемое значение равно DBIERR_NONE. Любое другое значение указывает на ошибку, а с помощью него можно определить саму ошибку, ее причину, и наметить действия, необходимые для ее устранения. Вот сам пример:procedure TForm1.Button1Click(Sender: TObject);
var
Error: DbiResult;
ErrorMsg: String;
Special: DBIMSG;
begin
table1.Active := False;
try
Table1.Exclusive := True;
Table1.Active := True;
Error := DbiPackTable(Table1.DBHandle, Table1.Handle, nil, szdBASE, True);
Table1.Active := False;
Table1.Exclusive := False;
finally
Table1.Active := True;
end;
case Error of
DBIERR_NONE: ErrorMsg := 'Успешно';
DBIERR_INVALIDPARAM: ErrorMsg := 'Указанное имя таблицы или указатель на имя таблицы ' +'равен NULL';
DBIERR_INVALIDHNDL: ErrorMsg := 'Указанный дескриптор базы данных или курсора ' +'неверен или равен NULL';
DBIERR_NOSUCHTABLE: ErrorMsg := 'Таблица с таким именем не существует';
DBIERR_UNKNOWNTBLTYPE: ErrorMsg := 'Неизвестный тип таблицы';
DBIERR_NEEDEXCLACCESS: ErrorMsg := 'Таблица открыта не в эксклюзивном режиме';
else
DbiGetErrorString(Error, Special);
ErrorMsg := '[' + IntToStr(Error) + ']: ' + Special;
end;
MessageDlg(ErrorMsg, mtWarning, [mbOk], 0);
end;
Пакование таблиц dBASE III
Для упаковки таблицы dBASE, открытой с помощью TTable, воспользуйтесь функцией BDE DbiPackTable. Для этого достаточно сделать две операции: 1. Добавьте в секцию uses следующие модули: { Для Delphi 1.0: } DBITYPES, DBIPROCS и DBIERRS; { Для Delphi 2.0: } BDE; 2. Затем вызовите BDE функцию DbiPackTable следующим образом:Check(DbiPackTable(Table1.DbHandle, Table1.Handle, Nil, szDBASE, TRUE));
Примечания:
• Таблица должна быть открыта в эксклюзивном режиме.
• При вызове функций API BDE используйте процедуру Check. Check в случае ошибки при вызове BDE генерирует исключительную ситуацию.
Пакование таблиц dBASE IV
Nomadic советует: Для dBase:uses DbiProcs;
with table do
begin
OldState := Active;
Close;
Exclusive := True;
Open;
DbiPackTable(DBHandle, Handle, nil, nil, True);
{^ здесь можно добавить check()}
Close;
Exclusive := False;
Active := OldState;
{ при желании можно сохранить закладку }
end;
Pavel Kulchenko
(2:465/66)
Пример для Paradox:
Uses BDE; // for d3, для d2 не помню (что-то типа dbiprocs и еще что-то)
// для пpимеpа
tLog : TTable; // таблица, юзающая d:\db\log.db
var
TblDesc: CRTblDesc;
rslt: DBIResult;
Dir: String; //имеется в виду huge string т.е. {$h+}
hDb: hDbiDb;
begin
tLog.Active := False; //деактивиpуем TTable
SetLength(Dir, dbiMaxNameLen + 1);
DbiGetDirectory(tLog.DBHandle, False, PChar(Dir));
SetLength(Dir, StrLen(PChar(Dir)));
DbiOpenDatabase(nil, nil, dbiReadWrite, dbiOpenExcl, nil, 0, nil, nil, hDb);
DbiSetDirectory(hDb, PChar(Dir));
FillChar(TblDesc, sizeof(CRTblDesc), 0);
StrPCopy(TblDesc.szTblName, 'd:\db\log.db');
// здесь должно быть полное имя файла
//котоpое можно: а) ввести pуками;
//б) вытащить из пpопеpтей таблицы;
//в) вытащить из алиаса;
//г) см. FAQ
StrCopy(TblDesc.szTblType, szParadox);
//BTW тут может и szDBase стоять
TblDesc.bPack := TRUE;
DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, false);
DbiCloseDatabase(hDb);
end;
// можно еще чеки ввести, но облом :-)
Показ удаленных записей в таблице dBASE
В таблицах dBASE записи не удаляются до тех пор, пока таблица не будет упакована. Пока же это не произойдет, удаленные записи остаются в таблице, только имеют при этом флажок "к удалению". Для того, чтобы показать эти существующие, но не отображаемые записи, существует функция ShowDeleted(), которая использует функцию BDE API DbiSetProp(), показывающая записи, помеченные к удалению. При использовании этой функции нет необходимости закрывать и вновь открывать таблицу. ShowDeleted() в качестве параметров передается TTable и логическое значение. Логический параметр указывает на необходимость показа удаленных записей. Демонстрационный проект:unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, DBCtrls, Grids, DBGrids, DB, DBTables;
type
TForm1 = class(TForm)
Table1: TTable;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
DBNavigator1: TDBNavigator;
CheckBox1: TCheckBox;
procedure CheckBox1Click(Sender: TObject);
public
procedure ShowDeleted(Table: TTable; ShowDeleted: Boolean);
end;
var
Form1: TForm1;
implementation
uses DBITYPES, DBIERRS, DBIPROCS;
{$R *.DFM}
procedure TForm1.ShowDeleted(Table: TTable; ShowDeleted: Boolean);
var
rslt: DBIResult;
szErrMsg: DBIMSG;
begin
Table.DisableControls;
try
Check(DbiSetProp(hDBIObj(Table.Handle), curSOFTDELETEON, LongInt(ShowDeleted)));
finally
Table.EnableControls;
end;
Table.Refresh;
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
ShowDeleted(Table1, CheckBox1.Checked);
end;
end.
Пароль на dBASE-файлы
Delphi 1dBase-файлы не поддерживают пароли. Естественно, вы можете создать свои собственные методы поддержки паролей. Но это будет работать только с вашими приложениями. Боюсь, что при наличии тысяч читателей/конверторов dBase, этот способ не годится.
Показ меток 'удаленных' записей в dBASE-файлах
Delphi 1Для начала вы должны включить SoftDeletes, после чего вы сможете просматривать записи, помеченные к удалению. В противном случае, вы их не увидите. По умолчанию, для файлов DBF, SoftDeletes установлен в False. Вот логика работы:
procedure TForm1.Button1Click(Sender: TObject);
var
B: BOOL;
W: Word;
begin
Check(DbiSetProp(hDBIObj(Table1.Handle), curSOFTDELETEON, longint(True)));
{ Проверяем, что это работает }
Check(DbiGetProp(hDBIObj(Table1.Handle), curSOFTDELETEON, @B, sizeof(B), W));
if B = False then Label2.Caption := 'Не помечена'
else Label2.Caption := 'Помечена';
end;
Когда указатель на запись указывает на запись, которую вы хотите удалить, используйте следующую логику:
Table1.UpdateCursorPos;
Check(DbiUndeleteRecord(Table1.Handle));
Метод UpdateCursorPos устанавливает основной курсор BDE на позицию курсора текущей записи, который существуют только для того, чтобы все работало правильно. Вам нужно только вызвать этот метод прямым вызовом одной из BDE API функций (такой как, например, DbiUndeleteRecord).
Ну и, наконец, чтобы все работало, поместите модули DBIPROCS и DBITYPES с список USES.
DB2
Как заставить работать DB2 через протокол IPX?
Nomadic отвечает: Связь Win-клиента c DB2 в сети Netware Hастройка доступа к DB21. Связь с использованием протокола IPX/SPX.
Возможны два варианта доступа: • через сервер NETWARE; • прямая адресация.1.1. Конфигурация для доступа через сервер.
Замечание: Проверялся доступ через сервера NW 3.11 и 3.12. Для 4.х нужно еще разобраться. 1.1.1. DB2 Сервер • должна быть установлена OS/2 Warp или OS/2 Warp Connect; • включена поддержка NETWARE; • в CONFIG.SYS в переменную среды DB2COMM добавить (через запятую) IPXSPX и перезагрузить систему; • создать командный файл DBIPXSET.CMD следующего вида:db2 update dbm cfg using fileserver objectname dbserver
где – <NWSERVER> – имя сервера;
• выполнить командный файл DBIPXSET.CMD;
• перестартовать сервер базы данных;
• создать командный файл DBIPXREG.CMD следующего вида:
db2 register nwbindery user
где – <USERNAME> – имя пользователя, обладающего правами администратора на сервере <NWSERVER>;
• выполнить командный файл DBIPXREG.CMD;
• ответить на запрос пароля.
1.1.2. WINDOWS-клиент
• установить WINDOWS 3.1 или WfWG 3.11;
• установить клиента NETWARE от версии 4.х;
• при установке влючить поддержку WINDOWS;
• установить клиента DB2 для WINDOWS;
• используя программу Client Setup описать новый узел – сервер базы данных:
Name – <любое имя>
Protocol – IPX/SPX
File server – <NWSERVER>
Object name – dbserver
• описать базу данных и разрешить доступ к ней через ODBC.
1.2. Конфигурация для доступа через прямую адресацию
1.2.1. DB2 Сервер • см. п 1.1.1; • найти в директории x:\sqllib\misc программу DB2IPXAD.EXE и выполнить ее; • записать полученный адрес; 1.2.2. WINDOWS-клиент • см. п. 1.1.2. (первые три шага); • используя программу Client Setup описать новый узел – сервер базы данных: Name – <любое имя> Protocol – IPX/SPX File server – * Object name – <адрес полученный от DB2IPXAD.EXE> • описать базу данных и разрешить доступ к ней через ODBC.Почему DB2 ругается на Create Trigger?
Nomadic отвечает: Я тут писал по поводу того, что у меня не работали триггеры. Все дело оказалось в правиле написания команды «create trigger». Если все остальные команды корректно воспpинимаются на любом регистре, то эта – только набранная одними большими буквами.Модули данных
Модуль данных для каждого MDIChild
Delphi 2Когда во время разработки вы устанавливаете "DataSource"-свойство в БД-компонентах для указания на модуль данных, VCL во время выполнения приложения будет пытаться создать связь с существующим TDataModule, основываясь на его свойтсве Name. Так, если вы добавите модуль данных к вашему проекту и переместите его в свойстве проекта из колонки автоматически создаваемых форм в колонку доступных, вы сможете разработать форму, содержащую элементы управления для работы с базами данных, после чего несколькими строчками кода можете создать экземпляр формы, имеющий экземпляр собственного модуля данных. С помощью Репозитория создайте "standard MDI application" (стандартное MDI-приложение), в котором модуль TMDICHild будет похож на приведенный ниже. Добавленные строки имеют комментарий {!}. Хитрости спрятаны в конструкторе create и задании другого порядка следования операторов.
unit Childwin;
interface
uses Windows, Classes, Graphics, Forms, Controls,ExtCtrls, DBCtrls, StdCtrls, Mask, Grids, DBGrids,DataM; {!} // Модуль TDataModule1
type
TMDIChild = class(TForm)
DBGrid1: TDBGrid;
DBGrid2: TDBGrid;
DBEdit1: TDBEdit;
DBEdit2: TDBEdit;
DBNavigator1: TDBNavigator;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private { Private declarations }
public { Public declarations }
{!} DM:TDataModule1;
{!} constructor Create(AOwner:TComponent); override;
end;
implementation
{$IFDEF XOXOXOX} // DataM должен находиться в секции interface. Необходимо для среды
uses DataM; // времени проектирования. Определение "XOXOXOX" подразумевает,{$ENDIF}
// что это никогда не будет определено, но чтобы компилятор видел это.
{$R *.DFM}
{!} constructor TMDIChild.Create;
{!} begin
{!} DM := TDataModule1.Create(Application);
{!} inherited Create(AOwner);
{!} DM.Name := '';
{!} end;
procedure TMDIChild.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
end.
– Pat Ritchey
Как передать UserName и Password в удаленный модуль данных (remote datamodule)?
Nomadic отвечает: В Удаленный Модуль Данных бросьте компонент TDatabase, затем добавьте процедуру автоматизации (пункт главного меню Edit | Add To Interface) для Login. Убедитесь, что свойство HandleShared компонента TDatabase установлено в True.procedure Login(UserName, Password: WideString);
begin
{ DB = TDatabase }
{ Something unique between clients }
DB.DatabaseName := UserName + 'DB';
DB.Params.Values['USER NAME'] := UserName;
DB.Params.Values['PASSWORD'] := Password;
DB.Open;
end;
После того, как Вы создали этот метод автоматизации, Вы можете вызывать его с помощью:
RemoteServer1.AppServer.Login('USERNAME','PASSWORD');
Paradox
Byte-поля Paradox
Delphi 2Что за магия при записи в поле Paradox Byte? По этому поводу в документации ничего не сказано. Есть 2 пути получить доступ к данным в TBytesField. Просто вызовите метод GetData, передавая ему указатель на буфер, где сам буфер должен иметь размер, достаточный для хранения данных:
procedure SetCheckBoxStates;
var CBStates: array[1..13] of Byte;
begin
CBStateField.GetData(CBStates);
{ Здесь обрабатываем данные… }
end;
Для записи значений вы должны использовать SetData.
Используйте свойство Value, возвращающее вариантный массив байт (variant array of bytes):
procedure SetCheckBoxStates;
var CBStates: Variant;
begin
CBStates := CBStateField.Value;
{ Здесь обрабатываем данные… }
end;
Первый метод, вероятно, для вас будет легче, поскольку вы сразу докапываетесь до уровня байт. Запись данных также получится сложнее, поскольку вам нужно будет работать с variant-методами типа VarArrayCreate и др.
– Mark Edington
Доступ к таблицам Paradox на CD или c флагом только для чтения
Тема: Доступ к таблицам Paradox на CD или на дисках c флагом только для чтения Данный совет поможет вам разобраться в таком вопросе, как доступ к таблицам Paradox, расположенным на CD-ROM или диске, имеющем флаг "только для чтения". Механиз блокирования файлов Paradox требует наличие файла PDOXUSRS.LCK, осуществляющий логику работы блокировки. Данный файл обычно создается во время выполнения приложения и располагается в том же каталоге, где и таблицы. Тем не менее, в случае с CD-ROM, во время выполнения программы нет никакой возможности создать на нем описанный выше файл. Решение простое: мы создаем этот файл и помещаем его на CD-ROM во время его (CD) создания. Следующая простейшая программка позволит создать вам файл PDOXUSRS.LCK и поместить его в образ компакта для его последующего копирования на CD-ROM: 1. Стартуйте пустой проект и добавьте на форму следующие компоненты: TEdit, TButton и TDatabase. 2. В обработчике кнопки OnClick используйте следующий код:procedure TForm1.Button1Click(Sender: TObject);
begin
if ChkPath then Check(DbiAcqPersistTableLock(Database1.Handle, 'PARADOX.DRO','PARADOX'));
end;
3. Функция ChkPath является методом, определенным пользователем для формы. Она просто проверяет путь, введенный пользователем в поле редактирования и убеждается, что он существует. Вот функция:
function TForm1.ChkPath : Boolean;
var s: array[0..100] of char;
begin
IfDirectoryExists(Edit1.Text) then begin
DataBase1.DatabaseName:= 'TempDB';
DataBase1.DriverName:= 'Standard';
DataBase1.LoginPrompt:= false;
DataBase1.Connected := False;
DataBase1.Params.Add('Path=' + Edit1.Text);
DataBase1.Connected := TRUE;Result := TRUE;
end else begin
StrPCopy(s,'Каталог : ' + Edit1.text + ' не найден');
Application.MessageBox(s, 'Ошибка!', MB_ICONSTOP);
Result := FALSE;
end;
end;
{ Примечание: Не забудьте добавить объявление функции в секцию public формы.}
4. Перед компиляцией необходимо вспомнить еще об одной вещи: в список Uses нужно добавить следующие модули:
Delphi 1.0: FileCtrl, DbiProcs, DbiTypes, DbiErrs.
Delphi 2.0: FileCtrl, BDE
После компиляции и выполнения, программа создаст два файла в определенном вами каталоге. Создаваемые два файла: PDOXUSRS.LCK и PARADOX.LCK.
Примечание: Файл PARADOX.LCK необходим только для доступа к таблицам Paradox for DOS, так что вы можете его удалить.
5. Вам осталась сделать только одну последнюю вещь: скопировать оставшийся файл (PDOXUSRS.LCK) в образ CD-ROM. Естественно, ваши таблицы будут только для чтения.
Примечание: Если вы собираетесь довольно часто пользоваться данной утилитой, то для удобства вы можете изменить свойство Text компонента Edit на ваш «любимый» каталог, а свойство Caption кнопки поменять на что-нибудь более «интеллектуальное».
Вот окончательная версия кода:
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DB, StdCtrls, FileCtrl,
{$IFDEF WIN32}
BDE;
{$ELSE}
DbiProcs, DbiTypes, DbiErrs;
{$ENDIF }
type TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
Database1: TDatabase;
procedure Button1Click(Sender: TObject);
private { Private declarations }
public { Public declarations }
function ChkPath : Boolean;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
function TForm1.ChkPath : Boolean;
var s: array[0..100] of char;
begin
If DirectoryExists(Edit1.Text) then begin
DataBase1.DatabaseName:= 'TempDB';
DataBase1.DriverName:= 'Standard';
DataBase1.LoginPrompt:= false;
DataBase1.Connected := False;
DataBase1.Params.Add('Path=' + Edit1.Text);
DataBase1.Connected := TRUE;
Result := TRUE;
end else begin
StrPCopy(s,'Каталог : ' + Edit1.text + ' не найден');
Application.MessageBox(s, 'Ошибка!', MB_ICONSTOP);
Result := FALSE;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if ChkPath then Check(DbiAcqPersistTableLock(Database1.Handle, 'PARADOX.DRO','PARADOX'));
end;
end.
Нечувствительный к регистру поиск в первичном индексе Paradox
Delphi 1К сожалению, это невозможно. Вы можете создать другой (вторичный) индекс, нечувствительный к регистру, для того же поля (или полей), для которых был создан первичный индекс, но как вы можете догадаться, этот путь потребует дополнительного программирования.
Создание таблицы Paradox
Delphi 1Вот маленький кусочек кода для создания таблицы Paradox:
with TTable.create(self) do begin
DatabaseName := 'C:\temp';
TableName := 'FOO';
TableType := ttParadox;
with FieldDefs do Begin
Add('Age', ftInteger, 0, True);
Add('Name', ftString, 25, False);
Add('Weight', ftFloat, 0, False);
End;
IndexDefs.Add('MainIndex','IntField', [ixPrimary, ixUnique]);
CreateTable;
End;
DBEdit и реальные значения
При работе с реальными числами, хранимые в таблице Paradox, вы уверены в том, что вы используете тип Real как тип ваших данных? Если так, то попробуйте использовать тип Double. Double – 8-байтовое (64-битное) реальное число, которое нормально работает с BDE, тогда как Real – 6-байтовая версия и подходит только для Delphi и BP. Или попробуйте использовать Extended, занимающий 10 байтов.Почему при создании таблицы Paradox с первичным нечувствительным к регистру индексом вываливается ошибка?
Пара строкNomadic отвечает: В Парадоксе первичный индекс всегда CaseSensitive.
Как сменить пароль (master password) для таблицы Paradox?
Nomadic отвечает: Пожалуйста:var
db : TDatabase;
Desc : CRTblDesc;
begin
db := PriceTable.OpenDatabase;
FillChar(Desc, SizeOf(Desc), #0 );
StrCopy(Desc.szTblName, PChar(PriceTable.TableName));
StrCopy(Desc.szTblType, szParadox);
StrCopy(Desc.szPassword, 'password');
Desc.bProtected := TRUE;
Check(DbiDoRestructure(db.Handle, 1, @Desc, nil, nil, nil, FALSE));
end;
Что нужно сделать для нормальной работы в одноранговой сети с базами Paradox?
Nomadic отвечает: BDE Config/Admin – нa вкладке System устaнови LOCAL SHARE в TRUE! Здесь комментарий – В Help параметр LOCAL SHARE описан как:AA> === Cut ===
AA> The ability to share access to local data between an active BDE
AA> application and an active non-BDE application. Set to TRUE if you need to
AA> work with the same files through both a BDE and a non-BDE application at
AA> the same time. (It is not necessary to set LOCAL SHARE to TRUE if you do
AA> not need to have both applications open at the same time.) Default: FALSE.
AA> === Cut ===
Дак читал я вышеизложенное, и расцениваю его кaк туманопускательство. А подозреваю, что просто у BDE для скорости есть свой внутренний кэш (или, может, мехaнизм блокировок в пaмяти), и для двух приложений на одном компьютере оно всё делает хорошо, a вот если приложение находится на другом компьютере (и лезет в БД через другую копию BDE), то у него есть доступ только к файлам нa диске (как и у non-BDE application).
Скорее всего, борланд отключает эти хитрости у сетевых дисков. Hо для локального дискa, который рaсшарен по сети, он этого, похоже, не сделaл :(
И BDE нa файл-сервере не заботится о правильных индексaх и блокировках нa диске (т.е. не ожидает, что кто-то мог исправить индекс, пока оно ворон считaло).
А этa установка заставляет его работать по старым парадоховым соглашениям.
Что и требовалось.
PS. Иначе говоря, следует считать, что network is non-BDE application, и тогда это не есть бага :)
Переиндексирование файлов Paradox в пределах моей программы
Delphi 1Попытаемся это сделать с помощью прямых вызовов функций BDE. На некоторых Интернет-серверах я видел описание этих функций. Некоторые «писатели» даже превращают свои трактаты в некое подобие файлов помощи. Поскольку я не хочу перегружать канал, то пошлю это по почте тому, кто пришлет мне запрос (т.е. кому это действительно нужно). …сейчая я пишу небольшое приложение, которое может оказаться полезным для восстановления «разбитых» таблиц. Аллен, я пошлю тебе полный список шагов, как только смогу перевести их (это писал итальянец, я же только перевожу это), но уже сейчас я могу сказать как это проблему я решил для себя. Один из наших клиентов всегда разбивал таблицы paradox, поскольку они у него всегда были очень большими (в Blob-полях хранились WAV-файлы – оцифрованный голос). Решение заключалось в создании маленьких таблиц, включенных в отношение справочной целостности, и загрузки больших blob-полей в эти отдельные таблицы. Ненужно никаких BDE функций, единственное условие – вы не должны вручную удалять индексные файлы (все .x00, .y01 и т.д., они все имеют маску .x?? и .y??, не трогайте других файлов!), в противном случае вы НЕ СМОЖЕТЕ ОТКРЫТЬ ТАБЛИЦУ, даже с помощью DBD! …затем я вручную восстанавливал все индексы (затем я что-то забыл, и приложение вылетело с ошибкой…). Если приложение, которое я тебе пришлю, не заработает, я думаю единственным решением будет физическое уничтожение индексов и пересоздание их с помощью соответствующих вызовов BDE.
Разное
Помещение Memo-файла с ASCII-разделителем в Memo-поле таблицы
Вам нужно использовать процедуру getTextBuf. Вот пример из электронной справки: Данный пример при нажатии пользователем на кнопку копирует текст из поля редактирования в строку с терминирующим нулем, и помещает эту строку в другое поле редактирования.procedure TForm1.Button1Click(Sender: TObject);
var
Buffer: PChar;
Size: Byte;
begin
Size := Edit1.GetTextLen; {Получаем длину строки в Edit1}
Inc(Size); {Добавляем место для терминирующего нуля}
GetMem(Buffer, Size); {Создаем динамическую переменную Buffer}
Edit1.GetTextBuf(Buffer,Size); {Помещаем Edit1.Text в Buffer}
Edit2.Text := StrPas(Buffer); {Преобразуем Buffer в строку паскалевского типа}
FreeMem(Buffer, Size); {Освобождаем память, распределенную для Buffer}
end;
Почему не всегда верно обновляются IndexDefs по Update?
Пара строкNomadic отвечает: Ошибка в VCL. А помогает добавление fUpdated:=false; в теле процедуры TIndexDefs.Update. Или убиением владельца через Free, и пересозданием.
БД-дерево взаимоотношений
Delphi 1Все это я делал раньше. Я не могу вам все это показать на развернутом примере, но я дам вам идею как сделать это. Вы должны иметь таблицу, осуществляющую взаимоотношение между людьми. Если на Peter работают Jane и Simon, вы должны иметь таблицу (RELATION) с этими двумя записями.
Master
Slave ------- имена полей
Peter Jane
Peter Simon
Если George и Elisa работают на Jane, то таблица становится такой:
Master Slave ------- имена полей
Peter Jane
Peter Simon
Jane George
Jane Elisa
и так далее.
Если в таблице RELATION необходимо создать дерево, начинающееся на Peter, то нужно добавить к дереву главный узел (запись), где Master = Peter. Затем каждая дочерняя запись располагается ниже записи Master = Peter. После добавления дочерней записи вы сразу увидите, если ребенок имеет собственного ребенка. Ребенок становится теперь, вероятно, отцом, поэтому вы должны позиционировать таблицу RELATION к первой записи, где Master = child, и так далее, рекурсивно. Такой способ гарантирует построение правильного дерева.
Пример:
AddFather('Peter')
AddChild('Peter',1)
Procedure AddFather(Name: String)
Begin
Tree.Add(Name);
End;
Procedure AddChildr(Name: String, Index:Integer)
Begin
Relation.FindKey([Name])while RelationMaster.AsString = Name do
Begin
Tree.AddChild(Index,RelationSlave.AsString);
AddChild(RelationSlave.AsString,Tree.ItemsCount);
Relation.Next;
End;
End;
По-моему, ошибок нет.
DBGrid и Memo-поля
Delphi 1В обработчик события GetText TMemoField поместите следующую строку:
Text := GrabMemoAsString(TMemoField(Sender));
и поместите следующую функцию так, чтобы к ней можно было свободно обратиться:
function GrabMemoAsString(TheField : TMemoField): String;
begin
if TheField.IsNull then Result := '' else with TBlobStream.Create(TheField, bmRead) do begin
if Size >= 255 then begin
Read(Result[1], 255);
Result[0] := #255;
end else begin
Read(Result[1], Size);
Result[0] := Chr(Size);
end;
Free;
while Pos(#10, Result) > 0 do Result[Pos(#10, Result)] := ' ';
while Pos(#13, Result) > 0 do Result[Pos(#13, Result] := ' ';
end;
end;
Убывающий индекс
Delphi 1Я нашел простой способ получения убывающего индекса. В Delphi это получается очень легко и красиво:
Table1.AddIndex('NewIndex', 'CustNo;CustName', [ixDescending]);
Как работать из Delphi напрямую с MS ADO (Microsoft Active Data Objects)?
Nomadic отвечает: Итак, хочу поделиться некоторыми достижениями… так на всякий случай. Если у вас вдруг потребуется сделать в своей программке доступ к базе данных, а BDE использовать будет неохота (или невозможно) – то есть довольно приятный вариант: использовать ActiveX Data Objects. Однако с их использованием есть некоторые проблемы, и одна из них это как передавать Optional параметры, которые вроде как можно не указывать. Однако, если вы работаете с ADO по-человечески, а не через тормозной IDispatch.Invoke то это превращается в головную боль. Вот как от нее избавляться:var
OptionalParam: OleVariant;
VarData: PVarData;
begin
OptionalParam := DISP_E_PARAMNOTFOUND;
VarData := @OptionalParam;
VarData^.VType := varError;
после этого переменную OptionalParam можно передавать вместо неиспользуемого аргумента.
Далее, самый приятный способ получения Result sets:
Там есть масса вариантов, но как выяснилось оптимальным является следующий вариант, который позволяет получить любой желаемый вид курсора (как клиентский, так и серверный)
var
MyConn: _Connection;
MyComm: _Command;
MyRecSet: _Recordset;
prm1: _Parameter;
begin
MyConn := CoConnection.Create;
MyConn.ConnectionString := 'DSN=pubs;uid=sa;pwd=;';
MyConn.Open('', '', '', –1);
MyCommand := CoCommand.Create;
MyCommand.ActiveConnection := MyConn;
MyCommand.CommandText := 'SELECT * FROM blahblah WHERE BlahID=?'
Prm1 := MyCommand.CreateParameter('Id', adInteger.adParamInput, –1, <value>);
MyCommand.AppendParameter(Prm1);
MyRecSet := CoRecordSet.Create;
MyRecSet.Open(MyCommand, OptionalParam, adOpenDynamic, adLockReadOnly, adCmdText);
…теперь можно фетчить записи. Работает шустро и классно. Меня радует. Особенно радуют серверные курсоры.
Проверялось на Delphi 3.02 + ADO 1.5 + MS SQL 6.5 sp4. Пашет как зверь.
Из вкусностей ADO – их легко можно использовать во всяких многопоточных приложениях, где BDE порой сбоит, если, конечно, ODBC драйвер грамотно сделан…
Ну и еще можно использовать для доступа к данным всяких там «нестандартных» баз типа MS Index Server или MS Active Directory Services.
В Delphi (как минимум в 4 версии) существует «константа» EmptyParam, которую можно подставлять в качестве пустого параметра.
Как засунуть в качестве паpаметpа хpанимой пpоцедуpы стpоку длиной более 255 символов? И вообще, как использовать паpаметpы SP, если они BLOB?
Nomadic отвечает: «Засунуть» длинную строку можно было и раньше, если написать редактируемый запрос, и воспользоваться операциями Insert/Edit. Однако это не относится к хранимым процедурам. В Delphi 3.0 появился новый тип параметра (TBlobField вроде) и соответственно его поддержка в BDE. Если просто взять BDE 4.01 и выше, то работать все-равно не будет – нужна соотв. версия VCL (из Delphi 3.0 или выше).Дублирование набора записей
Delphi 1Вы можете воспользоваться вторым объектом TTable, подключенным к той же таблице, или можете вызвать метод объект TTable DisableControls, сделать изменения, и вызвать EnableControls. Для сохранения той же позиции вы можете попробовать воспользоваться закладкой. Например, так:
procedure TMyForm.MakeChanges;
var
aBookmark: TBookmark;
begin
Table1.DisableControls;
aBookmark := Table.GetBookmark;
try
{ваш код}
finally
Table1.GotoBookmark(aBookmark);
Table1.FreeBookmark(aBookmark);
Table1.EnableControls;
end;
end;
Как программно изменить LangDriver для таблиц dBase и Paradox?
Nomadic отвечает: Откpываешь help и смотpишь:
……
var list:tstrings;
……
BEGIN
…….
List.Add ( 'LANGDRIVER=db866ru0 ');
……
Session.ModifyDriver( 'DBASE', List );
……
END;
Это действие я пpовожy пеpед откpытием таблицы
Ivan Sboev
(2:5049/36.15)
Это о «русификации» таблицы. В таблицах dBase и Paradox имеется байт, который определяет CodePage содержимого таблицы. Раньше он не использовался и был зарезервирован. Тебе нужно его правильно установить. Это делается через DBD Restructure table. Если хочешь программно, можешь воспользоваться следующей процедурой:
uses DbiTypes, DbiProcs, DbiErrs, DB, WinProcs, SysUtils;
procedure ChangeLangDriver( DatabaseName, TableName, LDName: string );
var
TblExt: string;
Database: TDatabase;
TblDesc: CRTblDesc;
OptDesc: FLDDesc;
OptData: array [0..250] of Char;
Cur: hDBICur;
Rec: CFGDesc;
begin
if (TableName='') or (LDName='') then raise Exception.Create('Unknown TableName or LDName');
Database:=Session.OpenDatabase(DatabaseName);
try
if Database.IsSQLBased then raise Exception.Create('Function ChangeLangDriver working only with dBase or Paradox tables');
FillChar(OptDesc, SizeOf(OptDesc), #0);
FillChar(TblDesc, SizeOf(TblDesc), #0);
StrCopy(OptDesc.szName, 'LANGDRIVER');
OptDesc.iLen := Length(LDName) + 1;
with TblDesc do
begin
StrPCopy(szTblName, TableName);
TblExt := UpperCase(ExtractFileExt(TableName));
if TblExt = 'DBF' then StrCopy(szTblType, szDbase)
else if TblExt = '.DB' then StrCopy(szTblType, szParadox)
else
begin
AnsiToOEM(StrPCopy(OptData, DatabaseName), OptData);
if DbiOpenCfgInfoList(nil, dbiREADONLY, cfgPersistent, StrPCopy(OptData, '\DATABASES\' + StrPas(OptData) + '\DB INFO\')Cur) <> DBIERR_NONE then raise Exception.Create('Unknown table type');
try
while DbiGetNextRecord(Cur, dbiNOLOCK, @Rec, nil) <> DBIERR_EOF do if StrComp(Rec.szNodeName, 'DEFAULT DRIVER') = 0 then
begin
StrCopy(szTblType, Rec.szValue);
Break;
end;
finally
Check(DbiCloseCursor(Cur));
end;
end;
iOptParams := 1;
pfldOptParams := @OptDesc;
pOptData := @OptData;
end;
StrPCopy(OptData, LDName);
Check(DbiDoRestructure(Database.Handle, 1, @TblDesc, nil, nil, nil, False));
finally
Session.CloseDatabase(Database);
end;
end;
Примеры использования:
ChangeLangDriver('DBDEMOS', 'EMPLOYEE', 'ancyrr');
ChangeLangDriver('DBDEMOS', 'EMPLOYEE.DB', 'ancyrr');
ChangeLangDriver('C:\DELPHI\DEMOS\DATA', 'CLIENTS.DBF', 'db866ru0');
LDName:
для D1 – имя .LD файла в каталоге IDAPI\LANGDRV;
для D2 и CB – из BDECFG32.HLP поле Short name в табличке по указателю language drivers, dBASE или поле Internal в табличке по указателю language drivers, Paradox;
для D3 и выше – не знаю так как у меня её нет, но думаю, что также, как и в D2.
Существует ли средство для вывода определения структуры таблицы?
Я создал таблицу и хочу получить её структуру, чтобы сделать изменённый оператор создания таблицы. Nomadic отвечает: Для этого существует утилита DB2LOOK. Она находится в SQLLIB\MISC. Пример использования:CONNECT TO SAMPLE USER xxx USING yyy
DB2LOOK –d SAMPLE –u xxx –e –t employee
Вывод может быть перенаправлен в файл. Полный синтаксис выдаётся по команде:
DB2LOOK ?
У меня есть текстовые файлы, которые я хочу использовать в запросах к DB2, но не хочу создавать из них постоянные таблицы в базе. Что делать?
Nomadic отвечает: Можно воспользоваться табличными функциями (Table Functions). Они позволяют использовать файлы как таблицы. Примеры приведены в руководстве «Embedded SQL Programming Guide».Список структуры полей таблицы
В данном проекте создается список структуры полей соответствующей таблицы, с использованием массивов Fields и IndexDefs, который затем отображается в компоненте ListBox. Демонстрационный проект (dbbrowsr.dpr) решает эту задачу несколько иначе. Вы можете сравнить две версии этого кода. Примечание: Данный код работает только в 16-битной среде.procedure TForm1.Button1Click(Sender: TObject);
const MyFielddefs: array[ftUnknown..ftGraphic] of string [8] = ('Unknown', 'String', 'Smallint', 'Integer', 'Word','Boolean', 'Float', 'Currency', 'BCD', 'Date','Time', 'DateTime', 'Bytes', 'VarBytes', 'Blob','Memo', 'Graphic');
var
i, Indx: integer;
Definition: string;
begin
for i := 0 to Table1.FieldCount - 1 do begin
Definition := Table1.Fields[i].DisplayLabel;
Definition := Definition + ' ' +MyFieldDefs[Table1.Fields[i].DataType];
Table1.IndexDefs.Update;
if Table1.Fields[i].IsIndexField then begin
Indx := Table1.IndexDefs.Indexof(Table1.Fields[i].Name);
if Indx > -1 then if ixPrimary in Table1.IndexDefs[Indx].Options then Definition := Definition + ' (Первичный)';
end;
Listbox1.Items.Add(Definition);
end;
end;
Приведенная выше версия не работает в 32-битной среде, поскольку в ней присутствуют дополнительные типы полей. Вот версия, которая работает в 32-битной среде:
procedure TForm1.Button1Click(Sender: TObject);
const
MyFielddefs: array[ftUnknown..ftTypedBinary] of string [11] =('Unknown', 'String', 'Smallint', 'Integer','Word', 'Boolean', 'Float', 'Currency', 'BCD','Date', 'Time', 'DateTime', 'Bytes', 'VarBytes','AutoInc', 'Blob', 'Memo', 'Graphic', 'FmtMemo','ParadoxOle', 'DBaseOle', 'TypedBinary');
var
i, Indx: integer;
Definition: string;
begin
for i := 0 to Table1.FieldCount - 1 do begin
Definition := Table1.Fields[i].DisplayLabel;
Definition := Definition + ' ' +MyFieldDefs[Table1.Fields[i].DataType];
Table1.IndexDefs.Update;
if Table1.Fields[i].IsIndexField then begin
Indx := Table1.IndexDefs.Indexof(Table1.Fields[i].Name);
if Indx > -1 thenif ixPrimary in Table1.IndexDefs[Indx].Options then Definition := Definition + ' (Первичный)';
end;
Listbox1.Items.Add(Definition);
end;
end;
Создание индексного файла из Delphi
Delphi 1Если вы используете таблицы dBASE или Paradox, то для создания нового индекса воспользуйтесь методом AddIndex. Для примера:
Table1.AddIndex('Articles','Title', []);
создаст индексный файл с именем ARTICLES с использованием поля TITLE в качестве индексного ключа. При создании вы можете воспользоваться различными индексными опциями (например, уникальность, необслуживаемый и пр.) – для получения дополнительной информации обратитесь к электронной справке по Delphi. ПРИМЕЧАНИЕ: Ваша таблица должна быть открыта исключительно для того, чтобы только воспользоваться методом AddIndex.
Поддержка/обновление индексного файла, если только при создании вы не выставили флаг «необслуживаемый», происходит автоматически.
Контекстное меню на основе базы данных
var
m:TMenuItem;
navidummy:TComponent;
…………………………………………………
procedure TMyForm.CreatePopUpMM(Sender: TObject);
begin
Navidummy.free;
Navidummy:=TComponent.create(self);
While not NaviT.EOF do
begin
m := TMenuItem.create(navidummy);
II:=II+1;
with m do begin
name :='MM'+IntToStr(II);
caption := NaviT.Fieldbyname('MyWHAT').AsString;
tag := NaviT.Fieldbyname('MyTAG').AsInteger;
visible:=True;
OnClick:= NaviExec;
end;
MyMenuItem.add(m);
NaviT.Next;
end;
NaviT.Close;
end;
procedure TMyForm.NaviExec(Sender:TObject);
begin
What.text := (Sender as TMenuItem).Caption;
{ Здесь я получаю то, что хочу ! }
Key:= (Sender as TMenuItem).Tag;
end;
Корректное закрытие базы данных приложением Delphi
Delphi 1Очень интересный и полезный вопрос!! Я сам так с ним до конца и не разобрался! Но я попробую систематизировать события, происходящие при запросе на завершение работы Windows: Windows посылает сообщение WM_QUERYENDSESSION главным окнам всех запущенных приложений, при этом приложения должно сообщить свою готовность к завершению работы. Если при этом хотя бы одно из приложений ответит отрицательно, Windows прерывает процесс завершения работы. Delphi перехватывает это сообщение, и, в свою очередь, вызывает метод TForm.CloseQuery, (в главной форме, естественно), который генерирует событие OnCloseQuery, в обработчике которого можно указать на неготовность завершения приложения и отмены завершения работы Windows. Если я правильно понимаю, если ваше приложение «не мешает» Windows завершить свою работу, Windows нормально НЕ завершает работу приложения, поскольку для этого нет необходимости, не нужно освобождать память, ресурсы и пр. Так, если это утверждение верно (это легко можно проверить, но я слишком ленив сейчас), то событие OnCloseQuery – ваш единственный шанс сохранения данных на диске. Я не думаю что эта логика слишком плоха, просто это одна из тех причуд Windows, которую нужно знать и пользоваться ею. Что может произойти в описанном выше сценарии: редактируемая в настоящий момент запись не будет отправлена (Post) в базу данных, но та же самая вещь может случиться и при нормальном завершении приложения. При выходе из windows, вы вызываете WM_CLOSE api (или что-то типа этого) для каждого работающего в настоящий момент приложения. Программа закрывается точно таким же образом, как если бы вы щелкнули на кнопке закрытия или вызвали close из главной формы. Поэтому вам не нужно предпринимать никаких дополнительный действий, связанных с завершением работы с таблицами.
Изменение свойств базы данных во время выполнения приложения
Delphi 1Свойство DatabaseName тесно связано с: • каталогом, где расположены ваши табличные файлы. • BDE-псевдоним вашей базы данных. • DatabaseName вашего компонента TDatabase, если вы имеете его. Выводы?
Как мне задать выражение по умолчанию для объекта TField?
Delphi 3Это будет работать, если вы уже установили атрибуты поля и ассоциировали его с полем вашей таблицы. Если вы установили значение в Инспекторе Объектов, т.е. задали строку, не думайте, что это сработает во время выполнения приложения. Если вы попытаетесь во время прогона установить свойство TField.DefaultExpression примерно так:
MyField.DefaultExpression := 'MyValue';
то это скомпилируется, но при создании в таблице новой записи, скажем, при щелчке на кнопке + в DBNavigator, значения по умолчанию вы не получите. Чтобы во время работы приложения все работало, код должен быть таким:
MyField.DefaultExpression := '''MyValue''';
В Инспекторе Объектов вам нужно просто поместить значение 'MyValue' (используя одинарные кавычки).
После того, как я использовал правый щелчок мыши для создания функции-провайдера, как мне снова выполнить команду контекстного меню `Export from Table`?
Nomadic отвечает: Как только Вы экспортировали интерфейс провайдера, эта команда контекстного меню перестает быть видимой. Чтобы снова включить ее, Вы должны удалить ассоциированное свойство в Редакторе Библиотеки Типов, и затем нажать кнопку обновления информации в Редакторе Библиотеки Типов (Type Library Editor's Refresh button). Вы могли бы также удалить точку вхождения «Get_XXX» в исходном тексте RemoteDataModule.Как работать с новыми, своими интерфейсами в RemoteDataModule?
Nomadic отвечает: В редакторе библиотеки типов (typelib) Вы можете добавить свои интерфейсы и сделать их членами оригинального coClass. После этого Вы можете обращаться к этим интерфейсам, используя следующий синтаксис:(IDispatch(RemoteServer.AppServer) as IAnother)
Необходимо заметить, что это будет работать только, если Вы используете DCOM как транспорт.
Database Desktop показывает содержимое таблиц шрифтом без русских букв
Nomadic отвечает: A: Для DBD 5.0 в файл c:\windows\pdoxwin.ini вставить в секцию[Properties]
SystemFont=Arial Cyr
Для DBD 7.0 нужно исправить реестр: ключ
HKCU\Software\Borland\DBD\7.0\Preferences\Properties\
SystemFont="Fixedsys"
Если такой ключ не существует, его следует создать. Впрочем, для просмотра таблиц все равно можно порекомендовать rx Database Explorer – у него это получается очень хорошо.
Ребят, я давно делаю под HТ (под 95 не знаю, не пробовал) такую вещь:
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\CodePage]
"1252"="c_1251.nls"
BDE
InterBase
FAQ по InterBase
Ответы на наиболее часто задаваемые вопросы по InterBase (09/27/1996)
Если вы имеете дополнения, исправления или пожелания, шлите мне письма по адресу rlove@pobox.com . Текущая версия данного FAQ'а доступна по адресу http://www.xmission.com/~uldata/ib/faq.txt . Авторские права: 1996 Robert J. Love Данный FAQ свободен для копирования, распространения и изменения формата. Многие из этих вопросов и ответов взяты непосредственно из документов Borland. Авторские права таких ответов остаются у Borland. Авторские права: Borland International, Inc.Вопросы
1. Что мне необходимо для распространения InterBase/Delphi приложения, созданного для нашего InterBase сервера? 2. Что мне необходимо для распространения InterBase/Delphi приложения, созданного дла работы с Local InterBase? 3. Что юридически необходимо для распространения Local InterBase Server (LIBS)? 4. Я не могу подключить мои 32-битные приложения к моему серверу Novel… 5. Мое подключение к Интернет (Internet Connection) стартует всякий раз, когда я пробую соединиться с InterBase. 6. При попытке соединения я получаю следующее сообщение: Statement failed, SQLCODE = –902 (запрос потерпел неудачу) Unable to complete network request to host «DEV». (Невозможно завершить сетевой запрос для хоста «DEV».) –Failed to locate host machine. (невозможно найти хост-машину) –Undefined service gds_db/tcp. (сервис gds_db/tcp неопределен) 7. Мое соединение с InterBase, похоже, очень медленно… 8. Какие существуют Интернет-сервера, посвященные InterBase? 9. Существуют ли 16-битные драйвера ODBC, позволяющие подключаться к InterBase NT, Netware или любому из серверов UNIX? 10. Почему Delphi 1.00 поставляется с 16-битными драйверами ODBC для InterBase? 11. Существуют ли 32-битные драйвера ODBC, позволяющие подключаться к InterBase NT, Netware или любому из серверов UNIX? 12. Поддерживают ли 32-битные драйвера ODBC DSN? 13. Почему Borland решил взимать плату за Local 32-битную версию? 14. Как мне подписаться на список рассылки InterBase Mailing List? 15. Если в этом FAQ'е нет ответа на мой вопрос, куда мне обратиться?Вопросы и ответы по InterBase 4.2
16. Что такое InterBase 4.2? 17. Что нового в InterBase 4.2? 18. Для чего нужен Local InterBase? 19. Кто может быть пользователем InterBase Server под Windows 95? 20. Что включает в себя сервер InterBase под Windows 95? 21. Что включает в себя InterBase Server 4.2 for Windows NT? 22. Как осуществляется лицензирование InterBase? 23. Могу ли я свободно копировать ODBC драйвера InterBase? 24. Сколько стоит обновление до 4.2?Вопросы/Ответы
1. Что мне необходимо для распространения InterBase/Delphi приложения, созданного для нашего InterBase сервера? Вам необходимо следующее: 1. BDE. 2. SQL Links 3. Клиентская лицензия 2. Что мне необходимо для распространения InterBase/Delphi приложения, созданного дла работы с Local InterBase? Вам необходимо следующее: 1. BDE 2. SQL Links 3. Local InterBase Server (смотри вопрос #3) 3. Что юридически необходимо для распространения Local InterBase Server (LIBS)? Реально это зависит от версии, которую вы пытаетесь распространить. Delphi C/S 1.0 поставляется с неограниченной лицензией (Unlimited Distribution License), позволяющей распространять неограниченное число копий 16-битной версии LIBS. Тем не менее, для 32-битной версии лицензия Unlimited Distribution License недоступна. По 408-431-1000 вы сможете узнать текущие условия лицензирования. 4. Я не могу подключить мои 32-битные приложения к моему серверу Novel… В настоящий момент соединение с помощью 32-битного SPX к InterBase невозможен, если вам необходимо подключить ваше 32-битное приложение к вашему серверу Novel, вы должны установить на нем поддержку протокола TCP/IP. (Это является следствием неготовности библиотеки 32 SPX Novel Libraries к моменту выхода SQL Links) 5. Мое подключение к Интернет (Internet Connection) стартует всякий раз, когда я пробую соединиться с InterBase. Вам необходимо выключить флажок Auto Dial, который вы можете найти в Control Panel на страничке настройки Internet. 6. При попытке соединения я получаю следующее сообщение:Statement failed, SQLCODE = –902
(запрос потерпел неудачу)
Unable to complete network request to host «DEV».
(Невозможно завершить сетевой запрос для хоста «DEV».)
-Failed to locate host machine.
(невозможно найти хост-машину)
-Undefined service gds_db/tcp.
(сервис gds_db/tcp неопределен)
Следующая строчка должна присутствовать в services-файле как в вашем клиенте, так и на сервере:
gds_db 3050/tcp
Services-файлы могут располагаться в следующих каталогах:
Windows95→C:\<WINDOWS95> (Где у вас установлен Win95)
Windows NT→C:\ \System32\drivers\etc
7. Мое соединение с InterBase, похоже, очень медленно…
Это очень вероятно, если вы пользуетесь Netbeui, входящей в состав NT версии 4.0. Данная версия имеет ошибку, очень замедляющую работу Netbeui. Для решения проблемы попробуйте один из следующих рецептов:
1. Обновите InterBase до самой последней версии.
2. Установите, как вы обычно делаете, TCP/IP, это будет работать быстрее с любой версией InterBase.
Примечание: Тестирование NT 4.0 и InterBase 4.2 с протоколами Netbeui и TCP/IP показало их равную производительность, а в некоторых случаях Netbeui был быстрее.
8. Какие существуют Интернет-сервера, посвященные InterBase?
На сегодняшний день я знаю 4 таких Интернет-сервера:
InterBase Development
http://www.xmission.com/~uldata/ib
Mers Systems
http://www.mers.com
Dunstan Thomas InterBase Links
http://www.demon.co.uk/dtuk/dtinterbaselinks.html
Borland International
http://www.borland.com/interbase
9. Существуют ли 16-битные драйвера ODBC, позволяющие подключаться к InterBase NT, Netware или любому из серверов UNIX?
Borland в настоящее время делает доступными 16-битные драйверы ODBC как часть продукта PC Client/Developer Toolkit [данное программное обеспечение также включается в пакеты InterBase для NT и сервера Netware]. Пользователи, приобредшие лицензии на PC Client/Developer Toolkit, имеют право устанавливать эти 16-битные драйвера. Цена за приобретаемый отдельно Client/Toolkit составляет $295, Borland использует для него товарный индекс ICL1140WWFN350.
10. Почему Delphi 1.00 поставляется с 16-битными драйверами ODBC для InterBase?
Delphi 1.00 содержал 16-битные драйвера ODBC для IB для того, чтобы все компоненты Delphi могли без проблем подключаться к серверу. Delphi 1.0 также включал SQL Link для InterBase, натив-драйвер с высокими скоростными характеристиками. Вопросы лицензирования не были явно или неявно отражены при пакетировании и в файлах deploy.txt драйвера ODBC, поэтому легальным пользователям продукта Delphi Client/Server не запрещается распространять продукты SQL Link и Local InterBase.
В Delphi 1.02 драйверы InterBase ODBC были удалены, поскольку в необходимость в них компонентов Delphi отпала. Упоминание о драйверах остались в нескольких текстовых файлах, но это больше не требуется, так как в файлах deploy.txt содержится информация о правилах их распространения.
11. Существуют ли 32-битные драйвера ODBC, позволяющие подключаться к InterBase NT, Netware или любому из серверов UNIX?
Сегодня InterBase включает в себя 32-битные драйвера ODBC для Windows 95 и NT. Данные драйвера включены в InterBase 4.1 под NT и InterBase 4.2 под NT. Они были разработаны компанией Visigenic [смотри сообщение для прессы «Visigenic/Borland» на сервере www.borland.com]. Они также включены в Local InterBase под Win95/NT, который продается отдельно от Delphi. Драйвера также доступны как натив-драйвера для таких клонов UNIX, как Solaris, AIX и HP-UX. Никаких правил лицензирования не предусмотрено, а из существующих документов нельзя сделать выводы отностильно получения разработчикам доступа к драйверам путем покупки продуктов InterBase.
12. Поддерживают ли 32-битные драйвера ODBC DSN?
В настоящее время пока нет, в InterBase 4.2 возможность ODBC «DSN» была добавлена для поддержки соединений с серверными приложениями, такими, как сервера Web. Тем не менее, при использовании InterBase с серверами Web Server, для сервера необходимо иметь нужное число лицензий. Скоро Borland огласит свою политику отностительно лицензирования InterBase при работе с Интернет.
13. Почему Borland решил взимать плату за Local 32-битную версию?
(Смотри ниже подробное объяснение)
Как вы, вероятно, уже знаете, Delphi C/S 1.0 включает в себя неограниченный в распространении Local InterBase [16-бит]. Мы [группа разработчиков InterBase] решили предложить эти беспрецендентные условия для распространения нашего продукта в среде разработчиков, демонстрации великолепия сервера и для увеличения полезности Delphi как средства разработки в среде Клиент/Сервер. Delphi Client/Server Suite 2.0 содержит Delphi Client/Server 1.0 и сохраняет условие свободного распространения Local InterBase [16-бит].
Для 32-битных версий Delphi мы имеем:
Delphi Desktop – не 32-битный InterBase любой сортировки [Desktop<>Client/Server]
Delphi Developer – Local InterBase для Windows 95/NT включен, без распространения.
Delphi C/S Suite 2.0 – Local IB для Win95/NT, IB Server NT на 2 пользователя, также без распространения.
Почему без распространения?
Во-первых, как вы можете увидеть из моих выкладок, новый продукт Local InterBase сертифицирован для использования в Windows 95 и Windows NT. Его архитектура полностью переписана с использованием нашего расширенного проекта SuperServer. Поскольку продукт разрабатывался как для Win95, так и для NT, Local InterBase настоятельно рекомендуется использовать в качестве отдельного сервера [MS не имеет сервера Win95; Oracle имеет один, но он имеет другой алгоритм программирования, чем NT server, они предлагают заплатить $400 за каждый 16– и 32-битный C API, и они посылают вас в InterSolv для ПОКУПКИ драйвера ODBC; Sybase имеет SQL Anywhere/Watcom и SQL Server 11 с другим API [ODBC против OpenClient], другой архитектурой и серьезными проблемами масштабируемости [продукт SQL Anywhere всегда использует Watcom с TransactSQL, но не использует OpenClient API, низкая многопользовательская производительность движка Watcom {для этого можно посмотреть последние обзоры в PC MAG за 10/94 и InfoWorld}, и так далее]; Informix не имеет ничего общего с работой на этих платформах; а Gupta свернула свою деятельность на этом поприще и кинулась разрабатывать High-End инструментарий для провайдеров, а не для серверов {если я правильно понял последнее сообщение для печати}]. 16-битные версии для отдельных пользователей отлично смотрелись в C/S пакете, в котором они распространялись. Ожидалось, что эти версии в пакете client/server должны быть свободными в распространении, но это не так.
При продаже отдельно от Delphi и других клиентских продуктов Borland, продукт Local InterBase под Win95/NT будет сравниваться с SQL Anywhere, Personal Oracle и Personal Oracle Lite, и MS SQL Server Workstation.
Мы включим наши C/C++ API для свободного использования.
Мы включим наши 32-битные драйвера ODBC 2.5 под Win95/NT для свободного использования.
Мы включим полную online-документацию, включая документацию по C API.
Мы включим великолепную интеграцию в среду Win95/NT.
Мы включим нативный 32-битный инструментарий.
Мы предлагаем РАЗЛИЧНЫЕ наборы-пакеты для полного сервера [различающиеся только в поддерживаемых DDL, API, включаемой online-документацией и др.] с РАЗЛИЧНЫМ ценообразованием.
Короче говоря, Local InterBase 32 предлагает бОльшие характеристики, лучшее взаимодействие с SQL [совместимость с уровнем ANSI 92, не '89], бОльшую универсальность [тот же комплект для Win95/NT], лучшую интеграцию с ОС, лучшую масштабируемость [мы работаем с 16 операционными системами, используя ОДНО И ТО ЖЕ API], лучшую производительность [поскольку вы пишите на одном API или посредством Delphi и никогда не переписываете свое приложение].
Мы предлагаем такие характеристики/производительность/цены, что конкуренты просто рыдают навзрыд.
14. Как мне подписаться на список рассылки InterBase Mailing List?
Для подписки отправьте письмо по адресу listproc@esunix1.emporia.edu с командой «SUBSCRIBE INTERBASE Ваше Имя» в теле сообщения (без кавычек).
15. Если в этом FAQ'е нет ответа на мой вопрос, куда мне обратиться?
У вас имеется несколько доступных способов:
1. Послать ваш вопрос в Compuserve GO BDEVTO (Секции 8 и 9)
2. Послать ваш вопрос в список рассылки InterBase Mailing List (смотри Вопрос 14)
3. Заключить контракт на поддержку (Support Contract) для InterBase и спросить службу технической поддержки (Technical Support)
Вопросы и ответы по InterBase 4.2
16. Что такое InterBase 4.2? InterBase 4.2 – новая версия сервера реляционной базы данных Borland InterBase под Windows 95 и NT. 17. Что нового в InterBase 4.2? InterBase 4.2 – целое семейство новых продуктов, включающее в себя потокобезопасные клиентские библиотеки для Windows 95/NT, с расширенными 32-битными драйверами ODBC, расширенную версию Local InterBase, предназначенную для разработки отдельным пользователем и ее распространения, новый многопользовательский сервер под Windows 95 для небольших рабочих групп и новый сервер под Windows NT для разработки приложений уровня департамента и предприятия. InterBase 4.2 был создан с использованием расширенной версией архитектуры Borland SuperServer, что позволило поднять производительность продукта на небывалую высоту, сохранив при этом исторические преимущества InterBase и добавив легкость установки, удобство использования и разработки. Кроме того, InterBase 4.2 для Windows NT также содержит нового менеджера лицензий (License Manager), позволяющий системным администраторам легко и эффективно управлять пользователями баз данных. 18. Для чего нужен Local InterBase? Local InterBase 4.2 разрабатывался для компаний и корпораций, поставляющих решения клиент/сервер для предприятий, которые имеют как автономных, так и сетевых пользователей. Local InterBase обеспечивает пользователей ноутбуков и рабочих групп автономным сервером баз данных, работающим на всех платформах Windows [Windows 3.1, 95 и NT], предлагая таким образом решение для сотрудников предприятий, имеющих нерегулярный доступ к сети. Поскольку Local InterBase использует тот же язык программирования и формат баз данных, что и семейство продуктов сервера InterBase [доступные для платформ Windows и UNIX], то приложения, созданные для использования с сервером InterBase, на 100% совместимы с Local InterBase, и не требуют внесений изменений для правильной работы. 19. Кто может быть пользователем InterBase Server под Windows 95? Сервер InterBase под Windows 95 – многопользовательский сервер для рабочих и небольших групп. Совместимый с Windows 95, Windows NT Workstation и NT Server, InterBase Server под Windows 95 идеален для приложений, которые требуют не более 4 параллельных пользователей. Если потенциальное количество пользователей может быть 10 и более, InterBase Server под Windows 95 будет управлять соединениями для гарантии того, что будут активны не более 4 пользователей, этопредохранит операционную систему Windows 95 от перегрузки с операциями, связанными с базами данных. InterBase Server под Windows 95 не требует для работы выделенной машины и может работать в сетевой среде типа «peer to peer», где сервер может обслуживать не только операции с базами данных. 20. Что включает в себя сервер InterBase под Windows 95? Сервер InterBase под Windows 95 включает в себя клиентские библиотеки и драйвера ODBC, необходимые для распространения в пределах рабочей группы, которая планирует пользоваться сервером, а также сам сервер, устанавливаемый на одной из машин [обычно самая быстрая машина в группе]. Отдельные клиентские приложения, работающие с Local InterBase, легко адаптируются для работы с сервером InterBase под Windows 95, тем самым позволяя компаниям и крупным корпорациям легко масштабировать свои решения по мере увеличения к ним требований. 21. Что включает в себя InterBase Server 4.2 for Windows NT? InterBase Server 4.2 под Windows NT включает в себя сервер InterBase, клиентские библиотеки InterBase [включая ODBC драйвера Win95/NT], менеджер лицензий License Manager, позволяющий системным администраторам легко и эффективно управлять пользователями баз данных, и высокопроизводительный 32-битный визуальный (GUI) инструментарий. Сервер InterBase под Windows NT фирмы Borland – наилучший выбор для сервера баз данных под Windows. Тестировавшийся и сертифицированный под NT 3.51 и 4.0, InterBase Server 4.2 легко справляется с задачами уровня крупного предприятия. Способный использовать многопроцессорные машины для максимальной производительности, InterBase Server 4.2 является наилучшим выбором для крупномасштабных приложений, требующих высокую скорость, легкость установки, удобство разработки и надежность эксплуатации. 22. Как осуществляется лицензирование InterBase? InterBase предусматривает два типа лицензий: Named User (пользовательская) и Concurrent Server (серверная). Лицензия Named User рекомендуется для приложений, в которых количество пользователей, имеющих доступ к базе данных, является числом относительно постоянным, а вероятность добавления в сетевую среду серверов InterBase достаточно высока. Данная лицензия гарантирует, что любой пользователь NT Named Client будет иметь полный доступ ко всем серверам предприятия InterBase NT без необходимости приобретения лицензий для множества пользователей. Цена лицензии Concurrent Server позволяет разработчикам иметь определенное количество параллельно работающих пользователей, но при этом количество потенциальных пользователей может быть значительно большим. Если число потенциальных пользователей значительно превышает число паралельно работающих пользователей на текущий момент, лицензия Concurrent Server позволит вам в будущем сэкономить немало денег. Тем не менее, если к приложению прибавляются дополнительные сервера баз данных, вы должны иметь серверные лицензии в количестве паралелльно работающих пользователей, подключенных к этим серверам, даже если эти пользователи уже работают с другими серверами NT, имеющимися на предприятии. Таким образом, лицензия Named Client позволяет лицензировать и пользователей, и машины, и допускает подключение клиента к любому серверу предприятия NT, имеющему лицензию Named Client. Лицензия Concurrent Server лицензирует количество параллельно работающих на сервере пользователей и не предоставляет клиентам никаких клиентских лицензий. 23. Могу ли я свободно копировать ODBC драйвера InterBase? Нет, но все пользователи InterBase 4.2, имеющие лицензию Named User, могут иметь копию клиентских библиотек InterBase и драйверов ODBC, установленных на их машине. Таким образом, если вы купили легальную лицензию для подключения к InterBase, вы имеете право на создание резервной копии. Аналогично этому, все пользователи InterBase 4.2 с лицензиями Concurrent Server также могут иметь копии клиентских библиотек и драйверов ODBC, установленных на их машине. Разработчики не могут копировать библиотеки 4.2 на машины незарегистрированных пользователей, или пользователей предыдущих версий InterBase [например, 4.0 и 4.1]. Пользователи этой группы должны обновить сервер до версии InterBase 4.2 или приобрести индивидуальные копии инструментария разработчика (Developer Toolkit) для каждого клиента, где имеются файлы этого инструментария [драйверы ODBC, GUI-утилиты и пр.]. 24. Сколько стоит обновление до 4.2? Клиенты InterBase 4.0 и 4.1 могут обновить InterBase до версии 4.2 за $499.95Как гарантированно сделать backup/restore БД InterBase с опцией 'Replace existing database' и записями протоколов в файлы с гарантированным отстрелом пользователей?
Nomadic советует: Att.bat:at 01:00 /INTERACTIVE "e:\IB_DATA\BR.BAT"
BR.bat
del e:\IB_DATA\b.txt
del e:\IB_DATA\r.txt
del e:\ib_data\AR_IB.PRV
del e:\IB_DATA\AR_IB.GBK
d:\ib_42\bin\gfix –shut –force 1 e:\ib_data\AR_IB.GDB –user "SYSDBA" –password "oooo"
net stop "InterBase Server"
copy e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.PRV
net start "InterBase Server"
d:\ib_42\bin\gbak e:\ib_data\AR_IB.GDB e:\ib_data\AR_IB.GBK –user "SYSDBA" –password "oooo" –B –L –Y "e:\IB_DATA\b.txt"
d:\ib_42\bin\gbak e:\ib_data\AR_IB.GBK e:\ib_data\AR_IB.GDB –user "SYSDBA" –password "oooo" –P 4096 –V –R –Y "e:\IB_DATA\r.txt"
Sergey Klochkovski
Как скомпилиpовать UDF для Interbase под Linux RH 4.0?
Nomadic советует: Пример –#!/bin/sh
gcc –c –O –fpic udflib.c
ld –o libudf.so –shared udflib.o
cp libudf.so /usr/interbase/lib/
ldconfig –v>>/dev/null
Как узнать текущие дату и время в Interbase?
Nomadic отвечает: Дата + время – DATE. Только дата – TODAY. Только время – DATE-TODAY.После снесения через родной uninstall Interbase Server 5.0 для Windows и желания поставить 5.1.1 вылетает ошибка: IBCheck. Что делать?
Nomadic отвечает: Решение найдено. Прочитай сам и передай товарищу: Надо запустить regedit, и открыть ключHKEY_LOCAL_MACHINE\Environment
Там есть строка PATH. Так вот иногда она почему-то становится не строкой, а еще чем-то. Ее надо убить, и пересоздать как строку, прописав туда прежнее содержимое (в виде строки).
При попытке регистрации UDF возникает ошибка (udf not defined). Что не так?
Nomadic отвечает: Располагайте DLL в каталоге Interbase/Bin, или в одном из каталогов, в которых ОС обязательно будет произведен поиск этой библиотеки (для Windows это %SystemRoot% и %Path%); При декларировании функции не следует указывать расширение модуля (в Windows по умолчанию DLL):declare external function f_SubStr
cstring(254), integer, integer
returns
cstring(254)
entry_point "Substr" module_name "UDF1"
Где UDF1 – UDF1.DLL.
Как заставить Interbase принять COLLATE PXW_CYRL по умолчанию?
Nomadic отвечает: (Это очень полезно при прямой работе с IB из различного CASE-инструментария, типа PowerDesigner или ErWIN) Чтобы не писать каждый раз COLLATE, я сделал следующее: 1. Создал сохранённую процедуруcreate procedure fix_character_sets
as
begin
update
rdb$character_sets
set
rdb$default_collate_name = 'PXW_CYRL'
where rdb$character_set_name = 'WIN1251'
and
rdb$default_collate_name = 'WIN1251'
;
end
2. Запустил ее один раз.
3. Создаю таблицы без указания COLLATE.
4. После восстановления из архива, запускаю еще раз.
ODBC
Добавление ODBC-драйверов в Delphi 3
Минимальные требования, необходимые для установки драйвера ODBC в Delphi 3.0, заключаются в наличии следующих компонентов: Microsoft ODBC Manager Windows 95 или NT Delphi версии Developer или Client/Server Поставляемый производителем драйвер ODBC (уже установленный в вашей системе) При использовании Delphi 3.0 есть два общих метода добавления ODBC драйверов к BDE. Первым шагом при использовании любого из методов является установка постовляемого производителем драйвера ODBC в вашу систему. После этого достаточно сложного шага остальные шаги будут не такими сложными. В левой панели менеджера BDE расположен список драйверов и источников данных, которые прежде были ориентированы на использование с приложениями BDE.Метод A:
1. Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.) 2. Теперь в главном меню выберите пункт Object|ODBC administrator. (будет показан спискок установленных в настоящий момент драйверов.) 3. Нажмите Add, выберите ODBC драйвер, для которого вы хотели бы создать источник данных, и нажмите на OK. 4. Затем заполните необходимую для вашего драйвера информацию. (Минимальная конфигурация требует заполнения поля Data Source Name. Вам необходимо будет заполнить по крайней мере еще одно поле, описывающее месторасположение данных. В случае таблиц Paradox и dBase это будет поле «Path» (путь), или поле «Server» (сервер) в случае конфигурирования драйвера ODBC для Interbase ODBC. Если вы используете Interbase, вы должны указать путь к файлу .GDB, если вы пользуетесь файлами Paradox или dBASE, вы должны определить месторасположение каталога с таблицами, и, наконец, если вы используете Oracle, вы указать строку, расположенную в вашем файле TNSNAMES.ORA. После того как вы это сделаете, можно считать, что виртуальный драйвер вами создан, и вы можете получить доступ к вашим файлам с базами данных через созданный вами источник данных.)Метод B:
1. Для начала запустите из меню Windows Start BDE Administrator (он должен располагаться в папке Delphi 3.0.) 2. Щелкните на закладке database, затем правой кнопкой мыши на левой панели. 3. Щелкните в контекстном меню на пункте New, выберите тип ODBC драйвера, который вы хотите добавить, и нажмите на кнопку OK. 4. Снова щелкните правой кнопкой на панели database, и в появившемся контекстном меню выберите Apply. 5. Теперь на панели definition вы должны выбрать правильный ODBC DSN (Data Source Name, имя источника данных) и нажать apply. Оба этих метода заканчиваются способностью Delphi с помощью TDataset перехватывать живые данные. Вы, возможно, обратили внимание на новые опции в меню Object|Options, эти опции позволяют вам выбирать для просмотра различные режимы конфигурации. Желательно в панели View в группе Select Configuration Modes включить (отметить галочками) все выключатели. При всех включенных checkbox-ах вы получите в свое распоряжение расширенный список всех драйверов и псевдонимов, доступных вам для использования. Если галочка напротив ‘virtual’ отсутствует, вы не сможете увидеть драйверы, добавленные через менеджер MS ODBC, а увидете драйверы, установленный только с помощью BDE (в соответствии с методом 2).Oracle
Связь Oracle с Win95
Delphi 2Оптимизация связи Oracle с Windows 95 Предварительные условия: • Windows 95 • Установленное клиентское программное обеспечение для доступа к Oracle & программа для соединения с Oracle Server через TCP/IP. • (Опционально) Программное обеспечение Delphi 2.0 C/S для тестирования результатов. Цель документа: помочь увеличить скорость соединения Oracle под Windows 95. Под WinNT такая проблема не стоит, следовательно, данный документ рассматривает только работу с Windows 95. Ниже вы видите разницу в скорости выполнения запроса, выполненного до модификации, и после: До : Win95 = 10-15 секунд. WinNT = 2-3 секунд. После : Win95 = 3-4 секунд. (Большое улучшение) Проблема: Windows 95 в сущности ищет адреса IPC в нескольких сетевых узлах ДО получения соединения с Oracle DNS, WinNT же поступает по другому. Решение: Измените файл Oracle SQLNET.ORA для выключения вышеуказанной характеристики Windows 95. Решение шаг-за-шагом: 1. Откройте в Notepad или Write файл SQLNET.ORA. (Данный файл расположен в каталоге <ORA_HOME>\network\admin. Проигнорируйте любые другие разновидности этого файла) Данный файл должен выглядеть примерно следующим образом:
################
# Filename......: sqlnet.ora
# Node..........: local.world
# Date..........: 24-MAY-94 13:23:20
################
TRACE_LEVEL_CLIENT = OFF
sqlnet.expire_time = 15
names.default_domain = borland.world
name.default_zone = borland.world
Добавьте следующий параметр в файл SQLNET.ORA:
AUTOMATIC_IPC = OFF
После изменений файл должен выглядеть примерно так:
################
# Filename......: sqlnet.ora
# Node..........: local.world
# Date..........: 24-MAY-94 13:23:20
################
AUTOMATIC_IPC = OFF
TRACE_LEVEL_CLIENT = OFF
sqlnet.expire_time = 15
names.default_domain = borland.world
name.default_zone = borland.world
Сохраните измененный файл SQLNET.ORA и ура! В дальнейшем при инициализации соединения с Oracle время соединения вместо 15 секунд составит всего лишь 3 секунды. Скорость работы Delphi существенно увеличится.
Возникла необходимость в обработке исключительных ситуаций в PL/SQL процедуре (Oracle7 WG Server Release 7.3.2.2.0). Почему у меня не получается?
Nomadic отвечает: Объявить выборку SELECT * FROM CUSTOM.CAMAIN20TEMP WHERE CC_07_01=curCC_07_01 AND CC_07_02=curCC_07_02 AND CC_07_03=curCC_07_03 курсором, а потом примерно так:loop
fetch_cursor;
выход когда фетчить больше нечего;
begin
INSERT INTO CUSTOM.CAMAIN20 чего нафетчили;
EXCEPTION
WHEN others THEN
BEGIN
DBMS_OUTPUT.PUT_LINE('ВВОД ДУБЛЯ В CUSTOM.CAMAIN20');
END
end
end loop;
Поясните, чем в Oracle являются понятия Instance, Database etc.?
Nomadic отвечает: Перевод документации: Что такое ORACLE Database? Это данные которые будут обрабатываться как единое целое. Database состоит из файлов операционной системы. Физически существуют database files и redo log files. Логически database files содержат словари, таблицы пользователей и redo log файлы. Дополнительно database требует одну или более копий control file. Что такое ORACLE Instance? ORACLE Instance обеспечивает программные механизмы доступа и управления database. Instance может быть запущен независимо от любой database (без монтирования или открытия любой database). Один instance может открыть только одну database. В то время как одна database может быть открыта несколькими Instance. Instance состоит из: SGA (System Global Area), которая обеспечивает коммуникацию между процессами; до пяти (в последних версиях больше) бэкграундовых процессов. От себя добавлю – database включает в себя tablespace, tablespace включает в себя segments (в одном файле данных может быть один или несколько сегментов, сегменты не могут быть разделены на несколько файлов). segments включают в себя extents.Как заставить Oracle анализировать все таблицы базы данных?
Nomadic отвечает: Конечно, можно использовать DBMS_SQL, DBMS_JOB… А можно и так:#!/bin/sh
#
# Analyze all tables
#
SQLFILE=/tmp/analyze.sql LOGFILE=/tmp/analyze.log
echo @connect dbo/passwd@> $SQLFILE
$ORACLE_HOME/bin/svrmgrl <> $SQLFILE
connect dbo/passwd
SELECT 'TABLE', TABLE_NAME FROM all_tables WHERE owner = 'DBO';
EOF
echo exit>> $SQLFILE
cat $SQLFILE> $LOGFILE
cat $SQLFILE | $ORACLE_HOME/bin/svrmgrl>> $LOGFILE
cat $LOGFILE | /usr/bin/mailx –s 'Analyze tables' tlk@nbd.kis.ru
rm $SQLFILE rm $LOGFILE
В режиме отладки приложения не разрешается доступ (открытие) базы данных. Как лечить?
Nomadic отвечает: Необходимо отключить (деинсталлировать через Oracle Installer) Trace Service на клиенте – совет от ORACLE. Глюк имеет место быть только под Windows NT 4.xx.Подскажите, как на Oracle 7.3.2.3 (Solaris x86) поменять compatible на 7.3.2.3 (c 7.1.0.0)?
Nomadic отвечает: Ставить в initmybase.oracompatible = "7.3.2.3"
и после старта с новым параметром сделать
ALTER DATABASE RESET COMPABILITY;
И рестартовать базу.
Как настроить Personal Oracle с русским языком на корректную работу с числами и BDE?
Nomadic отвечает: прописать в \HKEY_LOCAL_MACHINE\SOFTWARE\ORACLE параметр:NLS_NUMERIC_CHARACTERS = '.,'
или
после соединения с ORACLE выполнить
ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'
Как в Oracle создать sequence с некоторого номера?
Одной строкойNomadic отвечает:
create sequence minvalue 10;
Как решать некоторые вопросы при подключении к Oracle?
Nomadic отвечает:DD> 1. Все поля (TField), определенные в формах, имеющие типы TDateField, DD> TSmallIntField – при открытии таблицы ругаются: Field «…» is not of DD> expected type. Посмотрел – при переопределении их под Oracle'ом ониЧтобы «увидеть» integer-поля нужно в настройке Alias'а Oracle в BDE установить Enable Integers→True (и напрочь будет потерян Locate по этим якобы int/smallint полям). С датами, возможно, тоже надо разбираться через настройки Win & Oracle. У меня в Win дата формата «дд.мм.гггг», в Oracle NLS_LANG→AMERICAN_AMERICA.CL8MSWIN1251 и с датами все гут.
DD> 2. Используя в SQL DD> строки типа 'SELECT XX FROM YY WHERE XX="QQQ"' мы поступали DD> неправильно, DD> т.к. двойные кавычки в Oracle обрабатываются не так, как в Btrieve.Oracle в данном случае не при чем. Это глюк BDE. Лечилось просто – вместо обрамления двойными кавычками строкового значения, нужно обрамлять его с помощью #39, примерно так
MySQLString := 'SELECT XX FROM YY WHERE XX='+#39+'QQQ'+#39;
Belsky Roman
(2:450/94.75)
SS> У кого-нибудь есть опыт по настройке BDE? Откликнитесь плиз! При SS> попытке соединиться с базой вылезает ошибка: Vendor failed init! SS> Delphi запускаю под 95. Hа всякий случай пути к \BDE и ORAWIN\BIN я SS> проставил! orant71.dll (родной или переименнованый ora72win.dll) SS> закидывал куда угодно, но… все равно вылетает ошибка BDE Error SS> 15879 Vendor failed init :-(Клиент у тебя NT, как я понял? • ora7x.dll – 32bit клиент для win95 • orant7x.dll – 32bit клиент для NT • ora7xwin.dll – 16bit клиент для win т.е. ora7xwin в Delphi3 вообще ставить бесполезно (16bit для 32bit appl). ora*71.dll у меня изначально к ORACLE 7.2 не коннектился – они там как-то резко сменили OCI. Правда потом ora72win.dll с Personal Oracle 7.3 работал, но все равно лучше, наверное, чтобы номер версии dll был не ниже версии сервера. А вообще я 32bit дельфях в Vendor Init давно прописываю OCIW32.dll – он всегда для последней версии сервера с которым ты работаешь. Это IMHO. Hо у меня Delphi3 и Delphi1 коннектятся как с Oracle 7.1 на Unix'е, так и с Personal Oracle 7.3
WindowsNT 4.0 + Delphi 2.01 C/S + Oracle Client 7.3 + Oracle Server 7.3. После логина в базу данных возникает `EExternalError 0xC0000008`. Что делать?
Nomadic коротко отвечает: A: (IA, SK): Снести Oracle Trace Collection Services.Псевдонимы
Получение пути псевдонима и таблицы I
Delphi 1Есть три способа сделать это… №1 годится только для постоянных псевдонимов BDE. №2 работает с 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
Получение пути псевдонима и таблицы 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).
Получение пути псевдонима и таблицы III
Delphi 1Используйте 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;
Получение пути псевдонима и таблицы IV
Nomadic советует: 1. По таблице (фактически по Database) получить физическое местонахождение. Примечание: Database можно создать явно, если нет, Дельфи сама его создаст, доступ к ней по Table(Query).Databaseuses 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;
2. По алиасу.
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;
Информация о псевдониме BDE
Delphi 1
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;
Изменение каталога псевдонима во время выполнения приложения
Delphi 1Я делаю это все время. У меня есть 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;
Псевдоним на лету
Delphi 2Попробуйте это:
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.
Псевдонимы
Delphi 2Попробуйте следующий код:
var
theStrList : TStringList;
GPath : String;
begin
theStrList := TStringList.Create;
{Используем GetAliasParams для получения псевдонимов и ассоциированных с ними путей}
Session.GetAliasParams(<Здесь псевдоним из выпадающего списка>,theStrList);
{Удаляем первые шесть символов, которые всегда равны «PATH="}
GPath := copy(theStrList[0],6,length(theStrList[0]))
theStrList.Free;
Ошибки
Ошибка BDE32 $2104
Delphi 2Пример, приведенный для функции dbiGetDatabaseDesc в файле BDE32.HLP, неверен. Такой же пример содержится в файле TI3100.ASC. Я пробовал это на 3 разных компьютерах. Я использую среду Delphi. Ошибка, которую я получаю при попытке использования функции, выглядит следующим образом: EDBEngineError с сообщением 'Возникла ошибка при попытке инициализации Borland Database Engine (ошибка $2104).' При вызове любой из функций BDE, если вы не пользуетесь компонентами для работы с базами данных, вам необходимо инициализировать BDE вызовом dbiInit(nil). Pat Ritchey
Проблема BDE при использовании "неживого" TQuery
У меня была та же проблема, и я нашел единственное решение как ее обойти. Я подозреваю, что причина кроется в том, что Query1.Refresh ничего не делает, если установлен режим readonly, т.е. не ожидается никаких изменений. Один способ у меня прошел успешно (в предположении, что мы имеем один вход): я использовал 3 TQuerie, две сетки и форму обновления. Это способ, когда я могу установить requestlive в истину. Вы не должны допускать, чтобы пользователь мог сам редактировать табличную сетку (если это то, что вы хотите).Ошибка ApplyApdates
Делаем ApplyUpdates. Если при insert(update) произошла ошибка (поле null, сработал check, etc.), то BDE всегда говорит "General SQL Error" вместо нормального сообщения об ошибке :-( Без CU все нормально, разумеется. Как бороть этот баг? Nomadic советует: Использyй нормальнyю трансляцию ошибок в Application.OnException. Вpоде это.procedure DBExceptionTranslate(E: EDBEngineError);
function OriginalMessage: String;
var
I: Integer;
DBErr: TDBError;
S: String;
begin
Result := '';
for I := 0 to E.ErrorCount - 1 do begin
DBErr := E.Errors[I];
case DBErr.NativeError of
-836: { Intebase exception }
begin
S := DBErr.Message;
Result := #13#10 + Copy(S, Pos(#10, S) + 1, Length(S));
Exit;
end;
end;
S := Trim(DBErr.Message);
if S <> '' then Result := Result + #13#10 + S;
end;
end;
begin
case E.Errors[0].ErrorCode of
$2204:
E.Message := LoadStr(SKeyDeleted);
$271E,$2734:
E.Message := LoadStr(SInvalidUserName);
$2815:
E.Message := LoadStr(SDeadlock);
$2601:
E.Message := LoadStr(SKeyViol);
$2604:
E.Message := LoadStr(SFKViolation) + OriginalMessage;
else begin
E.Message := Format(LoadStr(SErrorCodeFmt), [E.Errors[0].ErrorCode]) + OriginalMessage;
end;
end;
end;
Ошибка создания дескриптора курсора
Delphi 1Вы должны использовать ExecSql вместо Open. К примеру, если имя вашего запроса UpdateStudent, то при необходимости обновления STUDENT.DB вы должны использовать следующий код:
Begin
…
UpdateStudent.ExecSql;
…
End;
Ваш запрос является Passtrough-запросом, который не может возвратить установленный результат, так что это не может быть открыто, а должно быть 'ВЫПОЛНЕНО'.
При разрушении обьектов, порожденных от TDataSet (TTable, TQuery), не отрабатывает событие OnBeforeClose. Что делать?
Nomadic отвечает: Недоработка в VCL. Сейчас вышел из ситуации так: в TForm.OnClose, т.е. пока ещё все компоненты формы живы, делаю CloseDatabases(Self).При обращении к memo-полю из BDE возникает ошибка 'Memo too large'. Как лечить?
Nomadic отвечает: В BDE есть крутая ошибка, достаточно известная всем, кроме Borland'a. Поскольку они ее еще с 1й Delphi не исправили. Этот баг проявляется как Access Violation в программе при обращении к таблице IB, которая содержит более одного поля типа VARCHAR (или CHAR) размером>255. Причем, первое поле меньшего, а второе большего размера. Если поменять местами поля или сделать их одного размера, то все нормально. Эффект имеет место только с IB, вроде.Нарушение уникальности записи
Delphi 1
try
tMyTable.Post;
except
on E : EDBEngineError do if E.Message = 'Key violation' then begin
MessageDlgC('Дублирование записи не допускается.' mtError, [mbOk], 0);
// Я не уверен в том, что это нужно делать:
tMyTable.Cancel;
end
else Raise;
end;
Хорошим примером может служить проект DBERRORS.DPR, расположенный в каталоге Delphi 2 Demos. Выглядит это примерно так:
Создайте функцию типа этой:
function DBError(DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction);
const eKeyViol = 9729;
var iDBIError: Integer;
begin
if (E is EDBEngineError) then begin
iDBIError := (E as EDBEngineError).Errors[0].Errorcode;
case iDBIError of
eKeyViol:
begin
MessageDlg('Нарушение уникальности записи ', mtWarning, [mbOK], 0);
Abort;
end;
end;
Затем для каждой таблицы вашего приложения создайте следующий обработчик события:
procedure TMainForm.Table1EditError(DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction);
begin
DBError(Table1, E, Action);
end;
Таким образом вы можете перехватить множество ошибок. Смотрите примеры от Borland, там много чего есть полезного.
При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается 'multiple records found, but only one was expected'. Как лечить?
Nomadic отвечает: Запросы вида SELECT c, b, a, q FROM T WHERE b = :b, где ключ c, но BDE посчитала ключом a. Интересный запрос, да? Такое впечатление, что, поскольку ключом в исходной таблице являлась третья колонка, то Дельфы посчитали ключом третью колонку. Перестановкой SELECT a, b, c, q… все исправилось. Я решил теперь использовать в таких (live) запросах только SELECT *.Как поймать свой RAISEERROR в Delphi?
Nomadic отвечает:procedure TFDMUtils.GeneralError( DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction);
var
i: Word;
ExtInfo : String;
begin
ExtInfo := '';
if (E is EDBEngineError) then begin
if (EDBEngineError(E).Errors[0].NativeError = 0) then begin // Local Error
if EDBEngineError(E).Errors[0].Errorcode = 9732 then
ExtInfo := DataSet.FieldByName(trim(copy(E.Message, 29, 20))).DisplayLabel;
.......................................
end
else begin // Remote SQL Server error
ExtInfo := ExtractFieldLabels(DataSet, E.Message);
case EDBEngineError( E ).Errors[0].NativeError of
233, 515:
Alert('Ошибка', 'Hе все поля заполнены ! ' + ExtInfo);
547:
if (StrPos(PChar(E.Message), PChar('DELETE')) <> nil) then
Alert('Ошибка пpи удалении', 'Имеются подчиненные записи, удаление (изменение) невозможно! ' + ExtInfo)
else if (StrPos(PChar(E.Message), PChar('INSERT')) <> nil) then
Alert('Ошибка пpи вставке', 'Отсутствует запись в МАСТЕР-таблице!' + ExtInfo)
else if (StrPos(PChar(E.Message), PChar('UPDATE')) <> nil) then
Alert('Ошибка пpи обновлении', 'Отсутствует запись в МАСТЕР-таблице! ' + ExtInfo);
2601:
Alert('Ошибка', 'Такая запись уже есть!');
else
Alert('Ошибка', 'Hеизвестная ошибка, код – ' + inttostr(EDBEngineError(E).Errors[0].NativeError) + ExtInfo);
end;
end;
end;
end;
Этот код был заточен под MSSQL, но не нужно пытаться его использовать, а лучше по этому пpимеpу написать свою процедуру.
Как добиться верной работы фильтра на запросах и на неиндексированных таблицах?
Nomadic отвечает: (Т.е. при работе программы наблюдалась следующая картина: в результате очередной фильтрации оставалось видно 4 записи из восьми. Добавляем букву к фильтру, остается, допустим, две. Убираем букву, которую только что добавили, в гриде все равно видно только две записи) Эта проблема была в Delphi 3.0 только на TQuery, а в Delphi 3.01 появилась и в TTable. Лечится так (простой пример):procedure TMainForm.Edit1Change(Sender: TObject);
begin
if length(Edit1.Text) > 0 then begin
Table1.Filtered := TRUE;
UpdateFilter(Table1);
end
else Table1.Filtered := FALSE;
end;
procedure TMainForm.UpdateFilter(DataSet: TDataSet);
var FR: TFilterRecordEvent;
begin
with DataSet do begin
FR := OnFilterRecord;
if Assigned(FR) and Active then begin
DisableControls;
try
OnFilterRecord := nil;
OnFilterRecord := FR;
finally
EnableControls;
end;
end;
end;
end;
Как бы мне соорудить в SP исключение, чтобы его увидел Delphi-клиент?
Nomadic отвечает: sqlstate='99999' не подходит, так как хочется на клиенте видеть код исключения. Используй RAISERROR с кодом >20000. Если еще при этом научишься без потерь передавать на Delphi-клиента русские ругательства, то скажи мне как ты этого добился :).Когда я применяю ApplyUpdates на ClientDataSet, на серверной стороне не срабатывает событие OnNewRecord для оригинального набора данных. Как это исправить?
Nomadic отвечает: Никак. Эти обновления идут прямо через BDE, а не через компонент набора данных. В Delphi 4.0 (C++Builder 4.0) ситуация радикально изменилась. Во-первых, обычному провайдеру данных (TProvider) можно указать, каким образом обновлять данные. Во-вторых, новый тип провайдера (TDataSetProvider) работает только через соответвующие методы TDataSet. То есть – все события при данных условиях на сервере будут отрабатываться обычным образом. Если же Вы пользуетесь более старой версией Delphi, то, как обычно, можно посоветовать использование хранимых процедур, в данном контексте это будут методы сервера приложений. К сожалению, совет неприемлем для транспорта Sockets.SQL
Функции дат в SQL
Тема: Функции дат в SQL Кто-нибудь знает как «вытащить» месяц или год из datetime-поля с помощью SQL? Я знаю, что QBE этого не может. SQL в состоянии это сделать? Как насчет функции EXTRACT?SELECT SALEDATE,
EXTRACT(DAY FROM SALEDATE) AS DD,
EXTRACT(MONTH FROM SALEDATE) AS MM,
EXTRACT(YEAR FROM SALEDATE) AS YY
FROM ORDERS
Steve Koterski
Зарезервированные слова Local SQL
Ниже приведен список в алфавитном порядке слов, зарезервированных Local SQL в Borland Database Engine. Имейте в виду, что данный совет публикуется «как есть».ACTIVE, ADD, ALL, AFTER, ALTER, AND, ANY, AS, ASC, ASCENDING, AT, AUTO, AUTOINC, AVG
BASE_NAME, BEFORE, BEGIN, BETWEEN, BLOB, BOOLEAN, BOTH, BY, BYTES
CACHE, CAST, CHAR, CHARACTER, CHECK, CHECK_POINT_LENGTH, COLLATE, COLUMN, COMMIT, COMMITTED, COMPUTED, CONDITIONAL, CONSTRAINT, CONTAINING, COUNT, CREATE, CSTRING, CURRENT, CURSOR
DATABASE, DATE, DAY, DEBUG, DEC, DECIMAL, DECLARE, DEFAULT, DELETE, DESC, DESCENDING, DISTINCT, DO, DOMAIN, DOUBLE, DROP
ELSE, END, ENTRY_POINT, ESCAPE, EXCEPTION, EXECUTE, EXISTS, EXIT, EXTERNAL, EXTRACT
FILE, FILTER, FLOAT, FOR, FOREIGN, FROM, FULL, FUNCTION
GDSCODE, GENERATOR, GEN_ID, GRANT, GROUP, GROUP_COMMIT_WAIT_TIME
HAVING, HOUR
IF, IN, INT, INACTIVE, INDEX, INNER, INPUT_TYPE, INSERT, INTEGER, INTO, IS, ISOLATION
JOIN
KEY
LONG, LENGTH, LOGFILE, LOWER, LEADING, LEFT, LEVEL, LIKE, LOG_BUFFER_SIZE
MANUAL, MAX, MAXIMUM_SEGMENT, MERGE, MESSAGE, MIN, MINUTE, MODULE_NAME, MONEY, MONTH
NAMES, NATIONAL, NATURAL, NCHAR, NO, NOT, NULL, NUM_LOG_BUFFERS, NUMERIC
OF, ON, ONLY, OPTION, OR, ORDER, OUTER, OUTPUT_TYPE, OVERFLOW
PAGE_SIZE, PAGE, PAGES, PARAMETER, PASSWORD, PLAN, POSITION, POST_EVENT, PRECISION, PROCEDURE, PROTECTED, PRIMARY, PRIVILEGES
RAW_PARTITIONS, RDB$DB_KEY, READ, REAL, RECORD_VERSION, REFERENCES, RESERV, RESERVING, RETAIN, RETURNING_VALUES, RETURNS, REVOKE, RIGHT, ROLLBACK
SECOND, SEGMENT, SELECT, SET, SHARED, SHADOW, SCHEMA, SINGULAR, SIZE, SMALLINT, SNAPSHOT, SOME, SORT, SQLCODE, STABILITY, STARTING, STARTS, STATISTICS, SUB_TYPE, SUBSTRING, SUM, SUSPEND
TABLE, THEN, TIME, TIMESTAMP, TIMEZONE_HOUR, TIMEZONE_MINUTE, TO, TRAILING, TRANSACTION, TRIGGER, TRIM
UNCOMMITTED, UNION, UNIQUE, UPDATE, UPPER, USER
VALUE, VALUES, VARCHAR, VARIABLE, VARYING, VIEW
WAIT, WHEN, WHERE, WHILE, WITH, WORK, WRITE
YEAR
Операторы:
||, –, *, /, <>, <, >, ,(запятая), =, <=, >=, ~=, !=, ^=, (, )
Сиротские Master-записи
Как с помощью SQL найти записи таблицы, которых нет в другой таблице? Вот пример:with PeopleHiddenForm.PersonQuery.SQL do begin
Add('Select P.Last, P.First, P.Middle, P."Suffix", P.KeyNo, COUNT(PersMemL.PersonKeyNo)');
Add('From Person P Left Outer Join ');
Add(' PersMemL PersMemL');
Add('On ((P.KeyNo = PersMemL.PersonKeyNo))');
Add('Group By P.Last, P.First, P.Middle, P.Suffix, P.KeyNo');
Add('Having ((Count(PersmemL.PersonKeyNo) = 0))');
Данный код позволяет связаться с таблицей (PersMemL), содержащей количество ключей персональной записи и запись членства. Запрос возвращает имена персон, которые не имеют записей членства.
На практике этот способ оказывается очень эффективным, по крайней мере, с локальным SQL в таблицах Paradox.
David G. Wachtel
Назначение SQL-счетчика переменной
Delphi 1
query.Close;
query.SQL.Clear;
query.SQL.Add('select count(*) from table where field = :XXX');
Query.ParamByName('XXX').AsString := value;
query.Open;
while Query.Eof <> True do begin
SqlCount := Query.Fields[0].AsInteger;
Query.Next
end;
Подразумевается наличие компонентов TTable, TQuery, TStoredProc
Объявление
property RecordCount: Longint;
Описание
Времени исполнения и только для чтения. Свойство RecordCount определяет количество записей в наборе данных. Количество возвращаемых записей может зависеть от сервера и не зависит от границ задаваемого диапазона.
Как удобнее работать с динамически формируемыми запросами?
Nomadic советует: В процессе работы с БД иногда необходимо выполнить какие-то мелкие запросы. Держать для этого где-то временную Query меня лично ломает, посему ловите творение (под Delphi) — модуль для создания временных TQuery и работы с ними. примеры использования:
var S: string;
…
S := FastLookUp(format('select A.F1 from A,B where A.F4=B.F4 and B.F9=%d', [1]));
with GiveMeResultSet( 'select*from A where F1="777"' ) do try
……
finally
Free; {не забудьте!}
end;
…
if NOT ExecuteSQL('delete from A') then ShowMessage('Something Wrong');
……
Сам модуль идёт ниже —
{
Temporary Queries Creatin' and handlin'
(c) 1997-98 by Volok Alexander (D1/D2)
creation date: 30.10.1997
last update : 17.06.1998
}
unit TmpQuery;
interface
uses DBTables;
const InternalDBname = 'MAIN'; {Изменять по вкусу - TDataBase.DataBaseName}
type TSQLScript = {$IFDEF WIN32} string {$ELSE} PChar {$ENDIF};
{Создаст куери с текстом запроса, но не откроет его}
function CreateTempQuery(SQLscript: TSQLscript): TQuery;
{Создаст куери и откроет запрос - не забудьте прибить}
function GiveMeResultSET(SQLscript: TSQLscript):TQuery;
{Проверит непустоту выборки, заданной ...}
function CheckExistence(SQLscript: TSQLscript): boolean;
{Вытащит аж одно значение(лукап) из выборки, заданной ...}
function FastLookUP(SQLscript: TSQLscript): string;
{Выполнит запрос и сообщит результат}
function ExecuteSQL(SQLscript: TSQLscript): boolean;
implementation
uses Forms;
function CreateTempQuery(SQLscript: TSQLscript): TQuery;
begin
Result:= TQuery.Create(Application);
with Result do begin
DatabaseName := InternalDBname;
{$IFDEF WIN32}
SQL.Text := SQLscript;
{$ELSE}
SQL.SetText(SQLscript);
{$ENDIF}
end;
end;
function ExecuteSQL(SQLscript: TSQLscript): boolean;
begin
with CreateTempQuery(SQLscript) do begin
try
ExecSQL;
Result := True;
except
Result := False;
end;
Free;
end;
end;
function CheckExistence(SQLscript: TSQLscript): boolean;
begin
with GiveMeResultSET(SQLscript) do begin
Result := NOT EOF;
Free;
end;
end;
function GiveMeResultSET(SQLscript: TSQLscript): TQuery;
begin
Result := CreateTempQuery(SQLscript);
with Result do try
Open;
except
Free;
Result:= NIL;
end;
end;
function FastLookUP(SQLscript: TSQLscript): string;
begin
with GiveMeResultSET(SQLscript) do begin
try
Result:= Fields[0].AsString;
except
Result:= '';
end;
Free;
end;
end;
end.
Поиск записи в SQL DataSet
Delphi 1В случае изменения содержимого полей редактирования сделайте следующее:
Query1.Close;
Query1.SQL.Clear;
Query1.SQL.Add('SELECT * FROM <таблица> WHERE <поле> LIKE ''' + SpeedEdit.Text + '*''');
Query1.Open;
Будут возвращены все записи, указанные в поле редактирования.
При попытке выполнения такого оператора SQL – 'DELETE from T39 T39C0 WHERE T39C0.F1LHT35=253291661' SQL-сервер ругается на недопустимый синтаксис. В чем я неправ?
Nomadic отвечает: В данном случае, видимо, T39C0 расценивается как псевдоним. Hо стандартом SQL-92 такое запрещено в DELETE. Цитата собственно из этого стандарта (сборник из delete и names and identifiers, определение identifier пропущено, просто набор <simple latin letter> | <digit>, начинается с буквы):Format <delete statement: positioned>::= delete from <table name> where current of <cursor name>
<table name> ::= <qualified name> | <qualified local name>
<qualified name> ::= [<shema name><period>] [<qualified identifier>]
<qualified identifier> ::=<identifier>
<shema name>::=[<catalog name><period>]<unqualified shema name>
<unqualified shema name>::=<identifier>
<catalog name>::=<identifier>
<qualified local name>::= MODULE <period><local table name>
<local table name>::=<qualified identifier>
Стандартом запрещено вот такое
select test.a, p_test.a from test p_test;
вот это не по стандарту, хотя Microsoft SQL Server такое ест.
Поиск с помощью SQL
Delphi 1Предположим: 1. если вашей таблицы определены следующие поля…
last_name char (n),
first_name char (n)
то…
select
last_name+', '+first_name
from
person
where
first_name='john'
2. если вашей таблицы определены следующие поля…
person_name char (n) (например, Lennon, John)
то…
select
person_name
from
person
where
person_name like '%John' <--- 'John' должен быть в конце строки, еще используйте '%John%'
Как получить результирующим полем разницу между хранимой датой и текущей датой?
Nomadic отвечает:SELECT CAST((поле_с_датой –"NOW") AS INTEGER) FROM MyBase
Получишь результат в днях.
SQL и поле даты
Delphi 1Есть множество способов сделать это: 1. Если дата константа, используйте:
WHERE Date = #31/11/95#
В зависимости от «настроек вашей страны», это могло бы быть и #11/31/95#. Попробуйте оба: один из них работает.
2. Если дата является переменной, вы должны воспользоваться параметром, например так:
WHERE Date = :MyDate
Затем, после нажатия на ok, выберите в Инспекторе Объектов для Query свойство Params, нажмите на кнопку с тремя точками, и установите MyDate как тип Date.
SELECT * from PFMANUAL WHERE PRMANUAL."DATE" = "31/11/95"
Я обнаружил это после решения аналогичной проблемы, когда для создания QBE-запроса я использовал DataBase Desktop, а затем «переводил» запрос на SQL.
SQL-запросы в Delphi
Примечание: Данный документ представляет собой коллективный труд нескольких авторов, которые индивидуально несут ответственность за качество предоставленной здесь информации. Borland не предоставлял, и не может предоставить никакой гарантии относительно содержимого данного документа.
1. Введение
Компоненты Delphi для работы с базами данных были созданы в расчете на работу с SQL и архитектурой клиент/сервер. При работе с ними вы можете воспользоваться характеристиками расширенной поддержки удаленных серверов. Delphi осуществляет эту поддержку двумя способами. Во-первых, непосредственные команды из Delphi позволяют разработчику управлять таблицами, устанавливать пределы, удалять, вставлять и редактировать существующие записи. Второй способ заключается в использовании запросов на языке SQL, где строка запроса передается на сервер для ее разбора, оптимизации, выполнения и передачи обратно результатов. Данный документ делает акцент на втором методе доступа к базам данных, на основе запросов SQL (pass-through). Авторы не стремились создать курсы по изучению синтаксиса языка SQL и его применения, они ставили перед собой цель дать несколько примеров использования компонентов TQuery и TStoredProc. Но чтобы сделать это, необходимо понимать концепцию SQL и знать как работают selects, inserts, updates, views, joins и хранимые процедуры (stored procedures). Документ также вскользь касается вопросов управления транзакциями и соединения с базой данных, но не акцентирует на этом внимание. Итак, приступая к теме, создайте простой запрос типа SELECT и отобразите результаты.2. Компонент TQuery
Если в ваших приложениях вы собираетесь использовать SQL, то вам непременно придется познакомиться с компонентом TQuery. Компоненты TQuery и TTable наследуются от TDataset. TDataset обеспечивает необходимую функциональность для получения доступа к базам данных. Как таковые, компоненты TQuery и TTable имеют много общих признаков. Для подготовки данных для показа в визуальных компонентах используется все тот же TDatasource. Также, для определения к какому серверу и базе данных необходимо получить доступ, необходимо задать имя псевдонима. Это должно выполняться установкой свойства aliasName объекта TQuery.Свойство SQL
Все же TQuery имеет некоторую уникальную функциональность. Например, у TQuery имеется свойство с именем SQL. Свойство SQL используется для хранения SQL-запроса. Ниже приведены основные шаги для составления запроса, где все служащие имеют зарплату свыше $50,000. 1. Создайте объект TQuery 2. Задайте псевдоним свойству DatabaseName. (Данный пример использует псевдоним IBLOCAL, связанный с демонстрационной базой данных employee.gdb). 3. Выберите свойство SQL и щелкните на кнопке с текстом - '…' (три точки, Инспектор Объектов — В.О.). Должен появиться диалог редактора списка строк (String List Editor). 4. Введите: Select * from EMPLOYEE where SALARY>50000. Нажмите OK. 5. Выберите в Инспекторе Объектов свойство Active и установите его в TRUE. 6. Разместите на форме объект TDatasource. 7. Установите свойство Dataset у TDatasource в Query1. 8. Разместите на форме TDBGrid. 9. Установите его свойство Datasource в Datasource1. Свойство SQL имеет тип TStrings. Объект TStrings представляет собой список строк, и чем-то похож на массив. Тип данных TStrings имеет в своем арсенале команды добавления строк, их загрузки из текстового файла и обмена данными с другим объектом TStrings. Другой компонент, использующий TStrings — TMemo. В демонстрационном проекте ENTRSQL.DPR (по идее, он должен находится на отдельной дискетте, но к "Советам по Delphi" она не прилагается — В.О.), пользователь должен ввести SQL-запрос и нажать кнопку "Do It" ("сделать это"). Результаты запроса отображаются в табличной сетке. В Листинге 1 полностью приведен код обработчика кнопки "Do It".Листинг 1
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Query1.close; {Деактивируем запрос в качестве одной из мер предосторожности }
Query1.SQL.Clear; {Стираем любой предыдущий запрос}
If Memo1.Lines[0] <> '' {Проверяем на предмет пустого ввода} then
Query1.SQL.Add(Memo1.Text) {Назначаем свойству SQL текст Memo}
else begin
messageDlg('Не был введен SQL-запрос', mtError, [mbOK], 0);
exit;
end;
try {перехватчик ошибок}
Query1.Open; {Выполняем запрос и открываем набор данных}
except {секция обработки ошибок}
On e : EDatabaseError do {e – новый дескриптор ошибки}
messageDlg(e.message, mtError, [mbOK],0); {показываем свойство message объекта e}
end; {окончание обработки ошибки}
end;
Свойство Params
Этого должно быть достаточно для пользователя, знающего SQL. Тем не менее, большинство пользователей не знает этого языка. Итак, ваша работа как разработчика заключается в предоставлении интерфейса и создании SQL-запроса. В Delphi, для создания SQL-запроса на лету можно использовать динамические запросы. Динамические запросы допускают использование параметров. Для определения параметра в запросе используется двоеточие (:), за которым следует имя параметра. Ниже приведе пример SQL-запроса с использованием динамического параметра:select * from EMPLOYEE
where DEPT_NO = :Dept_no
Если вам нужно протестировать, или установить для параметра значение по умолчанию, выберите свойство Params объекта Query1. Щелкните на кнопке '…'. Должен появиться диалог настройки параметров. Выберите параметр Dept_no. Затем в выпадающем списке типов данных выберите Integer. Для того, чтобы задать значение по умолчанию, введите нужное значение в поле редактирования «Value».
Для изменения SQL-запроса во время выполнения приложения, параметры необходимо связать (bind). Параметры могут изменяться, запрос выполняться повторно, а данные обновляться. Для непосредственного редактирования значения параметра используется свойство Params или метод ParamByName. Свойство Params представляет из себя массив TParams. Поэтому для получения доступа к параметру, необходимо указать его индекс. Для примера,
Query1.params[0].asInteger := 900;
Свойство asInteger читает данные как тип Integer (название говорит само за себя). Это не обязательно должно указывать но то, что поле имеет тип Integer. Например, если тип поля VARCHAR(10), Delphi осуществит преобразование данных. Так, приведенный выше пример мог бы быть записан таким образом:
Query1.params[0].asString := '900';
или так:
Query1.params[0].asString := edit1.text;
Если вместо номера индекса вы хотели бы использовать имя параметра, то воспользуйтесь методом ParamByName. Данный метод возвращает объект TParam с заданным именем. Например:
Query1.ParamByName('DEPT_NO').asInteger := 900;
В листинге 2 приведен полный код примера.
Листинг 2
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Query1.close; {Деактивируем запрос в качестве одной из мер предосторожности }
if not Query1.prepared then
Query1.prepare; {Убедимся что запрос подготовлен}
{Берем значение, введенное пользователем и заменяемим параметр.}
if edit1.text <> '' {Проверяем на предмет пустого ввода} then
Query1.ParamByName('DEPT_NO').AsString := edit1.text
else Begin
Query1.ParamByName('DEPT_NO').AsInteger := 0;
edit1.text := '0';
end;
try {перехватчик ошибок}
Query1.Open; {Выполняем запрос и открываем набор данных}
except {секция обработки ошибок}
On e : EDatabaseError do {e – новый дескриптор ошибки}
messagedlg(e.message, mtError, [mbOK],0); {показываем свойство message объекта e}
end; {окончание обработки ошибки}
end;
Обратите внимание на процедуру, первым делом подготовливающую запрос. При вызове метода prepare, Delphi посылает SQL запрос на удаленный сервер. Сервер выполняет грамматический разбор и оптимизацию запроса. Преимущество такой подготовки запроса состоит в его предварительном разборе и оптимизации. Альтернативой здесь может служить подготовка сервером запроса при каждом его выполнении. Как только запрос подготовлен, подставляются необходимые новые параметры, и запрос выполняется.
Источник данных
В предыдущем примере пользователь мог ввести номер отдела, и после выполнения запроса отображался список сотрудников этого отдела. А как насчет использования таблицы DEPARTMENT, позволяющей пользователю легко перемещаться между пользователями и отделами? Примечание: Следующий пример использует TTable с именем Table1. Для Table1 имя базы данных IBLOCAL, имя таблицы – DEPARTMENT. DataSource2 TDatasource связан с Table1. Таблица также активна и отображает записи в TDBGrid. Способ подключения TQuery к TTable – через TDatasource. Есть два основных способа сделать это. Во-первых, разместить код в обработчике события TDatasource OnDataChange. Например, листинг 3 демонстрирует эту технику.Листинг 3 – Использования события OnDataChange для просмотра дочерних записей
procedure TForm1.DataSource2DataChange(Sender: TObject; Field: TField);
begin
Query1.Close;
if not Query1.prepared then Query1.prepare;
Query1.ParamByName('Dept_no').asInteger := Table1Dept_No.asInteger;
try
Query1.Open;
except On e : EDatabaseError do
messageDlg(e.message, mtError, [mbOK], 0);
end;
end;
Техника с использованием OnDataChange очень гибка, но есть еще легче способ подключения Query к таблице. Компонент TQuery имеет свойство Datasource. Определяя TDatasource для свойства Datasource, объект TQuery сравнивает имена параметров в SQL-запросе с именами полей в TDatasource. В случае общих имен, такие параметры заполняются автоматически. Это позволяет разработчику избежать написание кода, приведенного в листинге 3 (*** приведен выше ***).
Фактически, техника использования Datasource не требует никакого дополнительного кодирования. Для поключения запроса к таблице DEPT_NO выполните действия, приведенные в листинге 4.
Листинг 4 – Связывание TQuery c TTable через свойство Datasource
Выберите у Query1 свойство SQL и введите:select * from EMPLOYEE
where DEPT_NO = :dept_no
Выберите свойство Datasource и назначьте источник данных, связанный с Table1 (Datasource2 в нашем примере)
Выберите свойство Active и установите его в True
Это все, если вы хотите создать такой тип отношений. Тем не менее, существуют некоторые ограничения на параметризованные запросы. Параметры ограничены значениями. К примеру, вы не можете использовать параметр с именем Column или Table. Для создания запроса, динамически изменяемого имя таблицы, вы могли бы использовать технику конкатенации строки. Другая техника заключается в использовании команды Format.
Команда Format
Команда Format заменяет параметры форматирования (%s, %d, %n и пр.) передаваемыми значениями. Например,Format('Select * from %s', ['EMPLOYEE'])
Результатом вышеприведенной команды будет 'Select * from EMPLOYEE'. Функция буквально делает замену параметров форматирования значениями массива. При использовании нескольких параметров форматирования, замена происходит слева направо. Например,
tblName := 'EMPLOYEE';
fldName := 'EMP_ID';
fldValue := 3;
Format('Select * from %s where %s=%d', [tblName, fldName, fldValue])
Результатом команды форматирования будет 'Select * from EMPLOYEE where EMP_ID=3'. Такая функциональность обеспечивает чрезвычайную гибкость при динамическом выполнении запроса. Пример, приведенный ниже в листинге 5, позволяет вывести в результатах поле salary. Для поля salary пользователь может задавать критерии.
Листинг 5 – Использование команды Format для создания SQL-запроса
procedure TForm1.BitBtn1Click(Sender: TObject);
var
sqlString : string; {здесь хранится SQL-запрос}
fmtStr1, fmtStr2 : string; {здесь хранится строка, передаваемая для форматирования}
begin
{ Создание каркаса запроса }
sqlString := 'Select EMP_NO %s from employee where SALARY %s';
if showSalaryChkBox.checked {Если checkbox Salary отмечен} then
fmtStr1 := ', SALARY'
else fmtStr1 := '';
if salaryEdit.text <> '' { Если поле редактирования Salary не пустое } then
fmtStr2 := salaryEdit.text
else fmtStr2 := '>0';
Query1.Close; {Деактивируем запрос в качестве одной из мер предосторожности }
Query1.SQL.Clear; {Стираем любой предыдущий запрос}
Query1.SQL.Add(Format(sqlString,[fmtStr1, fmtStr2])); {Добавляем}
{форматированную строку к свойству SQL}
try {перехватчик ошибок}
Query1.Open; {Выполняем запрос и открываем набор данных}
except {секция обработки ошибок}
On e : EDatabaseError do {e – новый дескриптор ошибки}
messageDlg(e.message, mtError,[mbOK],0);
{показываем свойство message объекта e}
end; {окончание обработки ошибки}
end;
В этом примере мы используем методы Clear и Add свойства SQL. Поскольку «подготовленный» запрос использует ресурсы сервера, и нет никакой гарантии что новый запрос будет использовать те же таблицы и столбцы, Delphi, при каждом изменении свойства SQL, осуществляет операцию, обратную «подготовке» (unprepare). Если TQuery не был подготовлен (т.е. свойство Prepared установлено в False), Delphi автоматически подготавливает его при каждом выполнении. Поэтому в нашем случае, даже если бы был вызван метод Prepare, приложению от этого не будет никакой пользы.
Open против ExecSQL
В предыдущих примерах TQuerie выполняли Select-запросы. Delphi рассматривает результаты Select-запроса как набор данных, типа таблицы. Это просто один класс допустимых SQL-запросов. К примеру, команда Update обновляет содержимое записи, но не возвращает записи или какого-либо значения. Если вы хотите использовать запрос, не возвращающий набор данных, используйте ExecSQL вместо Open. ExecSQL передает запрос для выполнения на сервер. В общем случае, если вы ожидаете, что получите от запроса данные, то используйте Open. В противном случае допускается использование ExecSQL, хотя его использование с Select не будет конструктивным. Листинг 6 содержит код, поясняющий сказанное на примере.Листинг 6
procedure Form1.BitBtnClick(sender : TObject)
begin
Query1.Close;
Query1.Clear;
Query1.SQL.Add('Update SALARY from EMPLOYEE ' +'where SALARY<:salary values (SALARY*(1+:raise)');
Query1.paramByName('salary').asString := edit1.text;
Query1.paramByName('raise').asString := edit2.text;
try
Query1.ExecSQL;
except On e : EDatabaseError do
messageDlg(e.message, mtError, [mbOK], 0);
end;
end;
Все приведенные выше примеры предполагают использования в ваших приложениях запросов. Они могут дать солидное основание для того, чтобы начать использовать в ваших приложениях TQuery. Но все же нельзя прогнозировать конец использования SQL в ваших приложених. Типичные серверы могут предложить вам другие характеристики, типа хранимых процедур и транзакций. В следующих двух секциях приведен краткий обзор этих средств.
3. Компонент TStoredProc
Хранимая процедура представляет собой список команд (SQL или определенного сервера), хранимых и выполняемых на стороне сервера. Хранимые процедуры не имеют концептуальных различий с другими типами процедур. TStoredProc наследуется от TDataset, поэтому он имеет много общих характеристик с TTable и TQuery. Особенно заметно сходство с TQuery. Поскольку хранимые процедуры не требуют возврата значений, те же правила действуют и для методов ExecProc и Open. Каждый сервер реализует работу хранимых процедур с небольшими различиями. Например, если в качестве сервера вы используете Interbase, хранимые процедуры выполняются в виде Select-запросов. Например, чтобы посмотреть на результаты хранимой процедуры, ORG_CHART, в демонстрационной базе данных EMPLOYEE, используйте следующих SQL-запрос:Select * from ORG_CHART
При работе с другими серверами, например, Sybase, вы можете использовать компонент TStoredProc. Данный компонент имеет свойства для имен базы данных и хранимой процедуры. Если процедура требует на входе каких-то параметров, используйте для их ввода свойство Params.
4. TDatabase
Компонент TDatabase обеспечивает функциональность, которой не хватает TQuery и TStoredProc. В частности, TDatabase позволяет создавать локальные псевдонимы BDE, так что приложению не потребуются псевдонимы, содержащиеся в конфигурационном файле BDE. Этим локальным псевдонимом в приложении могут воспользоваться все имеющиеся TTable, TQuery и TStoredProc. TDatabase также позволяет разработчику настраивать процесс подключения, подавляя диалог ввода имени и пароля пользователя, или заполняя необходимые параметры. И, наконец, самое главное, TDatabase может обеспечивать единственную связь с базой данных, суммируя все операции с базой данных через один компонент. Это позволяет элементам управления для работы с БД иметь возможность управления транзакциями. Транзакцией можно считать передачу пакета информации. Классическим примером транзакции является передача денег на счет банка. Транзакция должна состоять из операции внесения суммы на новый счет и удаления той же суммы с текущего счета. Если один из этих шагов по какой-то причине был невыполнен, транзакция также считается невыполненной. В случае такой ошибки, SQL сервер позволяет выполнить команду отката (rollback), без внесения изменений в базу данных. Управление транзакциями зависит от компонента TDatabase. Поскольку транзакция обычно состоит из нескольких запросов, вы должны отметить начало транзакции и ее конец. Для выделения начала транзакции используйте TDatabase.BeginTransaction. Как только транзакция начнет выполняться, все выполняемые команды до вызова TDatabase.Commit или TDatabase.Rollback переводятся во временный режим. При вызове Commit все измененные данные передаются на сервер. При вызове Rollback все изменения теряют силу. Ниже в листинге 7 приведен пример, где используется таблица с именем ACCOUNTS. Показанная процедура пытается передать сумму с одного счета на другой.Листинг 7
procedure TForm1.BitBtn1Click(Sender: TObject);
{ ПРИМЕЧАНИЕ: Поле BALANCE у ACCOUNTS имеет триггер, проверяющийситуацию, когда вычитаемая сумма превышает BALANCE. Если так, UPDATEбудет отменен}
begin
try
database1.StartTransaction;
query1.SQL.Clear;
{ Вычитаем сумму из выбранного счета }
query1.SQL.Add(Format('update ACCOUNTS ' +'set BALANCE = BALANCE - %s ) ' +'where ACCT_NUM = %s ',[edit1.text,Table1Acct_Num.asString]));
query1.ExecSQL;
query1.SQL.Clear;
{ Добавляем сумму к выбранному счету }
query1.SQL.Add(Format('update ACCOUNTS ' +'set BALANCE = BALANCE + %s ' +'where ACCT_NUM = %s ',[edit1.text,Table2Acct_Num.asString]));
query1.ExecSQL;database1.Commit; {В этом месте делаем все изменения}
table1.Refresh;
table2.Refresh;
except
{При возникновении в приведенном коде любых ошибок,откатываем транзакцию назад}
One : EDatabaseError do
begin
messageDlg(e.message, mtError, [mbOK], 0);
database1.rollback;
exit;
end;
One : Exception do
begin
messageDlg(e.message, mtError, [mbOK], 0);
database1.rollback;
exit;
end;
end;
end;
И последнее, что нужно учесть при соединении с базой данных. В приведенном выше примере, TDatabase использовался в качестве единственного канала для связи с базой данных, поэтому было возможным выполнение только одной транзакции. Чтобы выполнить это, было определено имя псевдонима (Aliasname). Псевдоним хранит в себе информацию, касающуюся соединения, такую, как Driver Type (тип драйвера), Server Name (имя сервера), User Name (имя пользователя) и другую. Данная информация используется для создания строки соединения (connect string). Для создания псевдонима вы можете использовать утилиту конфигурирования BDE, или, как показано в примере ниже, заполнять параметры во время выполнения приложения.
TDatabase имеет свойство Params, в котором хранится информация соединения. Каждая строка Params является отдельным параметром. В приведенном ниже примере пользователь устанавливает параметр User Name в поле редактирования Edit1, а параметр Password в поле Edit2. В коде листинга 8 показан процесс подключения к базе данных:
Листинг 8
procedure TForm1.Button1Click(Sender: TObject);
begin
try
With database1 do begin
Close;
DriverName := 'INTRBASE';
KeepConnection := TRUE;
LoginPrompt := FALSE;
With database1.Params do begin
Clear;
Add('SERVER NAME=C:\IBLOCAL\EXAMPLES\EMPLOYEE.GDB');
Add('SCHEMA CACHE=8');
Add('OPEN MODE=READ/WRITE');
Add('SQLPASSTHRU MODE=SHARED NOAUTOCOMMIT');
Add('USER NAME=' + edit1.text);
Add('PASSWORD=' + edit2.text);
end;
Open;
end;
session.getTableNames(database1.databasename, '*', TRUE, TRUE, ComboBox1.items);
Except One : EDatabaseError do
begin
messageDlg(e.message, mtError, [mbOK], 0);
end;
end;
end;
Этот пример показывает как можно осуществить подключение к серверу без создания псевдонима. Ключевыми моментами здесь являются определение DriverName и заполнение Params информацией, необходимой для подключения. Вам не нужно определять все параметры, вам необходимо задать только те, которые не устанавливаются в конфигурации BDE определенным вами драйвером базы данных. Введенные в свойстве Params данные перекрывают все установки конфигурации BDE. Записывая параметры, Delphi заполняет оставшиеся параметры значениями из BDE Config для данного драйвера. Приведенный выше пример также вводит такие понятия, как сессия и метод GetTableNames. Это выходит за рамки обсуждаемой темы, достаточно упомянуть лишь тот факт, что переменная session является дескриптором database engine. В примере она добавлена только для «показухи».
Другой темой является использование SQLPASSTHRU MODE. Этот параметр базы данных отвечает за то, как натив-команды базы данных, такие, как TTable.Append или TTable.Insert будут взаимодействовать с TQuery, подключенной к той же базе данных. Существуют три возможных значения: NOT SHARED, SHARED NOAUTOCOMMIT и SHARED AUTOCOMMIT. NOT SHARED означает, что натив-команды используют одно соединение с сервером, тогда как запросы – другое. Со стороны сервера это видится как работа двух разных пользователей. В любой момент времени, пока транзакция активна, натив-команды не будут исполняться (committed) до тех пор, пока транзакция не будет завершена. Если был выполнен TQuery, то любые изменения, переданные в базу данных, проходят отдельно от транзакции.
Два других режима, SHARED NOAUTOCOMMIT и SHARED AUTOCOMMIT, делают для натив-команд и запросов общим одно соединение с сервером. Различие между двумя режимами заключаются в передаче выполненной натив-команды на сервер. При выбранном режиме SHARED AUTOCOMMIT бессмысленно создавать транзакцию, использующую натив-команды для удаления записи и последующей попыткой осуществить откат (Rollback). Запись должна быть удалена, а изменения должны быть сделаны (committed) до вызова команды Rollback. Если вам нужно передать натив-команды в пределах транзакции, или включить эти команды в саму транзакцию, убедитесь в том, что SQLPASSTHRU MODE установлен в SHARED NOAUTOCOMMIT или в NOT SHARED.
5. Выводы
Delphi поддерживает множество характеристик при использовании языка SQL с вашими серверами баз данных. На этой ноте разрешите попращаться и пожелать почаще использовать SQL в ваших приложениях.SQL: – сортировка вычисляемого поля
Delphi 1Иногда схема данных требует, чтобы набор данных имел вычисляемый результат. В приложениях Delphi в случае использования SQL это возможно, но эта технология немного разнится в зависимости от используемого типа данных. Для локального SQL, включая таблицы Paradox и dBASE, вычисляемому полю дают имя с использованием ключевого слова AS. При этом допускается ссылаться на такое поле для задания порядка сортировки с помощью ключевой фразы ORDER BY в SQL-запросе. Например, используя демонстрационную таблицу ITEMS.DB:
SELECT I."PARTNO", I."QTY", (I."QTY" * 100) AS TOTAL
FROM "ITEMS.DB" I
ORDER BY TOTAL
В данном примере вычисляемому полю было присвоено имя TOTAL (временно, только для ссылки), после чего оно стало доступным в SQL-запросе для выражения ORDER BY.
Вышеуказанный метод не поддерживается в InterBase. Тем не менее, сортировать вычисляемые поля в таблицах InterBase (IB) или сервере Local InterBase Server все же возможно. Вместо использования имени вычисляемого поля, в выражении ORDER BY используется порядковое число, представляющее собой позицию вычисляемого поля в списке полей таблицы. Например, используя демонстрационную таблицу EMPLOYEE (расположенную в базе данных EMPLOYEE.GDB):
SELECT EMP_NO, SALARY, (SALARY / 12) AS MONTHLY
FROM EMPLOYEE
ORDER BY 3 DESCENDING
В то время, как таблицы IB и LIBS используют второй метод, и не могут воспользоваться первым, оба метода доступны при работе с локальным SQL. К примеру, используя SQL-запрос для таблицы Paradox, и приспосабливая его для работы с относительной позицией вычисляемого поля, а не его именем:
SELECT I."PARTNO", I."QTY", (I."QTY" * 100) AS TOTAL
FROM "ITEMS.DB" I
ORDER BY 3
SQL: – суммирование вычисляемого поля
Бывают случаи, когда в приложении Delphi, которое для получения доступа к данным использует SQL, необходимо узнать сумму вычисленных данных. Другими словами, необходимо с помощью SQL создать вычисляемое поле и применить к нему функцию SUM. При выполнении такой операции с SQL-таблицами (например, Local InterBase Server), все достаточно тривиально, и сумма вычисляется простым использованием функции SUM с указанием поля. Например, используя демонстрационную таблицу EMPLOYEE (из базы данных EMPLOYEE.GDB):SELECT SUM(SALARY / 12)
FROM EMPLOYEE
Та же самая методика применима в случае возвращаемого набора данных, в котором значения группируются в другом столбце с помощью утверждения GROUP BY:
SELECT EMP_NO, SUM(SALARY / 12)
FROM EMPLOYEE
GROUP BY EMP_NO
ORDER BY EMP_NO
Пока SQL базы данных поддерживают суммирование вычисляемых полей, локальный SQL этого делать не будет. Для получения результатов нужны другие методы, например копирование результатов запроса с вычисляемым полем во временную таблицу (как и в случае компонента TBatchMove), и использование компонента TQuery для вычисления суммы данных во временной таблице.
SQL: – использование функции SUBSTRING
SQL-функция SUBSTRING может использоваться в приложениях Delphi, работающих с запросами к локальной SQL, но она не поддерживается при работе с таблицами InterBase (IB) и Local InterBase Server (LIBS). Ниже приведен синтаксис функции SUBSTRING, примеры ее использования в запросах к local SQL, и альтернатива для возвращения тех же результатов для таблиц IB/LIBS. Синтаксис функции SUBSTRING:SUBSTRING(<column> FROM <start> [, FOR <length>])
Где:
<column> – имя колонки таблицы, из которой должна быть получена подстрока (substring).
<start> место в значении колонки, начиная с которого извлекается подстрока.
<length> длина извлекаемой подстроки.
Функция SUBSTRING в примере ниже возвратит второй, третий и четвертый символы из колонки с именем COMPANY:
SUBSTRING(COMPANY FROM 2 FOR 3)
Функция SUBSTRING может быть использована и для списка полей в SELECT-запросе, где ключевое слово WHERE допускает сравнение значения с определенным набором колонок. Функция SUBSTRING может использоваться только с колонками типа String (на языке SQL тип CHAR). Вот пример функции SUBSTRING, использующей список колонок в SELECT-запросе (используем демонстрационную таблицу Paradox CUSTOMER.DB):
SELECT (SUBSTRING(C."COMPANY" FROM 1 FOR 3)) AS SS
FROM "CUSTOMER.DB" C
Данный SQL-запрос извлекает первые три символа из колонки COMPANY, возвращаемой как вычисляемая колонка с именем SS. Вот пример функции SUBSTRING, использованной в SQL-запросе с ключевым словом WHERE (используем ту же самую таблицу):
SELECT C."COMPANY"
FROM "CUSTOMER.DB" C
WHERE SUBSTRING(C."COMPANY" FROM 2 FOR 2) = "an"
Данный запрос возвратит все строки таблицы, где второй и третий символы в колонке COMPANY равны «ar».
Так как функция SUBSTRING не поддерживается в базах данных IB и LIBS, операции с подстроками со списком колонок в запросе невозможны (исключение: IB может работать с подстроками через функции, определяемые пользователем, User-Defined Functions). Но с помощью оператора LIKE и сопутствующих символьных маркеров подстановки возможно работать с подстрокой и в случае WHERE. Вот пример на основе таблицы EMPLOYEE (в базе данных EMPLOYEE.GDB):
SELECT LAST_NAME, FIRST_NAME
FROM EMPLOYEE
WHERE LAST_NAME LIKE "_an%"
Данный SQL-запрос возвратит все строки таблицы, где второй и третий символы в колонке LAST_NAME равны «an», см. предыдущий пример на основе таблицы Paradox. Базам данных IB и LIBS для выполнения сравнения подстроки в операторе запроса WHERE данный метод необходим (и невозможно воспользоваться функцией SUBSTRING), таблицы же Paradox и dBASE (например, local SQL) могут воспользоваться любым методом.
Sybase
32-битное соединение с сервером Sybase
Delphi 2Данный документ содержит информацию, позволяющую осуществить подключение к базе данных Sybase через 32-битный пакет от фирмы Borland Sybase SQL Links, поставляемый в составе Delphi 2.x. Клиентское программное обеспечение Sybase займет на вашем жестком диске приблизительно 10+ мегабайт свободного пространства. Шаги для подключения: 1. Убедитесь в том, что пакет SQL Links установлен на вашем локальном диске. При полной установке Delphi 2.x это должно быть уже установлено в системе. 2. Инсталируйте клиентское программное обеспечение Sybase. 3. При появлявлении в процессе установки диалога выбора 16– и 32-разрядной версии Sybase links, выберите только 32-битную версию (отметьте галочкой) и убедитесь в том, что опция 16-битной версии выключена. 4. После того, как клиентское программное обеспечение будет установлено на вашем жестком диске, у вас попросят разрешение на автоматическую программную коррекцию вашего файла AUTOEXEC.BAT. Выберите YES. 5. На запрос по поводу редактирования вашего файла SQL.INI ответьте YES. 6. В секции «Input Server Name:» (введите имя сервера) укажите псевдоним сервера. Щелкните на кнопке 'Add' (добавить) для внесения имени сервера в список «Server Entry:». Затем убедитесь в том, что поля редактирования «Service Type:» (тип сервиса) (должно быть 'query' (запрос)), «Platform:» (платформа) (по умолчанию обычно устанавливается в NT, dos или Win3), и «Net-Library Driver:» (драйвер сетевой библиотеки) (должен быть NLWNSCK или NLNWLINK) содержат верные сведения. Заполните поле редактирования «Connection Information/Network Address:» (адрес информационного/сетевого соединения), введя сетевой адрес сервера, с которым вы хотите иметь соединение. Щелкните на кнопке 'Add Service' (добавить сервис). Вы можете теперь пропинговать ваш сервер, щелкая по кнопке 'Ping'. Сохраните текущие настройки и выйдите из программы. 7. Завершите работу Windows и перегрузите машину. 8. В меню пуск выберите программную группу Delphi и запустите Database Explorer. 9. В Навигаторе баз данных (Database explorer) щелкните на закладке Database. Активизируйте пункт меню Object | New… В диалоговом окне в выпадающем списке должно стоять имя STANDARD. Щелкните на стрелке и выберите из появившегося списка SYBASE. 10. Теперь там должен быть псевдоним для вашего соединения с Sybase с именем SYBASE1. Убедитесь в том, что это имя выделено. Щелкните в Database Explorer на следующей закладке. В секции «Server Name» (имя сервера) выберите имя одного из серверов, которые вы поместили в ваш SQL.INI, и который пингуется. В секции «User Name» укажите имя пользователя, имеющего права на доступ к определенному в секции «Server Name» серверу. Убедитесь в том, что вы знаете пароль только что назначенного пользователя. 11. Дважды щелкните на имене псевдонима (SYBASE1) и в появившемся диалоговом окне введите имя пользователя и его пароль. Имя пользователя должно совпадать с именем, определенным в секции «User Name» для псевдонима Sybase. Введите пароль, соответствующий данному пользователю. Нажмите кнопку OK. Теперь около псевдонима Sybase (SYBASE1) вы должны увидеть иконку, обозначающую маленький зеленый ящик. Это означает успешное установление соединения. Тестирование вашего соединения с помощью Delphi 2.x: 1. Разместите на пустой форме компоненты TDataSource, TTable и TDBGrid. 2. В Инспекторе Объектов (Object Inspector) установите для TDataSource свойство DataSet в 'Table1' (без кавычек). 3. В Инспекторе Объектов установите для TTable имя базы данных в SYBASE1. Переместитесь ниже до свойства TableName, и дважды щелкните на поле редактирования, расположенного около данного свойства. Должно появиться диалоговое окно с требованием ввести имя пользователя и его пароль. При этом должно уже отображаться имя пользователя, которое вы определили в Database Explorer для псевдонима Sybase. Введите соответствующий пароль. Нажмите на кнопку OK. 4. Теперь вы должны увидеть спискок, состоящий из имен таблиц. Выберите одно. 5. Щелкните на TDBGrid. Присвойте его свойству DataSource значение DataSource1. 6. Установите свойство Active компонента TTable в TRUE. 7. Теперь вы можете увидеть данные в TDBGrid. После запуска приложения должно появиться диалоговое окно с требованием ввести имя пользователя и его пароль. Введите пароль и нажмите OK. Теперь вы должны увидеть данные в табличной сетке. Сообщения об ошибках: Ошибка, связанная с невозможностью нахождения сетевой библиотеки: Данная ошибка означает, что программе не удалось найти нужную ей .DLL. Следующие файлы должны располагаться в вашем каталоге \Sybase\DLL:
Libblk.dll
Libcomn.dll
Libcs.dll
Libct.dll
Libintl.dll
Libsrv.dll
Libsybdb.dll
Libtcl.dll
Mscvrt10.dll
Nldecnet.dll
Nlmsnmp.dll
Nlnwadvt.exe
Nlnwlink.dll
Nlwnsck.dll
Предостережение: Данный документ не гарантирует установление соединения с сервером, он демонстрирует самый лучший и быстрый способ сделать это.
Разное
Решение проблемы BDE ~Index out of Date~
Некоторое время назад у меня также была масса ошибок типа 'index out of date' и даже искажение данных. После продолжительного исследования я выяснил причину, она оказалось в различных установках Paradox Language в BDE (v1 и V3) на странице Driver и System в утилите конфигурирования BDE. Я не обратил внимание на установки на странице System одной из рабочих станций, и получил искажение данных. Tom JensenОбратные вызовы BDE32 для получения статуса операций
Delphi 2Тема: Обратные вызовы BDE для получения статуса операций Данный совет показывает как в Delphi 2.01 можно использовать функцию BDE DbiCallBack для получения значения линейки прогресса при длительных пакетных операциях, связанных с движением данных. Дополнительная документация, описывающая вызовы функций BDE, находится в файле BDE32.HLP (расположенном в каталоге, где установлен 32-битный IDAPI). При создании функций обратного вызова BDE, BDE будет осуществлять "обратный вызов" функций вашего приложения, позволяя тем самым извещать ваше приложение о происходящих событиях, а в некоторых случаях передавать информацию обратно BDE. BDE определяет несколько возвращаемых типов, которые могут быть установлены для обратного вызова:
состояние больших пакетных операций.
запросы для передачи информации вызывающему оператору.
Данный совет подробно описывает обратный вызов типа cbGENPROGRESS, позволяющий изменять полоску прогресса в соответствии с состоянием операции.
Чтобы это сделать, необходимо сперва вызвать функцию DbiGetCallBack(), возвращающую дескриптор обратного вызова, который мог быть уже установлен (с этими параметрами), и сохранить информацию в структуре данных. Затем установить свой обратный вызов, заменяя им любой установленный до этого.
При установке вашего обратного вызова вам понадобится передавать BDE указатель на структуру данных, содержащую информацию о предыдущем установленном обратном вызове, после чего, при выполнении вашей функции обратного вызова, вы можете воспользоваться оригинальным обратным вызовом (если он установлен).
BDE каждый раз возвращает вашему приложению сообщение, содержащее количество обработанных записей, или же процентное соотношение обработанных записей, также передаваемое в виде целого числа. Ваш код должен учитывать эту ситуацию. Если процентное поле в структуре обратного вызова больше чем -1, можно сделать вывод что передан процент и можно сразу обновить линейку прогресса. Если же это поле меньше нуля, обратный вызов получил текстовое сообщение, помещенное в поле szTMsg и содержащее количество обработанных записей. В этом случае вам понадобится осуществить грамматический разбор текстового сообщения, преобразовать остальные строки в целое, затем вычислить текущий процент обработанных записей, и только после этого изменить линейку прогресса.
Наконец, после осуществления операции с данными, вам необходимо "отрегистрировать" ваш обратный вызов, и вновь установить предыдущую функцию обратного вызова (если она существует).
Для следующего примера необходимо создать форму и расположить на ней две таблицы, компонент ProgressBar и кнопку.
----- Демонстрационный код ---------
unit Testbc1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables, ComCtrls;
type TForm1 = class(TForm)
Table1: TTable;
BatchMove1: TBatchMove;
Table2: TTable;
Button1: TButton;
ProgressBar1: TProgressBar;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
uses Bde; {Здесь расположены Dbi Types и Procs}
{$R *.DFM}
{тип структуры данных для сохранения информации о предыдущем обратном вызове}
type TDbiCbInfo = record
ecbType : CBType;
iClientData : longint;
DataBuffLn : word;
DataBuff :pCBPROGRESSDesc;
DbiCbFn : pointer;
end;
type PDbiCbInfo = ^TDbiCbInfo;
{Наша функция обратного вызова}
function DbiCbFn(ecbType: CBType; iClientData: Longint; CbInfo: pointer): CBRType stdcall;
var s : string;
begin
{Проверяем, является ли тип обратного вызова тем, который мы ожидаем}
if ecbType = cbGENPROGRESS then begin
{если iPercentDone меньше нуля, извлекаем число}
{обработанных записей из параметра szMsg}
if pCBPROGRESSDesc(cbInfo).iPercentDone < 0 then begin
s := pCBPROGRESSDesc(cbInfo).szMsg;
Delete(s, 1, Pos(': ', s) + 1);
{Вычислям процент выполненного и изменяем линейку прогресса}
Form1.ProgressBar1.Position :=Round((StrToInt(s) / Form1.Table1.RecordCount) * 100);
end else begin
{Устанавливаем линейку прогресса}
Form1.ProgressBar1.Position:=pCBPROGRESSDesc(cbInfo).iPercentDone;
end;
end;
{существовал ли предыдущий зарегистрированный обратный вызов?}
{если так - осуществляем вызов и возвращаемся}
if PDbiCbInfo(iClientData)^.DbiCbFn <> nil then
DbiCbFn:=pfDBICallBack(PDbiCbInfo(iClientData)^.DbiCbFn)(ecbType,PDbiCbInfo(iClientData)^.iClientData,cbInfo)
else DbiCbFn := cbrCONTINUE;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
CbDataBuff: CBPROGRESSDesc; {Структура DBi}
OldDbiCbInfo : TDbiCbInfo; {структура данных должна хранить информацию о предыдущем обратном вызове}
begin
{Убедимся в том, что перемещаемая таблица открыта}
Table1.Open;
{Убедимся в том, что таблица-приемник закрыта}
Table2.Close;
{получаем информацию о любом установленном обратном вызове}
DbiGetCallBack(Table2.Handle, cbGENPROGRESS, @OldDbiCbInfo.iClientData, @OldDbiCbInfo.DataBuffLn, @OldDbiCbInfo.DataBuff, pfDBICallBack(OldDbiCbInfo.DbiCbFn));
{регистрируем наш обратный вызов}
DbiRegisterCallBack(Table2.Handle, cbGENPROGRESS, longint(@OldDbiCbInfo), SizeOf(cbDataBuff), @cbDataBuff, @DbiCbFn);
Form1.ProgressBar1.Position := 0;
BatchMove1.Execute;
{если предыдущий обратный вызов существовал - вновь устанавливаем его,}
{в противном случае "отрегистрируем" наш обратный вызов}
if OldDbiCbInfo.DbiCbFn <> nil then
DbiRegisterCallBack(Table2.Handle, cbGENPROGRESS, OldDbiCbInfo.iClientData,
OldDbiCbInfo.DataBuffLn, OldDbiCbInfo.DataBuff, OldDbiCbInfo.DbiCbFn)
else
DbiRegisterCallBack(Table2.Handle, cbGENPROGRESS, longint(@OldDbiCbInfo),
SizeOf(cbDataBuff), @cbDataBuff, nil);
{Показываем наш успех!}
Table2.Open;
end;
end.
Управление сетевыми каталогами (BDE)
Если два различных пользователя подключают два различных сетевых каталога (net control directories, NCD), но при этом пути к каталогам одинаковые (это не трудно при работе с сетью), BDE думает, что в этом случае используются одни и те же NCD. Это может привести к _огромным_ проблемам. Если два пользователя подключают один и тот же NCD, но с разными путями, BDE думает что используются два различных NCD и не позволяет второму пользователю редактировать таблицу. Например, пользователь A подключил NCD по пути G:\DATA\BDENET. Пользователь B подключил NCD по пути H:\BDENET, где H: подключен по пути G:\DATA. В этом случае оба пользователя пытаются использовать один и тот же NCD, но BDE не знает об этом. Если в вышеприведенном примере пользователи используют один и тот же путь, но с различными буквами диска, BDE позволяет работать обоим пользователям, подразумевая, что они используют один и тот же NCD. Так, если пользователь A подключен к G:\DATA\BDENET, а пользователь B к H:\DATA\BDENET, BDE даст работать обоим. Это полезно в peer-to-peer сети, где сервер также является и рабочей станцией. В этом случае некоторые (какие?) peer-to-peer OS не позволят серверу подключить сетевой диск к самому себе (я не уверен что у них невозможен эквивалент SUBST, но, по крайней мере, у тех OS, которые я знаю, это отсутствует) так что сервер может использовать только диск C: (или D:, или какой-то другой локальный диск), а рабочая станция нет, поскольку сама имеет собственный локальный диск C:. Richard Davis Дополнение от Mark Ostroff (Borland): В дополнение к ИЗУМИТЕЛЬНОМУ ответу Richard'а, пожалуйста помните об одной ОЧЕНЬ важной вещи… НИКОГДА не допускайте ситуации (в ЛЮБОЙ сети), при которой вы имеете нескольких пользователей, имеющих доступ к одним и тем же таблицам, но использующих разные физические NET-файлы. Это создает ОГРОМНЫЕ проблемы, особенно в в корпоративных и peer-to-peer сетях. Pdox DOS версии 4.0 использует ту же BDE-схему работы с сетью, что и таблицы Paradox. Необходимо учесть несколько важных моментов: 1. Убедитесь в том, что у вас включена опция BDE Local Share, если вы создаете таблицы с общим доступом для приложений Pdox DOS и BDE. 2. Из-за странного поведения при работе с сетевыми каталогами, пути в файле контроля сети Pdox DOS у ваших пользователей должны быть ИДЕНТИЧНЫ BDE путям (например, тот же каталог И та же буква диска). Это должно быть сделано в случае, если и Pdox DOS, и BDE делают общими одни и те же таблицы и запущены ОБА приложения. Это может создать некоторые проблемы с установкой peer-to-peer сетей. 3. Убедитесь в том, у вас выключена опция BDE Strict Integrity, если вы создаете таблицы с общим доступом для приложений Pdox DOS и BDE. В противном случае BDE заблокирует пользователей Pdox DOS для редактирования данных в таблицах Paradox (в любом каталоге), у которых установлена опция целостности данных (Referential Integrity). 4. Убедитесь в том, что номер версии Paradox, имеющийся в настройках BDE, совместим с OLDEST версией Pdox DOS для использования в вашей сети. Установить ее можно, выбрав соответствующий драйвер Paradox в BDE Config Utility и проверив значение в поле LEVEL. Установите номер версии Pdox DOS, округлив его до ближайшего МЕНЬШЕГО целого числа.Пример DBIDoRestructure
Единственный способ изменить размер поля или его тип — использовать DBIDoRestructure. Вот простой пример, который может вам помочь в этом:function BDEStringFieldResize(ATable: TTable; AFieldName: string; ANewSize: integer): boolean;
type TRestructStatus = (rsFieldNotFound, rsNothingToDo, rsDoIt);
var
hDB: hDBIdb;
pTableDesc: pCRTblDesc;
pFldOp: pCROpType; {фактически это массив array of pCROpType}
pFieldDesc: pFldDesc; {фактически это массив array of pFldDesc}
CurPrp: CurProps;
CSubType: integer;
CCbrOption: CBRType;
eRestrStatus: TRestructStatus;
pErrMess: DBIMsg;
i: integer;
begin
Result := False;
eRestrStatus := rsFieldNotFound;
AFieldName := UpperCase(AFieldName);
pTableDesc := nil;
pFieldDesc := nil;
pFldOp := nil;
with ATable do try
{убедимся что имеем исключительный доступ и сохраним dbhandle:}
if Active and (not Exclusive) then Close;
if (not Exclusive) then Exclusive := True;
if (not Active) then Open;hDB := DBHandle;
{готовим данные для DBIDoRestructure:}
BDECheck(DBIGetCursorProps(Handle,CurPrp));
GetMem(pFieldDesc,CurPrp.iFields*sizeOf(FldDesc));
BDECheck(DBIGetFieldDescs(Handle,pFieldDesc));
GetMem(pFldOp,CurPrp.iFields*sizeOf(CROpType));
FillChar(pFldOp^,CurPrp.iFields*sizeOf(CROpType),0);
{ищем в цикле (через fielddesc) наше поле:}
for i:=1 to CurPrp.iFields do begin
{для ввода мы имеем серийные номера вместоPdox ID, возвращаемых DbiGetFieldDescs:}
pFieldDesc^.iFldNum := i;
if (Uppercase(StrPas(pFieldDesc^.szName)) = AFieldName) and (pFieldDesc^.iFldType = fldZSTRING) then begin
eRestrStatus := rsNothingToDo;
if (pFieldDesc^.iUnits1 <> ANewSize) then begin
pFieldDesc^.iUnits1 := ANewSize;
pFldOp^ := crModify;
eRestrStatus := rsDoIt;
end;
end;
inc(pFieldDesc);
inc(pFldOp);
end; {for}
{"регулируем" массив указателей:}
dec(pFieldDesc,CurPrp.iFields);
dec(pFldOp,CurPrp.iFields);
{в случае отсутствия операций возбуждаем исключение:}
case eRestrStatus of
rsNothingToDo:
raise Exception.Create('Ничего не сделано');
rsFieldNotFound:
raise Exception.Create('Поле не найдено');
end;
GetMem(pTableDesc,sizeOf(CRTblDesc));
FillChar(pTableDesc^,SizeOf(CRTblDesc),0);
StrPCopy(pTableDesc^.szTblName,TableName);
{StrPCopy(pTableDesc^.szTblType,szPARADOX); {}
pTableDesc^.szTblType := CurPrp.szTableType;
pTableDesc^.iFldCount := CurPrp.iFields;
pTableDesc^.pecrFldOp := pFldOp;
pTableDesc^.pfldDesc := pFieldDesc;
Close;
BDECheck(DbiDoRestructure(hDB, 1, pTableDesc, nil, nil, nil, False));
finally
if pTableDesc <> nil then FreeMem(pTableDesc,sizeOf(CRTblDesc));
if pFldOp <> nil then FreeMem(pFldOp, CurPrp.iFields*sizeOf(CROpType));
if pFieldDesc <> nil then FreeMem(pFieldDesc, CurPrp.iFields*sizeOf(FldDesc));
Open;
end; {пробуем с table1}
Result := True;
end;
Reinhard Kalinke
Изменение конфигурации IDAPI
Delphi 1Возможно ли установить параметр MAXFILEHANDLES в IDAPI.CFG посредством Delphi? Да. Следующий компонент показывает как это можно сделать (а также изменить другие параметры):
unit CFGTOOL;
interface
uses SysUtils, Classes, DB, DbiProcs, DbiTypes, DbiErrs;
type TBDEConfig = class(TComponent)
private
FLocalShare : Boolean;
FMinBufSize : Integer;
FMaxBufSize : Integer;
FSystemLangDriver : String;
FParadoxLangDriver : String;
FMaxFileHandles : Integer;
FNetFileDir : String;
FTableLevel : String;
FBlockSize : Integer;
FDefaultDriver : String;
FStrictIntegrity : Boolean;
FAutoODBC : Boolean;
procedure Init;
procedure SetLocalShare(Value : Boolean);
procedure SetMinBufSize(Value : Integer);
procedure SetMaxBufSize(Value : Integer);
procedure SetSystemLangDriver(Value : String);
procedure SetParadoxLangDriver(Value : String);
procedure SetMaxFileHandles(Value : Integer);
procedure SetNetFileDir(Value : String);
procedure SetTableLevel(Value : String);
procedure SetBlockSize(Value : Integer);
procedure SetDefaultDriver(Value : String);
procedure SetAutoODBC(Value : Boolean);
procedure SetStrictIntegrity(Value : Boolean);
procedure UpdateCFGFile(path, item, value : string);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property LocalShare : Boolean read FLocalShare write SetLocalShare;
property MinBufSize : Integer read FMinBufSize write SetMinBufSize;
property MaxBufSize : Integer read FMaxBufSize write SetMaxBufSize;
property SystemLangDriver : String read FSystemLangDriver write SetSystemLangDriver;
property ParadoxLangDriver : String read FParadoxLangDriver write SetParadoxLangDriver;
property MaxFileHandles : Integer read FMaxFileHandles write SetMaxFileHandles;
property NetFileDir : String read FNetFileDir write SetNetFileDir;
property TableLevel : String read FTableLevel write SetTableLevel;
property BlockSize : Integer read FBlockSize write SetBlockSize;
property DefaultDriver : string read FDefaultDriver write SetDefaultDriver;
property AutoODBC : Boolean read FAutoODBC write SetAutoODBC;
property StrictIntegrity : Boolean read FStrictIntegrity write SetStrictIntegrity;
end;
procedure Register;
implementation
function StrToBoolean(Value : string) : Boolean;
begin
if (UpperCase(Value) = 'TRUE') or (UpperCase(Value) = 'ON') or (UpperCase(Value) = 'YES') or (UpperCase(Value) = '.T.' ) then Result := True
else Result := False;
end;
function BooleanToStr(Value : Boolean) : String;
begin
if Value then Result := 'TRUE'
else Result := 'FALSE';
end;
procedure Register;
begin
RegisterComponents('Data Access', [TBDEConfig]);
end;
procedure TBDEConfig.Init;
var
h: hDBICur;
pCfgDes: pCFGDesc;
n, v : string;
begin
Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,'\SYSTEM\INIT', h));
GetMem(pCfgDes, sizeof(CFGDesc));
try
FillChar(pCfgDes^, sizeof(CFGDesc), #0);
while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do begin
n := StrPas(pCfgDes^.szNodeName);
v := StrPas(pCfgDes^.szValue);
if n = 'LOCAL SHARE' then FLocalShare := StrToBoolean(v)
else if n = 'MINBUFSIZE' then FMinBufSize := StrToInt(v)
else if n = 'MAXBUFSIZE' then FMaxBufSize := StrToInt(v)
else if n = 'MAXFILEHANDLES' then FMaxFileHandles := StrToInt(v)
else if n = 'LANGDRIVER' then FSystemLangDriver := v
else if n = 'AUTO ODBC' then FAutoODBC := StrToBoolean(v)
else if n = 'DEFAULT DRIVER' then FDefaultDriver := v;
end;
if (h <> nil) then DbiCloseCursor(h);
Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,'\DRIVERS\PARADOX\INIT', h));
FillChar(pCfgDes^, sizeof(CFGDesc), #0);
while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do begin
n := StrPas(pCfgDes^.szNodeName);
v := StrPas(pCfgDes^.szValue);
if n = 'NET DIR' then FNetFileDir := v
else if n = 'LANGDRIVER' then FParadoxLangDriver := v;
end;
if (h <> nil) then DbiCloseCursor(h);
Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, '\DRIVERS\PARADOX\TABLE CREATE', h));
FillChar(pCfgDes^, sizeof(CFGDesc), #0);
while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do begin
n := StrPas(pCfgDes^.szNodeName);
v := StrPas(pCfgDes^.szValue);
if n = 'LEVEL' then FTableLevel := v
else if n = 'BLOCK SIZE' then FBlockSize := StrToInt(v)
else if n = 'STRICTINTEGRITY' then FStrictIntegrity := StrToBoolean(v);
end;
finally
FreeMem(pCfgDes, sizeof(CFGDesc));
if (h <> nil) then DbiCloseCursor(h);
end;
end;
procedure TBDEConfig.SetLocalShare(Value : Boolean);
begin
UpdateCfgFile('\SYSTEM\INIT', 'LOCAL SHARE', BooleanToStr(Value));
FLocalShare := Value;
end;
procedure TBDEConfig.SetMinBufSize(Value : Integer);
begin
UpdateCfgFile('\SYSTEM\INIT', 'MINBUFSIZE', IntToStr(Value));
FMinBufSize := Value;
end;
procedure TBDEConfig.SetMaxBufSize(Value : Integer);
begin
UpdateCfgFile('\SYSTEM\INIT', 'MAXBUFSIZE', IntToStr(Value));
FMaxBufSize := Value;
end;
procedure TBDEConfig.SetSystemLangDriver(Value : String);
begin
UpdateCfgFile('\SYSTEM\INIT', 'LANGDRIVER', Value);
FSystemLangDriver := Value;
end;
procedure TBDEConfig.SetParadoxLangDriver(Value : String);
begin
UpdateCfgFile('\DRIVERS\PARADOX\INIT', 'LANGDRIVER', Value);
FParadoxLangDriver := Value;
end;
procedure TBDEConfig.SetMaxFileHandles(Value : Integer);
begin
UpdateCfgFile('\SYSTEM\INIT', 'MAXFILEHANDLES', IntToStr(Value));
FMaxFileHandles := Value;
end;
procedure TBDEConfig.SetNetFileDir(Value : String);
begin
UpdateCfgFile('\DRIVERS\PARADOX\INIT', 'NET DIR', Value);
FNetFileDir := Value;
end;
procedure TBDEConfig.SetTableLevel(Value : String);
begin
UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'LEVEL', Value);
FTableLevel := Value;
end;
procedure TBDEConfig.SetBlockSize(Value : Integer);
begin
UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'BLOCK SIZE', IntToStr(Value));
FBlockSize := Value;
end;
procedure TBDEConfig.SetStrictIntegrity(Value : Boolean);
begin
UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'STRICTINTEGRITY', BooleanToStr(Value));
FStrictIntegrity := Value;
end;
procedure TBDEConfig.SetDefaultDriver(Value : String);
begin
UpdateCfgFile('\SYSTEM\INIT', 'DEFAULT DRIVER', Value);
FDefaultDriver := Value;
end;
procedure TBDEConfig.SetAutoODBC(Value : Boolean);
begin
UpdateCfgFile('\SYSTEM\INIT', 'AUTO ODBC', BooleanToStr(Value));
FAutoODBC := Value;
end;
procedure TBDEConfig.UpdateCFGFile;
var
h : hDbiCur;
pCfgDes: pCFGDesc;
pPath : array[0..127] of char;
begin
StrPCopy(pPath,Path);
Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, pPath, h));
GetMem(pCfgDes, sizeof(CFGDesc));
try
FillChar(pCfgDes^, sizeof(CFGDesc), #0);
while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do begin
if StrPas(pCfgDes^.szNodeName) = item then begin
StrPCopy(pCfgDes^.szValue, value);
Check(DbiModifyRecord(h, pCfgDes, True));
end;
end;
finally
FreeMem(pCfgDes, sizeof(CFGDesc));
if (h <> nil) then DbiCloseCursor(h);
end;
end;
constructor TBDEConfig.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Init;
end;
destructor TBDEConfig.Destroy;
begin
inherited Destroy;
end;
end.
Eryk Bottomley
Default Cursor после завершения выполнения запросов
Тема: Возврат курсора по умолчанию после выполнения запросаПочему мышиный курсор не возвращается обратно (не становится обычной стрелкой) после выполнения запроса? При выполнении открытого запроса, Delphi изменяет для вас курсор, и произойти это может даже в середине события, как, например, при нажатии на кнопку. Приведенный ниже пример отобразит курсор в виде иконки песочных часов (SQL Hourglass Icon) после того, как вы закроете окно с сообщением. При этом мышь будет вести себя так, как будто находится в режиме "стрелки".
// Добавьте к обработчику события нажатия кнопки,
// использование запроса при этом не имеет значения
// Select * from Customer (в IBLocal)
with query1 do begin
close;
open;
showmessage(IntToStr(RecordCount));
end; // with
При наступлении события, Delphi пробует обратно придать курсору тип стрелки (Arrow), при этом выводится новая форма (диалог showmessage), которая мешает автоматическому переводу курсора в режим стрелки.
Для решения этой проблемы нужно добавить Application.ProcessMessages прежде, чем форма будет показана, это позволит обработать все сообщения, скопившиеся в очереди (и очистить ее), после чего мышиный курсор вновь пример нормальную форму.
// Добавьте к обработчику события нажатия кнопки,
// использование запроса при этом не имеет значения
// Select * from Customer (в IBLocal)
with query1 do begin
close;
open;
application.ProcessMessages; // Добавьте эту строку.
showmessage(IntToStr(RecordCount));
end; // with
Протокол блокировки BDE
Тема: BDE и Database Desktop Locking Protocol Предполагаемая аудитория Данная информация будет полезна каждому, кто решил разрабатывать приложения для работы с базами данных с использованием Delphi и BDE. Предварительные условия Базовые знания или интерес к протоколам блокировки Paradox и форматам таблиц. Цель Дать пользователям лучшее понимание протокола блокировки таблицы. Таблицы, типы полей и поддерживаемые характеристики Каждый следующий выпуск Paradox, начиная с версии 2.0, содержал улучшения структуры таблицы. Все типы таблиц Paradox, начиная с Paradox 1.0 и заканчивая Paradox 3.5, совместимые друг с другом. Paradox 4.0 добавляет новый тип данных к формату таблиц: Binary Large Objects (бинарные большие объекты), обычно известные как BLOb'ы, и новые типы вторичных индексов. Paradox 4.0 поддерживает два типа BLOb-полей: Memo и BLOb. Paradox старее версии 4.0 и Engine до версии 3.0 не могут читать, писать и создавать этот новый табличный формат. При попытке чтения или записи таблиц типа Paradox 4.0 более ранней версией Paradox, вы получите ошибку о защите таблицы паролем. Paradox 5.0 добавляет несколько новых типов данных к формату таблиц: Long Integer, Time, TimeStamp, Logical, Autoincrement, BCD, Bytes. Paradox 7.0 добавляет наследуемый вторичный индекс. Создание или любое изменение таблицы переводит ее формат на новый уровень, включающий все вышеописанные характеристики. По умолчанию создаваемая с использованием Database Desktop или BDE (Borland Database Engine) таблица имеет тип Paradox 4.0. Данный тип, заданный по умолчанию, может быть изменен с помощью утилиты BDE configuration utility или Database desktop configuration utility, и ему может быть присвоен тип Paradox 3, 4, 5 или 7 для BDE. Paradox 4.0 может читать, писать и создавать таблицы типа Paradox, совместимые с таблицами версий от Paradox 1.0 до Paradox 4.0. Так, таблица, созданая в Paradox 1.0, совместима с Paradox 4.0. Таблица, созданная в Engine 1.0 или 2.0, может быть прочитана и записана в Paradox 4.0. Paradox и Engine не изменяет тип таблицы при чтении или записи. Тип таблицы изменяется только при ее реструктуризации. Протоколы блокировки Paradox Есть два различных протокола блокировки Paradox: протокол, введенный в Paradox 2.0 и протокол, введенный в Paradox 4.0. Эти два протокола не совместимы друг с другом. Протокол блокировки не оказывает влияния на тип таблицы, с которым может работать программа. Существуют несколько программ, также поддерживающих протоколы блокировки; тем не менее, эти программы в отдельный момент времени могут поддерживать только один протокол. Здесь мы рассматриваем только протокол блокировки версии 4.0. Протокол блокировки Database Desktop/ Paradox 4.0 Протокол блокировки Paradox 4.0 – единственный протокол, доступный для Paradox 4.0 и IDAPI Engine. Обозначение «Paradox 4.0 locking protocol» представляет данный стиль блокировки. Блокировки каталога Paradox 4.0 располагает файл блокировки, PDOXUSRS.LCK, в каждом каталоге, в котором доступны таблицы. Файл блокировки регулирует доступ к файлам, расположенным в каталоге. Файл блокировки ссылается на PDOXUSRS.NET, поэтому все пользователи должны подключать данные по одному и тому же пути. При этом в каталоге также располагается эксклюзивный файл PARADOX.LCK. Это делается для того, чтобы предохранить те версии Paradox или Engine, которые используют старую блокировочную систему, от неумышленного получения доступа к таблицам. Рабочие каталоги и каталоги общего доступа Когда Paradox или Database Desktop необходимо получить доступ к таблицам, расположенным в каталоге, то в этом каталоге они размещают «общий» файл PDOXUSRS.LCK и «эксклюзивный» файл PARADOX.LCK. Этим способом они «метят» каталог для того, чтобы другие пользователи Paradox 4.0 также могли иметь доступ к таблицам, расположенным в данном каталоге. Эксклюзивный файл PARADOX.LCK устанавливается в этом каталоге для обеспечения работы несовместимого протокола блокировки, и, таким образом, для уменьшения риска при постинге данных. В Paradox'е этот каталог известен как рабочий, «Working» каталог. Частные/эксклюзивные каталоги Для Paradox и Database Desktop также необходим каталог, где они могли бы сохранять временные файлы, например, результаты запроса. При запуске Paradox или Paradox Runtime, они также размещают в каталоге «эксклюзивные» файлы PDOXUSRS.LCK и PARADOX.LCK, определяя данный каталог как место для хранения временных файлов. Это обозначает, что другие пользователи Paradox не смогут получить доступ к таблицам в этом каталоге. В Paradox'е этот каталог известен как частный, «Private» каталог. Блокировка таблицы Paradox 4.0 размещает каждую табличную блокировку в блокирующем файле PDOXUSRS.LCK, располагаемом в каталоге с таблицами. Теперь нет необходимости в использовании отдельного блокирующего файла для каждой таблицы, как это было в предыдущих версиях. Например, если три пользователя просматривают таблицу CUSTOMER.DB и один пользователь реструктуризирует таблицу ORDERS.DB, то файл PDOXUSRS.LCK будет иметь общую блокировку, указывающую на каждого из тех трех пользователей, просматривающих таблицу CUSTOMER.DB, и эксклюзивную блокировку на ORDERS.DB для пользователя, реструктуризирующего таблицу. Протокол блокировки параллельности Paradox 4.0 (Locking Protocol Concurrency) В многопользовательской среде протокол блокировки Paradox 4.0 поддерживает параллелизм, т.е. одновременное использование приложений, через файл PDOXUSRS.NET. Все пользователи, которые хотят иметь общий доступ к таблицам Paradox, должны иметь один и тот же путь к файлу PDOXUSRS.NET, но при этом логическая буква сетевого диска может отличаться. Для того, чтобы предотвратить доступ к файлам, расположенным в каталоге, предыдущим версиям, Paradox размещает PDOXUSRS.LCK и эксклюзивный файл PARADOX.LCK в каждом каталоге, где имеются доступные таблицы. Каждый пользователь, который хочет дать общий доступ к таблице в этом каталоге, должен подключить этот каталог с одним и тем же путем, с использованием одного логического сетевого диска и пути. Затем Paradox разместит всю информацию о блокировках для этой таблице в файле PDOXUSRS.LCK, уменьшая этим количество необходимых файлов. Сетевой управляющий файл (Network Control File) Сетевой управляющий файл Paradox, PDOXUSRS.NET, служит в качестве контрольной точки для всех блокирующих файлов, создаваемых Paradox. Net-файл содержит список пользователей, в настоящий момент использующих BDE, вместе со списком используемых ими таблиц. Каждый блокирующий файл ссылается на сетевой управляющий файл и содержит информацию о блокировках таблицы и пользователях, заблокировавших эти таблицы, поэтому все пользователи должны иметь один и тот же путь к сетевому управляющему файлу, но при этом логическая буква сетевого диска может отличаться. Например, если вы используете том DATA на сервере SERVER_1, и сетевой управляющий файл расположен в каталоге \PDOXDATA, то все пользователи должны использовать путь \\SERVER_1\DATA:\PDOXDATA, тем не менее, любой пользователь может при этом использовать свою логическую букву сетевого диска. Если в вашей сети не пользуют тома, DATA должен быть корневым каталогом SERVER_1. Если вы подключаете \\SERVER_1\DATA в корень диска P, то каждая система Paradox должна определять расположение PARADOX.NET как P:\PDOXDATA\. Тем не менее, другие пользователи могут подключить \\SERVER_1\DATA к корневому каталогу O и установить O:\PDOXDATA\ как местоположение сетевого управляющего файла. Конфигурирование 16-битного Database Engine / IDAPI.CFG Файл конфигурации Database Engine хранит специфическую сетевую информацию, список псевдонимов баз дынных и другую информацию. Вы можете конфигурировать IDAPI с помощью программы конфигурации Database Engine, BDECFG.EXE, и устанавливать с помощью нее месторасположение сетевого управляющего файла. Также возможно добавление, удаление и изменение псевдонимов баз данных (включая информацию об используемом драйвере и типе псевдонима), каким способом IDAPI осуществляет общий доступ к локальным таблицам для программ, использующих протокол блокировки Paradox 4.0, а также некоторые особенности относительно таблиц и способа отображения данных. Локальные 16-битные установки Файл WIN.INI содержит путь к файлу IDAPI.CFG, «рабочему» («Working») каталогу Database Desktop и «частному» («Private») каталогу Database Desktop. Для изменения этих значений необходимо загрузить файл WIN.INI в любой текстовый редактор и отредактировать его. Путь к файлу IDAPI.CFG описан в группе [IDAPI] как CONFIGFILE=<полный диск, путь и имя файла> или CONFIGFILE01=<полный диск, путь и имя файла>. Месторасположение «рабочего» («Working») и «частного» («Private») каталога Database Desktop описано в группе [DBD] соответственно как WORKDIR=<полный диск и каталог> и PRIVDIR=<полный диск и каталог>. Конфигурирование 32-битного Database Engine / IDAPI32.CFG Конфигурационный файл BDE хранит ту же информацию, что и конфигурационный файл Database Engine. Для конфигурирования IDAPI32.CFG используется утилита BDE Configuration, BDECFG32.EXE. Вдобавок к этому, вы можете сохранять информацию в регистрах, или сразу, и в регистрах, и в IDAPI32.CFG. Локальные 32-битные установки В регистрах содержится путь к IDAPI32.CFG, к «рабочему» («Working») и частному («Private») каталогу. Месторасположение файла IDAPI32.CFG хранится в ключе HKEY_LOCAL_MACHINE\Software\Borland\Database Engine. Значение CONFIGFILE01 содержит данные типа <полный диск, путь и имя файла>. Месторасположение каталогов BDE «Working» и «Private» хранится соответственно в ключах HKEY_CURRENT_USER\Software\Borland\DBD\7.0\Configuration\WorkDir и HKEY_CURRENT_USER\Software\Borland\DBD\7.0\Configuration\PrivDir. По умолчанию, данные для каждого каталога хранятся в виде <Полный диск и каталог>. Доступ к таблицам Paradox BDE сначала пытается получить доступ к файлу PDOXUSRS.NET. Если файл PDOXUSRS.NET не найден, Paradox создает новый файл PDOXUSRS.NET и продолжает процедуру запуска. Если файл PDOXUSRS.NET присутствует, но владелец этого net-файла использует другой путь, т.е. подключил сервер иначе, возникает исключительная ситуация «Multiple net files in use» (Используются несколько net-файлов) и BDE прекращает свою работу. После того, как сеть успешно открыла эксклюзивную блокировку, PARADOX.LCK размещается во временном, частном каталоге. При невозможности установки блокировки, BDE прекращает свою работу. Причина неудачи может заключаться в том, что какой-то пользователь имеет в этом каталоге эксклюзивную блокировку, или же файлы блокировки используют различные net-файлы. После того, как каталог будет защищен от частного использования, общий файл PARADOX.LCK будет расположен в рабочем каталоге, и на этом процесс инициализации будет завершен.Я так и не смог заставить выводить текст с помощью DBMS_OUTPUT.PUT_LINE в режиме отладки
Nomadic отвечает: Эта функция используется действительно только для отладки. Для того, чтобы результаты ее работы были видны из SQL Plus, необходимо в нем выдать команду: set serveroutput on size 10000;После analyze_schema некоторые (приличное количество) из запросов начинают сильно тормозить. Как лечить?
Nomadic отвечает: Это у всех так или у воркгрупп 7.3.2 под HТ только? Пока полечил удалением статистики. Хинтить не предлагайте, запросы генерит crystal report, а он очень трепетно относится к редактированию sql-предложения в некоторых местах… А ты метод оптимизатора по дефолту переключи в RULE. Это можно сделать разными способами : 1. ALTER SESSION SET OPTIMIZER_GOAL = … (это только для данной сессии) 2. При старте инстанса поправить параметр OPTIMIZER_MODE (это для всех сессий)Определение установленной BDE
Delphi 1Для Delphi 2 проверьте регистрацию в ключе регистра
HKEY_LOCAL_MACHINE\Software\Borland\Database Engine
Для Delphi 1 проверьте в файле Win.INI секцию с именем IDAPI
[IDAPI]
DLLPATH=3DD:\WINPROG\DELPHI\IDAPI
CONFIGFILE01=3DD:\WINPROG\DELPHI\IDAPI\IDAPI.CFG
Хотя это и не лучший путь, поскольку пользователь может удалить BDE, а регистры или INI-файл будут хранить эту информацию.
Установка BDE
Delphi 1Вот имена файлов, которые вам нужно установить в рантайме:
Borland Database Engine
Уникальный файл на BDE Disk #1
Имя файла :– IDAPICFG.PAK
Устанавливаемый Exe :-Setup.exe
Borland SQL Links
Уникальный файл на SQL Disk #1
Имя файла :– MNOVLWP.PAK
Устанавливаемый Exe :-Setup.exe
Borland ReportSmith Runtime
Уникальный файл на RPT Disk #1
Имя файла :– INSTXTRA.PAK
Устанавливаемый Exe :-Setup.exe
Borland настоятельно рекомендует при установке рантайм-версий пользоваться программами установки.
Каковы текущие ограничения BDE?
Nomadic отвечает: BDE: под Windows, все версии. Если Вы обнаружите, что Вы ограничены более строго, чем здесь описано, или Вы получаете ошибку выхода за пределы доступной памяти, то увеличение параметра SHAREDMEMSIZE в BDE Config до 4096 или более может способствовать снятию более строгих ограничений. Здесь указаны максимальные ограничения для некоторых общих обьектов BDE. Основные ограничения BDE: • 48 клиентов в системе; • 32 сессии на одного клиента (для версии 3.5 и ниже, 16 Bit, 32 Bit) • 256 сессий на одного клиента (для версии 4.0 и выше, 32 Bit) • 32 открытых баз данных на сессию (для версии 3.5 и ниже, 16 Bit, 32 Bit) • 2048 открытых баз данных на сессию (для версии 4.0 и выше, 32 Bit) • 32 загруженных драйвера • 64 сессии в системе (для версии 3.5 и ниже, 16 Bit, 32 Bit) • 12288 сессии в системе (для версии 4.0 и выше, 32 Bit) • 4000 курсоров на сессию • 16 вхождений в стеке ошибок • 8 типов таблиц на один драйвер • 16 типов полей на один драйвер • 8 типов индексов на один драйвер • 48K Размер конфигурационного файла (IDAPI.CFG) • 64K Максимальный размер оператора SQL при RequestLive=False • 4K Максимальный размер оператора SQL при RequestLive=True (для версии 4.0 и ниже, 16/32 Bit) • 6K Максимальный размер оператора SQL при RequestLive=True (для версии 4.01 и выше, 32 Bit) • 16K Размер буфера записи (SQL и ODBC) • 31 Размер имени таблицы и имени поля в символах • 64 Размер имени хранимой процедуры в символах • 16 Полей в ключе • 3 Размер расширения имени файла в символах • 260 Длина имени таблицы в символах (некоторые сервера могут иметь другие ограничения) • 260 Длина полного имени файла и пути файловой системы в символах Ограничения Paradox: • 127 открытых таблиц в системе (для версии 4.0 и ниже, 16/32 Bit) • 254 открытых таблиц в системе (для версии 4.01 и выше, 32 Bit) • 64 блокировки на запись на одну таблицу (16Bit) на одну сессию • 255 блокировок на запись на одну таблицу (32Bit) на одну сессию • 255 записей, учавствующих в транзакции на таблицу (32 Bit) • 512 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.0 и ниже, 16/32 Bit) • 1024 открытых физически файлов (DB, PX, MB, X??, Y??, VAL, TV) (для версии 4.01 и выше, 32 Bit) • 300 пользователей в одном файле PDOXUSRS.NET • 255 полей в таблице • 255 размер символьных полей • 2 миллиарда записей в таблице • 2 миллиарда байт в .DB (таблица) файле • 10800 байт на запись для индексированных таблиц • 32750 байт на запись для неиндексированных таблиц • 127 вторичных индексов на таблицу • 16 полей на индекс • 255 одновременно работающих пользователей на таблицу • 256 Мегабайт данных на одно BLOb поле • 100 паролей на сессию • 15 длина пароля • 63 паролей на таблицу • 159 полей с проверками корректности (validity check) (32 Bit) • 63 поля с проверками корректности (validity check) (16 Bit) Ограничения dBase: • 256 открытых таблиц dBASE на систему (16 Bit) • 350 открытых таблиц dBASE на систему (BDE 3.0 – 4.0, 32 Bit) • 512 открытых таблиц dBASE на систему (BDE 4.01 и выше, 32 Bit) • 100 блокировок на запись на одной таблице dBASE (16 and 32 Bit) • 100 записей, учавствующих в транзакции на таблицу (32 Bit) • 1 миллиард записей в таблице • 2 миллиарда байт в файле .DBF (таблица) • 4000 Размер записи в байтах (dBASE 4) • 32767 Размер записи в байтах (dBASE for Windows) • 255 Количество полей в таблице (dBASE 4) • 1024 Количество полей в таблице (dBASE for Windows) • 47 Количество тэгов индексов на один .MDX-файл. • 254 Размер символьных полей • 10 открытых основных индексов (.MDX) на таблицу • 220 Длина ключевого выражения в символахВ процессе работы программы изменилась структура БД (alter table etc.). Программа продолжала успешно открывать таблицы, но запросы посылались в соответствии со старой схемой данных
Nomadic отвечает: В установках BDE (Configuration utility или BDEAdmin) можно выставить SCHEMA CACHE = FALSE (не кэшировать схему данных). Но в некоторых случаях ошибки такого рода все-таки происходят. В таком случае необходимо воспользоваться методом TDatabase.FlushSchemaCache после каждого изменения метаданных.Как в Delphi сбросить кэш БД на диск?
Nomadic отвечает:uses BDE {в Delphi 1.x не помню, но вроде bdeprocs};
dbiSaveChanges
На Delphi 1.x (16bit) дополнительно вызовите эту процедуру -
procedure DropCache; assembler;
asm
mov ah,$0D
int $21
end;
Как настроить MS SQL Server 6.5 на корректную работу с числами и BDE при выполнении UPDATE?
Nomadic отвечает: Дело в том, что SQL Links на NT-ишном клиенте шлет на сервер дату как 1-янв-97, что сервер не пpиемлет. Совершенно случайно я нашел системный скрипт, который подключает русский и болгарский языки. 1. выполни sp_configure и убедись, что у тебя default sortorder id==106 (rus case insens) или 105 (rus case sens). Если нет – переставь сервер. 2. найди в каталоге c:\mssql\install скрипт instlang.sql и запусти его. 3. либо руками каждому проставь каждому логину, работающему с NT, язык русский, либо поставь его как default language серверу. В этом случае 95-м клиентам придется руками прописать в логине язык us_english, иначе они перестанут работать. Для установки russian как default надо выполнить скрипт:exec sp_configure 'default language', 2
go
reconfigure
go
Как научить VCL делать Refresh для запросов правильно?
Особенно интересует Refresh для связки Master-Detail.Nomadic отвечает: Старо как мир, и нет ничего военного:
procedure RefreshQuery(Query: TQuery; F: boolean);
var B: TBookMark;
begin
with Query do if Query.Active then begin
B := GetBookMark;
try
Close;
Unprepare; {Если не поставить этого, то если используется select SP, то иногда последующая операция вешает сервер. Кто скажет почему?!}
Active:=True;
if F then begin
try
GotoBookMark(B)
except on EDatabaseError do First;
end
end else First;
finally
FreeBookmark(B);
end;
end;
end;
Уфф! Кажется, лучше уже не сделать. :)
dbtables можно опционально пропатчить (см. в конце), чтобы иметь такой вот рyлезный Detail query.
Update for dbtables.pas
New interface function DoRefreshQuery can Refresh TQuery component in master-detail scheme and alone.
TQuery.RefreshParams should be updated
function GetFieldNamesStr(DataSet: TDataSet): String;
var I: Integer;
begin
Result := '';
with DataSet do for I := 0 to FieldCount - 1 do begin
Result := Result + Fields[ I ].FieldName + ';';
end;
end;
procedure DoRefreshQuery(Query: TQuery; KeyFields: String; BookMarkSearch: Boolean);
var
Fields: TList;
KeyValues: Variant;
KeyNames: String;
Bmk: TBookmark;
I: Integer;
BookmarkFound: Boolean;
CanLocate: Boolean;
begin
Fields := TList.Create;
if KeyFields = '' then KeyFields := GetFieldNamesStr(Query);
try
Query.GetFieldList(Fields, KeyFields);
for I := Fields.Count - 1 downto 0 do with TField(Fields[I]) do
if Calculated or Lookup then Fields.Delete(I);
CanLocate := Fields.Count > 0;
if CanLocate then begin
if Fields.Count = 1 then KeyValues := TField(Fields[0]).Value
else begin
KeyValues := VarArrayCreate([0, Fields.Count - 1], varVariant);
KeyValues[0] := TField(Fields[0]).Value;
end;
KeyNames := TField(Fields[0]).FieldName;
for I := 1 to Fields.Count - 1 do begin
KeyNames := KeyNames + ';' + TField(Fields[I]).FieldName;
KeyValues[I] := TField(Fields[I]).Value;
end;
end;
finally
Fields.Free;
end;
with Query do begin
Bmk := nil;
DisableControls;
try
BookmarkFound := False;
if BookMarkSearch then Bmk := GetBookmark;
Close;
Open;
if Assigned(Bmk) then try
GotoBookMark(Bmk);
BookmarkFound := True;
except
end;
if not BookmarkFound and CanLocate then Locate(KeyNames, KeyValues, []);
finally
EnableControls;
Screen.Cursor := crDefault;
FreeBookmark(Bmk);
end;
end;
end;
procedure TQuery.RefreshParams;
var DataSet: TDataSet;
begin
DisableControls;
try
if FDataLink.DataSource <> nil then begin
DataSet := FDataLink.DataSource.DataSet;
if DataSet <> nil then
if DataSet.Active and (DataSet.State <> dsSetKey) then
DoRefreshQuery(Self, GetFieldNamesStr(Self), False);
end;
finally
EnableControls;
end;
end;
Как заставить BDE сохранять в БД поле времени с сотыми долями секунды?
Nomadic отвечает: Если руками, то в BDE Administrator (BDE Configuration Utility). Если при инсталляции твоей программы, то – В пункте Make Registry Changes InstallShield'а создай ключHKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine\Settings\SYSTEM\FORMATS\TIME\MILSECONDS=TRUE
Запись буфера BDE на диск
Delphi 1Общее: Сделанные в таблице изменения непосредственно на диск не записываются до тех пор, пока таблица не будет закрыта. Потеря питания или сбой в системе может привести к потере данных и прочим неприятностям. Чтобы избежать этого, существует два прямых вызова Database Engine, дающих один и тот же результат. Эти функции – DbiUseIdleTime и DbiSaveChanges. DbiSaveChanges(hDBICur): DbiSaveChanges сохраняет на диске все обновления, находящиеся в буфере таблицы, связанной с курсором (hDBICur). Может быть вызвана из любого места программы. Например, можно при каждом обновлении записи сохранять на диске все изменения (добавьте dbiProcs в список используемых модулей):
procedure TForm1.Table1AfterPost(DataSet: TDataSet);
begin
DbiSaveChanges(Table1.handle);
end;
При таком способе можно не беспокоиться насчет потерь данных в случае потери питания или сбоя системы, которое может произойти после обновления записи.
DbiSaveChanges также можно использовать для того, чтобы временную таблицу (созданную с помощью DbiCreateTempTable) сделать постоянной.
Эта функция не применима к таблицам SQL.
DbiUseIdleTime:
DbiUseIdleTime может быть вызвана, если «Windows Message Queue» (очередь запросов Windows) пуста. Это позволяет Database Engine сохранить на диске «грязные буферы». Другими словами, выполняется операция DbiSaveChanges, но применительно ко ВСЕМ измененным таблицам. Тем не менее, данная операция не обязательно должна выполняться после каждого обновления записи, ее нужно приберечь для «холостого» периода (период простоя, idle).
В Delphi это может быть использовано таким образом (добавьте dbiProcs в список используемых модулей):
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.onIdle := UseIdle;
end;
procedure Tform1.UseIdle(Sender: TObject; var Done: Boolean);
begin
DbiUseIdleTime;
end;
Некоторые замечания:
Использование обоих вызовов DbiUseIdleTime и DbiSaveChanges (после каждого обновления записи) излишне и сопровождается необязательными вызовами функций. Если приложение выполняет множественный ввод новых записей или их редактирование в течение небольшого периода времени, рекомендуем осуществлять вызов функции DbiUseIdleTime во время простоя клинта, а вызов DbiSaveChanges после осуществления «пакета» обновлений.
В случае, если в таблице выполняется не слишком много изменений, клиент может использовать вызов DbiSaveChanges после каждого постинга или же «повесить» на таймер вызов DbiUseIdleTime.
Internet
Форматы
UUE кодирование
rel="nofollow noopener noreferrer">Sergei Dubarev пишет: Ваши "Советы…" — классная штука. Столько всего вкусного! :-) Со своей стороны хочу предложить несколько тормозной и местами упрощенный, но все же рабочий ;), алгоритм UUE кодирования (см. аттач). Не вершина искусства, но все же… :) Для того, чтобы ОНО заработало, необходимо создать проект в составе: Форма (form) — 1 шт. Поле ввода (edit) — 2 шт., используются события OnDblClick. Кнопка (button) — 1 шт., используется событие OnClick. Диалог открытия файла (Open Dialog) — 1 шт. Диалог сохранения файла (Save Dialog) — 1 шт. Имена файлов будут вводится либо вручную, либо из диалога (double-click на поле ввода edit), причем в edit1.text должно лежать имя входного файла, в edit2.text — выходного. По нажатии кнопки пойдет процесс, который завершится сообщением "DONE." Всего хорошего. P.S. Функция toanysys обнаружена в книге "Для чего нужны и как работают персональные ЭВМ" от 1990 г. Там она присутствует в виде программы на BASIC'e. P.P.S. Для стимулирования фантазии читателей "Советов…" высылаю так же мессагу из эхи, на основе которой я сваял свое чудо.Файл Unit1.pas
//UUE кодирование
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,ExtDlgs, StdCtrls;
type TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
procedure Edit1DblClick(Sender: TObject);
procedure Edit2DblClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
const
ssz = (High(Cardinal) - $F) div sizeof(byte);//эта константа используется при выделении памяти
p: string = '0123456789ABCDEF';//эта константа используется функцией toanysys
//выбор входного файла
procedure TForm1.Edit1DblClick(Sender: TObject);
begin
if opendialog1.execute then edit1.text:= opendialog1.filename;
end;
//выбор выходного (UUE) файла
procedure TForm1.Edit2DblClick(Sender: TObject);
begin
if savedialog1.execute then edit2.text:= savedialog1.filename;
end;
//выделение подстроки
function mid(s: string; fromc, toc: byte): string;
var
s1: string;
i : byte;
begin
s1:= '';
for i:= fromc to toc do s1:= s1+s[i];
mid:= s1;
end;
//перевод числа (a) из десятичной системы в другую
//с основанием (r)
function toanysys(a, r: byte): string;
var
s, k : string;
n,m,i : byte;
begin
s:='';
m:= 1;
while m<>0 do begin
m:= a div r;
n:= a-m*r+1;
k:= p[n];
s:= k+s;
a:= m;
end;
//добавляет незначащие нули
for i:=1 to 8-length(s) do s:='0'+s;
toanysys:= s;
end;
//перевод 6-разрядного числа из двоичной системы в десятичную
//двоичное число подставляется в виде строки символов
function frombin(s: string): byte;
var i, e, b: byte;
begin
b:= 0;
for i:=1 to 6 do begin
e:= 1 shl (6-i);
if s[i]='1' then b:= b+e;
end;
frombin:= b;
end;
//непосредственно кодирование
type tcoola = array [1..1] of byte;
pcoola = ^tcoola;
procedure TForm1.Button1Click(Sender: TObject);
var
inf: file of byte;
ouf: textfile;
uue: pcoola;
b : array[1..4] of byte;
bin,t : string;
szf,oum,szl,szh,sxl,sxh,i, j : longint;
begin
{$I-}
assignfile(inf, edit1.text); //входной файл
reset(inf);
szf:= filesize(inf); //
szh:= (szf*8) div 6; //
if szf*8-szh*6 = 0 then szl:= 0
else szl:= 1; //
getmem(uue, szh+szl); //выделение памяти
oum:= 1;
while not(eof(inf)) do begin
b[1]:= 0;
b[2]:= 0;
b[3]:= 0;
b[4]:= 0;
//чтение должно быть сделано посложнее,
//дабы избежать "read beyond end of file"
read(inf, b[1], b[2], b[3]);
//читаем 3 байта из входного файла
//и формируем "двоичную" строку
bin:= toanysys(b[1],2)+toanysys(b[2],2)+toanysys(b[3],2);
//разбиваем строку на куски по 6 бит и добавляем 32
t:= mid(bin, 19, 24);
b[4]:= frombin(t)+32;
t:=mid(bin, 13, 18);
b[3]:= frombin(t)+32;
t:= mid(bin, 07, 12);
b[2]:= frombin(t)+32;
t:= mid(bin, 01, 06);
b[1]:= frombin(t)+32;
//запихиваем полученнные байты во временный массив
uue[oum]:= b[1];
oum:= oum+1;
uue[oum]:= b[2];
oum:= oum+1;
uue[oum]:= b[3];
oum:= oum+1;
uue[oum]:= b[4];
oum:= oum+1;
end;
//входной файл больше не нужен - закрываем его
closefile(inf);
//формируем выходной файл
assignfile(ouf, edit2.text); //выходной файл
rewrite(ouf);
oum:= 1;
sxh:= (szh+szl) div 60; //число строк в UUE файле
sxl:= (szh+szl)-sxh*60;
//заголовок UUE-файла
writeln(ouf, 'begin 644 '+extractfilename(edit1.text));
//записываем строки в файл
for i:=1 to sxh do begin
write(ouf, 'M');
// 'M' значит, что в строке 60 символов
for j:= 1 to 60 do begin
write(ouf, chr(uue[oum]));
oum:= oum+1;
end;
writeln(ouf);
end;
//записываем последнюю строку, которая//обычно короче 60 символов
sxh:= (sxl*6) div 8;
write(ouf, chr(sxh+32));
for i:= 1 to sxl do begin
write(ouf, chr(uue[oum]));
oum:= oum+1;
end;
// "добиваем" строку незначащими символами
for i:= sxl+1 to 60 do write(ouf, '`');
//записываем последние строки файла
writeln(ouf);
writeln(ouf, '`');
writeln(ouf, 'end');
closefile(ouf);
freemem(uue, szh+szl);
//освобождаем память
showmessage('DONE.'); //Готово. Забирайте!
end;
end.
Из FIDO-переписки:
- New auto-created HomeNet area (555:172/89.2) ------------- HOME.PROGRAMMERS -
Msg : 34 of 35
From : Philip Bondarovich 555:172/445.43 Пнд 17 Янв 00 02:51
To : Denis Guravski Втp 18 Янв 00 22:21
Subj : UUE
-------------------------------------------------------------------------------
Wednesday January 12 2000 22:56, Denis Guravski писал All:
DG> Люди , сpочно нyжно описание сабжа .
=== Begin uuecode ===
- INT.PROGRAMMERS (256:172/43) ------------------------------ INT.PROGRAMMERS -
Msg : 38 of 38 -36 Scn
From : Monk 256:172/10 15 Jan 00 18:24:30
To : Nikolay Severikov 16 Jan 00 03:47:50
Subj : UU-code
-------------------------------------------------------------------------------
Жывi сабе памаленькy, /_*Nikolay*_/!
У чацьвэp Стyдзеня 13 2000 y 23:25, цёмнай ночкаю, Nikolay Severikov тайна пiсаў All, i я ўцягнyўся...
NS> Расскажите плиз о сyбже... Как он кодиpyется.
Калi ласка.
=== Cut ===
1) Читаем из исходного хфайла 3 байта.
2) Разбиваем полyченные 24 бита (8x3=24) на 4 части, т.е. по 6 бит.
3) Добавляем к каждой части число 32 (десятичн.)
Примеp: Имеем тpи числа 234 12 76. Побитово бyдет так -
11101010 00001100 01001100 pазбиваем и полyчаем -
111010 100000 110001 001100 добавляем 32 -
+100000 +100000 +100000 +100000
------ ------ ------ ------
1011010 1000000 1010001 101100 или в бyквах -
Z @ Q ,
Вот собственно и все. В UUE файле в пеpвой позиции стоит кол-во закодиpованных
символов + 32. Т.е. вся стpока содеpжит 61 символ. 1 символ идет на кол-во.
Остается 60 символов _кода_. Если подсчитать, то мы yвидим, что для полyчения
60
символов кода необходимо 45 исходных символов. Для полной стpоки в начале стоит
бyква "M", а ее ASCII код = 77. 45+32=77.
=== Cut ===
З павагай да ўсiх вас, Monk. Спадзяюся на пpацяг pазмовы, *Nikolay*!
... -Папа, я есть хочy! -Стыдись, сынок, в твои годы я хотел стать космонавтом!
-+- GoldED+/386 1.1.1.2
+ Origin: - Тавеpна BBS - 241-5714 23:00-6:00. Freqs allowed. (256:172/10)
=== End uuecode ===
WBR.
... Чешиpский Котенок лyчше всех
--- GoldED+/W32 1.1.1.2
* Origin: WonderLand (555:172/445.43)
ISAPI
Почему мои ISAPI-ориентированные библиотеки, созданные в Delphi 3, не могут обрабатывать несколько соединений?
Nomadic отвечает: Волшебник по созданию ISAPI DLL в Delphi 3 создает полностью безопасную многопоточную библиотеку, но не выставляет флаг, говорящий приложению, что эта библиотека в этом отношении безопасна. Это легко исправить, просто добавив строчку:IsMultiThread := TRUE;
end;
первой строкой в Вашем блоке begin-end файла проекта (DPR).
Соединение
Проверка URL
The_Sprite отвечает: Данная функция позволяет Вам проверить существование определённого адреса(URL) в интернете. Естественно она может пригодиться веб-мастерам, у которых на сайте много ссылок, и необходимо с определённой периодичнойстью эти ссылки проверять. URL может быть как с префиксом http:/ так и без него - эта функция добавляет префикс http:// если он отсутствует (необходимо для функции internetOpenUrl которая так же поддерживает FTP:// и gopher:// Эта функция проверяет только два возвращаемых кода '200'(ОК) или '302' (Редирект), но Вы можете заставить проверять функцию и другие коды. Для этого достаточно модифицировать строчку "result := ". Платформа: Delphi 3.x (или выше)uses wininet;
Function CheckUrl(url:string):boolean;
var
hSession, hfile, hRequest: hInternet;
dwindex,dwcodelen :dword;
dwcode:array[1..20] of char;
res : pchar;
begin
if pos('http://',lowercase(url))=0 then url := 'http://'+url;
Result := false;
hSession := InternetOpen('InetURL:/1.0', INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);
if assigned(hsession) then begin
hfile := InternetOpenUrl(hsession, pchar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
dwIndex := 0;
dwCodeLen := 10;
HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE, @dwcode, dwcodeLen, dwIndex);
res := pchar(@dwcode);
result:= (res ='200') or (res ='302');
if assigned(hfile) then InternetCloseHandle(hfile);
InternetCloseHandle(hsession);
end;
end;
Разное
Объект DocInput
Delphi 2Тема: Объект DocInput: свойства и методы Объект DocInput — объект из пакета Internet Solutions Pack фирмы NetManage, поставляемого в составе Delphi 2.01. Он предназначен для описания входной информции для документа, передаваемого элементу управления. Все элементы управления для работы с Интернетом, имеющиеся в данном пакете, имеют доступ к объекту через соответствующее свойство, могут хранить в нем документы и передавать его от одного элемента управления другому. Объект DocInput имеет следующие свойства: BytesTotal, BytesTransferred, DocLink, FileName, Headers, PushStreamMode, State и Suspended. BytesTotal — счетчик общего количества байт передаваемого элемента. Значение по умолчанию и начальное значение равно нулю. Тип данных — Long. Данное свойство времени выполнения и только для чтения. Значение данного свойства получается из свойства заголовка "content-length" (длина содержимого). Это значение используется элементом управления для определения размера (объема) передаваемой информации. С помощью него также возможно управление буфером, который вы используете для "сборки" данных после их передачи. Свойство BytesTranferred является свойством, передаваемым вам при наступлении события OnDocInput. Данное свойство времени выполнения, только для чтения и имеет тип long. При начале новой передачи значение свойства обнуляется. Обновляется в начале события OnDocInput. Значение данного свойства отражает величину последней передачи, когда другие передачи не осуществлялись. Свойство BytesTransferred может использоваться для показа линейки прогресса или для утверждения того, насколько фактически переданный размер соответствует ожидаемому. Свойство DocLink сообщает получающему элементу управления о том, что источник не будет посылать документ через поток данных или входной файл. Оно ссылается на свойство DocOutput.DocLink, которое становится источником при передаче данных. Данное свойство является read/write-свойством (для чтения и записи) и доступно только во время выполнения программы. Свойство имеет тип DocLink. Это строковый тип, имеющий значение по умолчанию ''. Если значению данного свойства присваивается величина, отличная от '', свойство FileName автоматически устанавливается в ''. Данное свойство используется для определения источника, являющегося internet-компонентом с указывающим на объект свойством DocOutput.DocLink, т.е. они используются в парах. Свойство FileName является read/write-свойством (для чтения и записи) только времени выполнения и имеет строковый тип. Значение по умолчанию ''. Это должно быть правильным именем файла. Данное свойство может быть установлено при его передаче в качестве аргумента объекту DocInput. Если значению данного свойства присваивается величина, отличная от '', свойство DocLink автоматически устанавливается в ''. Свойство Headers является свойстом только для чтения и времени выполнения. "headers" — коллекция элементов DocHeader, которые определяют передаваемый документ. Содержимое свойства headers должно быть изменено перед вызовом метода GetDoc. Каждый DocHeader представляет собой MultiPurpose Internet Mail Extension (MIME). Mime является механизмом для определения и описания формата тела сообщения Интернет (Internet Message Bodies). (Для получения дополнительной информации смотри документ rfc1341). Используемые headers (заголовки) зависят от используемого протокола, но существуют два заголовка, независимые от протокола: 1. content-type (тип содержимого) content type указывает спецификацию MIME для следующего за заголовком документа. Примером этого является "text/plain". 2. content-length (размер содержимого) content length указывает размер документа в байтах. Свойтво state является свойством только для чтения и времени выполнения, и имеет перечислимый тип DocStateConstants. Значение по умолчанию icDocNone. Свойство state элемента управления обновляет себя каждый раз при наступлении события DocInput. Свойство suspended является свойством только для чтения и времени выполнения, и имеет логический тип. Устанавливается вызывом метода suspend. При установке значения, равного True, передача приостанавливается. Свойство PushStream является read/write-свойством (для чтения и записи) только времени выполнения и имеет логический тип. Значение по умолчанию — False. Если свойству FileName или DocLink присваивается значение, отличное от '', то свойство PushStream становится недоступным. Объект DocInput имеет 4 метода: GetData, PushStream, SetData и Suspend. Метод GetData сообщает объекту DocInput об извлечении текущего блока данных в момент наступления события DocOutput. Данный метод может быть вызван только в течение события OnDocInput, и только когда свойство State установлено в icDocData(3). При использовании свойства FileName или DocLink, данный метод позволяет исследовать данные во время их передачи. Метод PushStream может быть вызван только если PushStreamMode установлен в True и когда данные доступны. PushStream устанавливает свойство State на основе следующего шага передачи документа и активизирует в нужный момент событие DocInput. Затем происходит возврат до следующего вызова PushStream. Перед вызовом PushStream должен быть вызван SetData. Метод SetData определяет следующий буфер передаваемых данных при наступлении события DocInput. SetData вызывается в течение события DocInput или перед вызовом SendDoc. Если метод используется перед вызовом SendDoc, он может служить альтернативой передачи параметров InputData в InputData. Тип должен быть определен как variant. Метод Suspend передает форме команду suspend(true) или suspend(false). Если метод с параметром True был вызван дважды, то для продолжения передачи его необходимо дважды вызвать с параметром False. Вот некоторый код примера, показывающий как можно использовать объект DocInput. Полный проект, содержащий данный код, вы можете найти в подкаталоге demos на CD-ROM с Delphi 2.01. Имя проекта SimpMail.dpr. Данные проект представляет собой большое пример использования свойтсва объекта headers. Также показано соответствующее использование события DocInput и свойства State.
{Очистка и новое заполнение заголовков MIME с помощью свойства компонента DocInput. Может также использоваться отдельный OLE объект DocInput. Для получения полной информации о типах MIME смотри документ RFC1521/1522.}
procedure TMainForm.CreateHeaders;
begin
with SMTP1 do begin
DocInput.Headers.Clear;
DocInput.Headers.Add('To', eTo.Text);
DocInput.Headers.Add('From', eHomeAddr.Text);
DocInput.Headers.Add('CC', eCC.Text);
DocInput.Headers.Add('Subject', eSubject.Text);
DocInput.Headers.Add('Message-Id',
Format('%s_%s_%s', [Application.Title, DateTimeToStr(Now), eHomeAddr.Text]));
DocInput.Headers.Add('Content-Type', 'TEXT/PLAIN charset=US-ASCII');
end;
end;
{Посылаем простое почтовое сообщение}
procedure TMainForm.SendMessage;
begin
CreateHeaders;
with SMTP1 do SendDoc(NoParam, DocInput.Headers, reMessageText.Text, '', '');
end;
{Посылаем файл, расположенный на диске. Оставляем пустым параметр SendDoc InputData и определяем имя файла для InputFile для посылки содержимого файла, расположенного на диске. Для осуществления собственного кодирования (Base64, UUEncode и др.), вы можете использовать событие DocInput и методы GetData }
procedure TMainForm.SendFile(Filename: string);
begin
CreateHeaders;
with SMTP1 do begin
DocInput.Filename := FileName;
SendDoc(NoParam, DocInput.Headers, NoParam, DocInput.FileName, '');
end;
end;
{Событие DocInput возникает при каждом изменении состояния DocInput во время передачи почтового сообщения. DocInput хранит всю информацию о текущей передаче, включая заголовки, количество переданных байт и сами данные сообщения. Хотя в этом примере и не показано, для кодирования данных перед отправкой каждого блока вы можете вызвать метод DocInput SetData, если DocInput.State = icDocData. }
procedure TMainForm.SMTP1DocInput(Sender: TObject; const DocInput: Variant);
begin
case DocInput.State of
icDocBegin:
SMTPStatus.SimpleText := 'Начало передачи документа';
icDocHeaders:
SMTPStatus.SimpleText := 'Посылаем заголовки';
icDocData:
if DocInput.BytesTotal > 0 then
SMTPStatus.SimpleText:=
Format('Послано данных: %d из %d байт (%d%%)',
[Trunc(DocInput.BytesTransferred),
Trunc(DocInput.BytesTotal),
Trunc(DocInput.BytesTransferred/DocInput.BytesTotal*100)])
else SMTPStatus.SimpleText := 'Посылка...';
icDocEnd:
if SMTPError then SMTPStatus.SimpleText := 'Передача прервана'
else
SMTPStatus.SimpleText :=
Format('Почта послана %s (%d байт данных)',
[eTo.Text,Trunc(DocInput.BytesTransferred)]);
end;
SMTPStatus.Update;
end;
Объект DocOutput
Delphi 2Тема: Объект DocOutput: свойства и методы Объект DocOutput — объект из пакета Internet Solutions Pack фирмы NetManage, поставляемого в составе Delphi 2.01. Он описывает выходную информацию передаваемого документа. Все элементы управления, имеющие свойство DocOutput, используют этот тип. Он также является объектом, на который указывает событие DocOutput. Объект DocOutput имеет следующие свойства: BytesTotal, BytesTransferred, DocLink, FileName, Headers, PushStreamMode, State и Suspend. BytesTotal — счетчик общего количества байт передаваемого элемента. Значение по умолчанию и начальное значение равно нулю. Тип данных — Long. Данное свойство времени выполнения и только для чтения. Значение данного свойства получается из свойства заголовка "content-length" (длина содержимого). Это значение используется элементом управления для определения размера (объема) передаваемой информации. С помощью него также возможно управление буфером, который вы используете для "сборки" данных после их передачи. Свойство BytesTranferred является свойством, передаваемым вам при наступлении события OnDocInput. Данное свойство времени выполнения, только для чтения и имеет тип long. При начале новой передачи значение свойства обнуляется. Обновляется в начале события OnDocInput. Значение данного свойства отражает величину последней передачи, когда другие передачи не осуществлялись. Свойство BytesTransferred может использоваться для показа линейки прогресса или для утверждения того, насколько фактически переданный размер соответствует ожидаемому. Свойство DocLink сообщает получающему элементу управления о том, что источник не будет посылать документ через поток данных или входной файл. Оно ссылается на свойство DocOutput.DocLink, которое становится источником при передаче данных. Данное свойство является read/write-свойством (для чтения и записи) и доступно только во время выполнения программы. Свойство имеет тип DocLink. Это строковый тип, имеющий значение по умолчанию ''. Если значению данного свойства присваивается величина, отличная от '', свойство FileName автоматически устанавливается в ''. Данное свойство используется для определения источника, являющегося internet-компонентом с указывающим на объект свойством DocOutput.DocLink, т.е. они используются в парах. Свойство FileName является read/write-свойством (для чтения и записи) только времени выполнения и имеет строковый тип. Значение по умолчанию ''. Это должно быть правильным именем файла. Данное свойство может быть установлено при его передаче в качестве аргумента объекту DocInput. Если значению данного свойства присваивается величина, отличная от '', свойство DocLink автоматически устанавливается в ''. Свойство Headers является свойстом только для чтения и времени выполнения. "headers" — коллекция элементов DocHeader, которые определяют передаваемый документ. Содержимое свойства headers должно быть изменено перед вызовом метода GetDoc. Каждый DocHeader представляет собой MultiPurpose Internet Mail Extension (MIME). Mime является механизмом для определения и описания формата тела сообщения Интернет (Internet Message Bodies). (Для получения дополнительной информации смотри документ rfc1341). Используемые headers (заголовки) зависят от используемого протокола, но существуют два заголовка, независимые от протокола: 1. content-type (тип содержимого) content type указывает спецификацию MIME для следующего за заголовком документа. Примером этого является "text/plain". 2. content-length (размер содержимого) content length указывает размер документа в байтах. Свойтво state является свойством только для чтения и времени выполнения, и имеет перечислимый тип DocStateConstants. Значение по умолчанию icDocNone. Свойство state элемента управления обновляет себя каждый раз при наступлении события DocInput. Свойство suspended является свойством только для чтения и времени выполнения, и имеет логический тип. Устанавливается вызывом метода suspend. При установке значения, равного True, передача приостанавливается. Свойство PushStream является read/write-свойством (для чтения и записи) только времени выполнения и имеет логический тип. Значение по умолчанию — False. Если свойству FileName или DocLink присваивается значение, отличное от '', то свойство PushStream становится недоступным. Объект DocOutput имеет три метода: GetData, SetData и Suspend. Метод GetData сообщает объекту DocInput об извлечении текущего блока данных в момент наступления события DocOutput. Данный метод может быть вызван только в течение события OnDocInput, и только когда свойство State установлено в icDocData(3). При использовании свойства FileName или DocLink, данный метод позволяет исследовать данные во время их передачи. Метод SetData определяет следующий буфер передаваемых данных при наступлении события DocInput. SetData вызывается в течение события DocInput или перед вызовом SendDoc. Если метод используется перед вызовом SendDoc, он может служить альтернативой передачи параметров InputData в InputData. Тип должен быть определен как variant. Метод Suspend передает форме команду suspend(true) или suspend(false). Если метод с параметром True был вызван дважды, то для продолжения передачи его необходимо дважды вызвать с параметром False. Приведенный здесь код взят из демонстрационного проекта, расположенного в подкаталоге Delphi 2.01 demos\internet. Имя проекта HTTPDemo.dpr. Данный проект представляет собой пример использования свойств объекта BytesTransferred и state. Также показано использование различных типов данных, являющимися новыми для Delphi 2.01. Эти типы данных важны для использования OLE, и пользователи Delphi должны о них узнать как можно скорее, если они хотят начать использовать технологию OLE в своих приложениях.
procedure TForm1.HTTP1DocOutput(Sender: TObject; const DocOutput: Variant);
var
S: String;
i: integer;
MsgNo, Header: String;
Parser: TSimpleHTMLParser;
ALine: String;
begin
Statusbar1.Panels[2].Text :=Format('Байт: %s',[DocOutput.BytesTransferred]);
case DocOutput.State of
icDocBegin:
begin
Memo1.Lines.Clear;
Data := '';
end;
icDocData:
begin
DocOutput.GetData(S, VT_BSTR);
Data := Data + S;
end;
icDocEnd:
begin
{ Теперь удаляем все HTML-тэги и отображаем текст }
Parser := TSimpleHTMLParser.Create(Data);
ALine := '';
while Parser.FToken <> etEnd do begin
case Parser.FToken of
etHTMLTag:
begin
if Parser.TokenHTMLTagIs('BR') then ALine := ALine + #13#10;
if Parser.TokenHTMLTagIs('P') then ALine := ALine + #13#10#13#10;
end;
etSymbol:
ALine := ALine + ' ' + Parser.FTokenString;
etLineEnd:
begin
Memo1.Lines.Add(ALine);
ALine := '';
end;
end;
Parser.NextToken;
end;
Memo1.Lines.Add(ALine);
Memo1.SelStart := 0;
SendMessage(Memo1.Handle, EM_ScrollCaret, 0, 0);
end;
end;
Refresh;
end;
Захват текущего URL у MSIE
The_Sprite советует: Пример показывает, как найти окно Internet Explorer, и захватить из него текущий URL, находящийся в поле адреса IE. В Исходнике используются простые функции win32 api на delphi.
{-------------------------------------------------------}
Function GetText(WindowHandle: hwnd):string;
var
txtLength : integer;
buffer: string;
begin
TxtLength := SendMessage(WindowHandle, WM_GETTEXTLENGTH, 0, 0);
txtlength := txtlength + 1;
setlength(buffer, txtlength);
sendmessage(WindowHandle, wm_gettext, txtlength, longint(@buffer[1]));
result := buffer;
end;
function GetURL:string;
var ie, toolbar, combo, comboboxex, edit, worker, toolbarwindow: hwnd;
begin
ie := FindWindow(pchar('IEFrame'), nil);
worker := FindWindowEx(ie, 0, 'WorkerA', nil);
toolbar := FindWindowEx(worker, 0, 'rebarwindow32', nil);
comboboxex := FindWindowEx(toolbar, 0, 'comboboxex32', nil);
combo := FindWindowEx(comboboxex, 0, 'ComboBox', nil);
edit := FindWindowEx(combo, 0, 'Edit', nil);
toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil);
result := GetText(edit);
{-------------------------------------------------------}
procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(GetURL);
end;
Мультимедиа
Звук
Заставьте приложение Delphi 2 `петь`
Delphi 2Тема: Как заставить приложение Delphi 2 `петь`. Данный совет демонстрирует четыре различных способа как заставить ваше Delphi 2.0 приложение `петь`, т.е. загружать и проигрывать звуковой файл: 1. Для проигрывания звукового файла используйте непосредственно функцию sndPlaySound(). 2. Считывайте звуковой файл в память, затем для его проигрывания используйте sndPlaySound(). 3. Используйте sndPlaySound для непосредственного проигрывания звуковых файлов, расположенных в файлах ресурсов, прилинкованных к вашему приложению. 4. Считывайте звуковой файл, располагаемый в файле ресурса, прилинкованному к вашему приложению, в память, и затем для его проигрывания используйте sndPlaySound(). Для построения проекта вам понадобиться: 1. Создайте звуковой файл с именем 'hello.wav' в каталоге проекта. 2. Создайте текстовый файл с именем 'snddata.rc' в каталоге проекта. 3. Добавьте следующую строку к файлу 'snddata.rc':
HELLO WAVE hello.wav
.
4. В dos-сессии перейдите в ваш каталог приложения и скомпилируйте .rc-файл, используя компилятор ресурсов Borland (brcc32.exe): введите путь к brcc32.exe и передайте 'snddata.rc' в качестве параметра.
Пример:
bin\brcc32 snddata.rc
Это создаст файл 'snddata.res', который Delphi слинкует с EXE-файлом вашего приложения.
Далее приведен необходимый вам код:
unit PlaySnd1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm)
PlaySndFromFile: TButton;
PlaySndFromMemory: TButton;
PlaySndbyLoadRes: TButton;
PlaySndFromRes: TButton;
procedure PlaySndFromFileClick(Sender: TObject);
procedure PlaySndFromMemoryClick(Sender: TObject);
procedure PlaySndFromResClick(Sender: TObject);
procedure PlaySndbyLoadResClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
{$R snddata.res}
uses MMSystem;
procedure TForm1.PlaySndFromFileClick(Sender: TObject);
begin
sndPlaySound('hello.wav', SND_FILENAME or SND_SYNC);
end;
procedure TForm1.PlaySndFromMemoryClick(Sender: TObject);
var
f: file;
p: pointer;
fs: integer;
begin
AssignFile(f, 'hello.wav');
Reset(f,1);
fs := FileSize(f);
GetMem(p, fs);
BlockRead(f, p^, fs);
CloseFile(f);
sndPlaySound(p, SND_MEMORY or SND_SYNC);
FreeMem(p, fs);
end;
procedure TForm1.PlaySndFromResClick(Sender: TObject);
begin
PlaySound('HELLO', hInstance, SND_RESOURCE or SND_SYNC);
end;
procedure TForm1.PlaySndbyLoadResClick(Sender: TObject);
var
h: THandle;
p: pointer;
begin
h := FindResource(hInstance, 'HELLO', 'WAVE');
h := LoadResource(hInstance, h);
p := LockResource(h);
sndPlaySound(p, SND_MEMORY or snd_sync);
UnLockResource(h);
FreeResource(h);
end;
end.
Создание нового WAV-файла
Тема: Создание нового файла с расширением .wav. Данный документ был создан по многочисленным просьбам пользователей и описывает дополнительную функциональность компонента Delphi TMediaPlayer. Новая функциональность компонента заключается в возможности создания при записи нового файла формата .wav. Процедура "SaveMedia" создает тип record, передаваемый команде MCISend. Существует исключение, которое вызывает закрытие медиа при любой ошибке, возникающей при открытии определенного файла. Приложение состоит из двух кнопок. Button1 вызывает по-порядку процедуры OpenMedia и RecordMedia. Процедура CloseMedia вызывается при генерации приложением исключительной ситуации. Button2 вызывает процедуры StopMedia,SaveMedia и CloseMedia.unit utestrec;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, MPlayer, MMSystem, StdCtrls;
type TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure AppException(Sender: TObject; E: Exception);
private
FDeviceID: Word;
{ Private declarations }
public
procedure OpenMedia;
procedure RecordMedia;
procedure StopMedia;
procedure SaveMedia;
procedure CloseMedia;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
var MyError,Flags: Longint;
procedure TForm1.OpenMedia;
var
MyOpenParms: TMCI_Open_Parms;
MyPChar: PChar;
TextLen: Longint;
begin
Flags:=mci_Wait or mci_Open_Element or mci_Open_Type;
with MyOpenParms do begin
dwCallback:=Handle; // TForm1.Handle
lpstrDeviceType:=PChar('WaveAudio');
lpstrElementName:=PChar('');
end;
MyError:=mciSendCommand(0, mci_Open, Flags, Longint(@MyOpenParms));
if MyError = 0 then FDeviceID:=MyOpenParms.wDeviceID;
end;
procedure TForm1.RecordMedia;
var
MyRecordParms: TMCI_Record_Parms;
TextLen: Longint;
begin
Flags:=mci_Notify;
with MyRecordParms do begin
dwCallback:=Handle; // TForm1.Handle
dwFrom:=0;
dwTo:=10000;
end;
MyError:=mciSendCommand(FDeviceID, mci_Record, Flags,Longint(@MyRecordParms));
end;
procedure TForm1.StopMedia;
var MyGenParms: TMCI_Generic_Parms;
begin
if FDeviceID <> 0 then begin
Flags:=mci_Wait;
MyGenParms.dwCallback:=Handle; // TForm1.Handle
MyError:=mciSendCommand(FDeviceID, mci_Stop, Flags,Longint(@MyGenParms));
end;
end;
procedure TForm1.SaveMedia;
type // не реализовано в Delphi
PMCI_Save_Parms = ^TMCI_Save_Parms;
TMCI_Save_Parms = record
dwCallback: DWord;
lpstrFileName: PAnsiChar; // имя файла, который нужно сохранить
end;
var MySaveParms: TMCI_Save_Parms;
begin
if FDeviceID <> 0 then begin
// сохраняем файл...
Flags:=mci_Save_File or mci_Wait;
with MySaveParms do begin
dwCallback:=Handle;
lpstrFileName:=PChar('c:\message.wav');
end;
MyError:=mciSendCommand(FDeviceID, mci_Save, Flags,Longint(@MySaveParms));
end;
end;
procedure TForm1.CloseMedia;
var MyGenParms: TMCI_Generic_Parms;
begin
if FDeviceID <> 0 then begin
Flags:=0;
MyGenParms.dwCallback:=Handle; // TForm1.Handle
MyError:=mciSendCommand(FDeviceID, mci_Close, Flags,Longint(@MyGenParms));
if MyError = 0 then FDeviceID:=0;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenMedia;
RecordMedia;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
StopMedia;
SaveMedia;
CloseMedia;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnException := AppException;
end;
procedure TForm1.AppException(Sender: TObject; E: Exception);
begin
CloseMedia;
end;
end.
Как реализовать регулятор громкости?
Nomadic советует: Да всё пpосто. Даже, я бы сказал, тyпо. :-)INT GetMasterVolumeControlID() {
// get dwLineID
MIXERLINE mxl;
mxl.cbStruct = sizeof(MIXERLINE);
mxl.dwComponentType = MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
if (::mixerGetLineInfo((HMIXEROBJ)ghmx, &mxl, MIXER_OBJECTF_HMIXER | MIXER_GETLINEINFOF_COMPONENTTYPE) != MMSYSERR_NOERROR) return 34;
// get dwControlID
MIXERCONTROL mxc;
MIXERLINECONTROLS mxlc;
mxlc.cbStruct = sizeof(MIXERLINECONTROLS);
mxlc.dwLineID = mxl.dwLineID;
mxlc.dwControlType = MIXERCONTROL_CONTROLTYPE_VOLUME;
mxlc.cControls = 1;
mxlc.cbmxctrl = sizeof(MIXERCONTROL);
mxlc.pamxctrl = &mxc;
if (::mixerGetLineControls((HMIXEROBJ)ghmx, &mxlc, MIXER_OBJECTF_HMIXER | MIXER_GETLINECONTROLSF_ONEBYTYPE) != MMSYSERR_NOERROR) return 34;
return mxc.dwControlID;
}
BOOL SetMasterVolume(DWORD dwVolume) {
MIXERCONTROLDETAILS mxcd;
MIXERCONTROLDETAILS_UNSIGNED mxcd_u;
mxcd.cbStruct = sizeof(mxcd);
mxcd.dwControlID = MasterVolumeControlID;
mxcd.cChannels = 1;
mxcd.cMultipleItems = 0;
mxcd.cbDetails = 4;
mxcd.paDetails = &mxcd_u;
mmr = mixerGetControlDetails((HMIXEROBJ)ghmx, &mxcd, 0L);
if (MMSYSERR_NOERROR != mmr) return FALSE;
mxcd_u.dwValue = dwVolume;
mmr = mixerSetControlDetails((HMIXEROBJ)ghmx, &mxcd, 0L);
if (MMSYSERR_NOERROR != mmr) return FALSE;
return TRUE;
}
Переписывать на Delphi, думаю, ни к чему. Надо лишь не забыть добавить uses MMSystem; Громкость отдельных каналов очень просто устанавливается через auxSetVolume и аналогичные.
Как использовать в своей программе API DirectSound и DirectSound3D?
Nomadic советует:
Пример 1
Представляю вашему вниманию рабочий пример использования DirectSound на Delphi + несколько полезных процедур. В этом примере создается один первичный SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла. Первичный буфер создается процедурой AppCreateWritePrimaryBuffer, а любой вторичный - AppCreateWritePrimaryBuffer. Так как вторичный буфер связан с WAV файлом, то при создании буфера нужно определить его параметры в соответствии со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в виде параметров процедуры. Time — время WAV'файла в секундах (округление в сторону увеличения). При нажатии на кнопку происходит микширование из вторичных буферов в первичный. AppWriteDataToBuffer позволяет записать в буфер PCM сигнал. Процедура CopyWAVToBuffer открывает WAV файл, отделяет заголовок, читает чанк 'data' и копирует его в буфер (при этом сначала считывается размер данных, так как в некоторых WAV файлах существует текстовый довесок, и если его не убрать, в динамиках возможен треск). PS. Если есть какие-нибудь вопросы, постараюсь на них ответить.unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls,Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
type TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
DirectSound: IDirectSound;
DirectSoundBuffer: IDirectSoundBuffer;
SecondarySoundBuffer: array[0..1] of IDirectSoundBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer; SamplesPerSec: Integer; Bits: Word; isStereo: Boolean; Time: Integer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer; OffSet: DWord; var SoundData; SoundBytes: DWord);
procedure CopyWAVToBuffer(Name: PChar;
var Buffer: IDirectSoundBuffer);
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then Raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0], 22050, 8,False, 10);
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1], 22050, 16, True, 1);
end;
procedure TForm1.FormDestroy(Sender: TObject);
var i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then DirectSoundBuffer.Release;
for i:=0 to 1 do if Assigned(SecondarySoundBuffer[i]) then SecondarySoundBuffer[i].Release;
if Assigned(DirectSound) then DirectSound.Release;
end;
procedure TForm1.AppWriteDataToBuffer;
var
AudioPtr1, AudioPtr2: Pointer;
AudioBytes1, AudioBytes2: DWord;
h: HResult;
Temp: Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST then begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');
end
else if H <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');
Temp:=@SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then begin
Temp:=@SoundData;
Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK then Raise Exception.Create('Unable to UnLock Sound Buffer');
end;
procedure TForm1.AppCreateWritePrimaryBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps : DSBCaps;
PCM : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC), 0);
FillChar(PCM, SizeOf(TWaveFormatEx), 0);
with BufferDesc do begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle, DSSCL_WRITEPRIMARY) <> DS_OK then Raise Exception.Create('Unable to set Coopeative Level');
if DirectSound.CreateSoundBuffer(BufferDesc, DirectSoundBuffer, nil) <> DS_OK then Raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then Raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then Raise Exception.Create('Unable to set Coopeative Level');
end;
procedure TForm1.AppCreateWriteSecondaryBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps : DSBCaps;
PCM : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC), 0);
FillChar(PCM, SizeOf(TWaveFormatEx), 0);
with BufferDesc do begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then PCM.nChannels:=2
else PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc, Buffer, nil) <> DS_OK then Raise Exception.Create('Create Sound Buffer failed');
end;
procedure TForm1.CopyWAVToBuffer;
var
Data: PChar;
FName: TFileStream;
DataSize: DWord;
Chunk: String[4];
Pos: Integer;
begin
FName:=TFileStream.Create(Name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.Read(Chunk[1],4);
Inc(Pos);
until Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.Read(DataSize, SizeOf(DWord));
GetMem(Data, DataSize);
FName.Read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer, 0, Data^, DataSize);
FreeMem(Data, DataSize);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('1.wav', SecondarySoundBuffer[0]);
CopyWAVToBuffer('flip.wav', SecondarySoundBuffer[1]);
if SecondarySoundBuffer[0].Play(0, 0, 0) <> DS_OK then ShowMessage('Can''t play the Sound');
if SecondarySoundBuffer[1].Play(0, 0, 0) <> DS_OK then ShowMessage('Can''t play the Sound');
end;
end.
Пример 2
Представляю вашему вниманию очередной пример работы с DirectSound на Delphi. В этом примере показан принцип работы с 3D буфером. Итак, процедуры AppCreateWritePrimaryBuffer, AppWriteDataToBuffer, CopyWAVToBuffer я оставил без изменения (см. письма с до этого). Процедура AppCreateWriteSecondary3DBuffer является полным аналогом процедуры AppCreateWriteSecondaryBuffer, за исключением флага DSBCAPS_CTRL3D, который указывает на то, что со статическим вторичным буфером будет связан еще один буфер – SecondarySound3DBuffer. Чтобы его инициализировать, а также установить некоторые начальные значения (положение в пространстве, скорость и .т.д.) вызывается процедура AppSetSecondary3DBuffer, в качестве параметров которой передаются сам SecondarySoundBuffer и связанный с ним SecondarySound3DBuffer. В этой процедуре SecondarySound3DBuffer инициализируется с помощью метода QueryInterface c соответствующим флагом. Кроме того, здесь же устанавливается положение источника звука в пространстве: SetPosition(Pos,1{X},1{Y},0{Z}). Таким образом в начальный момент времени источник находится на высоте 1 м (ось Y направлена вертикально вверх, а ось Z – «в экран»). Если смотреть сверху : ↑ Z
|
А |
|
O----------------> X
Точка O (фактически вы) имеет координаты (0,0), источник звука А(-25,1). Разумеется понятие «метр» весьма условно.
При нажатии на кнопку в буфер SecondarySoundBuffer загружается звук 'xhe4.wav'. Это звук работающего винта вертолета, его длина (звука) ровно 3.99 с (а размер буфера ровно 4 с). Далее происходит микширование из вторичного буфера в первичный с флагом DSBPLAY_LOOPING, что позволяет сделать многократно повторяющийся звук; время в 0.01 с ухом практически не улавливается и получается непрерывный звук летящего вертолета. После этого запускется таймер (поле INTERVAL в Инспекторе Оъектов установлено в 1). Разумеется, Вам совсем необязательно делать именно так, это просто пример. В процедуре Timer1Timer просто меняется координата X с шагом 0.1.
В итоге получаем летящий вертолет слева направо. Заодно можете проверить, правильно ли у вас расположены колонки.
PS. Если есть вопросы, постараюсь на них ответить.
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls,Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
type TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
DirectSound: IDirectSound;
DirectSoundBuffer: IDirectSoundBuffer;
SecondarySoundBuffer: IDirectSoundBuffer;
SecondarySound3DBuffer: IDirectSound3DBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondary3DBuffer(var Buffer: IDirectSoundBuffer; SamplesPerSec: Integer; Bits: Word; isStereo: Boolean; Time: Integer);
procedure AppSetSecondary3DBuffer(var Buffer: IDirectSoundBuffer; var _3DBuffer: IDirectSound3DBuffer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer; OffSet: DWord; var SoundData; SoundBytes: DWord);
procedure CopyWAVToBuffer(Name: PChar; var Buffer: IDirectSoundBuffer);
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var Result : HResult;
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then Raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondary3DBuffer(SecondarySoundBuffer, 22050, 8, False, 4);
AppSetSecondary3DBuffer(SecondarySoundBuffer, SecondarySound3DBuffer);Timer1.Enabled:=False;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then DirectSoundBuffer.Release;
if Assigned(SecondarySound3DBuffer) then SecondarySound3DBuffer.Release;
if Assigned(SecondarySoundBuffer) then SecondarySoundBuffer.Release;
if Assigned(DirectSound) then DirectSound.Release;
end;
procedure TForm1.AppCreateWritePrimaryBuffer;
var
BufferDesc : DSBUFFERDESC;
Caps : DSBCaps;
PCM : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx), 0);
with BufferDesc do begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle, DSSCL_WRITEPRIMARY) <> DS_OK then Raise Exception.Create('Unable to set Cooperative Level');
if DirectSound.CreateSoundBuffer(BufferDesc, DirectSoundBuffer, nil) <> DS_OK then Raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then Raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle, DSSCL_NORMAL) <> DS_OK then Raise Exception.Create('Unable to set Cooperative Level');
end;
procedure TForm1.AppCreateWriteSecondary3DBuffer;
var
BufferDesc : DSBUFFERDESC;
Caps : DSBCaps;
PCM : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC), 0);
FillChar(PCM, SizeOf(TWaveFormatEx), 0);
with BufferDesc do begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then PCM.nChannels:=2
else PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC or DSBCAPS_CTRL3D;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc, Buffer, nil) <> DS_OK then Raise Exception.Create('Create Sound Buffer failed');
end;
procedure TForm1.AppWriteDataToBuffer;
var
AudioPtr1, AudioPtr2: Pointer;
AudioBytes1, AudioBytes2: DWord;
h: HResult;
Temp: Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST then begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');
end
else if H <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');
Temp:=@SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then begin
Temp:=@SoundData;
Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK then Raise Exception.Create('Unable to UnLock Sound Buffer');
end;
procedure TForm1.CopyWAVToBuffer;
var
Data : PChar;
FName : TFileStream;
DataSize : DWord;
Chunk : String[4];
Pos : Integer;
begin
FName:=TFileStream.Create(Name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.Read(Chunk[1], 4);
Inc(Pos);
until Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.Read(DataSize, SizeOf(DWord));
GetMem(Data, DataSize);
FName.Read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer, 0, Data^, DataSize);
FreeMem(Data, DataSize);
end;
var Pos : Single = -25;
procedure TForm1.AppSetSecondary3DBuffer;
begin
if Buffer.QueryInterface(IID_IDirectSound3DBuffer, _3DBuffer) <> DS_OK then Raise Exception.Create('Failed to create IDirectSound3D object');
if _3DBuffer.SetPosition(Pos, 1, 1, 0) <> DS_OK then Raise Exception.Create('Failed to set IDirectSound3D Position');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('xhe4.wav',SecondarySoundBuffer);
if SecondarySoundBuffer.Play(0, 0, DSBPLAY_LOOPING) <> DS_OK then ShowMessage('Can''t play the Sound');
Timer1.Enabled:=True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
SecondarySound3DBuffer.SetPosition(Pos,1,1,0);
Pos:=Pos + 0.1;
end;
end.
Аппаратное обеспечение
CD-ROM
Открытие и закрытие нескольких приводов CD-ROM
Что касается вопроса "Открытие и закрытие привода CD-ROM", то при наличии более одного CD-ROMа в системе, рекомендую воспользоваться следующими функциями:// ____ _ ______ __
// / __ \_____(_) _____/_ __/___ ____ / /____
// / / / / ___/ / | / / _ \/ / / __ \/ __ \/ / ___/
// / /_/ / / / /| |/ / __/ / / /_/ / /_/ / (__ )
// /_____/_/ /_/ |___/\___/_/ \____/\____/_/____/
//
(*******************************************************************************
* DriveTools 1.0 *
* *
* (c) 1999 Jan Peter Stotz *
* *
********************************************************************************
* *
* If you find bugs, has ideas for missing featurs, feel free to contact me *
* jpstotz@gmx.de *
* *
********************************************************************************
* Date last modified: May 22, 1999 *
*******************************************************************************)
unit DriveTools;
interface
uses Windows, SysUtils, MMSystem;
function CloseCD(Drive: Char): Boolean;
function OpenCD(Drive: Char): Boolean;
implementation
function OpenCD(Drive : Char): Boolean;
Var
Res: MciError;
OpenParm: TMCI_Open_Parms;
Flags: DWord;
S: String;
DeviceID: Word;
begin
Result:=false;
S:=Drive+':';
Flags:=mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res<>0 Then exit;
DeviceID:=OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
IF Res=0 Then exit;
Result:=True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;
function CloseCD(Drive : Char) : Boolean;
Var
Res: MciError;
OpenParm: TMCI_Open_Parms;
Flags: DWord;
S: String;
DeviceID: Word;
begin
Result:=false;
S:=Drive+':';
Flags:=mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res:= mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res<>0 Then exit;
DeviceID:=OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
IF Res=0 Then exit;
Result:=True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;
end.
Прислал Vadim Petrov.
Клавиатура
Переключение клавиатуры
Переключение языков из программы Для переключения языка применяется вызов LoadKeyboardLayout:var russian, latin: HKL;
russian:=LoadKeyboardLayout('00000419', 0);
latin:=LoadKeyboardLayout('00000409', 0); где то в программе
SetActiveKeyboardLayout(russian);
Прислал Igor Nikolaev aKa The Sprite.
Как отловить нажатия клавиш в системе
Для этого используется функция GetAsyncKeyState(KeyCode) в качестве параметра используются коды клавиш(например A – 65). GetAsyncKeyState возвращает ненулевое значение если во время ее вызова нажата указаная клавиша.//----Этот пример отлавливает нажатие клавиши «A»
//Этот код необходимо поместить в процедуру обработки
//таймера с интервалом «1»
if getasynckeystate(65)<>0 then showmessage('A – pressed');
//----------
Прислал Igor Nikolaev aKa The Sprite.
Клавиша с кодом #0
Delphi 1В действительности она служит флагом проверки нажатия клавиши, по соглашению, код #0 означает, что никакой клавиши нажато не было. В некоторых случаях событие может активизировать передачу этого кода (например, прямым вызовом), или предок, возможно, уже обработал нажатие клавиши, и Key был установлен в #0.
Как из программы переключить раскладку клавиатуры?
Одной строкойNomadic отвечает: A: ActivateKeyboardLayout(). Учтите, что использование этой функции – плохой тон.
Модем
Как получить список установленных модемов в Win95/98?
Nomadic советует:unit PortInfo;
interface
uses Windows, SysUtils, Classes, Registry;
function EnumModems: TStrings;
implementation
function EnumModems: TStrings;
var
R: TRegistry;
s: ShortString;
N: TStringList;
i: integer;
j: integer;
begin
Result:= TStringList.Create;
R:= TRegistry.Create;
try
with R do begin
RootKey:= HKEY_LOCAL_MACHINE;
if OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) then
if HasSubKeys then begin
N:= TStringList.Create;
try
GetKeyNames(N);
for i:=0 to N.Count – 1 do begin
closekey; { + }
openkey('\System\CurrentControlSet\Services\Class\Modem',false); { + }
OpenKey(N[i], False);
s:= ReadString('AttachedTo');
for j:=1 to 4 do if pos(chr(j+ord('0')), s) > 0 then Break;
Result.AddObject(ReadString('DriverDesc'),TObject(j));
CloseKey;
end;
finally
N.Free;
end;
end;
end;
finally
R.Free;
end;
end;
end.
Порты
Асинхронная связь
Delphi 1
unit Comm;
interface
uses Messages,WinTypes,WinProcs,Classes,Forms;
type
TPort=(tptNone,tptOne,tptTwo,tptThree,tptFour,tptFive,tptSix,tptSeven,tptEight);
TBaudRate= (tbr110, tbr300, tbr600, tbr1200, tbr2400, tbr4800, tbr9600, tbr14400, tbr19200, tbr38400, tbr56000, tbr128000, tbr256000);
TParity=(tpNone,tpOdd,tpEven,tpMark,tpSpace);
TDataBits=(tdbFour,tdbFive,tdbSix,tdbSeven,tdbEight);
TStopBits=(tsbOne,tsbOnePointFive,tsbTwo);
TCommEvent=(tceBreak, tceCts, tceCtss, tceDsr, tceErr, tcePErr, tceRing, tceRlsd, tceRlsds, tceRxChar, tceRxFlag, tceTxEmpty);
TCommEvents=set of TCommEvent;
const
PortDefault=tptNone;
BaudRateDefault=tbr9600;
ParityDefault=tpNone;
DataBitsDefault=tdbEight;
StopBitsDefault=tsbOne;
ReadBufferSizeDefault=2048;
WriteBufferSizeDefault=2048;
RxFullDefault=1024;
TxLowDefault=1024;
EventsDefault=[];
type
TNotifyEventEvent=procedure(Sender:TObject; CommEvent:TCommEvents) of object;
TNotifyReceiveEvent=procedure(Sender:TObject; Count:Word) of object;
TNotifyTransmitEvent=procedure(Sender:TObject; Count:Word) of object;
TComm=class(TComponent)
private
FPort:TPort;
FBaudRate:TBaudRate;
FParity:TParity;
FDataBits:TDataBits;
FStopBits:TStopBits;
FReadBufferSize:Word;
FWriteBufferSize:Word;
FRxFull:Word;
FTxLow:Word;
FEvents:TCommEvents;
FOnEvent:TNotifyEventEvent;
FOnReceive:TNotifyReceiveEvent;
FOnTransmit:TNotifyTransmitEvent;
FWindowHandle:hWnd;
hComm:Integer;
HasBeenLoaded:Boolean;
Error:Boolean;
procedure SetPort(Value:TPort);
procedure SetBaudRate(Value:TBaudRate);
procedure SetParity(Value:TParity);
procedure SetDataBits(Value:TDataBits);
procedure SetStopBits(Value:TStopBits);
procedure SetReadBufferSize(Value:Word);
procedure SetWriteBufferSize(Value:Word);
procedure SetRxFull(Value:Word);
procedure SetTxLow(Value:Word);
procedure SetEvents(Value:TCommEvents);
procedure WndProc(var Msg:TMessage);
procedure DoEvent;
procedure DoReceive;
procedure DoTransmit;
protected
procedure Loaded; override;
public
constructor Create(AOwner:TComponent); override;
destructor Destroy; override;
procedure Write(Data:PChar; Len:Word);
procedure Read(Data:PChar; Len:Word);
function IsError:Boolean;
published
property Port:TPort read FPort write SetPort default PortDefault;
property BaudRate:TBaudRate read FBaudRate write SetBaudRate default BaudRateDefault;
property Parity:TParity read FParity write SetParity default ParityDefault;
property DataBits:TDataBits read FDataBits write SetDataBits default DataBitsDefault;
property StopBits:TStopBits read FStopBits write SetStopBits default StopBitsDefault;
property WriteBufferSize:Word read FWriteBufferSize write SetWriteBufferSize default WriteBufferSizeDefault;
property ReadBufferSize:Word read FReadBufferSize write SetReadBufferSize default ReadBufferSizeDefault;
property RxFullCount:Word read FRxFull write SetRxFull default RxFullDefault;
property TxLowCount:Word read FTxLow write SetTxLow default TxLowDefault;
property Events:TCommEvents read FEvents write SetEvents default EventsDefault;
property OnEvent:TNotifyEventEvent read FOnEvent write FOnEvent;
property OnReceive:TNotifyReceiveEvent read FOnReceive write FOnReceive;
property OnTransmit:TNotifyTransmitEvent read FOnTransmit write FOnTransmit;
end;
procedure Register;
implementation
procedure TComm.SetPort(Value:TPort);
const CommStr:PChar='COM1:';
begin
FPort:=Value;
if (csDesigning in ComponentState) or (Value=tptNone) or (not HasBeenLoaded) then exit;
if hComm>=0 then CloseComm(hComm);
CommStr[3]:=chr(48+ord(Value));
hComm:=OpenComm(CommStr,ReadBufferSize,WriteBufferSize);
if hComm<0 then begin
Error:=True;
exit;
end;
SetBaudRate(FBaudRate);
SetParity(FParity);
SetDataBits(FDataBits);
SetStopBits(FStopBits);
SetEvents(FEvents);
EnableCommNotification(hComm,FWindowHandle,FRxFull,FTxLow);
end;
procedure TComm.SetBaudRate(Value:TBaudRate);
var DCB:TDCB;
begin
FBaudRate:=Value;
if hComm>=0 then begin
GetCommState(hComm,DCB);
case Value of
tbr110:
DCB.BaudRate:=CBR_110;
tbr300:
DCB.BaudRate:=CBR_300;
tbr600:
DCB.BaudRate:=CBR_600;
tbr1200:
DCB.BaudRate:=CBR_1200;
tbr2400:
DCB.BaudRate:=CBR_2400;
tbr4800:
DCB.BaudRate:=CBR_4800;
tbr9600:
DCB.BaudRate:=CBR_9600;
tbr14400:
DCB.BaudRate:=CBR_14400;
tbr19200:
DCB.BaudRate:=CBR_19200;
tbr38400:
DCB.BaudRate:=CBR_38400;
tbr56000:
DCB.BaudRate:=CBR_56000;
tbr128000:
DCB.BaudRate:=CBR_128000;
tbr256000:
DCB.BaudRate:=CBR_256000;
end;
SetCommState(DCB);
end;
end;
procedure TComm.SetParity(Value:TParity);
var DCB:TDCB;
begin
FParity:=Value;
if hComm<0 then exit;
GetCommState(hComm,DCB);
case Value of
tpNone:
DCB.Parity:=0;
tpOdd:
DCB.Parity:=1;
tpEven:
DCB.Parity:=2;
tpMark:
DCB.Parity:=3;
tpSpace:
DCB.Parity:=4;
end;
SetCommState(DCB);
end;
procedure TComm.SetDataBits(Value:TDataBits);
var DCB:TDCB;
begin
FDataBits:=Value;
if hComm<0 then exit;
GetCommState(hComm,DCB);
case Value of
tdbFour:
DCB.ByteSize:=4;
tdbFive:
DCB.ByteSize:=5;
tdbSix:
DCB.ByteSize:=6;
tdbSeven:
DCB.ByteSize:=7;
tdbEight:
DCB.ByteSize:=8;
end;
SetCommState(DCB);
end;
procedure TComm.SetStopBits(Value:TStopBits);
var DCB:TDCB;
begin
FStopBits:=Value;
if hComm<0 then exit;
GetCommState(hComm,DCB);
case Value of
tsbOne:
DCB.StopBits:=0;
tsbOnePointFive:
DCB.StopBits:=1;
tsbTwo:
DCB.StopBits:=2;
end;
SetCommState(DCB);
end;
procedure TComm.SetReadBufferSize(Value:Word);
begin
FReadBufferSize:=Value;
SetPort(FPort);
end;
procedure TComm.SetWriteBufferSize(Value:Word);
begin
FWriteBufferSize:=Value;
SetPort(FPort);
end;
procedure TComm.SetRxFull(Value:Word);
begin
FRxFull:=Value;
if hComm<0 then exit;
EnableCommNotification(hComm,FWindowHandle,FRxFull,FTxLow);
end;
procedure TComm.SetTxLow(Value:Word);
begin
FTxLow:=Value;
if hComm<0 then exit;
EnableCommNotification(hComm,FWindowHandle,FRxFull,FTxLow);
end;
procedure TComm.SetEvents(Value:TCommEvents);
var EventMask:Word;
begin
FEvents:=Value;
if hComm<0 then exit;
EventMask:=0;
if tceBreak in FEvents then inc(EventMask,EV_BREAK);
if tceCts in FEvents then inc(EventMask,EV_CTS);
if tceCtss in FEvents then inc(EventMask,EV_CTSS);
if tceDsr in FEvents then inc(EventMask,EV_DSR);
if tceErr in FEvents then inc(EventMask,EV_ERR);
if tcePErr in FEvents then inc(EventMask,EV_PERR);
if tceRing in FEvents then inc(EventMask,EV_RING);
if tceRlsd in FEvents then inc(EventMask,EV_RLSD);
if tceRlsds in FEvents then inc(EventMask,EV_RLSDS);
if tceRxChar in FEvents then inc(EventMask,EV_RXCHAR);
if tceRxFlag in FEvents then inc(EventMask,EV_RXFLAG);
if tceTxEmpty in FEvents then inc(EventMask,EV_TXEMPTY);
SetCommEventMask(hComm,EventMask);
end;
procedure TComm.WndProc(var Msg:TMessage);
begin
with Msg do begin
if Msg=WM_COMMNOTIFY then begin
case lParamLo of
CN_EVENT:
DoEvent;
CN_RECEIVE:
DoReceive;
CN_TRANSMIT:
DoTransmit;
end;
end else Result:=DefWindowProc(FWindowHandle, Msg, wParam, lParam);
end;
end;
procedure TComm.DoEvent;
var
CommEvent:TCommEvents;
EventMask:Word;
begin
if (hComm<0) or not Assigned(FOnEvent) then exit;
EventMask:=GetCommEventMask(hComm,Integer($FFFF));
CommEvent:=[];
if (tceBreak in Events) and (EventMask and EV_BREAK<>0) then CommEvent:=CommEvent+[tceBreak];
if (tceCts in Events) and (EventMask and EV_CTS<>0) then CommEvent:=CommEvent+[tceCts];
if (tceCtss in Events) and (EventMask and EV_CTSS<>0) then CommEvent:=CommEvent+[tceCtss];
if (tceDsr in Events) and (EventMask and EV_DSR<>0) then CommEvent:=CommEvent+[tceDsr];
if (tceErr in Events) and (EventMask and EV_ERR<>0) then CommEvent:=CommEvent+[tceErr];
if (tcePErr in Events) and (EventMask and EV_PERR<>0) then CommEvent:=CommEvent+[tcePErr];
if (tceRing in Events) and (EventMask and EV_RING<>0) then CommEvent:=CommEvent+[tceRing];
if (tceRlsd in Events) and (EventMask and EV_RLSD<>0) then CommEvent:=CommEvent+[tceRlsd];
if (tceRlsds in Events) and (EventMask and EV_Rlsds<>0) then CommEvent:=CommEvent+[tceRlsds];
if (tceRxChar in Events) and (EventMask and EV_RXCHAR<>0) then CommEvent:=CommEvent+[tceRxChar];
if (tceRxFlag in Events) and (EventMask and EV_RXFLAG<>0) then CommEvent:=CommEvent+[tceRxFlag];
if (tceTxEmpty in Events) and (EventMask and EV_TXEMPTY<>0) then CommEvent:= CommEvent+[tceTxEmpty];
FOnEvent(Self,CommEvent);
end;
procedure TComm.DoReceive;
var Stat:TComStat;
begin
if (hComm<0) or not Assigned(FOnReceive) then exit;
GetCommError(hComm,Stat);
FOnReceive(Self,Stat.cbInQue);
GetCommError(hComm,Stat);
end;
procedure TComm.DoTransmit;
var Stat:TComStat;
begin
if (hComm<0) or not Assigned(FOnTransmit) then exit;
GetCommError(hComm,Stat);
FOnTransmit(Self,Stat.cbOutQue);
end;
procedure TComm.Loaded;
begin
inherited Loaded;
HasBeenLoaded:=True;
SetPort(FPort);
end;
constructor TComm.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
FWindowHandle:=AllocateHWnd(WndProc);
HasBeenLoaded:=False;
Error:=False;
FPort:=PortDefault;
FBaudRate:=BaudRateDefault;
FParity:=ParityDefault;
FDataBits:=DataBitsDefault;
FStopBits:=StopBitsDefault;
FWriteBufferSize:=WriteBufferSizeDefault;
FReadBufferSize:=ReadBufferSizeDefault;
FRxFull:=RxFullDefault;
FTxLow:=TxLowDefault;
FEvents:=EventsDefault;
hComm:=-1;
end;
destructor TComm.Destroy;
begin
DeallocatehWnd(FWindowHandle);
if hComm>=0 then CloseComm(hComm);
inherited Destroy;
end;
procedure TComm.Write(Data:PChar;Len:Word);
begin
if hComm<0 then exit;
if WriteComm(hComm,Data,Len)<0 then Error:=True;
GetCommEventMask(hComm,Integer($FFFF));
end;
procedure TComm.Read(Data:PChar;Len:Word);
begin
if hComm<0 then exit;
if ReadComm(hComm,Data,Len)<0 then Error:=True;
GetCommEventMask(hComm,Integer($FFFF));
end;
function TComm.IsError:Boolean
begin
IsError:=Error;
Error:=False;
end;
procedure Register;
begin
RegisterComponents('Additional',[TComm]);
end;
end.
Принтер
Печать табуляторов с помощью TextOut
Delphi 2Я пытаюсь напечатать некий текст с помощью Printer.Canvas.TextOut. Моя строка содержит табуляторы, но они почему-то печатаются на бумаге в виде черных прямоугольников. Как мне правильно напечатать строку, содержащую табуляторы? Обратите внимание на функцию API «TabbedTextOut». Ваш холст (canvas) воспользоваться ей не сможет, но вы можете просто вызвать эту API функцию и передать ей дескриптор холста. – Bob Fisher
Печать через спулер на матричный принтер
Оргиш Александр (FIDO: 2:454/3.24) пишет: Печатаю через спулер на матричный принтер текст таким образом :
Var
pcbNeeded: DWORD;
FDevice: PChar;
FPort: PChar;
FDriver: PChar;
FPrinterHandle: THandle;
FDeviceMode: THandle;
FJob: PADDJOBINFO1;
Stream: TFileStream;
begin
GetMem(FDevice, 128);
GetMem(FDriver, 128);
GetMem(FPort, 128);
Printer.GetPrinter(FDevice, FDriver, FPort, FDeviceMode);
if FDeviceMode = 0 then Printer.GetPrinter(FDevice, FDriver, FPort, FDeviceMode);
if OpenPrinter(FDevice, FPrinterHandle, nil) then begin
GetMem(FJob,1024);
//Добавляем задание, получаем имя файла в директории windows\spoool\
AddJob(FPrinterHandle,1,FJob,1024,pcbNeeded);
Stream:=TFileStream.Create(FJob.Path,fmCreate);
// Дальше пишем текст (+ESC команды!!!!) прямо в Stream
// и не забываем переводить в DOS – кодировку
………
………
Stream.Free;
//Постановка задания в очередь – только теперь принтер начинает печатать
ScheduleJob(FPrinterHandle,FJob.JobID);
FreeMem(FJob);
ClosePrinter(FPrinterHandle);
end;
FreeMem(FDevice, 128);
FreeMem(FDriver, 128);
FreeMem(FPort, 128);
end;
С уважением, Оргиш Александр
Лучший способ печати формы
Данный документ содержит подробное описание способа печати содержимого формы: получение отдельных битов устройства при 256-цветной форме, и использования полученных битов для печати формы на принтере. Кроме того, в данном коде осуществляется проверка палитры устройства (экран или принтер), и включается обработка палитры соответствующего устройства. Если устройством палитры является устройство экрана, принимаются дополнительные меры по заполнению палитры растрового изображения из системной палитры, избавляющие от некорректного заполнения палитры некоторыми видеодрайверами. Примечание: Поскольку данный код делает снимок формы, форма должна располагаться на самом верху, поверх остальных форм, быть полность на экране, и быть видимой на момент ее "съемки".unit Prntit;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
uses Printers;
procedure TForm1.Button1Click(Sender: TObject);
var
dc: HDC;
isDcPalDevice: BOOL;
MemDc:hdc;
MemBitmap: hBitmap;
OldMemBitmap: hBitmap;
hDibHeader: Thandle;
pDibHeader: pointer;
hBits: Thandle;
pBits: pointer;
ScaleX: Double;
ScaleY: Double;
ppal: PLOGPALETTE;
pal: hPalette;
Oldpal: hPalette;
i: integer;
begin
{Получаем dc экрана}
dc := GetDc(0);{
Создаем совместимый dc}
MemDc := CreateCompatibleDc(dc);
{создаем изображение}
MemBitmap := CreateCompatibleBitmap(Dc,form1.width,form1.height);
{выбираем изображение в dc}
OldMemBitmap := SelectObject(MemDc, MemBitmap);
{Производим действия, устраняющие ошибки при работе с некоторыми типами видеодрайверов}
isDcPalDevice := false;
if GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE then begin
GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
FillChar(pPal^, sizeof(TLOGPALETTE) +(255 * sizeof(TPALETTEENTRY)), #0);
pPal^.palVersion := $300;
pPal^.palNumEntries := GetSystemPaletteEntries(dc,0,256,pPal^.palPalEntry);
if pPal^.PalNumEntries <> 0 then begin
pal := CreatePalette(pPal^);
oldPal := SelectPalette(MemDc, Pal, false);
isDcPalDevice := true
end else FreeMem(pPal, sizeof(TLOGPALETTE) +(255 * sizeof(TPALETTEENTRY)));
end;
{копируем экран в memdc/bitmap}
BitBlt(MemDc,0, 0, form1.width, form1.height, Dc, form1.left, form1.top, SrcCopy);
if isDcPalDevice = true then begin
SelectPalette(MemDc, OldPal, false);
DeleteObject(Pal);
end;
{удаляем выбор изображения}
SelectObject(MemDc, OldMemBitmap);
{удаляем dc памяти}
DeleteDc(MemDc);
{Распределяем память для структуры DIB}
hDibHeader := GlobalAlloc(GHND,sizeof(TBITMAPINFO) +(sizeof(TRGBQUAD) * 256));
{получаем указатель на распределенную память}
pDibHeader := GlobalLock(hDibHeader);
{заполняем dib-структуру информацией, которая нам необходима в DIB}
FillChar(pDibHeader^, sizeof(TBITMAPINFO) + (sizeof(TRGBQUAD) * 256),#0);
PBITMAPINFOHEADER(pDibHeader)^.biSize :=sizeof(TBITMAPINFOHEADER);
PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
PBITMAPINFOHEADER(pDibHeader)^.biWidth := form1.width;
PBITMAPINFOHEADER(pDibHeader)^.biHeight := form1.height;
PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
{узнаем сколько памяти необходимо для битов}
GetDIBits(dc, MemBitmap, 0, form1.height, nil, TBitmapInfo(pDibHeader^), DIB_RGB_COLORS);
{Распределяем память для битов}
hBits := GlobalAlloc(GHND, PBitmapInfoHeader(pDibHeader)^.BiSizeImage);
{Получаем указатель на биты}
pBits := GlobalLock(hBits);
{Вызываем функцию снова, но на этот раз нам передают биты!}
GetDIBits(dc, MemBitmap, 0, form1.height, pBits, PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS);
{Пробуем исправить ошибки некоторых видеодрайверов}
if isDcPalDevice = true then begin
for i := 0 to (pPal^.PalNumEntries - 1) do begin
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := pPal^.palPalEntry[i].peRed;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen := pPal^.palPalEntry[i].peGreen;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := pPal^.palPalEntry[i].peBlue;
end;
FreeMem(pPal, sizeof(TLOGPALETTE) +(255 * sizeof(TPALETTEENTRY)));
end;
{Освобождаем dc экрана}
ReleaseDc(0, dc);
{Удаляем изображение}
DeleteObject(MemBitmap);
{Запускаем работу печати}
Printer.BeginDoc;
{Масштабируем размер печати}
if Printer.PageWidth < Printer.PageHeight then begin
ScaleX := Printer.PageWidth;
ScaleY := Form1.Height * (Printer.PageWidth / Form1.Width);
end else begin
ScaleX := Form1.Width * (Printer.PageHeight / Form1.Height);
ScaleY := Printer.PageHeight;
end;
{Просто используем драйвер принтера для устройства палитры}
isDcPalDevice := false;
if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE = RC_PALETTE then begin
{Создаем палитру для dib}
GetMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
FillChar(pPal^, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)), #0);
pPal^.palVersion := $300;
pPal^.palNumEntries := 256;
for i := 0 to (pPal^.PalNumEntries - 1) do begin
pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
end;
pal := CreatePalette(pPal^);
FreeMem(pPal, sizeof(TLOGPALETTE) + (255 * sizeof(TPALETTEENTRY)));
oldPal := SelectPalette(Printer.Canvas.Handle, Pal, false);
isDcPalDevice := true
end;
{посылаем биты на принтер}
StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(scaleX), Round(scaleY), 0, 0, Form1.Width, Form1.Height, pBits, PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS,SRCCOPY);
{Просто используем драйвер принтера для устройства палитры}
if isDcPalDevice = true then begin
SelectPalette(Printer.Canvas.Handle, oldPal, false);
DeleteObject(Pal);
end;
{Очищаем распределенную память}
GlobalUnlock(hBits);
GlobalFree(hBits);
GlobalUnlock(hDibHeader);
GlobalFree(hDibHeader);
{Заканчиваем работу печати}
Printer.EndDoc;
end;
Как мне отправить на принтер чистый поток данных?
Nomadic советует: Под Win16 Вы можете использовать функцию SpoolFile, или Passthrough escape, если принтер поддерживает последнее. Под Win32 Вы можете использовать WritePrinter. Ниже пример открытия принтера и записи чистого потока данных в принтер. Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet 5MP", чтобы функция сработала успешно. Конечно, Вы можете включать в поток данных любые необходимые управляющие коды, которые могут потребоваться.
uses WinSpool;
procedure WriteRawStringToPrinter(PrinterName: String; S: String);
var
Handle: THandle;
N: DWORD;
DocInfo1: TDocInfo1;
begin
if not OpenPrinter(PChar(PrinterName), Handle, nil) then begin
ShowMessage('error ' + IntToStr(GetLastError));
Exit;
end;
with DocInfo1 do begin
pDocName := PChar('test doc');
pOutputFile := nil;
pDataType := 'RAW';
end;
StartDocPrinter(Handle, 1, @DocInfo1);
StartPagePrinter(Handle);
WritePrinter(Handle, PChar(S), Length(S), N);
EndPagePrinter(Handle);
EndDocPrinter(Handle);
ClosePrinter(Handle);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
WriteRawStringToPrinter('HP', 'Test This');
end;
Посмотри и доделай как тебе надо.
unit TextPrinter;
interface
uses Windows, Controls, Forms, Dialogs;
type TTextPrinter = class(TObject)
private
FNumberOfBytesWritten: Integer;
FHandle: THandle;
FPrinterOpen: Boolean;
FErrorString: PChar;
procedure SetErrorString;
public
constructor Create;
procedure Write(const Str: string);
procedure WriteLn(const Str: string);
destructor Destroy; override;
published
property NumberOfBytesWritten: Integer read FNumberOfBytesWritten;
end;
implementation
{TTextPrinter}
constructor TTextPrinter.Create;
begin
FHandle := CreateFile('LPT1', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
if FHandle = INVALID_HANDLE_VALUE then begin
SetErrorString;
raise Exception.Create(FErrorString);
end else FPrinterOpen := True;
end;
procedure TTextPrinter.SetErrorString;
begin
if FErrorString <> nil then LocalFree(Integer(FErrorString));
FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError(),
LANG_USER_DEFAULT, @FErrorString, 0, nil);
end;
procedure TTextPrinter.Write(const Str: string);
var
OEMStr: PChar;
NumberOfBytesToWrite: Integer;
begin
if not FPrinterOpen then Exit;
NumberOfBytesToWrite := Length(Str);
OEMStr := PChar(LocalAlloc(LMEM_FIXED, NumberOfBytesToWrite + 1));
try
CharToOem(PChar(Str), OEMStr);
if not WriteFile(FHandle, OEMStr^, NumberOfBytesToWrite, FNumberOfBytesWritten, nil) then begin
SetErrorString;
raise Exception.Create(FErrorString);
end;
finally
LocalFree(Integer(OEMStr));
end;
end;
procedure TTextPrinter.WriteLn(const Str: string);
begin
Self.Write(Str);
Self.Write(#10);
end;
destructor TTextPrinter.Destroy;
begin
CloseHandle(FHandle);
if FErrorString <> nil then LocalFree(Integer(FErrorString));
end;
end.
P.S. В принципе, вместо LPT1 может стоять что угодно, даже сетевой сервер печати (\\server\prn) – все равно печатает. Можно и параметр в конструктор вставить и т.д.
Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра?
Nomadic советует: Маленькое предисловие. Т.к. основная моя работа связана с написанием софта для института, обрабатывающего геоданные, то и в отделе, где pаботаю, так же мучаются проблемами печати (в одном случае — надо печатать карты, с изолиниями, заливкой, подписями и пр.; в другом случае — свои таблицы и сложные отрисовки по внешнему виду). В итоге, моим коллегой был написан кусок, в котором ему удалось добиться качественной печати в двух режимах : MetaFile, Bitmap. Работа с MetaFile у нас сложилась уже исторически — достаточно удобно описать ф-цию, которая что-то отрисовывает (хоть на экране, хоть где), которая принимает TCanvas, и подсовывать ей то канвас дисплея, то канвас метафайла, а потом этот Metafile выбрасывать на печать. Достаточно решить лишь проблемы масштабирования, после чего — вперед. Главная головная боль при таком методе — при отрисовке больших кусков, которые занимают весь лист или его большую часть, надо этот метафайл по размерам делать сразу же в пикселах на этот самый лист. Тогда при изменении размеров (просмотр перед печатью) — искажения при уменьшении не кpритичны, а вот при увеличении линии и шрифты не "поползут". Итак: Hабор идей, котоpые были написаны (с) Андреем Аристовым, программистом отдела матобеспечения СибНИИНП, г. Тюмень. Моего здесь только — приделывание сверху надстроек для личного использования. Вся работа сводится к следующим шагам : 1. Получить необходимые коэф-ты; 2. Построить метафайл или bmp для последующего вывода на печать; 3. Hапечатать. Hиже приведенный кусок (прошу меня не пинать, но писал я и писал для достаточно кривой реализации с передачей параметров через глобальные переменные) я использую для того, чтобы получить коэф-ты пересчета. kScale — для пересчета размеров шрифта, а потом уже закладываюсь на его размеры и получаю два новых коэф-та для kW, kH — которые и позволяют мне с учетом высоты шрифта выводить графику и пр. У меня при работе kW <> kH, что приходится учитывать. Решили пункт 1.
procedure SetKoeffMeta; // установить коэф-ты
var
PrevMetafile : TMetafile;
MetaCanvas : TMetafileCanvas;
begin
PrevMetafile := nil;
MetaCanvas := nil;
try
PrevMetaFile := TMetaFile.Create;
try
MetaCanvas := TMetafileCanvas.Create(PrevMetafile, 0);
kScale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) / Screen.PixelsPerInch;
MetaCanvas.Font.Assign(oGrid.Font);
MetaCanvas.Font.Size := Round(oGrid.Font.Size * kScale);
kW := MetaCanvas.TextWidth('W') / oGrid.Canvas.TextWidth('W');
kH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W');
finally
MetaCanvas.Free;
end;
finally
PrevMetafile.Free;
end;
end;
Решаем 2.
…
var
PrevMetafile : TMetafile;
MetaCanvas : TMetafileCanvas;
begin
PrevMetafile := nil;
MetaCanvas := nil;
try
PrevMetaFile := TMetaFile.Create;
PrevMetafile.Width := oWidth;
PrevMetafile.Height := oHeight;
try
MetaCanvas := TMetafileCanvas.Create(PrevMetafile, 0);
// здесь должен быть ваш код - с учетом масштабиpования.
// я эту вещь вынес в ассигнуемую пpоцедуpу, и данный блок
// вызываю лишь для отpисовки целой стpаницы.
см. PS1.
finally
MetaCanvas.Free;
end;
...
PS1. Код, котоpый используется для отpисовки. oCanvas - TCanvas метафайла.
...
var iHPage : integer; // высота страницы
begin
with oCanvas do begin
iHPage := 3000;
// залили область метайфайла белым - для дальнейшей pаботы
Pen.Color := clBlack;
Brush.Color := clWhite;
FillRect(Rect(0, 0, 2000, iHPage));
// установили шpифты - с учетом их дальнейшего масштабиpования
oCanvas.Font.Assign(oGrid.Font);
oCanvas.Font.Size := Round(oGrid.Font.Size * kScale);
...
xEnd := xBegin;
iH := round(RowHeights[iRow] * kH);
for iCol := 0 to ColCount - 1 do begin
x := xEnd;
xEnd := x + round(ColWidths[iCol] * kW);
Rectangle(x, yBegin, xEnd, yBegin + iH);
r := Rect(x + 1, yBegin + 1, xEnd – 1, yBegin + iH – 1);
s := Cells[iCol, iRow];
// выписали в полученный квадрат текст
DrawText(oCanvas.Handle, PChar(s), Length(s), r, DT_WORDBREAK or dt_center);
Главное, что важно помнить на этом этапе – это не забывать, что все выводимые объекты должны пользоваться описанными коэф-тами (как вы их получите – это уже ваше дело). В данном случае – я работаю с пеpеделанным TStringGrid, который сделал для многостраничной печати. Последний пункт – надо сформированный метафайл или bmp напечатать.
…
var
Info: PBitmapInfo;
InfoSize: Integer;
Image: Pointer;
ImageSize: DWORD;
Bits: HBITMAP;
DIBWidth, DIBHeight: Longint;
PrintWidth, PrintHeight: Longint;
begin
...
case ImageType of
itMetafile:
begin
if Picture.Metafile<>nil then Printer.Canvas.StretchDraw(Rect(aLeft, aTop, aLeft+fWidth, aTop+fHeight), Picture.Metafile);
end;
itBitmap:
begin
if Picture.Bitmap<>nil then begin
with Printer, Canvas do begin
Bits := Picture.Bitmap.Handle;
GetDIBSizes(Bits, InfoSize, ImageSize);
Info := AllocMem(InfoSize);
try
Image := AllocMem(ImageSize);
try
GetDIB(Bits, 0, Info^, Image^);
with Info^.bmiHeader do begin
DIBWidth := biWidth;
DIBHeight := biHeight;
end;
PrintWidth := DIBWidth;
PrintHeight := DIBHeight;
StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth, PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Image, ImageSize);
end;
finally
FreeMem(Info, InfoSize);
end;
end;
end;
end;
end;
В чем заключается идея PreView? Остается имея на руках Metafila, Bmp – отрисовать с пересчетом внешний вид изобpажения (надо высчитать левый верхний угол и размеpы «предварительно просматриваемого» изображения. Для показа изобpажения достаточно использовать StretchDraw.
После того, как удалось вывести объекты на печать, проблему создания PreView решили как «домашнее задание».
Кстати, когда мы работаем с Bmp, то для просмотра используем следующий хинт – записываем битовый образ через такую процедуру:
w:=MulDiv(Bmp.Width, GetDeviceCaps(Printer.Handle,LOGPIXELSX), Screen.PixelsPerInch);
h:=MulDiv(Bmp.Height, GetDeviceCaps(Printer.Handle,LOGPIXELSY), Screen.PixelsPerInch);
PrevBmp.Width:=w;
PrevBmp.Height:=h;
PrevBmp.Canvas.StretchDraw(Rect(0, 0, w, h),Bmp);
aPicture.Assign(PrevBmp);
Пpи этом масштабируется битовый образ с минимальными искажениями, а вот при печати – приходится bmp печатать именно так, как описано выше. Итог – наша bmp при печати чуть меньше, чем печатать ее через WinWord, но при этом – внешне – без каких-либо искажений и пр.
Imho, я для себя пpоблему печати pешил. Hа основе вышесказанного, сделал PreView для myStringGrid, где вывожу сложные многостpочные заголовки и пр. на несколько листов, осталось кое-что допилить, но с принтером у меня проблем не будет уже точно :)
PS. Кстати, Андрей Аристов на основе своей наработки сделал сложные геокарты, которые по качеству не хуже, а может, и лучше, чем выдает Surfer (специалисты поймут). Hа ватмат.
PPS. Прошу прощения за возможные стилистические неточности – время вышло, охрана уже ругается. Но код – выдран из работающих исходников.
Разное
Как в ATX корпусе программно выключить питание под DOS
Serj Kolesnikov рекомендует:=== Cut ===
mov ax,5301h
sub bx,bx
int 15h
jc @@finish
mov ax,530Eh
sub bx,bx
mov cx,102h
int 15h
jc @@finish
mov ax,5307h
mov bx,1
mov cx,3
int 15h
@@finish:
int 20h
=== Cut ===
Операционная система
Буфер обмена
Как удобнее работать с буфером обмена как с последовательностью байт?
Из советов Nomadic'a: Используя потоки —unit ClipStrm;
{
This unit is Copyright (c) Alexey Mahotkin 1997-1998
and may be used freely for any purpose. Please mail
your comments to
E-Mail: alexm@hsys.msk.ru
FidoNet: Alexey Mahotkin, 2:5020/433
This unit was developed during incorporating of TP Lex/Yacc
into my project. Please visit ftp://ftp.nf.ru/pub/alexm
or FREQ FILES from 2:5020/433 or mail me to get hacked
version of TP Lex/Yacc which works under Delphi 2.0+.
}
interface uses Classes, Windows;
type TClipboardStream = class(TStream)
private
FMemory : pointer;
FSize : longint;
FPosition : longint;
FFormat : word;
public
constructor Create(fmt : word);
destructor Destroy; override;
function Read(var Buffer; Count : Longint) : Longint; override;
function Write(const Buffer; Count : Longint) : Longint; override;
function Seek(Offset : Longint; Origin : Word) : Longint; override;
end;
implementation uses SysUtils;
constructor TClipboardStream.Create(fmt : word);
var
tmp : pointer;
FHandle : THandle;
begin
FFormat := fmt;
OpenClipboard(0);
FHandle := GetClipboardData(FFormat);
FSize := GlobalSize(FHandle);
FMemory := AllocMem(FSize);
tmp := GlobalLock(FHandle);
MoveMemory(FMemory, tmp, FSize);
GlobalUnlock(FHandle);
FPosition := 0;
CloseClipboard;
end;
destructor TClipboardStream.Destroy;
begin
FreeMem(FMemory);
end;
function TClipboardStream.Read(var Buffer; Count : longint) : longint;
begin
if FPosition + Count > FSize then Result := FSize - FPosition
else Result := Count;
MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result);
Inc(FPosition, Result);
end;
function TClipboardStream.Write(const Buffer; Count : longint) : longint;
var
FHandle : HGlobal;
tmp : pointer;
begin
ReallocMem(FMemory, FPosition + Count);
MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count);
FPosition := FPosition + Count;
FSize := FPosition;
FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize);
try
tmp := GlobalLock(FHandle);
try
MoveMemory(tmp, FMemory, FSize);
OpenClipboard(0);
SetClipboardData(FFormat, FHandle);
finally
GlobalUnlock(FHandle);
end;
CloseClipboard;
except
GlobalFree(FHandle);
end;
Result := Count;
end;
function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint;
begin
case Origin of
0 : FPosition := Offset;
1 : Inc(FPosition, Offset);
2 : FPosition := FSize + Offset;
end;
Result := FPosition;
end;
end.
Шрифты
Хранение стилей шрифта
Как мне сохранить свойство шрифта Style, ведь он же набор? Вы можете получать и устанавливать FontStyle через его преобразование к типу byte. Для примера,Var Style: TFontStyles;
begin
{ Сохраняем стиль шрифта в байте }
Style := Canvas.Font.Style; {необходимо, поскольку Font.Style – свойство}
ByteValue := Byte(Style);
{ Преобразуем значение byte в TFontStyles }
Canvas.Font.Style := TFontStyles(ByteValue);
end;
Для восстановления шрифта, вам необходимо сохранить параметры Color, Name, Pitch, Style и Size в базе данных и назначить их соответствующим свойствам при загрузке.
– Robert Wittig
Управление настройками шрифта
Delphi 1
{
Данный код изменяет стиль шрифта поля редактирования,
если оно выбрано. Может быть адаприрован для управления
шрифтами в других объектах.
Расположите на форме Edit(Edit1) и ListBox(ListBox1).
Добавьте следующие элементы (Items) к ListBox:
fsBold
fsItalic
fsUnderLine
fsStrikeOut
}
procedure TForm1.ListBox1Click(Sender: TObject);
var X: Integer;
type TLookUpRec = record
Name: String;
Data: TFontStyle;
end;
const LookUpTable: array[1..4] of TLookUpRec = (
(Name: 'fsBold'; Data: fsBold),
(Name: 'fsItalic'; Data: fsItalic),
(Name: 'fsUnderline'; Data: fsUnderline),
(Name: 'fsStrikeOut'; Data: fsStrikeOut));
begin
X := ListBox1.ItemIndex;
Edit1.Text := ListBox1.Items[X];
Edit1.Font.Style := [LookUpTable[ListBox1.ItemIndex+1].Data];
end;
Перетащи и брось (Drag and Drop)
Как получить список файлов, которые были перенесены на мою форму, например, из Проводника?
Из советов Nomadic'a: Развлекался когда-то — вот, осталось:unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI, Grids, StdCtrls;
type TForm1 = class(TForm)
lb: TListBox;
Memo1: TMemo;
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure WMDropFiles(var M: TMessage); message WM_DROPFILES;
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
Var
CountFiles: integer;
SizeName : integer;
cch : integer;
Var
hDrop: integer;
Point: TPoint;
lpszFile: PChar;
{$R *.DFM}
procedure TForm1.WMDropFiles(var M: TMessage);
Var i: integer;
begin
hDrop:= M.WParam;
DragQueryPoint(hDrop, Point);
CountFiles:= DragQueryFile(hDrop, $FFFFFFFF, nil, cch);
for i:=0 to CountFiles-1 do begin
SizeName:= DragQueryFile(hDrop, i, nil, cch);
GetMem(lpszFile, SizeName+1);
DragQueryFile(hDrop, i, lpszFile, SizeName+1);
lb.Items.Add(lpszFile);
FreeMem(lpszFile, SizeName+1);
end;
DragFinish(hDrop);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Handle,True);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
lb.Items.Clear;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShellAbout(Handle, 'Anton Saburov', 'APSystems', 0);
end;
end.
Рабочий стол
Как програмным путем задавать координаты ярлыкам на рабочем столе?
Рабочий стол перекрыт сверху компонентом ListView. Вам просто необходимо взять хэндл этого органа управления. Пример:function GetDesktopListViewHandle: THandle;
var S: String;
begin
Result := FindWindow('ProgMan', nil);
Result := GetWindow(Result, GW_CHILD);
Result := GetWindow(Result, GW_CHILD);
SetLength(S, 40);
GetClassName(Result, PChar(S), 39);
if PChar(S) <> 'SysListView32' then Result := 0;
end;
После того, как Вы взяли тот хэндл, Вы можете использовать API этого ListView, определенный в модуле CommCtrl, для того, чтобы манипулировать рабочим столом. Смотрите тему «LVM_xxxx messages» в оперативной справке по Win32.
К примеру, следующая строка кода:
ListView_SetItemPosition(GetDesktopListViewHandle, i, x, y); {Не забудьте в uses добавить CommCtrl}
ярлыку с индексом i, задаст координаты (x,y). К примеру Мой компьютер имеет индекс 0, т.е i:=0;
С наилучшими пожеланиями, Сергей.
E-mail: ssa_sss@mail.ru
Nomadic дополняет:
К примеру, следующая строка кода:
SendMessage(GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0);
разместит иконки рабочего стола по левой стороне рабочего стола Windows.
Как я могу использовать анимированный курсор?
Из советов Nomadic'a: Сперва Вы должны взять хэндл курсора Windows и присвоить его одному из элементов массива Cursors обьекта Screen. Предопределенные курсоры имеют отрицательный индекс, а определенные пользователем (Вами) курсоры получают положительные индексы. Ниже пример формы, использующей анимированный курсор:procedure TForm1.Button1Click(Sender: TObject);
var h: THandle;
begin
h:= LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE);
if h = 0 then ShowMessage('Cursor not loaded')
else begin
Screen.Cursors[1] := h;
Form1.Cursor := 1;
end;
end;
Как узнать текущее разрешение экрана?
Из советов Nomadic'a : Советуем ознакомиться с Help topic относительно глобального обьекта Screen типа TScreen. У этого обьекта есть свойства Width и Height.{ Example }
begin
iScreenWidth := Screen.Width;
end;
Заодно и другие свойства могут Вас заинтересовать, например, Fonts и Cursors.
Как изменить изображение кнопки `Пуск`
The_Sprite советует: Пример из серии "Что можно сделать с рабочим столом". В общем, это обычный трюк с кнопкой "Пуск" (Start). Совместимость: все версии Delphi{ объявляем глобальные переменные }
var
Form1: TForm1;
StartButton: hWnd;
OldBitmap: THandle;
NewImage: TPicture;
{ добавляем следующий код в событие формы OnCreate }
procedure TForm1.FormCreate(Sender: TObject);
begin
NewImage := TPicture.create;
NewImage.LoadFromFile('C:\Windows\Circles.BMP');
StartButton := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil);
OldBitmap := SendMessage(StartButton, BM_SetImage, 0, NewImage.Bitmap.Handle);
end;
{ Событие OnDestroy }
procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(StartButton, BM_SetImage, 0, OldBitmap);
NewImage.Free;
end;
Как программно заменить обои на рабочем столе? III
Igor Nikolaev aKa The Sprite советует:
program wallpapr;
uses Registry, WinProcs;
procedure SetWallpaper(sWallpaperBMPPath: String; bTile: boolean);
var reg : TRegIniFile;
begin
// Изменяем ключи реестра
// HKEY_CURRENT_USER
// Control Panel\Desktop
// TileWallpaper (REG_SZ)
// Wallpaper (REG_SZ)
reg := TRegIniFile.Create('Control Panel\Desktop');
with reg do begin
WriteString('', 'Wallpaper', sWallpaperBMPPath);
if (bTile) then begin
WriteString('', 'TileWallpaper', '1');
end else begin
WriteString('', 'TileWallpaper', '0');
end;
end;
reg.Free;
// Оповещаем всех о том, что мы изменили системные настройки
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil,
{Эта строка – продолжение предыдущей} SPIF_SENDWININICHANGE);
end;
// пример установки WallPaper по центру рабочего стола
SetWallpaper('c:\winnt\winnt.bmp', False);
//Эту строчку надо написать где-то в программе.
Как программно заменить обои на рабочем столе? IV
Владимир Рыбант пишет: Советы «Как програмно заменить обои на рабочем столе» I, II, III не изменяют обои, если в Windows работает в режиме Active Desktop Нужно использовать следующее:uses ComObj, ShlObj;
procedure ChangeActiveWallpaper;
const CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var ActiveDesktop: IActiveDesktop;
begin
ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
ActiveDesktop.SetWallpaper('c:\windows\forest.bmp', 0);
ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
end;
Этим способом можно также изменять обои картинками jpg и gif.
А как поместить свою иконку на taskbar, там где часы и переключатель клавиатуры?
Nomadic советует: A: В библиотеке rxLib есть компонент TrxTrayIcon. Заметьте, что для корректного завершения работы операционной системе вам потребуется обрабатывать сообщение WM_QUERYENDSESSION.Как ограничить перемещение курсора мыши какой-либо областью экрана?
Одной строкойNomadic отвечает: A: ClipCursor(). Учтите, что использование этой функции – плохой тон.
Диалоги
Использование InputBox и InputQuery
Тема: Использование InputBox, InputQuery и ShowMessage Данная функция демонстрирует 3 очень мощных и полезных процедуры, интегрированных в Delphi. Диалоговые окна InputBox и InputQuery позволяют пользователю вводить данные. Функция InputBox используется в том случае, когда не имеет значения что пользователь выбирает для закрытия диалогового окна – кнопку OK или кнопку Cancel (или нажатие клавиши Esc). Если вам необходимо знать какую кнопку нажал пользователь (OK или Cancel (или нажал клавишу Esc)), используйте функцию InputQuery. ShowMessage – другой простой путь отображения сообщения для пользователя.procedure TForm1.Button1Click(Sender: TObject);
var
s, s1: string;
b: boolean;
begin
s := Trim(InputBox('Новый пароль', 'Пароль', 'masterkey'));
b := s <> '';
s1 := s;
if b then b := InputQuery('Повторите пароль', 'Пароль', s1);
if not b or (s1 <> s) then ShowMessage('Пароль неверен');
end;
Текст на кнопках MessageDlg
Как можно сменить текст на кнопках диалогового окна MessageDlg? Английский язык для текста кнопок пользователь хочет заменить на родной. Текст кнопок извлекается из списка строк, расположенных в файле …\DELPHI\SOURCE\VCL\CONSTS.PAS. Отредактируйте его, после чего пересоберите VCL. -Steve SchaferДополнение
VS дополняет: Но можно ничего не менять. Вместо MessageDlg использовать MessageBox – функция WINDOWS. И, если ваш WINDOWS русифицирован, то надписи на кнопках в диалоговых окнах будут на русском языке.Изменения в TOpenDialog
Delphi 1Почитайте про Open Dialog Box (диалоговое окно открытия файла) в файле помощи Windows API. Ознакомьтесь в статье с описанием аргумента lpTemplateName. Главное, вы можете создать новое диалоговое окно для Open Dialog Box и заменить стандартный диалог вашим собственным.
Как вывести диалог выбора каталога?
Одной строкойNomadic советует: A: (DS): SelectDirectory, rxLib: TDirectoryEdit.
Сообщения
Как послать самостийное сообщение всем главным окнам в Windows?
Nomadic советует: Пример:Var FM_FINDPHOTO: Integer;
// Для того, чтобы использовать hwnd_Broadcast нужно сперва зарегистрировать уникальное
// сообщение.
Initialization
FM_FindPhoto:=RegisterWindowMessage('MyMessageToAll');
// Чтобы поймать это сообщение в другом приложении (приёмнике) нужно перекрыть DefaultHandler
procedure TForm1.DefaultHandler(var Message);
begin
with TMessage(Message) do begin
if Msg = Fm_FindPhoto then MyHandler(WPARAM,LPARAM)
else Inherited DefaultHandler(Message);
end;
end;
// А теперь можно в приложении-передатчике
SendMessage(HWND_BROADCAST, FM_FINDPHOTO, 0, 0);
Кстати, для посылки сообщения дочерним контролам некоего контрола можно использовать метод Broadcast.
Как избавиться от торможения модальных окон?
Igor Nikolaev aKa The Sprite советует: Hемодальные диалоговые окна, находящиеся на экране во время выполнения длительных операций,могут реагировать на действия пользователя очень медленно. Это ограничение Windows, и обойти его можно так:while Flag do begin
PerformOperation;
Application.ProcessMessages;
Flag:=ContinueOperation;
end;
Моя программа довольно долго делает какую-то полезную работу, типа чтения дерева каталогов или обильных вычислений, и в этот момент почти не работают остальные программы. Как разрешить им это делать?
Nomadic отвечает: A: Application.ProcessMessages. (AA): Если вы хотите отдавать timeslices в нитях, пользуйтесь Sleep(0); это отдаст остаток слайса системе. (Win16) Если вы хотите разрешить отработку сообщений другим программам, но не вашей, то лучше пользоваться Yield().Файловая система
Метка диска под Win32
По моему глубокому убеждению для получения метки диска в среде Win95 необходимо использовать FindFile. Но это не работает, так? Правильно, FindFile в Win32 больше не возвращает имя диска, поскольку в не-FAT файловых системах (например, в NTFS) это работает иначе, чем в FAT. Вместо этого используйте функцию API GetVolumeInformation. – Peter BelowВосстанавление длинных имен файлов по известным коротким
boris советует://---------------------------------------------------------------------
// Восстанавливает длинные имена файлов по известным коротким (8.3)
// В качестве аргумента принимает полный или неполный (в т.ч. относительный)
// путь к файлу, например 'C:\WINDOWS\РАБОЧИ~1\ИТАКДА~1.LNK' или
// '..\..\COMMON~1\BORLAN~1\BDE\BDEREA~1.TXT'. Понимает сетевые имена.
// Возвращает полный(!) путь типа 'C:\Windows\Рабочий стол\и так далее.lnk',
// 'C:\Program Files\Common Files\Borland Shared\BDE\bdereadme.txt',
// '\\Computer\resource\Folder with long name\File with long name.ext'
//---------------------------------------------------------------------
Function RestoreLongName(fn: string): string;
function LookupLongName(const filename: string): string;
var sr: TSearchRec;
begin
if FindFirst(filename, faAnyFile, sr)=0 then Result:=sr.Name
else Result:=ExtractFileName(filename);
SysUtils.FindClose(sr);
end;
function GetNextFN: string;
var i: integer;
begin
Result:='';
if Pos('\\', fn)=1 then begin
Result:='\\';
fn:=Copy(fn, 3, length(fn)-2);
i:=Pos('\', fn);
if i<>0 then begin
Result:=Result+Copy(fn,1,i);
fn:=Copy(fn, i+1, length(fn)-i);
end;
end;
i:=Pos('\', fn);
if i<>0 then begin
Result:=Result+Copy(fn,1,i-1);
fn:=Copy(fn, i+1, length(fn)-i);
end else begin
Result:=Result+fn;
fn:='';
end;
end;
Var name: string;
Begin
fn:=ExpandFileName(fn);
Result:=GetNextFN;
Repeat
name:=GetNextFN;
Result:=Result+'\'+LookupLongName(Result+'\'+name);
Until length(fn)=0;
End;
Как указать системе на необходимость сбросить буфера *.INI-файла на диск?
Nomadic советует:procedure FlushIni(FileName: string);
var
{$IFDEF WIN32}
CFileName: array[0..MAX_PATH] of WideChar;
{$ELSE}
CFileName: array[0..127] of Char;
{$ENDIF}
begin
{$IFDEF WIN32}
if (Win32Platform = VER_PLATFORM_WIN32_NT) then begin
WritePrivateProfileStringW(nil, nil, nil, StringToWideChar(FileName, CFileName, MAX_PATH));
end else begin
WritePrivateProfileString(nil, nil, nil, PChar(FileName));
end;
{$ELSE}
WritePrivateProfileString(nil, nil, nil, StrPLCopy(CFileName, FileName, SizeOf(CFileName) – 1));
{$ENDIF}
end;
Копирование файлов III
Nomadic советует: Можно так:procedure CopyFile(const FileName, DestName: TFileName);
var
CopyBuffer: Pointer; { buffer for copying }
TimeStamp, BytesCopied: Longint;
Source, Dest: Integer; { handles }
Destination: TFileName; { holder for expanded destination name }
const
ChunkSize: Longint = 8192; { copy in 8K chunks }
begin
Destination := ExpandFileName(DestName); { expand the destination path }
if HasAttr(Destination, faDirectory) then { if destination is a directory... }
Destination := Destination + '\' + ExtractFileName(FileName); { ...clone file name }
TimeStamp := FileAge(FileName); { get source's time stamp }
GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
try
Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
if Source < 0 then raise EFOpenError.Create(FmtLoadStr(SFOpenError, [FileName]));
try
Dest := FileCreate(Destination); { create output file; overwrite existing }
if Dest < 0 then raise EFCreateError.Create(FmtLoadStr(SFCreateError, [Destination]));
try
repeat
BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk }
if BytesCopied > 0 then { if we read anything... }
FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
until BytesCopied < ChunkSize; { until we run out of chunks }
finally
FileClose(Dest); { close the destination file }
{ SetFileTimeStamp(Destination, TimeStamp);} { clone source's time stamp }{!!!}
end;
finally
FileClose(Source); { close the source file }
end;
finally
FreeMem(CopyBuffer, ChunkSize); { free the buffer }
end;
FileSetDate(Dest,FileGetDate(Source));
end;
Хм. IMHO крутовато будет такие функции писать, когда в большинстве случаев достаточно что-нубудь типа нижеприводимого, причем оно даже гибче, так как позволяет скопировать как весь файл пpи From и Count = 0, так и произвольный его кусок.
function CopyFile(InFile, OutFile: String; From, Count: Longint): Longint;
var InFS, OutFS: TFileStream;
begin
InFS := TFileStream.Create(InFile, fmOpenRead);
OutFS := TFileStream.Create(OutFile, fmCreate);
InFS.Seek(From, soFromBeginning);
Result := OutFS.CopyFrom(InFS, Count);
InFS.Free;
OutFS.Free;
end;
try..except расставляются по вкусу, а навороты вроде установки атрибутов, даты и времени файла и т.п. для ясности удалены, да и не нужны они в основном никогда.
Конечно, под Win32 имеет смысл использовать функции CopyFile, SHFileOperation.
Как получить имя папки pабочего стола (не чеpез registry)?
Nomadic советует: Просто очень хочется поработать с shell functions. В этом примере делается и это -procedure TForm1.Button1Click(Sender: TObject);
procedure madd(s:string);
begin
memo1.lines.add(s);
end;
VAR
ppmalloc:imalloc;
id:ishellfolder;
pi:pitemidlist;
lpname:tstrret;
begin
if succeeded(shgetspecialfolderlocation(0, CSIDL_PROGRAMS, pi)) then begin
madd('Succeeded programs location');
if succeeded(shgetdesktopfolder(id)) then begin
madd('Succeeded get desktop folder');
if succeeded(id.getdisplaynameof(pi, 0, lpname)) then begin
madd('Succeeded get display name');
if lpname.uType=2 then begin
madd(lpname.cstr);
end;
end else madd('UnSucceeded get display name');
end else madd('UnSucceeded get desktop folder');
end else madd('UNSucceeded programs location');
end;
Количество строк в текстовом файле
Если файлы не слишком велики, вы можете сделать так:List := TStringList.Create;
try
List.LoadFromFile('C:\FILE.TXT');
Gauge.MaxValue := List.Count;
finally
List.Free;
end;
Мы читаем в память весь текст, и кроме подсчета строк этот код ничего не делает. Другая идея заключается в использовании не счетчика строк, а счетчика байт. В самом начале вы запрашиваете размер файла (используя функцию Delphi FileSize), и в цикле проходите все байты, как вы делали это со строками. Цикл может выглядеть примерно так (предположим, вы используете стандартный паскалевский тип TEXT):
Gauge.MaxValue := FileSize(TextFile);
Reset(TextFile);
while not eof(TextFile) do begin
Readln(TextFile, Line);
{ Обработка строки }
with Gauge do begin
Progress := Progress + Length(Line) + 2; { 2 для CR/LF }
Refresh;
end;
end;
Копирование файлов IV
Igor Nikolaev aKa The Sprite советует:Copyfile('C:\1.txt', 'C:\files\2.txt', 0);
где первый параметр – путь и имя нужного файла, а второй путь и имя нового(скопированого) файла
Если же необходимо задавать имена файлов через Edit, то:
Copyfile(PChar(edit1.text), PChar(edit2.text), 0);
Сеть
Как узнать доступные сетевые pесуpсы?
Nomadic советует: Вот пример:type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;
Procedure EnumResources(LpNR:PNetResource);
Var
NetHandle: THandle;
BufSize: Integer;
Size: Integer;
NetResources: PNetResourceArray;
Count: Integer;
NetResult:Integer;
I: Integer;
NewItem:TListItem;
Begin
If WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY,
// RESOURCETYPE_ANY - все ресурсы
// RESOURCETYPE_DISK - диски
// RESOURCETYPE_PRINT - принтеры
0, LpNR, NetHandle) <> NO_ERROR then Exit;
Try
BufSize := 50 * SizeOf(TNetResource);
GetMem(NetResources, BufSize);
Try
while True do begin
Count := -1;
Size := BufSize;
NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
If NetResult = ERROR_MORE_DATA then begin
BufSize := Size;
ReallocMem(NetResources, BufSize);
Continue;
end;
if NetResult <> NO_ERROR then Exit;
For I := 0 to Count-1 do Begin
With NetResources^[I] do Begin
If RESOURCEUSAGE_CONTAINER = (DwUsage and RESOURCEUSAGE_CONTAINER) then
EnumResources(@NetResources^[I]);
If dwDisplayType = RESOURCEDISPLAYTYPE_SHARE Then
// ^^^^^^^^^^^^^^^^^^^^^^^^^ - ресурс
// RESOURCEDISPLAYTYPE_SERVER - компьютер
// RESOURCEDISPLAYTYPE_DOMAIN - рабочая группа
// RESOURCEDISPLAYTYPE_GENERIC - сеть
Begin
NewItem:= Form1.ListView1.Items.Add;
NewItem.Caption:=LpRemoteName;
End;
End;
End;
End;
finally
FreeMem(NetResources, BufSize);
end;
finally
WNetCloseEnum(NetHandle);
end;
End;
procedure TForm1.Button1Click(Sender: TObject);
Var OldCursor: TCursor;
begin
OldCursor:= Screen.Cursor;
Screen.Cursor:= crHourGlass;
With ListView1.Items do Begin
BeginUpdate;
Clear;
EnumResource(nil);
EndUpdate;
End;
Screen.Cursor:= OldCursor;
end;
Реестр
Как из программы выявить версию Windows, на кого зарегистрирована и т.п.?
Nomadic пишет: Вот тебе кyсочек Windows Registry, pазбиpайся:=== Cut here! [a.reg] === REGEDIT4
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion]
"InstallType"=hex:03,00
"SetupFlags"=hex:08,01,00,00
"DevicePath"="C:\\WINDOWS\\INF"
"ProductType"="9"
"RegisteredOwner"="Jacky Shikerya"
"RegisteredOrganization"="SigmaЩ Soft. Universal ltd.й"
"ProductId"="12095-OEM-0004226-12233"
"LicensingInfo"=""
"SubVersionNumber"=" B"
"InventoryPath"="C:\\WINDOWS\\SYSTEM\\PRODINV.DLL"
"ProgramFilesDir"="C:\\Program Files"
"CommonFilesDir"="C:\\Program Files\\Common Files"
"MediaPath"="C:\\WINDOWS\\media"
"ConfigPath"="C:\\WINDOWS\\config"
"SystemRoot"="C:\\WINDOWS"
"OldWinDir"=""
"ProductName"="Microsoft Windows 95"
"FirstInstallDateTime"=hex:81,73,b0,22
"Version"="Windows 95"
"VersionNumber"="4.00.1111"
"BootCount"="3"
"OtherDevicePath"="C:\\WINDOWS\\INF\\OTHER"
=== And cut Here!(or there?!) [a.reg] ===
В uses пpописываешь модуль Registry и дальше так:
var
R:TRegistry;
No:String;
begin
R:=TRegistry.Create;
R.RootKey:=HKEY_LOCAL_MACHINE;
R.OpenKey('….', false) {если false то пытается откpыть не создавая}
No:=R.ReadString('VersionNumber');
if no=….. then …… else ……
end;
Выше был приведён кусочек из Windows 95/98 Registry. В Windows NT эта ветвь находится в разделе [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion] Кроме того, обязательно посмотрите на список функций WinAPI, имена которых начинаются с Get…. Например, GetComputerName, GetVersionEx, GetSystemInfo, SystemParametersInfo.
Ярлыки (ShortCuts)
Создание ярлыков
VRSLazy@mail.ru пишет: Может ещё так можно ярлыки делать?uses … ShlObj, ComObj, ActiveX, shellapi, ComCtrls, ... // не помню какая из них нужна, вообще наити можно поиском в *.pas в каталоге
// disk:\Program Files\Borland\Delphi5\Source
procedure SetShortCut(path, cmd, icon, wd, name, arg : String);
var
ShellObject:IUnknown;
LinkFile:IPersistFile;
ShellLink:IShellLink;
begin
Try
CoInitialize(nil);
ShellObject:=CreateComObject(CLSID_ShellLink);
LinkFile:=ShellObject as IPersistFile;
ShellLink:=ShellObject as IShellLink; // RTFM - интерфейсу IShellLink, там всё описано
ShellLink.SetPath(@cmd[1]);
ShellLink.SetWorkingDirectory(@wd[1]);
ShellLink.SetIconLocation(@icon[1], 0); // вместо 0 можно указать номер иконки если их там много…
ShellLink.SetDescription(@name[1]);
ShellLink.SetArguments(@arg[1]);
LinkFile.Save(PWChar(WideString(path)),true);
finally
ShellObject:=Unassigned;
CoUninitialize;
end;
end;
Разное
`Устойчивые` всплывающие подсказки
На TabbedNotebook у меня есть множество компонентов TEdit. Я изменяю цвет компонентов TEdit на желтый и назначаю свойству Hint компонента строчку предупреждения, если поле редактирования содержит неверные данные. Поведение окна со всплывающей подсказкой (hintwindow) позволяет делать его видимым только тогда, когда курсор мыши находится в области элемента управления. Но мой заказчик хочет видеть подсказки все время, пока поле редактирования имеет фокус. Я не знаю как изменить поведение всплывающей подсказки, заданное по умолчанию. Я знаю что это возможно, но кто мне подскажет как? Ниже приведен модуль, содержащий новый тип hintwindow, TFocusHintWindow. Когда вы "просите" TFocusHintWindow появиться, он появляется ниже элемента управления, имеющего фокус. Для показа и скрытия достаточно следующих команд:
FocusHintWindow.Showing := True;
FocusHintWindow.Showing := False;
Пример того, как это можно использовать, содержится в комментариях к модулю. Это просто.
unit FHintWin;
{ -----------------------------------------------------------
TFocusHintWindow --
Вот пример того, как можно использовать TFocusHintWindow.
Данный пример выводит всплывающую подсказку ниже любого
TEdit, имеющего фокус. В противном случае выводится
стандартная подсказка Windows.
unit Unit1;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, FHintWin;
type TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
FocusHintWindow: TFocusHintWindow;
procedure AppIdle(Sender: TObject; var Done: Boolean);
procedure AppShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
end;
implementation
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnIdle := AppIdle;
Application.OnShowHint := AppShowHint;
FocusHintWindow := TFocusHintWindow.Create(Self);
end;
procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);
begin
FocusHintWindow.Showing := Screen.ActiveControl is TEdit;
end;
procedure TForm1.AppShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
begin
CanShow := not FocusHintWindow.Showing;
end;
end.
----------------------------------------------------------- }
interface
uses SysUtils, WinTypes, WinProcs, Classes, Controls, Forms;
type TFocusHintWindow = class(THintWindow)
private
FShowing: Boolean;
HintControl: TControl;
protected
procedure SetShowing(Value: Boolean);
function CalcHintRect(Hint: string): TRect;
procedure Appear;
procedure Disappear;
public
property Showing: Boolean read FShowing write SetShowing;
end;
implementation
function TFocusHintWindow.CalcHintRect(Hint: string): TRect;
var Buffer: array[Byte] of Char;
begin
Result := Bounds(0, 0, Screen.Width, 0);
DrawText(Canvas.Handle, StrPCopy(Buffer, Hint), -1, Result, DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
with HintControl, ClientOrigin do OffsetRect(Result, X, Y + Height + 6);
Inc(Result.Right, 6);
Inc(Result.Bottom, 2);
end;
procedure TFocusHintWindow.Appear;
var
Hint: string;
HintRect: TRect;
begin
if (Screen.ActiveControl = HintControl) then Exit;
HintControl := Screen.ActiveControl;
Hint := GetShortHint(HintControl.Hint);
HintRect := CalcHintRect(Hint);
ActivateHint(HintRect, Hint);
FShowing := True;
end;
procedure TFocusHintWindow.Disappear;
begin
HintControl := nil;
ShowWindow(Handle, SW_HIDE);
FShowing := False;
end;
procedure TFocusHintWindow.SetShowing(Value: Boolean);
begin
if Value then Appear else Disappear;
end;
end.
– Ed Jordan
Вызов 16-разрядного кода из 32-разрядного
Andrew Pastushenko пишет: Посылаю код для определения системных ресурсов (как в "Индикаторе ресурсов"). Использовалась статья "Calling 16-bit code from 32-bit in Windows 95".
{ GetFeeSystemResources routine for 32-bit Delphi.
Works only under Windows 9x }
unit SysRes32;
interface
const
//Constants whitch specifies the type of resource to be checked
GFSR_SYSTEMRESOURCES = $0000;
GFSR_GDIRESOURCES = $0001;
GFSR_USERRESOURCES = $0002;
// 32-bit function exported from this unit
function GetFeeSystemResources(SysResource: Word): Word;
implementation
uses SysUtils, Windows;
type
//Procedural variable for testing for a nil
TGetFSR = function(ResType: Word): Word; stdcall;
//Declare our class exeptions
EThunkError = class(Exception);
EFOpenError = class(Exception);
var
User16Handle : THandle = 0;
GetFSR : TGetFSR = nil;
//Prototypes for some undocumented API
function LoadLibrary16(LibFileName: PAnsiChar): THandle; stdcall; external kernel32 index 35;
function FreeLibrary16(LibModule: THandle): THandle; stdcall; external kernel32 index 36;
function GetProcAddress16(Module: THandle; ProcName: LPCSTR): TFarProc;stdcall; external kernel32 index 37;
procedure QT_Thunk; cdecl; external 'kernel32.dll' name 'QT_Thunk';
{$StackFrames On}
function GetFeeSystemResources(SysResource: Word): Word;
var EatStackSpace: String[$3C];
begin
// Ensure buffer isn't optimised away
EatStackSpace := '';
@GetFSR:=GetProcAddress16(User16Handle, 'GETFREESYSTEMRESOURCES');
if Assigned(GetFSR) then //Test result for nil
asm
//Manually push onto the stack type of resource to be checked first
push SysResource
//Load routine address into EDX
mov edx, [GetFSR]
//Call routine
call QT_Thunk
//Assign result to the function
mov @Result, ax
end
else raise EFOpenError.Create('GetProcAddress16 failed!');
end;
initialization
//Check Platform for Windows 9x
if Win32Platform <> VER_PLATFORM_WIN32_WINDOWS then raise EThunkError.Create('Flat thunks only supported under Windows 9x');
//Load 16-bit DLL (USER.EXE)
User16Handle:= LoadLibrary16(PChar('User.exe'));
if User16Handle < 32 then raise EFOpenError.Create('LoadLibrary16 failed!');
finalization
//Release 16-bit DLL when done
if User16Handle <> 0 then FreeLibrary16(User16Handle);
end.
Как проверить, имеем ли мы административные привилегии в системе?
Nomadic пишет:// Routine: check if the user has administrator provileges
// Was converted from C source by Akzhan Abdulin. Not properly tested.
type PTOKEN_GROUPS = TOKEN_GROUPS^;
function RunningAsAdministrator(): Boolean;
var
SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY;
psidAdmin: PSID;
ptg: PTOKEN_GROUPS = nil;
htkThread: Integer; { HANDLE }
cbTokenGroups: Longint; { DWORD }
iGroup: Longint; { DWORD }
bAdmin: Boolean;
begin
Result := false;
if not OpenThreadToken(GetCurrentThread(), // get security token
TOKEN_QUERY, FALSE, htkThread) then
if GetLastError() = ERROR_NO_TOKEN then begin
if not OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, htkThread) then Exit;
end else Exit;
if GetTokenInformation(htkThread, // get #of groups
TokenGroups, nil, 0, cbTokenGroups) then Exit;
if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then Exit;
ptg := PTOKEN_GROUPS(getmem(cbTokenGroups));
if not Assigned(ptg) then Exit;
if not GetTokenInformation(htkThread, // get groups
TokenGroups, ptg, cbTokenGroups, cbTokenGroups) then Exit;
if not AllocateAndInitializeSid(SystemSidAuthority, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdmin) then Exit;
iGroup := 0;
while iGroup < ptg^.GroupCount do // check administrator group
begin
if EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then begin
Result := TRUE;
break;
end;
Inc(iGroup);
end;
FreeSid(psidAdmin);
end;
Два метода в одном флаконе:
#include
#include
#include
#pragma hdrstop
#pragma comment(lib, "netapi32.lib")
// My thanks to Jerry Coffin (jcoffin@taeus.com)
// for this much simpler method.
bool jerry_coffin_method() {
bool result;
DWORD rc;
wchar_t user_name[256];
USER_INFO_1 *info;
DWORD size = sizeof(user_name);
GetUserNameW(user_name, &size);
rc = NetUserGetInfo(NULL,user_name, 1, (byte **)&info);
if (rc != NERR_Success) return false;
result = info->usri1_priv == USER_PRIV_ADMIN;
NetApiBufferFree(info);
return result;
}
bool look_at_token_method() {
int found;
DWORD i, l;
HANDLE hTok;
PSID pAdminSid;
SID_IDENTIFIER_AUTHORITY ntAuth = SECURITY_NT_AUTHORITY;
byte rawGroupList[4096];
TOKEN_GROUPS& groupList = *((TOKEN_GROUPS *)rawGroupList);
if (!OpenThreadToken(GetCurrentThread(), TOKEN_QUERY, FALSE, &hTok)) {
printf( "Cannot open thread token, trying process token [%lu].\n", GetLastError());
if (!OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hTok)) {
printf("Cannot open process token, quitting [%lu].\n", GetLastError());
return 1;
}
}
// normally, I should get the size of the group list first, but ...
l = sizeof rawGroupList;
if (!GetTokenInformation(hTok, TokenGroups, &groupList, l, &l)) {
printf( "Cannot get group list from token [%lu].\n", GetLastError());
return 1;
}
// here, we cobble up a SID for the Administrators group, to compare to.
if (!AllocateAndInitializeSid(&ntAuth, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &pAdminSid )) {
printf("Cannot create SID for Administrators [%lu].\n", GetLastError());
return 1;
}
// now, loop through groups in token and compare
found = 0;
for (i = 0; i < groupList.GroupCount; ++i) {
if (EqualSid(pAdminSid, groupList.Groups[i].Sid)) {
found = 1;
break;
}
}
FreeSid(pAdminSid);
CloseHandle(hTok);
return !!found;
}
int main() {
bool j, l;
j = jerry_coffin_method();
l = look_at_token_method();
printf("NetUserGetInfo(): The current user is %san Administrator.\n", j? "": "not ");
printf("Process token: The current user is %sa member of the Administrators group.\n", l? "": "not ");
return 0;
}
//****************************************************************************//
Как узнать язык Windows по умолчанию?
Одной строкойNomadic лаконично отвечает: GetSystemDefaultLCID GetLocaleInfo
GetLocalUserList — возвращает список пользователей (Windows NT, Windows 2000)
Кондратюк Виталий предлагает следующий код:
unit Func;
interface
uses Sysutils, Classes, Stdctrls, Comctrls, Graphics, Windows;
////////////////////////////////////////////////////////////////////////////////
{$EXTERNALSYM NetUserEnum}
function NetUserEnum(servername: LPWSTR; level, filter: DWORD; bufptr: Pointer; prefmaxlen: DWORD; entriesread, totalentries, resume_handle: LPDWORD): DWORD; stdcall; external 'NetApi32.dll' Name 'NetUserEnum';
function NetApiBufferFree(Buffer: Pointer{LPVOID}): DWORD; stdcall; external 'NetApi32.dll' Name 'NetApiBufferFree';
////////////////////////////////////////////////////////////////////////////////
procedure GetLocalUserList(ulist: TStringList);
implementation
//------------------------------------------------------------------------------
// возвращает список пользователей локального хоста
//------------------------------------------------------------------------------
procedure GetLocalUserList(ulist: TStringList);
const
NERR_SUCCESS = 0;
FILTER_TEMP_DUPLICATE_ACCOUNT = $0001;
FILTER_NORMAL_ACCOUNT = $0002;
FILTER_PROXY_ACCOUNT = $0004;
FILTER_INTERDOMAIN_TRUST_ACCOUNT = $0008;
FILTER_WORKSTATION_TRUST_ACCOUNT = $0010;
FILTER_SERVER_TRUST_ACCOUNT = $0020;
type
TUSER_INFO_10 = record
usri10_name, usri10_comment, usri10_usr_comment, usri10_full_name: PWideChar;
end;
PUSER_INFO_10 = ^TUSER_INFO_10;
var
dwERead, dwETotal, dwRes, res: DWORD;
inf: PUSER_INFO_10;
info: Pointer;
p: PChar;
i: Integer;
begin
if ulist=nil then Exit;
ulist.Clear;
info := nil;
dwRes := 0;
res := NetUserEnum(nil, 10, FILTER_NORMAL_ACCOUNT, @info, 65536, @dwERead, @dwETotal, @dwRes);
if (res<>NERR_SUCCESS) or (info=nil) then Exit;
p := PChar(info);
for i:=0 to dwERead-1 do begin
inf := PUSER_INFO_10(p + i*SizeOf(TUSER_INFO_10));
ulist.Add(WideCharToString(PWideChar((inf^).usri10_name)));
end;
NetApiBufferFree(info);
end;
end.
Каков способ обмена информацией между приложениями Win32 – Win16?
Nomadic предлагает следующее: Пользуйтесь сообщением WM_COPYDATA. Для Win16 константа определена как $004A, для Win32 смотрите в WinAPI Help.#define WM_COPYDATA 0x004A
/*
* lParam of WM_COPYDATA message points to…
*/
typedef struct tagCOPYDATASTRUCT {
DWORD dwData;
DWORD cbData;
PVOID lpData;
} COPYDATASTRUCT, *PCOPYDATASTRUCT;
Остановка и запуск сервисов
Postmaster предлагает следующий код:Unit1.dfm
object Form1: TForm1
Left = 192
Top = 107
Width = 264
Height = 121
Caption = 'Сервис'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 2
Top = 8
Width = 67
Height = 13
Caption = 'Имя сервиса'
end
object Button1: TButton
Left = 4
Top = 56
Width = 95
Height = 25
Caption = 'Стоп сервис'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 148
Top = 56
Width = 95
Height = 25
Caption = 'Старт сервис'
TabOrder = 1
OnClick = Button2Click
end
object Edit1: TEdit
Left = 0
Top = 24
Width = 241
Height = 21
TabOrder = 2
Text = 'Messenger'
end
end
Unit1.pas
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Winsvc;
type TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure StopService(ServiceName: String);
procedure Button2Click(Sender: TObject);
procedure StartService(ServiceName: String);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
StopService(Edit1.Text);
end;
procedure TForm1.StopService(ServiceName: String);
var
schService, schSCManager: DWORD;
p: PChar;
ss: _SERVICE_STATUS;
begin
p:=nil;
schSCManager:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if schSCManager = 0 then RaiseLastWin32Error;
try
schService:=OpenService(schSCManager, PChar(ServiceName), SERVICE_ALL_ACCESS);
if schService = 0 then RaiseLastWin32Error;
try
if not ControlService(schService, SERVICE_CONTROL_STOP, SS) then RaiseLastWin32Error;
finally
CloseServiceHandle(schService);
end;
finally
CloseServiceHandle(schSCManager);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
StartService(Edit1.Text);
end;
procedure TForm1.StartService(ServiceName: String);
var
schService, schSCManager: Dword;
p: PChar;
begin
p:=nil;
schSCManager:= OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if schSCManager = 0 then RaiseLastWin32Error;
try
schService:=OpenService(schSCManager, PChar(ServiceName), SERVICE_ALL_ACCESS);
if schService = 0 then RaiseLastWin32Error;
try
if not Winsvc.startService(schService, 0, p) then RaiseLastWin32Error;
finally
CloseServiceHandle(schService);
end;
finally
CloseServiceHandle(schSCManager);
end;
end;
end.
Прямой вызов метода Hint
Delphi 1
function RevealHint (Control: TControl): THintWindow;
{----------------------------------------------------------------}
{ Демонстрирует всплывающую подсказку для определенного элемента }
{ управления (Control), возвращает ссылку на hint-объект, }
{ поэтому в дальнейшем подсказка может быть спрятана вызовом }
{ RemoveHint (смотри ниже). }
{----------------------------------------------------------------}
var
ShortHint: string;
AShortHint: array[0..255] of Char;
HintPos: TPoint;
HintBox: TRect;
begin
{ Создаем окно: }
Result := THintWindow.Create(Control);
{ Получаем первую часть подсказки до '|': }
ShortHint := GetShortHint(Control.Hint);
{ Вычисляем месторасположение и размер окна подсказки }
HintPos := Control.ClientOrigin;
Inc(HintPos.Y, Control.Height + 6); <<<< Смотри примечание ниже
HintBox := Bounds(0, 0, Screen.Width, 0);
DrawText(Result.Canvas.Handle, StrPCopy(AShortHint, ShortHint), -1, HintBox, DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
OffsetRect(HintBox, HintPos.X, HintPos.Y);
Inc(HintBox.Right, 6);
Inc(HintBox.Bottom, 2);
{ Теперь показываем окно: }
Result.ActivateHint(HintBox, ShortHint);
end; {RevealHint}
procedure RemoveHint (var Hint: THintWindow);
{----------------------------------------------------------------}
{ Освобождаем дескриптор окна всплывающей подсказки, выведенной }
{ предыдущим RevealHint. }
{----------------------------------------------------------------}
begin
Hint.ReleaseHandle;
Hint.Free;
Hint := nil;
end; {RemoveHint}
Строка с комментарием <<<< позиционирует подсказку ниже элемента управления. Это может быть изменено, если по какой-то причине вам необходима другая позиция окна с подсказкой.
Как использовать свои курсоры в программе? I
Nomadic предлагает следующее:{$R CURSORS.RES}
const
crZoomIn = 1;
crZoomOut = 2;
Screen.Cursors[crZoomIn] := LoadCursor(hInstance, 'CURSOR_ZOOMIN');
Screen.Cursors[crZoomOut] := LoadCursor(hInstance, 'CURSOR_ZOOMOUT');
С вашей программой должен быть слинкован файл ресурсов, содержащий соответствующие курсоры.
Как использовать свои курсоры в программе? II
С помощью программы Image Editor упакуйте курсор в RES-файл. В следующем примере подразумевается, что вы сохранили курсор в RES-файле как «cursor_1», и записали RES-файл с именем MYFILE.RES.{$R c:\programs\delphi\MyFile.res} { Это ваш RES-файл }
const PutTheCursorHere_Dude = 1; { произвольное положительное число }
procedure stuff;
begin
screen.cursors[PutTheCursorHere_Dude] := LoadCursor(hInstance, PChar('cursor_1'));
screen.cursor := PutTheCursorHere_Dude;
end;
Компоненты
BatchMove
Пересборка индексов с помощью TBatchMove
Delphi 1… вы все делаете правильно. BatchMove не может пересобирать индексы. Тем не менее, следующая процедура все же поможет вам сделать это (создать индексы заново). Задайте ей необходимые параметры (.DBF. Name, исходная и целевая таблица, Source и Target) и попробуйте ее в деле!
procedure Form1.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;
Есть некоторая таблица и требуется при нажатии на кнопку создавать таблицы такой же структуры. Подскажите, как это удобнее всего сделать?
Nomadic отвечает: Удобней всего, например, так —
with bmovMyBatchMove do begin
Mode := bmCopy;
RecordCount := 1;
Execute;
R Destination.Delete;
end;
Где bmovMyBatchMove – экземпляр класса TBatchMove из VCL.
Неправда Ваша! ;)
Этот загадочный 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;
Button
Цветная кнопка
VS пишет: В книгах Калверта, Свана и других авторов можно найти похожий текст. Смысл текста — "Изменить цвет кнопок Button, BitBt нельзя, т.к. их рисует WINDOWS". Если нельзя, но ОЧЕНЬ НУЖНО, то можно. Небольшой компонент ColorBtn, дает возможность использовать в кнопках цвет. Кроме того, представлено новое свойство — Frame3D, позволяющее получить более реалистичный вид нажатой кнопки. В отличие от API, при изменении значения свойства Frame3D, не требуется переоткрытие компонента.unit ColorBtn;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons;
type TColorBtn = class(TButton)
private
{ Private declarations }
IsFocused: boolean;
FCanvas: TCanvas;
F3DFrame: boolean;
FButtonColor: TColor;
procedure Set3DFrame(Value: boolean);
procedure SetButtonColor(Value: TColor);
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
procedure DrawButtonText(const Caption: string; TRC: TRect; State: TButtonState; BiDiFlags: Longint);
procedure CalcuateTextPosition(const Caption: string; var TRC: TRect; BiDiFlags: Longint);
protected
{ Protected declarations }
procedure CreateParams(var Params: TCreateParams); override;
procedure SetButtonStyle(ADefault: boolean); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property ButtonColor: TColor read FButtonColor write SetButtonColor default clBtnFace;
property Frame3D: boolean read F3DFrame write Set3DFrame default False;
end;
procedure Register;
implementation
{ TColorBtn }
constructor TColorBtn.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);
FCanvas:= TCanvas.Create;
FButtonColor:= clBtnFace;
F3DFrame:= False;
end;
destructor TColorBtn.Destroy;
begin
FCanvas.Free;
Inherited Destroy;
end;
procedure TColorBtn.CreateParams(var Params: TCreateParams);
begin
Inherited CreateParams(Params);
with Params do Style:= Style or BS_OWNERDRAW;
end;
procedure TColorBtn.Set3DFrame(Value: boolean);
begin
if F3DFrame <> Value then F3DFrame:= Value;
end;
procedure TColorBtn.SetButtonColor(Value: TColor);
begin
if FButtonColor <> Value then begin
FButtonColor:= Value;
Invalidate;
end;
end;
procedure TColorBtn.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;
procedure TColorBtn.SetButtonStyle(ADefault: Boolean);
begin
if IsFocused <> ADefault then IsFocused:= ADefault;
end;
procedure TColorBtn.CNDrawItem(var Message: TWMDrawItem);
var
RC: TRect;Flags: Longint;
State: TButtonState;
IsDown, IsDefault: Boolean;
DrawItemStruct: TDrawItemStruct;
begin
DrawItemStruct:= Message.DrawItemStruct^;
FCanvas.Handle:= DrawItemStruct.HDC;
RC:= ClientRect;
with DrawItemStruct do begin
IsDown:= ItemState and ODS_SELECTED <> 0;
IsDefault:= ItemState and ODS_FOCUS <> 0;
if not Enabled then State:= bsDisabled
else if IsDown then State:= bsDown
else State:= bsUp;
end;
Flags:= DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
if IsDown then Flags:= Flags or DFCS_PUSHED;
if DrawItemStruct.ItemState and ODS_DISABLED <> 0 then Flags:= Flags or DFCS_INACTIVE;
if IsFocused or IsDefault then begin
FCanvas.Pen.Color:= clWindowFrame;
FCanvas.Pen.Width:= 1;
FCanvas.Brush.Style:= bsClear;
FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom);
InflateRect(RC, -1, -1);
end;
if IsDown then begin
FCanvas.Pen.Color:= clBtnShadow;
FCanvas.Pen.Width:= 1;
FCanvas.Rectangle(RC.Left, RC.Top, RC.Right, RC.Bottom);
InflateRect(RC, -1, -1);
if F3DFrame then begin
FCanvas.Pen.Color:= FButtonColor;
FCanvas.Pen.Width:= 1;
DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags);
end;
end else DrawFrameControl(DrawItemStruct.HDC, RC, DFC_BUTTON, Flags);
FCanvas.Brush.Color:= FButtonColor;
FCanvas.FillRect(RC);
InflateRect(RC, 1, 1);
if IsFocused then begin
RC:= ClientRect;
InflateRect(RC, -1, -1);
end;
if IsDown then OffsetRect(RC, 1, 1);
FCanvas.Font:= Self.Font;
DrawButtonText(Caption, RC, State, 0);
if IsFocused and IsDefault then begin
RC:= ClientRect;
InflateRect(RC, -4, -4);
FCanvas.Pen.Color:= clWindowFrame;
Windows.DrawFocusRect(FCanvas.Handle, RC);
end;
FCanvas.Handle:= 0;
end;
procedure TColorBtn.CalcuateTextPosition(const Caption: string; var TRC: TRect; BiDiFlags: Integer);
var
TB: TRect;
TS, TP: TPoint;
begin
with FCanvas do begin
TB:= Rect(0, 0, TRC.Right + TRC.Left, TRC.Top + TRC.Bottom);
DrawText(Handle, PChar(Caption), Length(Caption), TB, DT_CALCRECT or BiDiFlags);
TS := Point(TB.Right - TB.Left, TB.Bottom - TB.Top);
TP.X := ((TRC.Right - TRC.Left) - TS.X + 1) div 2;
TP.Y := ((TRC.Bottom - TRC.Top) - TS.Y + 1) div 2;
OffsetRect(TB, TP.X + TRC.Left, TP.Y + TRC.Top);
TRC:= TB;
end;
end;
procedure TColorBtn.DrawButtonText(const Caption: string; TRC: TRect; State: TButtonState; BiDiFlags: Integer);
begin
with FCanvas do begin
CalcuateTextPosition(Caption, TRC, BiDiFlags);
Brush.Style:= bsClear;
if State = bsDisabled then begin
OffsetRect(TRC, 1, 1);
Font.Color:= clBtnHighlight;
DrawText(Handle, PChar(Caption), Length(Caption), TRC, DT_CENTER or DT_VCENTER or BiDiFlags);
OffsetRect(TRC, -1, -1);
Font.Color:= clBtnShadow;
DrawText(Handle, PChar(Caption), Length(Caption), TRC, DT_CENTER or DT_VCENTER or BiDiFlags);
end else DrawText(Handle, PChar(Caption), Length(Caption), TRC, DT_CENTER or DT_VCENTER or BiDiFlags);
end;
end;
procedure Register;
begin
RegisterComponents('Controls', [TColorBtn]);
end;
end.
Небольшое дополнение. Кнопку по прежнему рисует WINDOWS, а раскрашивает ее ColorBtn. Код компонента на 90% повторяет код BitBtn, ничего необычного здесь нет. Хочется повторить слова Калверта — «Пользуйтесь исходным кодом». Чаще заглядывайте в VCL – можно найти много интересного.
Обработка щелчка нескольких кнопок, используя их заголовок
Delphi 1…с ваших слов я понял, что вы все уже реализовали, но давайте все повторим: вы должны убедиться в том, что событие OnClick привязано к каждой кнопке калькулятора (числовые кнопки 0..9) и указывают на общий обработчик события. В разделяемом обработчике события получите заголовок обрабатываемой кнопки следующим образом:
Edit1.Text := TButton(Sender).Caption;
…я думаю в этом случае самым разумным будет использование свойства Tag каждой кнопки:
1. назначьте уникальный Tag для каждой кнопки (например, эквивалент арабским цифрам)
2. procedureTForm1.Button1Click(Sender: TObject);
begin
if (Sender is TButton) then with (Sender as TButton) do
{используем Tag}
end;
Если вам нужен только заголовок, то есть изящный способ получить к нему доступ. Подключите общий обработчик события для всех кнопок и используйте приведение типа как показано ниже:
procedure TForm1.Edit1Click(Sender: TObject);
begin
edit1.text := (sender as TButton).caption;
end;
Приведенная ниже конструкция будет недостаточной:
sender.caption
поскольку компилятор не знает о том, имеет ли «sender» свойство caption, или нет.
CheckBox
Массив из CheckBox – использование разделяемого обработчика события I
Delphi 1Поместите несколько Checkbox в компонент TGroupBox. Во время прогона (или проектирования) назначьте общий обработчик события Click для всех checkbox'в. Чтобы в цикле обойти все «дочерние» TCheckBox'ы, можно воспользоваться свойством-массивом Controls TGroupBox (и заодно привести их к типу TCheckBox). Приблизительно так:
for i := 0 to GroupBox1.ControlCount -1 do
if (GroupBox1.Controls[i] as TCheckBox).checked then
{что-то там еще};
Вы можете получить имя sender следующим образом:
procedure TMain1.CheckBoxClick(Sender: TObject);
var whodidit: string[63];
begin
whodidit := TComponent(sender).name;
end;
После приведения типа можно добраться и до других свойств. К примеру, очень полезным может оказаться свойство Tag. Во время создания, вы можете присвоить каждому checkbox.tag свой ID номер. А в обработчике события, читая ID, можно идентифицировать sender.
Массив из CheckBox – использование разделяемого обработчика события II
Delphi 1
var
CheckArray: array[1..x] of TCheckBox;
i:integer;
begin
for i:=1 to x do begin
CheckArray[i]:=TCheckBox.Create(Form1);
{Устанавливаем свойства}
with CheckBox[i] do begin
Left:=i*20;
Width:=15;
другое…
end;
end;
Очевидно, можно сказать:
Check[i].OnClick:=xyz.
Пока я и сам не знаю как поступить. Динамическое создание компонентов да, но обработчики событий?
Существует способ организации массива checkbox'ов с разделяемым обработчиком события. Расположите их на форме и дайте им «непрерывные» имена (Check1, Check2 и т.д.). Затем установите у них общий обработчик события. Обработчик события может выглядеть так:
procedure TForm.Check1Click(Sender : TObject);
var i : Integer;
begin
for i := 1 to 10 { предположим, что мы имеем 10 checkbox'ов } do
With TCheckBox(FindComponent('Check'+IntToStr(i))) do begin
{ другой какой-то код }
end;
end;
Идентификация CheckBox'ов
Delphi 3В режиме проектирования вы, как программист, без труда узнаете, сколько checkbox'ов содержит ваша форма. А вот когда приложение запущено… Используйте Delphi Run Time Type Information (RTTI). Для нашей испытуемой формы вы можете попробовать следующий код:
var i : Integer
begin
for i := 0 to ComponentCount - 1 do
if Components[i] is TCheckBox then
(Components[i] as TCheckBox).Checked then begin
... сюда поместите ваш код ...
end;
end;
Кроме того, следующий код Delphi абсолютно корректен:
if Components[i] = CheckBox5 then Чтотоделаем;
Также, каждый компонент в Delphi имеет опубликованное (Published) свойство с именем 'Tag', значение которого вы можете задавать во время создания компонента, и затем, во время выполнения приложения, обращаться к нему для получения доступа к компоненту:
var i : Integer
begin
for i := 0 to ComponentCount - 1 do
if Components[i] is TCheckBox then
with (Components[i] as TCheckBox) do
Case Tag of
1 : if Checked then DoSomethingOnBox1;
2 : if Checked then DoSomethingOnBox2;
… другое …
end;
end;
Для получения дополнительной информации, обратитесь к справке Delphi с ключевым словом «ComponentCount».
BitBtn
Кнопка с несколькими строчками текста III
Вот полный код проекта, создающего на кнопке во время выполнения две строчки текста.program TwolnBtn;
uses Forms,TwolnBtu in 'TWOLNBTU.PAS' {Form1};
{$R *.RES}
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Файл TWOLNBTU.TXT → TWOLNBTU.DFM
object Form1: TForm1
Left = 202
Top = 98
Width = 320
Height = 176
Caption = 'Form1'
Font.Color = clRed
Font.Height = -12
Font.Name = 'Arial'
Font.Style = [fsBold]
PixelsPerInch = 96
OnActivate = ChgSpeedButton
OnCreate = ChgBitBtn
TextHeight = 15
object SpeedButton1: TSpeedButton
Left = 144
Top = 24
Width = 65
Height = 45
Caption = 'Это двустрочный заголовок'
OnClick = ChgSpeedButton
end
object
BitBtn1: TBitBtn
Left = 32
Top = 24
Width = 69
Height = 37
Caption = 'Прерывание работы программы'
TabOrder = 0
OnClick = BitBtn1Click
end
end
Файл TWOLNBTU.PAS
unit Twolnbtu;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons;
type TForm1 = class(TForm)
BitBtn1: TBitBtn;
SpeedButton1: TSpeedButton;
procedure ChgBitBtn(Sender: TObject);
procedure ChgSpeedButton(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.ChgBitBtn(Sender: TObject);
VAR
R : TRect;
N : Integer;
Buff : ARRAY[0..255] OF Char;
BEGIN
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;
END;
procedure TForm1.ChgSpeedButton(Sender: TObject);
VAR
R : TRect;
N : Integer;
Buff : ARRAY[0..255] OF Char;
BEGIN
WITH SpeedButton1 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;
END;
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Close;
end;
end.
-Dennis Passmore
ComboBox
Хочу реализовать правильный выпадающий контрол (combo). Как это сделать?
Nomadic отвечает: Когда-то потратил немало времени на разбор, как же все таки работают дропдаун-контролы. В итоге мной был написан маленький юнит, который я положил у себя в каталоге Demo для ознакомления интересующихся. Он маленький (его основная задача — показать принцип работы, а все остальное — как реализуешь), я думаю, что большинству он пригодиться, поэтому публикую здесь. Касательно твоего вопроса - реализуй вместо листбокса выпадающий контрол, который даст тебе функциональность дерева.unit edit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TPopupListbox = class(TCustomListbox)
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
end;
TTestDropEdit = class(TEdit)
private
FPickList: TPopupListbox;
procedure CMCancelMode(var Message: TCMCancelMode); message CM_CancelMode;
procedure WMKillFocus(var Message: TMessage); message WM_KillFocus;
protected
procedure CloseUp(Accept: Boolean);
procedure DropDown;
procedure WndProc(var Message: TMessage); override;
public
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
end;
implementation
{ TPopupListBox }
procedure TPopupListBox.CreateParams(var Params: TCreateParams);
begin
inherited;
with Params do begin
Style := Style or WS_BORDER;
ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST;
WindowClass.Style := CS_SAVEBITS;
end;
end;
procedure TPopupListbox.CreateWnd;
begin
inherited CreateWnd;
Windows.SetParent(Handle, 0);
CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0);
end;
procedure TPopupListbox.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
TTestDropEdit(Owner).CloseUp((X >= 0) and (Y >= 0) and (X < Width) and (Y < Height));
end;
{ TTestDropEdit }
constructor TTestDropEdit.Create(Owner: TComponent);
begin
inherited Create(Owner);
Parent := Owner as TWinControl;
FPickList := TPopupListbox.Create(nil);
FPickList.Visible := False;
FPickList.Parent := Self;
FPickList.IntegralHeight := True;
FPickList.ItemHeight := 11;
FPickList.Items.CommaText :='1,2,3,4,5,6,7,8,9,0';
end;
destructor TTestDropEdit.Destroy;
begin
FPickList.Free;
inherited;
end;
procedure TTestDropEdit.CloseUp(Accept: Boolean);
begin
if FPickList.Visible then begin
if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
SetWindowPos(FPickList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
if FPickList.ItemIndex <> -1 then Text := FPickList.Items.Strings[FPickList.ItemIndex];
FPickList.Visible := False;
Invalidate;
end;
end;
procedure TTestDropEdit.DropDown;
var
P: TPoint;
I,J,Y: Integer;
begin
if Assigned(FPickList) and (not FPickList.Visible) then begin
FPickList.Width := Width;
FPickList.Color := Color;
FPickList.Font := Font;
FPickList.Height := 6 * FPickList.ItemHeight + 4;
FPickList.ItemIndex := FPickList.Items.IndexOf(Text);
P := Parent.ClientToScreen(Point(Left, Top));
Y := P.Y + Height;
if Y + FPickList.Height > Screen.Height then Y := P.Y - FPickList.Height;
SetWindowPos(FPickList.Handle, HWND_TOP, P.X, Y, 0, 0, SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
FPickList.Visible := True;
Invalidate;
Windows.SetFocus(Handle);
end;
end;
procedure TTestDropEdit.CMCancelMode(var Message: TCMCancelMode);
begin
if (Message.Sender <> Self) and (Message.Sender <> FPickList) then CloseUp(False);
end;
procedure TTestDropEdit.WMKillFocus(var Message: TMessage);
begin
inherited;
CloseUp(False);
end;
procedure TTestDropEdit.WndProc(var Message: TMessage);
procedure DoDropDownKeys(var Key: Word; Shift: TShiftState);
begin
case Key of
VK_UP, VK_DOWN:
if ssAlt in Shift then begin
if FPickList.Visible then CloseUp(True)
else DropDown;
Key := 0;
end;
VK_RETURN, VK_ESCAPE:
if FPickList.Visible and not (ssAlt in Shift) then begin
CloseUp(Key = VK_RETURN);
Key := 0;
end;
end;
end;
begin
case Message.Msg of
WM_KeyDown, WM_SysKeyDown, WM_Char:
with TWMKey(Message) do begin
DoDropDownKeys(CharCode, KeyDataToShiftState(KeyData));
if (CharCode <> 0) and FPickList.Visible then begin
with TMessage(Message) do SendMessage(FPickList.Handle, Msg, WParam, LParam);
Exit;
end;
end
end;
inherited;
end;
end.
Программное открытие ComboBox II
Delphi 1
procedureTForm1.ComboBox1Enter(Sender:TObject);
begin
SendMessage(ComboBox1.Handle, CB_SHOWDROPDOWN, Integer(True), 0);
end;
Поместите эту строку в обработчик события OnEnter ComboBox:
SendMessage(combobox1.Handle, CB_SHOWDROPDOWN, 1, 0);
Измените третий параметр (1) на 0, если вы хотите спрятать список.
Проблемы с ComboBox
Delphi 1…попробуйте сохранять в переменной в методе формы OnEnter или OnCreate значение Index. Затем, чтобы отменить выбор пользователя, сделайте:
ComboBox1.ItemIndex := var1;
DBEdit
Исправление DBEdit MaxLength
Delphi 1Я, кажется, не могу получить свойство MaxLength, чтобы работать с компонентами TDBEdit. В TEdit это работает как положено, но при попытке задать максимальную длину текста в TDBEdit это не срабатывает, и я все еще могу набрать текст сверх установленного ограничения. По-моему, это является следствием этого кода в TDBEdit.DataChange (DBCTRLS.PAS):
if FDataLink.Field <> nil then begin
…
if FDataLink.Field.DataType = ftString then MaxLength := FDataLink.Field.Size
else MaxLength := 0;
…
end else begin
…
MaxLength := 0;
…
end;
т.к. иногда значение устанавливается на ноль…
Похоже все будет работать, если вы измените строку
MaxLength := 0;
на
MaxLength := inherited MaxLength;
Для того, чтобы изменения вступили в силу, вам необходимо перекомпилировать ваш complib с измененным DBCTRLS.PAS, находящимся в пути lib.
Если вы хотите использовать MaxLength с StringField, изменений необходимо сделать немного больше:
…
if (FDataLink.Field.DataType = ftString) and (inherited MaxLength = 0) then
MaxLength := FDataLink.Field.Size
else MaxLength := inherited MaxLength;
…
Или использовать что-то типа EditMask…
– Reinhard Kalinke
Поиск и управление TEdit/TField
Я хотел бы менять цвет компонентов TDBEdit и TEdit, расположенных на форме, на другой, "отчетливый" цвет, в том случае, если с помощью них требуется ввести какие-либо данные. Как насчет этого? Представляю вашему вниманию два метода. Первый метод задает цвет каждому DBEdit, имеющему требуемое поле. Второй метод (более сложный) задает цвет каждому БД-компоненту, имеющему необходимое поле.
procedure TForm3.Button3Click(Sender: TObject);
Var Control : Integer;
begin
For Control := 0 To ControlCount-1 Do
If Controls[Control] Is TDBEdit Then
With TDBEdit(Controls[Control]) Do
If DataSource.DataSet.FieldByName(DataField).Required Then Color := clRed;
end;
{ Данный метод будет работать только в случае, если БД-компонент обладает тремя полями: DataSource, типа TDataSource, DataField, типа String, и Color, типа TColor (это не должно быть проблемой). Также вам необходимо включить TypInfo в список используемых модулей }
procedure TForm3.Button4Click(Sender: TObject);
Var
Control : Integer;
DataSource : TDataSource;
DataField : String;
Function GetDataSource(Instance: TComponent) : Boolean;
Var PropInfo: PPropInfo;
Begin
Result := False;
PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, 'DataSource');
If (PropInfo <> Nil) And (PropInfo^.PropType^.Kind = tkClass) Then Begin
DataSource := TDataSource(TypInfo.GetOrdProp(Instance, PropInfo));
Result := DataSource <> Nil;
End;
End;
Function GetDataField(Instance: TComponent) : Boolean;
Var PropInfo : PPropInfo;
Begin
Result := False;
PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, 'DataField');
If (PropInfo <> Nil) And (PropInfo^.PropType^.Kind = tkString) Then Begin
DataField := TypInfo.GetStrProp(Instance, PropInfo);
Result := True;
End;
End;
Procedure SetColor(Instance: TComponent; Color: TColor);
Var PropInfo : PPropInfo;
Begin
PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, 'Color');
If (PropInfo <> Nil) And (PropInfo^.PropType^.Kind = tkInteger) Then TypInfo.SetOrdProp (Instance, PropInfo, Ord(Color));
End;
begin
For Control := 0 To ControlCount-1 Do
If GetDataSource(Controls[Control]) And GetDataField(Controls[Control]) And
(DataSource.DataSet <> Nil) And
DataSource.DataSet.FieldByName(DataField).Required Then
SetColor(Controls[Control], clRed);
end;
– Robert Wittig
Insert/Override с помощью DBEdit
Сама Windows не позволяет это сделать, но я нашел как это обойти с помощью одной хитрости, и, похоже, это классно работает (надеюсь вы получите даже больше, чем вы хотите :). Сначала я добавляю к моей форме свойство (и соответствующие переменные и процедуры), наподобие этому:private
FinsertMode: boolean;
procedure SetInsertMode(value: boolean);
public
property insertMode: boolean read FinsertMode write SetInsertMode;
В обработчике создания события формы я инициализирую его:
procedure TForm1.FormCreate(Sender: TObject);
begin
{инициализация}
insertMode := True;
end;
Также для этого свойства я создаю процедуру SetInsertMode, которая с помощью TPanel с именем Panel1 извещает пользователя о текущем режиме работы:
procedure TForm1.SetInsertMode(value: boolean);
begin
FinsertMode := value;
if FinsertMode then Panel1.Caption := 'ВСТАВКА'
else Panel1.Caption := 'ПЕРЕЗАПИСЬ';
end;
Затем я добавляю три обработчика событий (OnKeyDown, OnKeyPress, OnEnter) для каждого моего DBEdit (можно при наличии нескольких компонентов создать один общий обработчик для всех):
procedure TForm1.DBEditKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (Key = VK_INSERT) then insertMode := not insertMode;
end;
procedure TForm1.DBEditKeyPress(Sender: TObject; var Key: Char);
begin
if (not insertMode) and (Sender is TDBEdit) then (Sender as TDBEdit).SelLength := 1
else (Sender as TDBEdit).SelLength := 0;
end;
procedure TForm1.DBEditEnter(Sender: TObject);
begin
insertMode := True;
end;
Банзай! Похоже это работает, хотя я и не имел достаточного времени протестировать это. Естественно, вы можете изменить это по просьбе вашего заказчика (например, я всегда сбрасывал режим во вставку при перемещении к другому компоненту DBEedit). Все вышесказанное должно также работать без проблем и с компонентами Edit.
– Denis Sarrazin
Как очистить DBEdit
Delphi 1Пробую так:
myDbEdit.Text := '';
или адрес TField, если вы хотите так:
TableNameMyField.Value := '';
Ответ:
Table1.Edit;
Table1.FieldByName(DBEdit1.FieldName).Clear;
DBGrid
Dbgrid и множественный выбор
Delphi 2Тема: TDBGrid и множественный выбор записей (Multi-Selecting Records) При включении флажка [dgMultiSelect] в свойстве-наборе Options компонента DBGrid, вы добавляете к табличной сетке возможность множественного выбора записей. Выбранные вами записи представлены в виде закладок и храняться в свойстве SelectedRows. Свойство SelectedRows является объектом, имеющим тип TBookmarkList. Его свойства иметоды описаны ниже.
// property SelectedRows: TBookmarkList read FBookmarks;
// TBookmarkList = class
// public
{* Метод Clear освобождает все выбранные в DBGrid записи *}
// procedure Clear;
{* Метод Delete удаляет все выбранные строки из набора данных *}
// procedure Delete;
{* Метод Find определяет наличие закладки в выбранном списке. *}
// function Find(const Item: TBookmarkStr;
// var Index: Integer): Boolean;
{* Метод IndexOf возвращает индекс закладки, расположенной в свойстве Items. *}
// function IndexOf(const Item: TBookmarkStr): Integer;
{* Метод Refresh возвращает логическую величину, уведомляющую о том, что в то время, пока в табличной сетке была выбрана запись, были добавлены (удалены) какие-то данные. Метод Refresh может быть использован для обновления списка выбранных записей для уменьшения возможности получения удаленной записи. *}
// function Refresh: Boolean; True = orphans found
{* Свойство Count возвращает количество выбранных в настоящий момент элементов в DBGrid *}
// property Count: Integer read GetCount;
{* Свойство CurrentRowSelected содержит логическую величину, зависящую от того, выбрана текущая строка или нет. *}
// property CurrentRowSelected: Boolean
// read GetCurrentRowSelected
// write SetCurrentRowSelected;
{* Свойство Items – TStringList TBookmarkStr *}
// property Items[Index: Integer]: TBookmarkStr
// read GetItem; default;
// end;
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables;
type TForm1 = class(TForm)
Table1: TTable;
DBGrid1: TDBGrid;
Count: TButton;
Selected: TButton;
Clear: TButton;
Delete: TButton;
Select: TButton;
GetBookMark: TButton;
Find: TButton;
FreeBookmark: TButton;
DataSource1: TDataSource;
procedure CountClick(Sender: TObject);
procedure SelectedClick(Sender: TObject);
procedure ClearClick(Sender: TObject);
procedure DeleteClick(Sender: TObject);
procedure SelectClick(Sender: TObject);
procedure GetBookMarkClick(Sender: TObject);
procedure FindClick(Sender: TObject);
procedure FreeBookmarkClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Bookmark1: TBookmark;
z: Integer;
implementation
{$R *.DFM}
//Пример использования свойства Count
procedure TForm1.CountClick(Sender: TObject);
begin
if DBgrid1.SelectedRows.Count > 0 then begin
showmessage(inttostr(DBgrid1.SelectedRows.Count));
end;
end;
//Пример использования свойства CurrentRowSelected
procedure TForm1.SelectedClick(Sender: TObject);
begin
if DBgrid1.SelectedRows.CurrentRowSelected then showmessage('Выбрана');
end;
//Пример использования метода Clear
procedure TForm1.ClearClick(Sender: TObject);
begin
dbgrid1.SelectedRows.Clear;
end;
//Пример использования метода Delete
procedure TForm1.DeleteClick(Sender: TObject);
begin
DBgrid1.SelectedRows.Delete;
end;
{*Данные пример проходит в цикле все выбранныезаписи табличной сетки и отображает второеполе набора данных.
Метод DisableControls используется в случае,когда необходимо запретить обновление DBGridпри изменении набора данных. Последняя позициянабора данных сохраняется как TBookmark.
Метод IndexOf вызывается при необходимостипроверить существование закладки.Решение использовать метод IndexOf, а неRefresh, должно приниматься исходя изспецифики приложения.*}
procedure TForm1.SelectClick(Sender: TObject);
var
x: word;
TempBookmark: TBookMark;
begin
DBGrid1.Datasource.Dataset.DisableControls;
with DBgrid1.SelectedRows do if Count > 0 then begin
TempBookmark:= DBGrid1.Datasource.Dataset.GetBookmark;
for x:= 0 to Count - 1 do begin
if IndexOf(Items[x]) > -1 then begin
DBGrid1.Datasource.Dataset.Bookmark:= Items[x];
showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString);
end;
end;
end;
DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark);
DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark);
DBGrid1.Datasource.Dataset.EnableControls;
end;
{*Данный пример позволит вам установить закладку изатем найти ее в списке выбранных записей компонента DBGrid.*}
//Устанавливаем закдадку
procedure TForm1.GetBookMarkClick(Sender: TObject);
begin
Bookmark1:= DBGrid1.Datasource.Dataset.GetBookmark;
end;
//Освобождаем закладку
procedure TForm1.FreeBookmarkClick(Sender: TObject);
begin
if assigned(Bookmark1) then begin
DBGrid1.Datasource.Dataset.FreeBookmark(Bookmark1);
Bookmark1:= nil;
end;
end;
//Испольуем метод Find для установления позиции
//записи-закладки в списке выбранных записей компонента DBGrid
procedure TForm1.FindClick(Sender: TObject);
begin
if assigned(Bookmark1) then begin
if DBGrid1.SelectedRows.Find(TBookMarkStr(Bookmark1),z) then showmessage(inttostr(z));
end;
end;
end.
Вертикальная полоса прокрутки Dbgrid
Delphi 1Это небольшое исправление к исходному коду VCL, позволяющее поддерживать перемещение по таблице с помощью изменения позиции движка вертикальной полосы прокрутки. (Примечание: это работает только с таблицами Paradox и BDE. Для использования этого кода с другими таблицами/движками вам необходимо заменить DBIGetSeqNo на функцию, надежно возвращающую текущую позицию записи вне зависимости от того, использует ли таблица индекс или нет.) В DBGRID.PAS измените две следующих процедуры:
procedure TCustomDBGrid.UpdateScrollBar;
var
Pos: Integer;
mPos, mMax: longint;
begin
if FDatalink.Active and HandleAllocated then
with FDatalink.DataSet do begin
UpdateCursorPos;
if (DBIGetSeqNo(Handle,mPos) = DBIERR_NONE) then begin
mMax := RecordCount;
while mMax > 1000 do begin
mMax := mMax div 10;
mPos := mPos div 10;
end;
SetScrollRange(Self.Handle, SB_VERT, 1, mMax, False);
end else begin
if BOF then mPos := 0
else if EOF then mPos := 4
else mPos := 2;
SetScrollRange(Self.Handle, SB_VERT, 0, 4, False);
end; (**)
if GetScrollPos(Self.Handle, SB_VERT) <> mPos then
SetScrollPos(Self.Handle, SB_VERT, mPos, True);
end;
end;
procedure TCustomDBGrid.WMVScroll(var Message: TWMVScroll);
var
mMin, mMax: integer;
RecCount, RecNo, NewRecNo: longint;
begin
if not AcquireFocus then Exit;
if FDatalink.Active then
with Message, FDataLink.DataSet, FDatalink do
case ScrollCode of
SB_LINEUP: MoveBy(-ActiveRecord - 1);
SB_LINEDOWN: MoveBy(RecordCount - ActiveRecord);
SB_PAGEUP: MoveBy(-VisibleRowCount);
SB_PAGEDOWN: MoveBy(VisibleRowCount);
SB_THUMBPOSITION:
if (DBIGetSeqNo(Handle,RecNo) = DBIERR_NONE) then begin
GetScrollRange(self.Handle, SB_VERT, mMin, mMax);
NewRecNo := Pos*(FDataLink.DataSet.RecordCount div mMax);
MoveBy(NewRecNo-RecNo);
end else case Pos of
0: First;
1: MoveBy(-VisibleRowCount);
2: Exit;
3: MoveBy(VisibleRowCount);
4: Last;
end;
SB_BOTTOM: Last;
SB_TOP: First;
end;
end;
Имейте в виду, что из-за небольшой ошибки в VCL (MoveBy использует integer-параметр вместо longint), могут быть проблемы с большими таблицами (RecordCount>MaxInt). Объяснение этому факту я нашел в журнале Delphi Magazine. Для больших таблиц вы должны заменить вызовы MoveBy на DBISetToSeqNo или DBIGetRelativeRecord. Не забудьте после данного вызова вызвать Resnyc([]) или Refresh!
P.S. Пока вы ковыряетесь в DBGRIDS.PAS: найдите и замените TitleColor на FixedColor в TCustomDBGrid.Create и в TCustomDBGrid.DrawCell. Значение свойства FixedColor влияет на показ заголовков колонок, и они будут выводится как и ожидалось.
– Reinhard Kalinke
TDBGrid Lookup-поле в D2
Delphi 21. Как создать lookup-поле в TDBGrid для Delphi 2.0 2. Разместите на форме 2 компонента TTable, 1 компонент TDataSource и 1 – TDBGrid. • Подключите Table1 – к DataSource1 – к DBGrid1 • DataSource1.DataSet = Table1 • DBGrid1.DataSource = DataSource1 3. Установка Table1 • Table1.Database = DBDemos • Table1.TableName = Customer • Table1.Active = True 4. Установка Table2 • Table2.Database = DBDemos • Table2.TableName = Orders • Table2.Active = True 5. Добавьте все поля для Table1, используя Fields Editor (редактор полей): • Дважды щелкните на Table1 • Нажмите правую кнопку мыши в редакторе полей • Выберите пункт Add New Fields. Добавьте их все. 6. Добавьте новое поле для Table1. • Нажмите правую кнопку мыши в редакторе полей и выберите пункт «New Field». 7. Определите следующие параметры для вновь добавленного поля: • Name: Bob • Type: String • Size: 30 • Select Lookup • Key Fields: CustNo – Поле в Table1 для хранения значения • DataSet: Table2 – Здесь устанавливается табличный lookup • LookUpKeys: CustNo – Данный ключ копируется в KeyField • Result Field: OrderNo – Значение для показа пользователю в выпадающем списке 8. Запустите приложение
Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?
Nomadic советует: Это маленькая вставка в Ваш наследник от TCustomDBGrid, которая решает данную задачу.// DBGRIDEX.PAS
// ----------------------------------------------------------------------------
destructor TDbGridEx.Destroy;
begin
_HideColumnsValues.Free;_HideColumns.Free;
inherited Destroy;
end;
// ----------------------------------------------------------------------------
constructor TDbGridEx.Create(Component : TComponent);
begin
inherited Create(Component);
FFreezeCols := ?;
_HideColumnsValues := TList.Create;
_HideColumns := TList.Create;
end;
// ----------------------------------------------------------------------------
procedure TDbGridEx.KeyDown(var Key: Word; Shift: TShiftState);
begin
if (Key = VK_LEFT) then ColBeforeEnter(-1);
if (Key = VK_RIGHT) then ColBeforeEnter(1);
inherited;
end;
// ----------------------------------------------------------------------------
procedure TDbGridEx.SetFreezeColor(AColor : TColor);
begin
InvalidateRow(0);
end;
// ----------------------------------------------------------------------------
procedure TDbGridEx.SetFreezeCols(AFreezeCols : Integer);
begin
FFreezeCols := AFreezeCols;
InvalidateRow(0);
end;
// ----------------------------------------------------------------------------
procedure TDbGridEx.ColEnter;
begin
ColBeforeEnter(0);
if Assigned(OnColEnter) then OnColEnter(Self);
end;
// ----------------------------------------------------------------------------
procedure TDbGridEx.ColBeforeEnter(ADelta : Integer);
var nIndex : Integer;
function ReadWidth : Integer;
var i : Integer;
begin
i := _HideColumns.IndexOf(Columns[nIndex]);
if i = -1 then result := 120
else result := Integer(_HideColumnsValues[i]);
end;
procedure SaveWidth;
var i : Integer;
begin
i := _HideColumns.IndexOf(Columns[nIndex]);
if i <> - 1 then begin
_HideColumnsValues[i] := Pointer(Columns[nIndex].Width);
end else begin
_HideColumns.Add(Columns[nIndex]);
_HideColumnsValues.Add(Pointer(Columns[nIndex].Width));
end;
end;
begin
for nIndex := 0 to Columns.Count - 1 do begin
if (Columns[nIndex].Width = 0) then begin
if (nIndex + 1 <= FreezeCols) or (nIndex >= SelectedIndex + ADelta) then
Columns[nIndex].Width := ReadWidth;
end else begin
SaveWidth;
if (nIndex + 1 > FreezeCols) and (nIndex < SelectedIndex + ADelta) and
(nIndex + 1 < Columns.Count) and (FreezeCols > 0) then
Columns[nIndex].Width := 0;
end;
end;
end;
Dbgrid с цветными ячейками IV
Nomadic советует: Hапример, так:DefaultDrawing:=False;
….
procedure TfrmCard.GridDrawColumnCell(Sender: TObject; constRect: TRect; DataCol: Integer; Column: TColumn;State: TGridDrawState);
var
Index : Integer;
Marked, Selected: Boolean;
begin
Marked := False;
if (dgMultiSelect in Grid.Options) and THackDBGrid(Grid).Datalink.Active then
Marked:=Grid.SelectedRows.Find(THackDBGrid(Grid).Datalink.Datasource.Dataset.Bookmark, Index);
Selected := THackDBGrid(Grid).Datalink.Active and (Grid.Row-1 = THackDBGrid(Grid).Datalink.ActiveRecord);
if Marked then begin
Grid.Canvas.Brush.Color:=$DFEFDF;
Grid.Canvas.Font.Color :=clBlack;
end;
if Selected then begin
Grid.Canvas.Brush.Color:=$FFFBF0;
Grid.Canvas.Font.Color :=clBlack;
if Marked then Grid.Canvas.Brush.Color:=$EFE3DF; { $8F8A30 }
end;
Grid.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;
где
THackDBGrid = class(TDBGrid)
property DataLink;
property UpdateLock;
end;
Обратите внимание на обьявление класса THackDBGrid. Таким образом можно получить доступ к приватным полям, свойствам и методам класса, что, к сожалению, приходится делать, если авторы исходного класса оказались не предусмотрительны.
Dbgrid с цветными ячейками V
Delphi 1Попробуйте следующий код в обработчике события TDBGrid OnDrawDataCell:
Procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState);
begin
If gdFocused in State then with (Sender as TDBGrid).Canvas do begin
Brush.Color := clRed;
FillRect(Rect);
TextOut(Rect.Left, Rect.Top, Field.AsString);
end;
end;
Установите рисование по умолчинию (Default drawing) в True. Только после этого можно нарисовать выделенную ячейку. Если вы установили DefaultDrawing в False, вы должны сами рисовать все ячейки, используя свойство Canvas.
Что я получаю от наличия ConstraintBroker (брокера ограничений)?
Nomadic отвечает: ConstraintBroker позволяет Вам включать проверки на ограничения в данные. Это означает, что когда Вы запрашиваете данные, Вы получаете вместе с ними и правила, которым они дорлжны удовлетворять. Эти правила автоматически без дополнительного кода входят в силу. Поскольку это происходит без единой строчки кода, то Вам не требуется переписывать или обновлять приложение каждый раз при изменении правил. Фактически это простое решение задачи обновления клиентского приложения без выхода из него. Каждое приложение, использующее ConstraintBroker, автоматически получает это качество…Улучшенный Dbgrid
Delphi 1
{
Код улучшенного TDBGrid, имеющего свойства Col, Row и Canvas и метод CellRect. Это чрезвычайно полезно в случае, если вы, к примеру, хотите получить выпадающий список на месте редактируемой пользователем ячейки.
}
unit VUBComps;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,Forms, Dialogs, Grids, DBGrids, DB, Menus;
type TDBGridVUB = class(TDBGrid)
private
{ Private declarations }
protected
{ Protected declarations }
public
property Canvas;
function CellRect(ACol, ARow: Longint): TRect;
property Col;
property Row;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('VUBudget', [TDBGridVUB]);
end;
function TDBGridVUB.CellRect(ACol, ARow: Longint): TRect;
begin
Result := inherited CellRect(ACol, ARow);
end;
end.
Пример Drag and Drop между двумя Dbgrid
Delphi 3Данный пример компонента и демонстрационный проект показывают простой путь осуществления операции "drag and drop" (перетащи и брось) между двумя полями различных табличных сеток. Запустите Delphi 3 (с незначительными изменениями данный код может работать и в Delphi 1-2).
Активизируйте File|New|Unit. Скопируйте приведенный ниже модуль MyDBGrid во вновь созданный модуль. Сделайте File|Save As. Сохраните модуль как MyDBGrid.pas.
Выберите пункт меню Component|Install Component. Переключитесь на страницу Info New Package. Поместите MyDBGrid.pas в поле редактирования "Unit file name" (имя файла модуля). Назовите модуль MyPackage.dpk. Ответьте Yes на вопрос Delphi 3 о необходимости сборки и установки пакета. Нажмите OK на сообщение Delphi 3 о необходимости включения VCL30.DPL. После этого пакет будет собран и установлен. Теперь компонент TMyDBGrid будет отображен в Палитре Компонентов в группе "Samples". Закройте редактор пакетов и сохраните пакет.
Выберите пункт меню File|New Application. Щелкните правой кнопкой мыши на форме (Form1) и выберите View As Text. Скопируйте приведенный ниже исходный код формы GridU1 в Form1. Щелкните правой кнопкой мыши на форме и выберите View As Form. Убедитесь в активности ваших таблиц. Скопируйте расположенный ниже модуль GridU1 в ваш модуль Unit1.
Выберите пункт меню File|Save Project As. Сохраните модуль как GridU1.pas. Сохраните проект как GridProj.dpr.
Теперь запустите проект и наслаждайтесь функцией Drag and Drop между двумя табличными сетками.
Модуль MyDBGrid
unit MyDBGrid;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids;
type TMyDBGrid = class(TDBGrid)
private
{ Private declarations }
FOnMouseDown: TMouseEvent;
protected
{ Protected declarations }
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
published
{ Published declarations }
property Row;
property OnMouseDown read FOnMouseDown write FOnMouseDown;
end;
procedure Register;
implementation
procedure TMyDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Assigned(FOnMouseDown) then FOnMouseDown(Self, Button, Shift, X, Y);
inherited MouseDown(Button, Shift, X, Y);
end;
procedure Register;
begin
RegisterComponents('Samples', [TMyDBGrid]);
end;
end.
Модуль GridU1
unit GridU1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Db, DBTables, Grids, DBGrids, MyDBGrid, StdCtrls;
type TForm1 = class(TForm)
MyDBGrid1: TMyDBGrid;
Table1: TTable;
DataSource1: TDataSource;
Table2: TTable;
DataSource2: TDataSource;
MyDBGrid2: TMyDBGrid;
procedure MyDBGrid1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure MyDBGrid1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure MyDBGrid1DragDrop(Sender, Source: TObject; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
var SGC : TGridCoord;
procedure TForm1.MyDBGrid1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var DG : TMyDBGrid;
begin
DG := Sender as TMyDBGrid;
SGC := DG.MouseCoord(X,Y);
if (SGC.X > 0) and (SGC.Y > 0) then (Sender as TMyDBGrid).BeginDrag(False);
end;
procedure TForm1.MyDBGrid1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
var GC : TGridCoord;
begin
GC := (Sender as TMyDBGrid).MouseCoord(X,Y);
Accept := Source is TMyDBGrid and (GC.X > 0) and (GC.Y > 0);
end;
procedure TForm1.MyDBGrid1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
DG : TMyDBGrid;
GC : TGridCoord;
CurRow : Integer;
begin
DG := Sender as TMyDBGrid;
GC := DG.MouseCoord(X,Y);
with DG.DataSource.DataSet do begin
with (Source as TMyDBGrid).DataSource.DataSet do
Caption := 'Вы перетащили «'+Fields[SGC.X-1].AsString+'"';
DisableControls;
CurRow := DG.Row;
MoveBy(GC.Y-CurRow);
Caption := Caption+' в «'+Fields[GC.X-1].AsString+'"';
MoveBy(CurRow-GC.Y);
EnableControls;
end;
end;
end.
Форма GridU1
object Form1: TForm1
Left = 200
Top = 108
Width = 544
Height = 437
Caption = 'Form1'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object MyDBGrid1: TMyDBGrid
Left = 8
Top = 8
Width = 521
Height = 193
DataSource = DataSource1
Row = 1
TabOrder = 0
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowTextTitle
Font.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
OnDragDrop = MyDBGrid1DragDrop
OnDragOver = MyDBGrid1DragOver
OnMouseDown = MyDBGrid1MouseDown
end
object MyDBGrid2: TMyDBGrid
Left = 7
Top = 208
Width = 521
Height = 193
DataSource = DataSource2
Row = 1
TabOrder = 1
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
OnDragDrop = MyDBGrid1DragDrop
OnDragOver = MyDBGrid1DragOver
OnMouseDown = MyDBGrid1MouseDown
end
object Table1: TTableActive = True
DatabaseName = 'DBDEMOS'
TableName = 'ORDERS'
Left = 104
Top = 48
end
object DataSource1: TDataSource
DataSet = Table1
Left = 136
Top = 48
end
object Table2: TTable
Active = True
DatabaseName = 'DBDEMOS'
TableName = 'CUSTOMER'
Left = 104
Top = 240
end
object DataSource2: TDataSource
DataSet = Table2
Left = 136
Top = 240
end
end
Как заставить DBGrid сортировать данные по щелчку на заголовке столбца?
Nomadic советует: Кyсочек кода, чтобы повесить на clickable столбец RxGrid, показывающий RxQuery с определенным макросом %Order. Работать не бyдет (без модyлей), но в качестве идеи может быть полезен.unit vgRXutil;
interface
uses SysUtils, Classes, DB, DBTables, rxLookup, RxQuery;
{ TrxDBLookup }
procedure RefreshRXLookup(Lookup: TrxLookupControl);
procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);
function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;
{ TRxQuery }
{ Applicatable to SQL's without SELECT * syntax }
{ Inserts FieldName into first position in '%Order' macro and refreshes query }
procedure HandleOrderMacro(Query: TRxQuery; Field: TField);
{ Sets '%Order' macro, if defined, and refreshes query }
procedure InsertOrderBy(Query: TRxQuery; NewOrder: String);
{ Converts list of order fields if defined and refreshes query }
procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);
implementation
uses vgUtils, vgDBUtl, vgBDEUtl;
{ TrxDBLookup refresh }
type TRXLookupControlHack = class(TrxLookupControl)
property DataSource;
property LookupSource;
property Value;
property EmptyValue;
end;
procedure RefreshRXLookup(Lookup: TrxLookupControl);
var SaveField: String;
begin
with TRXLookupControlHack(Lookup) do begin
SaveField := DataField;
DataField := '';
DataField := SaveField;
end;
end;
procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);
var SaveField: String;
begin
with TRXLookupControlHack(Lookup) do begin
SaveField := LookupDisplay;
LookupDisplay := '';
LookupDisplay := SaveField;
end;
end;
function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;
begin
with TRXLookupControlHack(Lookup) do try
if Value <> EmptyValue then Result := StrToInt(Value)
else Result := 0;
except
Result := 0;
end;
end;
procedure InsertOrderBy(Query: TRxQuery; NewOrder: String);
var
Param: TParam;
OldActive: Boolean;
OldOrder: String;
Bmk: TPKBookMark;
begin
Param := FindParam(Query.Macros, 'Order');
if not Assigned(Param) then Exit;
OldOrder := Param.AsString;
if OldOrder <> NewOrder then begin
OldActive := Query.Active;
if OldActive then Bmk := GetPKBookmark(Query, '');
try
Query.Close;
Param.AsString := NewOrder;
try
Query.Prepare;
except
Param.AsString := OldOrder;
end;
Query.Active := OldActive;
if OldActive then SetToPKBookMark(Query, Bmk);
finally
if OldActive then FreePKBookmark(Bmk);
end;
end;
end;
procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);
var NewOrderFields: TStrings;
procedure AddOrderField(S: String);
begin
if NewOrderFields.IndexOf(S) < 0 then NewOrderFields.Add(S);
end;
var
I, J: Integer;
Field: TField;
FieldDef: TFieldDef;
S: String;
begin
NewOrderFields := TStringList.Create;
with Query do try
for I := 0 to OrderFields.Count - 1 do begin
S := OrderFields[I];
Field := FindField(S);
if Assigned(Field) and (Field.FieldNo > 0) then AddOrderField(IntToStr(Field.FieldNo))
else try
J := StrToInt(S);
if J < FieldDefs.Count then AddOrderField(IntToStr(J));
except
end;
end;
OrderFields.Assign(NewOrderFields);
finally
NewOrderFields.Free;
end;
end;
procedure HandleOrderMacro(Query: TRxQuery; Field: TField);
var
Param: TParam;
Tmp, OldOrder, NewOrder: String;
I: Integer;
C: Char;
TmpField: TField;
OrderFields: TStrings;
begin
Param := FindParam(Query.Macros, 'Order');
if not Assigned(Param) or Field.Calculated or Field.Lookup then Exit;
OldOrder := Param.AsString;
I := 0;
Tmp := '';
OrderFields := TStringList.Create;
try
OrderFields.Ad(Field.FieldName);
while I < Length(OldOrder) do begin
Inc(I);
C := OldOrder[I];
if C in FieldNameChars then Tmp := Tmp + C;
if (not (C in FieldNameChars) or (I = Length(OldOrder))) and (Tmp <> '') then begin
TmpField := Field.DataSet.FindField(Tmp);
if OrderFields.IndexOf(Tmp) < 0 then OrderFields.Add(Tmp);
Tmp := '';
end;
end;
UpdateOrderFields(Query, OrderFields);
NewOrder := OrderFields[0];
for I := 1 to OrderFields.Count – 1 do NewOrder := NewOrder + ', ' + OrderFields[1];
finally
OrderFields.Free;
end;
InsertOrderBy(Query, NewOrder);
end;
end.
DBGrid и TQuery
Delphi 11. Расположите на вашей форме 2 TQuerie с двумя соответствующими TDatasource (Query1 будет вашим Мастером, Query2 будет вашей Деталью) 2. Разместите 2 TDBGrid, связанных с Datasource'ами (вероятно, вы уже это сделали) 3. Используйте базу данных, поставляемую с Delphi:
Query1.SQL := 'Select * from customer'
Query2.SQL := 'Select * from Orders whereOrders."CustNo" = :CustNo'
(это можно сделать как во время выполнения приложения, так и во время его разработки)
4. В свойствах Query2 выберите свойство Params и напишите в строке 'CustNo'. 'CustNo' был определен как параметр, поскольку в SQL строке было использовано ':'.
5. ОЧЕНЬ ВАЖНО: установите Query2.Datasource в набор данных, связанный с Query1.
Каждый раз при изменении записи в наборе данных Query1, Query2 будет обновляться. Имя параметра 'CustNo' соответствует имени реального поля в таблице Customer.
P.S.: Для получения дополнительной информации обратитесь к разделу электронной справки 'dynamic SQL'
DBGrid как навигатор
Delphi 11. Расположите компонент table на пустой форме и свяжите его с вашего таблицей Client. 2. Добавьте компонент Datasource и свяжите его с компонентом table, описанным выше. 3. Добавьте компонент grid и свяжите его с компонентом datasource, описанным выше. 4. Используя Редактор Полей (Fields Editor), создайте компоненты TField для всех полей таблицы client. 5. Установите свойство Visible всех компонентов TField, кроме Client Name (или другого поля, которое будет отображаться в DBGrid), в False. Grid теперь будет отображать только Client Name. 6. Для отображения полей таблицы Client (которые вы хотите показать, или которые вы хотите сделать доступными для редактирования пользователем), ниже табличной сетки расположите компоненты DBEdit. Они могут использовать тот же набор данных, что и DBGrid. Теперь пользователь может воспользоваться DBGrid для навигации и ввода/редактирования данных посредством DBEdit'ов.
Позиция DBGrid
Delphi 1В режиме разработки дважды щелкните на компоненте TQuery, и выберите все поля, которые вы хотите использовать в DBGrid. Затем в обработчике события DBGrid doubleclick смотрите значение DBGrid.SelectedIndex. Если оно < 0, выбранных пунктов нет. Также, текущая запись TQuery будет указывать на ту же самую строку, которая выбранна в DBGrid. Таким образом, вы можете использовать что-то типа requiredvalue := Query1Field1.AsString; и т.д., естественно, компоненты TQuery и DBGrid должны быть подключены друг к другу.
DBGrid – переход к следующей записи
Delphi 1Для перехода к следующей записи:
MyDBGrid.SelectedIndex := MyDBGrid.SelectedIndex + 1;
Колонки DBGrid индексируются с 0, поэтому SelectedIndex := 0 даст вам первую колонку. Свойство FieldCount вернет вам количество колонок, так что вы без труда можете пробежаться по всей матрице данных.
onClick и DBGrid
Многие программисты хотели бы использовать OnClick у TDBGrid. Но TDBGrid не имеет такого события. В данном документе рассказывается о том, как обеспечить поддержку события OnClick для TDBGrid. Рассказанная здесь технология может пригодиться при добавлении других свойств к различным объектам. Если вы знаете, что сделать это мог предок, то можно заставить сделать это и наследника. Ключевым моментом здесь можно считать добавление csClickEvents к свойству-набору элемента управления ControlStyle. Это позволит элементу управления, приведенному к типу THack, получать и правильно обрабатывать системные сообщение о щелчке мышью. Назначение OnClick какого-либо элемента управления OnClick DBGrid1 позволяет воспользоваться событием OnClick для элемента управления, которое его не поддерживает. Это "неофициальный" путь. Существует несколько причин того, почему dbgrid не поддерживает этого события. Используйте этот код на свой страх и риск.unit Udbgclk;
interface
uses Windows, Messages, SysUtils, Classes, Graphics,Controls, Forms, Dialogs, StdCtrls, Grids, DBGrids, DBTables, DB;
type
thack = class(tcontrol);
TForm1 = class(TForm)
DBGrid1: TDBGrid;
Button1: TButton;
DataSource1: TDataSource;
Table1: TTable;
procedure Button1Click(Sender: TObject);
procedure FormClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
THack(dbgrid1).controlstyle :=THack(dbgrid1).controlstyle + [csClickEvents];
THack(dbgrid1).OnClick := Form1.OnClick;
end;
procedure TForm1.FormClick(Sender: TObject);
begin
messagebeep(0);
application.processmessages;
end;
end.
Числа с плавающей точкой в DBGrid
Delphi 1Для показа в табличной сетке дробных чисел, выберите таблицу, с которой связана ваша сетка (через datasource, источник данных). Активизируйте редактор полей (правой кнопкой мыши) и выберите поле, в котором вы хотите видеть дробное число. Измените значение свойств 'DisplayFormat' и 'EditFormat', чтобы дробь имела формат такой, какой вы хотите (к примеру, шаблон '0.00', позволяющий сетке показывать поле с двумя цифрами после запятой). Дважды щелкните на компоненте table, расположенном на форме. Нажмите на кнопку 'Add'. Будут показаны все поля вашей таблицы. Выберите их в списке «Available field» (доступные поля) и щелкните на кнопке OK. Теперь при щелчке на имени поля, в Инспекторе Объектов будут показаны все свойства, относящиеся к данному полю, здесь можно изменить текст заголовка, выводимый формат «DisplayFormat» (это как раз то, что вам нужно, измените его на ####0.0) и пр.
Получение данных DBGrid прежде, чем они будут отправлены: как мне узнать, что пользователь вводит в DBGrid?
Delphi 3Вы можете «видеть» что набирается в TDBGrid, «смотря» на контрол сетки TInPlaceEdit. Вы должны убедиться только в том, что к моменту использования TInPlaceEdit, контрол уже создан. Следующая функция покажет данные, редактируемые в колонках сетки:
procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
var B: byte;
begin
for B := 0 to DBGrid1.ControlCount - 1 do
if DBGrid1.Controls[B] is TInPlaceEdit then begin
with DBGrid1.Controls[B] as TInPlaceEdit do begin
Label1.Caption := 'Текст = ' + Text;
end;
end;
end;
Хочу шапку в TDBGrid. Как сделать?
Nomadic советует: Уже реализовано в виде вот этого компонента — © Andreunit bdbgrid;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids, Math;
type
TOnDrawTitleEvent = procedure(ACol : integer; ARect : TRect; var TitleText : string) of object;
TBitDBGrid = class(TDBGrid)
private
FBitmapBrowse : TBitmap;
FBitmapEdit : TBitmap;
FBitmapInsert : TBitmap;
FBitmapFill : TBitmap;
FRealTitleFont : TFont;
FOnDrawTitle : TOnDrawTitleEvent;
FResizeFlag : boolean;
{ Private declarations }
procedure SetRealTitleFont(Value : TFont);
procedure UpdateTitlesHeight;
protected
procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
{ Protected declarations }
public
constructor Create(AOwner : TComponent);override;
destructor Destroy; override;
{ Public declarations }
published
property OnDrawTitle : TOnDrawTitleEvent read FOnDrawTitle write FOnDrawTitle;
property RealTitleFont : TFont read FRealTitleFont write SetRealTitleFont;
{ Published declarations }
end;
procedure Register;
implementation
var DrawBitmap : TBitmap;
function Max(X, Y: Integer): Integer;
begin
Result := Y;
if X > Y then Result := X;
end;
procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer; const Text: string; Alignment: TAlignment);
// © Borland function :)
const AlignFlags : array [TAlignment] of Integer =
( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX );
var
B, R: TRect;
I, Left: Integer;
begin
with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }
begin { brush origin tics in painting / scrolling. }
Width := Max(Width, Right - Left);
Height := Max(Height, Bottom - Top);
R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1);
B := Rect(0, 0, Right - Left, Bottom - Top);
end;
with DrawBitmap.Canvas do begin
DrawBitmap.Canvas.CopyRect(B, ACanvas, ARect);
Font := ACanvas.Font;
Font.Color := ACanvas.Font.Color;
Brush := ACanvas.Brush;
SetBkMode(Handle, TRANSPARENT);
DrawText(Handle, PChar(Text), Length(Text), R, AlignFlags[Alignment]);
end;
ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);
end;
constructor TBitDBGrid.Create(AOwner : TComponent);
begin
inherited Create(Aowner);
FRealTitleFont := TFont.Create;
FResizeFlag := false;
end;
destructor TBitDBGrid.Destroy;
begin
FRealTitleFont.Free;
inherited Destroy;
end;
procedure TBitDBGrid.UpdateTitlesHeight;
var
Loop : integer;
MaxTextHeight : integer;
RRect : TRect;
begin
MaxTextHeight := 0;
for loop := 0 to Columns.Count - 1 do begin
RRect := CellRect(0, 0);
RRect.Right := Columns[Loop].Width;
RRect.Left := 0;
Canvas.Font := RealTitleFont;
MaxTextHeight := Max(MaxTextHeight, DrawText(Canvas.Handle, PChar(Columns[Loop].Title.Caption), Length(Columns[Loop].Title.Caption), RRect, DT_CALCRECT + DT_WORDBREAK));
end;
if TitleFont.Height <> - MaxTextHeight then TitleFont.Height := - MaxTextHeight;
end;
procedure TBitDBGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if MouseCoord(X, Y).Y = 0 then FResizeFlag := true;
inherited MouseDown(Button, Shift, X, Y);
end;
procedure TBitDBGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited MouseUp(Button, Shift, X, Y);
if FResizeFlag then begin
FResizeFlag := false;
UpdateTitlesHeight;
end;
end;
procedure TBitDBGrid.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
Indicator : TBitmap;
TitleText : string;
Al : TAlignment;
begin
if not ((gdFixed in AState) and ((ARow = 0) and (dgTitles in Options) and (ACol <> 0))) then
inherited DrawCell(ACol, ARow, ARect, AState)
else begin
if DefaultDrawing then begin
DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_BOTTOMLEFT);
DrawEdge(Canvas.Handle, ARect, BDR_RAISEDINNER, BF_TOPRIGHT);
InflateRect(ARect, -1, -1);
Canvas.Brush.Color := FixedColor;
Canvas.FillRect(ARect);
end;
TitleText := Columns[ACol - 1].Title.Caption;
if Assigned(OnDrawTitle) then OnDrawTitle(ACol, ARect, TitleText);
if DefaultDrawing and (TitleText <> '') then begin
Canvas.Brush.Style := bsClear;
Canvas.Font := RealTitleFont;
if ACol > 0 then Al := Columns[ACol - 1].Title.Alignment
else Al := Columns[0].Title.DefaultAlignment;
WriteText(Canvas, ARect, 2, 2, TitleText, Al);
end;
end;
end;
procedure TBitDBGrid.SetRealTitleFont(Value : TFont);
begin
FRealTitleFont.Assign(Value);
Repaint;
end;
procedure Register;
begin
RegisterComponents('Andre VCL', [TBitDBGrid]);
end;
initialization
DrawBitmap := TBitmap.Create;
finalization
DrawBitmap.Free;
end.
Несколько таблиц в одном TDBGrid
Delphi 1Насколько я знаю, единственное легкое решение заключается в использовании вычисляемых полей. Для того, чтобы поместить данные из нескольких таблиц в один DBGrid, нужно воспользоваться объектом TQuery. На заметку: используйте TQuery в режиме только для чтения, если вы не можете обеспечить гарантию выполнения некоторых из его руководящих принципов, один из которых – данные могут быть получены только от одной таблицы.
Как сделать так, чтобы в DBGrid напротив некоторых строк можно было бы галочку поставить?
Nomadic советует: Ну примерно так (лишнее мало-мало порезал, больно много его, но идея видна :) на сервере — тaблицa Advertis.DB, первичный ключ ID — autoincrement. На локальном диске — тaблицa Founds.DB, с полем Advertis: integer, по которому есть индекс, и tblFounds.IndexFieldNames = 'Advertis'. На гриде: === cut ===procedure TMainForm.dbgWorkDblClick(Sender: TObject);
begin
TriggerRowSelection;
end;
procedure TMainForm.TriggerRowSelection;
begin
if dmFile.AdvertisCount <> 0 then begin
with dmFile do if not tblFounds.FindKey([tblAdvertisID.Value]) then begin
tblFounds.AppendRecord([tblAdvertisID.Value]);
end else begin
tblFounds.Delete;
end;
dbgWork.Refresh;
end;
end;
procedure TMainForm.dbgWorkDrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if DataCol = 0 then with dmFile, dbgWork.Canvas do begin
FillRect(Rect); {clear the cell}
if tblFounds.FindKey([tblAdvertisID.Value]) then begin
TextOut(Rect.Left, Rect.Top, '?');
end else begin
TextOut(Rect.Left, Rect.Top, 'o');
end;
end;
end;
=== cut ===
Оказывается, я переопределял рисование гридa, а не вычислял поле. Не помню точно, но кажется, чтобы не перечитывать таблицу на каждый даблклик, а только перерисовать грид.
А колонка для галки в гриде определялась так:
=== cut ===
with dmFile, dbgWork.Columns do begin
BeginUpdate;
Clear;
{check mark}
nc := Add;
nc.Width := 14;
nc.Font.Name := 'Wingdings';
nc.Font.Size := 11;
nc.Alignment := taRightJustify;
nc.Title.Caption := 'y';
nc.Title.Font.Name := 'Wingdings';
nc.Title.Font.Size := 10;
nc.Title.Alignment := taCenter;
[skip определения остaльных колонок]
EndUpdate;
end;
=== cut ===
Вроде всё.
Ну, как напечатать/обработать только помеченное, сам разберёшься. У меня там накручено чего-то с фильтрами, думаю, можно проще.
Что касается других способов – можно вместо временной тaблицы попользовать список, массив или in-memory table.
Как в TDBGrid разрешить только операции UPDATE записей и запретить INSERT/DELETE?
Nomadic советует: А я делаю так. На DataSource, к которому прицеплен Grid, вешаю обработчик на событие OnStateChange. Ниже текст типичного обработчика –if DBGrid1.DataSource.DataSet.State in [dsEdit, dsInsert] then
DBGrid1.Options := DBGrid1.Options + goRowSelect
else DBGrid1.Options := DBGrid1.Options – goRowSelect;
Дело в том, что если у Grid'а стоит опция goRowSelect, то из Grid'а невозможно добавить запись. Ну а когда програмно вызываешь редактирование или вставку, то курсор принимает обычный вид и все Ok.
Лучше использовать конструкцию«State in dsEditModes».
Обновление TDBGrid после редактирования отдельной записи на отдельной форме
Delphi 1А вы постите запись, прежде чем закрыть форму? При закрытии, форма самостоятельно данных не постит. Вы должны постить изменения или с помощью компонента dbnavigator, или c помощью кода, который при закрытии формы постит данные в основную таблицу. На странице 95 Database Application Developers Guide (руководство разработчиков приложений баз данных), поставляемое с Delphi, приведен демонстрационный проект с двумя формами, демонстрирующий хорошую технику при использовании ttable на мастер-форме в качестве набора данных для детали. Одним из решений вашей проблемы может служить связывание компонента DataSource на Form2 с набором данных DataSet на Form1. Это может быть достигнуто путем добавления следующей строки в обработчик события OnActivate для Form2:
MyDataSource.DataSet := Form1.MyTable;
Данный метод имеет 3 преимущества:
1. сделанные вами изменения немедленно отображаются, поскольку вы используете одну и ту же логическую таблицу;
2. если вам нужно определить установки для ваших полей таблицы, например, DisplayFormat или EditMask, вам нужно сделать это только один раз в таблице на Form1, вам не нужно это делать на каждой форме, которая использует таблицу;
3. это сохраняет ресурсы и повышает производительность, поскольку ваше приложение при работе с таблицей использует только одну сессию. Тем не менее, в проектном времени вам нужно иметь TTable на вашей Form2 для того, чтобы вы могли выбрать поля для БД-контролов, после чего вы можете удалить TTable.
Пересортица в коде полей TDBGrid во время вополнения программы
Одной строкойиспользуйте <имя поля>.index := <желаемый номер поля>
В Delphi 3 и выше ползунок TDBGrid иногда может находится не только в трех фиксированных позициях. Что для этого нужно?
Nomadic отвечает: Здесь отрывки из исходников VCL —
unit DBGrids;
procedure TCustomDBGrid.UpdateScrollBar;
var
SIOld, SINew: TScrollInfo;
begin
[skipped]
if IsSequenced then begin
SINew.nMin := 1;
SINew.nPage := Self.VisibleRowCount;
SINew.nMax := RecordCount + SINew.nPage -1;
if State in [dsInactive, dsBrowse, dsEdit] then SINew.nPos := RecNo; // else keep old pos
end else begin
SINew.nMin := 0;
SINew.nPage := 0;
SINew.nMax := 4;
if BOF then SINew.nPos := 0
else if EOF then SINew.nPos := 4
else SINew.nPos := 2;
end;
[skipped]
unit dbtables;
function TBDEDataSet.IsSequenced: Boolean;
begin
Result := (FRecNoStatus = rnParadox) and (not Filtered);
end;
То есть, к примеру, все будет работать «красиво» на таблицах BDE, если они:
• таблицы Paradox;
• на них не установлен фильтр.
TClientDataSet в режиме single-tier (briefcase) также работает «красиво».
Изменение месторасположение колонок в TDBGrid
Delphi 1
Var
i: Integer;
fName: string;
…………
{ Определение изменения месторасположения колонок }
…………
with dbgrid1.datasource.dataset as ttable do
for i := 0 to indexdefs.count – 1 do begin
fName := DBGrid1.Fields[0].FieldName;
if copy(indexdefs[i].fields, 1, length(fname)) = fname then IndexName := IndexDefs[i].Name
end;
Решение проблемы передачи фокуса TDBGrid
В данном документе содержится решение проблемы невозможности получения DBGrid-ом фокуса после щелчка на каком-либо элементе управления родительской формы, в то время, как DBGrid находится на ее дочерней MDI-форме. Относится ко всем версиям Delphi. Очевидно, DBGrid имеет некоторые проблемы с управлением фокусом, если он находится на дочерней MDI-форме. Эта проблема решена в приведенном ниже наследнике TDBGrid, в котором обрабатываются мышиные сообщения и выясняется когда фокус должен быть передан сетке. Наследник создан в виде компонента, который легко устанавливается в Палитру Компонентов. Примечание: код адаптирован для всех версий Delphi. Проблемы могут быть в Delphi 2 и 3, если вы забудете заменить устаревшие в этих версиях модули "winprocs" и "wintypes" на "windows."unit FixedDBGrid;
interface
uses Winprocs,wintypes, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, DBGrids;
type TFixedDBGrid = class(TDBGrid)
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
published
{ Published declarations }
end;
procedure Register;
implementation
procedure TFixedDBGrid.WMRButtonDown(var Message: TWMRButtonDown);
begin
winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}
inherited;
end;
procedure TFixedDBGrid.WMLButtonDown(var Message: TWMLButtonDown);
begin
winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}
inherited;
end;
procedure tfixeddbgrid.wmlbuttondown(var Message: twmlbuttondown);
begin
winprocs.SetFocus(handle); {помните, что winprocs относится только к Delphi 1!}
inherited;
end;
procedure Register;
begin
RegisterComponents('Samples', [TFixedDBGrid]);
end;
end.
Как отучить TDBGrid от автодобавления новой записи?
Добавьте в обработчик события вашего TTable «BeforeInsert» следующую строку:procedure TForm1.Tbable1BeforeInsert(DataSet: TDataset);
begin
Abort; ←эту строчку
end;
Осуществляем перехват нажатия клавиши и проверку на конец файла (end-of-file):
procedure TForm8.DBGrid1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (Key = VK_DOWN) then begin
TTable1.DisableControls;
TTable1Next;
if TTable1.EOF then Key := 0
else TTable1.Prior;
TTable1.EnableControls;
end;
end;
Две таблицы в одном TDBGrid
Delphi 2Если у вас D2, вы можете воспользоваться свойством Lookup. Для этого выберите в контекстном меню объекта table редактор полей (fields editor). Затем для добавления нового поля нажмите <Ctrl>+N. Просто раскройте combobox и выберите lookup-поле. TDBGrid автоматически создаст выпадающий список, в котором пользователь сможет выбрать нужный элемент.
Добавление к TDBGrid события OnClick
Delphi 1
TGroothuisGrid = class() {!}
published
property OnClick;
end;
Это все! OnClick уже объявлен в TControl как защищенное свойство. Все, что вы должны сделать, это опубликовать это свойство в компоненте-наследнике, зарегистрировать его (смотри гл. 8 Руководства по созданию компонентов, Component Writer's Guide) и использовать взамен TDBGrid.
Позиция ячейки в TDBGrid
Delphi 1В TCustomGrid определен метод CellRect, который, к сожалению, защищен. Это означает, что даный метод доступен только для TCustomGrid и его наследников. Но все-таки существует немного мудреное решение вызова данного метода:
type TMyDBGrid = class(TDBGrid)
public
function CellRect(ACol, ARow: Longint): TRect;
end;
function TMyDBGrid.CellRect(ACol, ARow: Longint): TRect;
begin
Result := inherited CellRect(ACol, ARow);
end;
Вы можете сделать приведение типа вашего DBGrid к TMyDBGrid (это возможно, поскольку CellRect статический метод) и вызвать CellRect:
Rectangle := TMyDBGrid(SomeDBGrid).CellRect(SomeColumn, SomeRow);
procedure TfmLoadIn.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect; DataCol: Integer; Column: TColumn;State: TGridDrawState);
const Disp = 2; //Правильно выравниваем компонент
begin
inherited;
if (gdFocused in State) then begin
if (Column.FieldName = 'TYPEDescription') then begin
dlTYPEDescription.Left := Rect.Left + DBGrid1.Left + Disp;
dlTYPEDescription.Top := Rect.Top + DBGrid1.top + Disp;
dlTYPEDescription.Width := Rect.Right – Rect.Left;
dlTYPEDescription.Height := Rect.Bottom – Rect.Top;
dlTYPEDescription.Visible := True;
end;
end;
end;
Dbgrid с цветными ячейками VI
Delphi 1Установите defaultDrawing в false, и создайте собственный onDrawDataCell, в котором и задавайте нужный вам цвет ячеек. Примерно так:
procedure Tform1.DBgrid1DrawDataCell(Sender: TObject; const Rect: TRect; Field: TField; State: TGridDrawState);
begin
{ выберите цвет для текста (font.color) и фона (brush.color) }
if (field = table1Status) then begin
{ белый на красном }
DBgrid1.canvas.font.color := clWhite;
DBgrid1.canvas.brush.color := clRed;
end else begin
{ черное на белом }
DBgrid1.canvas.brush.color := clWhite;
DBgrid1.canvas.font.color := clBlack;
end;
{ рисуем ячейку }
DBgrid1.canvas.textrect(rect, rect.left+2, rect.top+2, field.asString);
end;
procedure TMainForm.CharGridDrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState);
var TheText: string;
begin
TheText := CharGrid.Cells[Col, Row];
with CharGrid.Canvas do begin
{ Определяем цвет фона в зависимости от состояния ячейки: }
if gdFocused in State then Brush.Color := clYellow {Цвет ячейки с фокусом}
else if gdSelected in State then Brush.Color := clOlive {Цвет выбранной ячейки}
else {ячейка не имеет фокуса и не выбрана}
if IntFromStr(TheText) <> 0 then Brush.Color := clNavy {Цвет фона подсвеченной ячейки}
else Brush.Color := clWhite; {Цвет фона нормальной ячейки}
{ Определяем цвет текста: }
if IntFromStr(TheText) <> 0 then Font.Color := clRed {Цвет текста подсвеченной ячейки}
else Font.Color := clNavy; {Цвет текста нормальной ячейки}
TextRect(Rect, Rect.Left + 2, Rect.Top + 2, TheText);
end; {with CharGrid.Canvas}
end;
Показ Memo-поля в Dbgrid
Delphi 1…я все же лелею надежду, что когда-нибудь увижу TMemoField.DataSize, имеющим значение, отличное от нуля. Может быть значение DataSize является размером части Memo, которая сохранилась в .db-файле? Вместо этого я теперь пользуюсь объектом TBlobStream, который вполне хорошо справляется с этой работой. Все это у меня происходит примерно так:
Var
pBuffer: PChar;
Blob: TBlobStream;
begin
{FDataField – это TMemoField}
Blob := TBlobStream.Create(FDataField, bmRead);
try
if Blob.Size > 0 then try
GetMem(pBuffer, Blob.Size);
Blob.Read(pBuffer^, Blob.Size);
{ что-то тут делаем }
FreeMem(pBuffer, Blob.Size);
except
ShowMessage('Нехватка памяти' );
end;
finally
Blob.Free
end;
Как определить изменение фокуса строки в TDBGrid?
Используйте событие OnDataChange объекта Datasource, соединенного с DBGrid. Если параметр State в обработчике событие равен dsBrowse, значит вы перешли в новую строку (или только что открыли таблицу). Почему сетка не поддерживает такое событие? Поскольку сетка может быть не единственным элементом управления, оторбажающим данные из текущей строки и может быть не единственным элементом, позволяющим осуществлять перемещение от строки к строке. С помощью Datasource обработка события осуществляется централизованно. Я не уверен в том, что проблему можно решить, обрабатывая событие одинарного щелчка, для отслеживания события изменения строк я рекомендую использовать событие TDatasource.OnDataChange, а для колонок — TDBGrid.OnColEnter/Exit. Лично я пользуюсь следующей рабочей технологией: 1. Для того, чтобы обнаружить изменения текущей строки, воспользуйтесь событием TDataSource OnDataChange. OnDataChange возникает при прокрутке или щелчке на другой строке. Обработчик события может выглядеть приблизительно так:procedure Form1.DSrc1DataChange(Sender: TObject; Field: TField);
где Field является колонкой, где произошло изменение.
Поля TTable могут использоваться для сравнения текущих выбранных строк полей (ключ) с вашими требованиями. С той же целью может быть использовано и свойство TDBGrid Fields. Для примера:
if tbl1.Fields[0].AsString = 'BlaBlaBla' then …
или
if dbGrid1.Fields[I].IsNull then …
2. Для отслеживания изменения колонки, используйте события TDBGrid OnColExit & OnColEnter. Для определения выбранной к настоящему времени колонки воспользуйтесь свойствами TDBGrid SelectedField и SelectedIndex.
Когда выбирается другая колонка другой строки, вы получаете события OnColExit, OnColEnter и OnDataChange.
3. Можно пойти и «кривым» путем, взявшись за обработку события TDBGrid OnDrawDataCell, которое возникает когда ячейка выбирается, или когда сетка скроллируется. Обработчик события может выглядеть примерно так:
procedure Form1.dbGrid1DrawDataCell(Sender: TObject; Rect: TRect; Field: TField; State: TGridDrawState);
При изменении ячейки вы получаете поток событий, поэтому вам нужно каким-то образом их фильтровать.
4. Если у вас нет проблем в создании «101 изменения» стандартных компонентов – что является проблемой для меня 8-), то попробуйте это. Это легко.
Чтобы иметь доступ к индексу строки или колонки выбранной ячейки, вы должны унаследовать ваш класс от TCustomGrid и опубликать свойства времени выполнения Row и Col (текущие строка и колонка сетки, не таблицы!!):
type TSampleDBGrid = class(TCustomGrid)
public
property Col;
property Row;
end;
в соответствующей процедуре или обработчике события осуществите приведение типа:
var G: TSampleDBGrid;
begin
G := TSampleDBGrid(myDBGrid1);
if G.Row = I then …
if G.Col = J then …
Дело в том, что TDBGrid является потомком TCustomGrid, который имеет несколько свойств, содержащих координаты сетки, но это не опубликовано в TDBGrid.
…из чего я могу заключить, что вы должны это сделать программным путем. Подразумеваем, что сетка уже существует, и у вас есть доступ к основной таблице TTable:
grid.colcount := dbGrid.fieldcount;
table.first;
row := 0;
while not table.eof do begin
grid.rowcount := row + 1;
for i := 0 to grid.colcount-1 do
grid.cells[i,row] := dbGrid.fields[i].asString;
table.next;
inc(row);
end;
Могут быть ошибки, но это должно помочь.
Посмотрите на следующий код, он может вам помочь. Он берет у элемента управления свойсто 'Name' и помещает его в свойство 'Caption' метки.
unit Unit1;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm)
Label1: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure Edit1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure Edit2MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
close;
end;
procedure TForm1.Edit1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Label1.Caption := TEdit(Sender).Name;
end;
procedure TForm1.Edit2MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Label1.Caption := TEdit(Sender).Name;
end;
end.
Включение ComboBox в TDBGrid
Delphi 1Вот основные шаги чтобы сделать это: 1. Создавайте и рисуйте TComboBox (CB) при получении ввода ячейки необходимой колонки табличной сетки 2. Получайте текущее значение поля (если имеется) и помещайте его в CB 3. После всех манипуляций, поместите новое значение обратно в поле 4. Избавляемся от CB
DBLookupComboBox
Предустановка DBLookupComboBox
Delphi 1Вы можете редактировать ваш источник данных. Говорят, вы хотите сохранить ваши lookuping-данные из таблицы customer в таблицу sales – 'Cust No'? Вы можете просто проинициализировать поля (задать значение по умолчанию), редактируя таблицу sales «Cust No»
with tbSales do begin
Edit;
FieldByName('Cust No').AsInteger := 1;
Post;
end;
Сортировка DBLookupComboBox по вторичному индексу
Delphi 1Одним из способов вывести выши данные в другом порядке сортировки является использование TQuery и включение в SQL-запрос ключевого слова «order by». После чего вы можете установить этот запрос как DataSource в вашем DBLookupComboBox. ПРИМЕР: Если у вас имеется таблица Customer, содержащая «Customer_No» и «Customer_Name», и индексированная по Customer_No, то ваш запрос должен содержать в редакторе списка строк (свойство SQL) для вашего TQuery следующую строку:
select Customer_No, Customer_Name from Customer
order by Customer_Name
Значение DBLookupComboBox
Я думаю что у меня есть то, что вы хотите. Если вы обратитесь к свойству LookUpValue, то вы получите поле, которое .... ищете. Я надеюсь что помог вам.unit clookup;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, DB, DBLookup;
type
TDBJustLookupCombo = class(TDBLookupCombo)
private
{ Private declarations }
protected
{ Protected declarations }
function GetLValue: TField;
public
{ Public declarations }
property LookUpValue: TField read GetLValue;
published
{ Published declarations }
end;
TDBJustLookupList = class(TDBLookupList)
private
{ Private declarations }
protected
{ Protected declarations }
function GetLValue: TField;
public
{ Public declarations }
property LookUpValue: TField read GetLValue;
published
{ Published declarations }
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data Controls', [TDBJustLookupList, TDBJustLookupCombo]);
end;
function TDBJustLookupCombo.GetLValue: TField;
begin
Result := LookupSource.DataSet.FieldByName(LookUpField);
end;
function TDBJustLookupList.GetLValue: TField;
begin
Result := LookupSource.DataSet.FieldByName(LookUpField);
end;
end.
DBMemo
Копирование содержимого DBMemo в DBMemo другого поля
Delphi 1Попробуй:
DBMemo6.Lines:=DBMemo5.Lines.Assign;
Поиск текста в DBMemo
Delphi 1Попробуйте так: "Подключите" следующую процедуру к событию OnFind для FindDialog. Единственная проблема заключается в том, что в DBMemo я не могу получить выделенный текст, тем не менее в стандартном Memo такой проблемы нет.
procedure TMainForm.FindDialog1Find(Sender: TObject);
var
Buff, P, FT : PChar;
BuffLen : Word;
begin
With Sender as TFindDialog do begin
GetMem(FT, Length(FindText) + 1);
StrPCopy(FT, FindText);
BuffLen:= DBMemo1.GetTextLen + 1;
GetMem(Buff,BuffLen);
DBMemo1.GetTextBuf(Buff,BuffLen);
P:= Buff + DBMemo1.SelStart + DBMemo1.SelLength;
P:= StrPos(P, FT);
if P = NIL then MessageBeep(0)
else begin
DBMemo1.SelStart:= P – Buff;
DBMemo1.SelLength:= Length(FindText);
end;
FreeMem(FT, Length(FindText) + 1);
FreeMem(Buff,BuffLen);
end;
end;
Попробуйте так:
«Подключите» следующую процедуру к событию OnFind для FindDialog. Единственная проблема заключается в том, что в DBMemo я не могу получить выделенный текст, тем не менее в стандартном Memo такой проблемы нет.
begin
DBMemo1.SelStart:= P – Buff;
DBMemo1.SelLength:= Length(FindText);
end;
FreeMem(FT, Length(FindText) + 1);
FreeMem(Buff,BuffLen);
DBMemo1.SetFocus;
end;
DBNavigator
Настройки всплывающих подсказок в DBNavigator во время выполнения приложения
Возможно ли изменение свойства Hints компонента TDBNavigator во время выполнения программы? Это должно работать:procedure TForm1.Button1Click(Sender: TObject);
var ix : integer;
begin
With DBNavigator1 do
for ix := 0 to ControlCount - 1 do
if Controls[ix] is TNavButton then
with Controls[ix] as TNavButton do
case index of
nbFirst : Hint := 'Подсказка для кнопки First';
nbPrior : Hint := 'Подсказка для кнопки Prior';
nbNext : Hint := 'Подсказка для кнопки Next';
nbLast : Hint := '';
{……}
end;
end;
– Freddy Hansson
Выключение кнопок в DBNavigator
Delphi 1
{ Расширение DBNavigator: позволяет разработчику включать и выключать
отдельные кнопки через методы EnableButton и DisableButton }
unit GNav;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, DBCtrls;
type TMyNavigator = class(TDBNavigator)
public
procedure EnableButton(Btn : TNavigateBtn);
procedure DisableButton(Btn : TNavigateBtn);
end;
procedure Register;
implementation
procedure TMyNavigator.EnableButton(Btn : TNavigateBtn);
begin
Buttons[Btn].Enabled := True;
end;
procedure TMyNavigator.DisableButton(Btn : TNavigateBtn);
begin
Buttons[Btn].Enabled := False;
end;
procedure Register;
begin
RegisterComponents('Samples', [TMyNavigator]);
end;
end.
Работа в коде с кнопками DBNavigator
Delphi 1Я думаю вам поможет следующий пример (взят из электронной справки по DELPHI), показывающий код нажатой кнопки. Я видел пару вопросов о том, как изменять кнопки навигатора в зависимости от состояния редактируемой вами записи. Если вам необходимо подтверждение действий пользователя, то необходимо каким-то образом организовать дополнительный перехватчик. Как это сделать, я, честно говоря, еще не думал. Прежде, чем вы сделаете любой постинг или изменение данных, убедитесь, что таблица находится в режиме редактирования. Посмотрите описание свойства state в электронной справке по DELPHI. Там подробно рассказано как работать с ним. Следующий код определяет нажатую кнопку навигатора и выводит сообщение с ее именем.
procedure TForm1.DBNavigator1Click(Sender: TObject; Button: TNavigateBtn);
var BtnName: string;
begin
case Button of
nbFirst : BtnName := 'nbFirst';
nbPrior : BtnName := 'nbPrior';
nbNext : BtnName := 'nbNext';
nbLast : BtnName := 'nbLast';
nbInsert : BtnName := 'nbInsert';
nbDelete : BtnName := 'nbDelete';
nbEdit : BtnName := 'nbEdit';
nbPost : BtnName := 'nbPost';
nbCancel : BtnName := 'nbCancel';
nbRefresh: BtnName := 'nbRefresh';
end;
MessageDlg('Была нажата кнопка' + BtnName, mtInformation, [mbOK], 0);
end;
Edit
Денежное поле редактирования
Delphi 1
unit CurrEdit;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Menus, Forms, Dialogs, StdCtrls;
type TCurrencyEdit = class(TCustomMemo)
private
DispFormat: string;
FieldValue: Extended;
procedure SetFormat(A: string);
procedure SetFieldValue(A: Extended);
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
procedure CMExit(var Message: TCMExit); message CM_EXIT;
procedure FormatText;
procedure UnFormatText;
protected
procedure KeyPress(var Key: Char); override;
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
published
property Alignment default taRightJustify;
property AutoSize default True;
property BorderStyle;
property Color;
property Ctl3D;
property DisplayFormat: string read DispFormat write SetFormat;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property MaxLength;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property TabOrder;
property Value: Extended read FieldValue write SetFieldValue;
property Visible;
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Additional', [TCurrencyEdit]);
end;
constructor TCurrencyEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AutoSize := True;
Alignment := taRightJustify;
Width := 121;
Height := 25;
DispFormat := '$,0.00;($,0.00)';
FieldValue := 0.0;
AutoSelect := False;
WantReturns := False;
WordWrap := False;
FormatText;
end;
procedure TCurrencyEdit.SetFormat(A: String);
begin
if DispFormat <> A then begin
DispFormat:= A;
FormatText;
end;
end;
procedure TCurrencyEdit.SetFieldValue(A: Extended);
begin
if FieldValue <> A then begin
FieldValue := A;
FormatText;
end;
end;
procedure TCurrencyEdit.UnFormatText;
var
TmpText : String;
Tmp : Byte;
IsNeg : Boolean;
begin
IsNeg := (Pos('-',Text) > 0) or (Pos('(',Text) > 0);
TmpText := '';
For Tmp := 1 to Length(Text) do
if Text[Tmp] in ['0'..'9','.'] then
TmpText := TmpText + Text[Tmp];
try
FieldValue := StrToFloat(TmpText);
if IsNeg then FieldValue := -FieldValue;
except
MessageBeep(mb_IconAsterisk);
end;
end;
procedure TCurrencyEdit.FormatText;
begin
Text := FormatFloat(DispFormat,FieldValue);
end;
procedure TCurrencyEdit.CMEnter(var Message: TCMEnter);
begin
SelectAll;
inherited;
end;
procedure TCurrencyEdit.CMExit(var Message: TCMExit);
begin
UnformatText;
FormatText;
Inherited;
end;
procedure TCurrencyEdit.KeyPress(var Key: Char);
begin
if Not (Key in ['0'..'9','.','-']) Then Key := #0;
inherited KeyPress(Key);
end;
procedure TCurrencyEdit.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
case Alignment of
taLeftJustify : Params.Style := Params.Style or ES_LEFT and Not ES_MULTILINE;
taRightJustify: Params.Style := Params.Style or ES_RIGHT and Not ES_MULTILINE;
taCenter : Params.Style := Params.Style or ES_CENTER and Not ES_MULTILINE;
end;
end;
end.
Отслеживаем позицию курсора в EditBox
Совет от читателяThe_Sprite советует: В форму добавляются TEditBox и TLabel, при этом TLabel постоянно показывает позицию курсора в элементе редактирования. Совместимость: Все версии Delphi Пример:
procedure TForm1.Edit1Change(Sender: TObject);
begin
CurPos := Edit1.SelStart;
Label1.Caption := IntToStr(CurPos);
end;
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
If Key = VK_LEFT then dec(CurPos);
if Key = VK_RIGHT then inc(CurPos);
Label1.Caption:= IntToStr(CurPos);
end;
GroupBox
Рисование на GroupBox
Я хочу рисовать на холсте (Canvas) моего компонента GroupBox. Но когда я пробую рисовать на Component.Parent.Canvas, рисование происходит на форме, а не на моем компоненте GroupBox. Что я делаю неправильно? Canvas – защищенное свойство TGroupBox и, поэтому, недоступное. Вы можете сделать его доступным следующим образом:type TMyGroupBox = class(TGroupBox)
public
property Canvas;
end;
procedure SomeProcedure;
begin
…
with TMyGroupBox(GroupBox1).Canvas do
CopyRect(ClipRect, Image1.Canvas, ClipRect);
…
end;
– Ralph Friedman
Доступ к компонентам GroupBox
Delphi 1Одно из свойств всех элементов управления – указатель на другие элементы, которые он содержит. Это свойство – свойство Controls, которое индексируется наподобие массива. Количество элементов управления содержится в свойстве ControlCount. Если вы хотите получить доступ к свойству или методу, которого нет у TControl, вам неоходимо осуществить приведение типа элемента списка.
procedure DoSomethingWithAGroupBox;
var i: integer;
begin
with AGroupBox do
for i := 0 to ControlCount - 1 do
if controls[i] is TEdit then
TEdit(controls[i]).text := 'Как насчет этого?';
end;
end;
Приведенный выше пример будет работать, если элементом управления является TEdit или его наследник, например, TDBEdit или TMaskEdit. Все объекты могут быть приведены к типу одного из объектов, являющегося наследником базового типа (или им самим). Но не спешите приводить все к родительскому классу, родитель в данном случае здесь не подходит, поскольку он означает объект, который содержит сам себя.
Label
Как сделать бегущую строку?
Письмо читателяThe_Sprite отвечает: с помощью TLabel и TTimer. Пример:
procedure TForm1.Timer1Timer(Sender: TObject);
Const
LengthGoString = 10;
GoString = 'В конце строку желательно повторить,'+
' чтоб получить эффект кольцевого движения! В конце ст';
Const i: Integer = 1;
begin
Label1.Caption:=Copy(GoString,i,LengthGoString);
Inc(i);
If Length(GoString)-LengthGoString < i then i:=1;
end;
ListBox
Навигация в ListBox при множественном выборе
Тема: Навигация в ListBox при множественном выборе Данный пример выводит сообщение для каждого элемента Listbox, выбранного пользователем.procedure TForm1.Button1Click(Sender: TObject);
var Loop: Integer;
begin
for Loop := 0 to Listbox1.Items.Count – 1 do begin
if listbox1.selected[loop] then ShowMessage(Listbox1.Items.Strings[Loop]);
end;
end;
Внешние данные и ListBox
Delphi 2Мне необходимо создать Listbox с использованием внешних данных, хранимых в огромном (!) TStringList. Существует ли какое-нибудь системное сообщение, которое я мог бы перехватывать для получения данных Listbox из внешнего TStringlist? Просматривая справочник по API, я нашел интересный пункт, который может помочь вам решить проблему: в Win32 вы можете создать Listbox со стилем LBS_NODATA: (из описания CreateWindow:) LBS_NODATA Определяет ListBox со стилем no-data (без данных). Данный стиль необходимо применять в случае, если количество элементов в ListBox превышает одну тысячу. no-data ListBox также должен иметь стиль LBS_OWNERDRAWFIXED, но не может иметь стиль LBS_SORT или LBS_HASSTRINGS. no-data ListBox похож на owner-drawn ListBox за исключением того, что он не содержит в своих элементах строк и изображений (иконок). Команды добавления, вставки или удаления данных в элементах такого типа ListBox будут проигнорированы, а запросы для поиска строк всегда будут заканчиваться неудачей. При необходимости отрисовки данного элемента, Windows посылает родительскому окну сообщение WM_DRAWITEM. Член itemID стуктуры DRAWITEMSTRUCT, передаваемой с сообщением WM_DRAWITEM, определяет номер строки (элемент), который должен быть перерисован. no-data ListBox не посылает сообщение WM_DELETEITEM. Количество элементов в таком списке вы можете установить с помощью сообщения LB_SETCOUNT. Это позволит вам создать «виртуальный» ListBox с очень небольшой загрузкой. Чтобы воспользоваться новым стилем, вам нужно создать новый класс-наследник от TListbox и перекрыть метод CreateParams. – Peter Below
Инкрементальный поиск в ListBox II
Я видел приложение, в котором ListBox позволял осуществлять инкрементальный поиск. При вводе очередного символа он позиционирует вас к первой ячейке, начало значения которой совпадает с введенным пользователем текстом, или выделяет все строки с текстом, содержащим введенный текст. Как это осуществить на Delphi? Здесь придется немного воспользоваться Win API. Установите свойство формы KeyPreview в True и сделайте примерно следующее:
unit LbxSrch;
interface
uses Windows, Messages, SysUtils, Classes, Controls, Forms, StdCtrls;
type TFrmLbxSrch = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
ListBox1: TListBox;
Label1: TLabel;
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure ListBox1Enter(Sender: TObject);
private
{ Private declarations }
FPrefix: array[0..255] of char;
public
{ Public declarations }
end;
varFrmLbxSrch: TFrmLbxSrch;
implementation
{$R *.DFM}
procedure TFrmLbxSrch.FormKeyPress(Sender: TObject; var Key: Char);
{ Помните о том, что свойство KeyPreview должно быть установлено в True }
var
curKey: array[0..1] of char;
ndx: integer;
begin
if ActiveControl = ListBox1 then begin
if key = #8 {Backspace (клавиша возврата)} then begin
if FPrefix[0] <> #0 then begin
FPrefix[StrLen(FPrefix) - 1] := #0;
end
end else begin
curKey[0] := Key;
curKey[1] := #0;
StrCat(FPrefix, curKey);
ndx := SendMessage(ListBox1.Handle, LB_FINDSTRING,-1, longint(@FPrefix));
if ndx <> LB_ERR then ListBox1.ItemIndex := ndx;
end;
Label1.Caption := StrPas(FPrefix);
Key := #0;
end;
end;
procedure TFrmLbxSrch.ListBox1Enter(Sender: TObject);
begin
FPrefix[0] := #0;
Label1.Caption := StrPas(FPrefix);
end;
end.
– Ralph Friedman
Табуляция в графическом ListBox'е
Письмо читателяИспользование табуляции в ListBox'е когда компонент находится в стандартном режиме не составляет труда. Но что делать если надо использовать графическое отображение элементов списка? Ведь при этом надо самому писать обработчик отрисовки элементов с разбиением на колонки. Элементарное решение — использование API функции TabbedTextOut, однако результаты работы этой функции меня явно не удовлетворили. Пришлось-таки "выкручиваться"… Символ-разделитель можно использовать любой. Например, будем использовать символ "|", тогда обработчик OnDrawItem может выглядеть следующим образом:
procedure TBrowser.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
S, Ss: String;
P: Integer; // Флаг символа-разделителя
begin
begin
ListBox1.Canvas.FillRect(Rect);
//Отрисовка графики
…
//
S:=ListBox1.Items.Strings[Index];
P:=Pos('|', S);
If P=0 then Ss:=S
else Ss:=Copy(S, 1, P-1);
// Если нет табуляции, то пишем всю строку, иначе отрезаем кусок до разделителя
ListBox1.Canvas.TextOut(Rect.Left + 20, Rect.Top + 2, Ss);
If P>0 then
ListBox1.Canvas.TextOut(ListBox1.TabWidth, Rect.Top + 2, Copy(S, P+1, Length(S)-P+2));
end;
end;
Не забудьте перед запуском поставить нужное значение TabWidth.
Virtualik
Выравнивание в ListBox'е
Delphi 1Перед тем, как вычислить позицию фразы, необходимо с помощью функции TextWidth вычислить ее ширину. Например:
var J, TempInt, LongPrefixLen, CurrPrefixLen: Integer;
begin
{Вычисляем TextWidth по ключевой строке}
{Устанавливаем CurrPrefixLen в TextWidth ключевого слова строки Indexth}
LongPrefixLen := 0;
for J := 0 to ListBox1.Items.Count-1 do
with ListBox1.Canvas do begin
TempInt:= TextWidth(Copy(Items[J], 1, Pos(KeyString, Items[J]-1)));
if LongPrefixLen < TempInt then LongPrefixLen:= TempInt;
if J = Index then CurrPrefixLen:= TempInt;
end;
{PrevTextLeft – TextLeft = Где мы хотим вывести новый элемент}
TextOut(LongPrefixLen-CurrPrefixLen, Y, Items[I]);
end;
Создание ListBox во время выполнения программы
Delphi 1Установка выравнивания ListBox на alLeft вызывает изменение размеров ListBox при любом изменении размеров формы. Установка ширины происходит очень легко (помните о том, что ширина Width, которую вы видите в правой части строки, является свойством Width формы). Количество элементов, хранимых ListBox, ограничено только доступной памятью.
procedure TForm1.CreateListBox;
var LB : TListBox;
begin
LB := TListBox.Create;
LB.Align := alLeft;
LB.Width := Width div 2;
end;
Вот логика динамического создания ListBox и изменения его размера при изменения размеров формы. Я надеюсь, что помог вам. Также я подозреваю, что данные ListBox ограничены 32 килобайтами.
unit Unit1;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls { вам нужно это для ListBox } ;
type TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
listbox: TListBox;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
listbox := TListBox.Create(self);
listbox.Parent := self;
listbox.Top := 0;
listbox.Left := 0;
listbox.Width := self.Width div 2;
listbox.Height := self.Height div 2;
listbox.items.add('тест 1');
listbox.items.add('тест 2');
{ и т.д, и т.п. … }
end;
procedure TForm1.FormResize(Sender: TObject);
begin
listbox.Width := self.Width div 2 ;
listbox.Height := self.Height div 2 ;
end;
end.
Двойной ListBox
Я расположил на форме два компонента Listbox, и с помощью следующего кода заполнил один из них данными из таблицы:tableName.Refresh; {в вашем случае это может и не понадобится}
tableName.First; {Убедимся, что мы смотрим первую запись}
while not tableName.Eof do {проходим в цикле таблицу}
begin
listbox1.items.add(tableName.FieldByName('USRID').AsString); {добавляем элемент в listbox1}
tableName.Next; {переходим к следующей записи}
end;
ниже я привел процедуру из моего рабочего кода, в котором я использую эту технологию. Я передаю ей в качестве параметров имя таблицы и имена компонентов listbox1 и listbox2. Я пользуюсь этой процедурой, поскольку у меня есть несколько таблиц с полями одинакового типа:
procedure TTemplateFrm.buildList(tableName: TTable; SelBox, AvailBox: TListBox);
begin
{в этой процедуре мы собираемся добавить данные в listbox'ы}
{получаем любые новые данные}
tableName.Refresh;
{Убедимся, что мы смотрим первую запись}
tableName.First;
{Теперь очищаем ListBox'ы}
SelBox.Clear;
AvailBox.Clear;
{Теперь добавляем элементы}
while not tableName.EOF do begin
AvailBox.Items.Add(tableName.fieldByName('USRID').AsString + ' ' + tableName.fieldByName('DESCRIPTION').AsString);
tableName.Next;
end;
end;
Как перемещать данные между этими двумя списками? Если вы хотите использовать технологию «drag and drop» (перетащи и брось), то в обработчике mousedown вашей исходной таблицы воспользуйтесь процедурой begindrag:
if Button = mbLeft then Tlistbox(sender).BeginDrag(false);
Затем, в вашем другом ListBox, для «опознания» и получения данных создайте следующий обработчик DragOver:
if Source = ListBox1 then Accept := true
else Accept := false;
Не используйте «Accept := (Source is TListbox)», как это показано в большинстве примеров. У вас имеется два компонента ListBox, следовательно, вам нужно сослаться на имя объекта, а не на его тип, а иначе программа просто не поймет кто есть кто.
Затем в обработчике dragDrop поместите следующий код, добавляющий данные в ListBox2 и удаляющий их из ListBox1.
Listbox2.Items.Add(Listbox1.Items[Listbox1.ItemIndex]);
Listbox1.Items.Delete(Listbox1.ItemIndex);
И, наконец, добавьте кнопку «Сохранить», если вы хотите сохранить содержимое ListBox2 в базе данных.
Я надеюсь, что это именно то, что вы искали, и что это окажется вам полезным. Если вы хотите также перемещать данные из ListBox2 в ListBox1, вам необходимо будет создать тот же код, но реверсировать его для получения в коде правильных ссылок на компоненты ListBox.
ListBox — OnChange
Delphi 1Это было два месяца тому назад. Я нашел это на одном из Delphi-сайтов. Не очень сложно и понятно.
UNIT Lbox;
INTERFACE
USES SysUtils, WinTypes, Messages, Classes, Controls, Graphics, Forms,Menus, StdCtrls;
Type TCngListBox = Class(TListBox)
private
FOnChange : TNotifyEvent;
FLastSel : integer;
procedure Click; override;
protected
procedure Change; Virtual;
published
property OnChange : TNotifyEvent read FOnChange write FOnChange;
public
constructor create(AOwner : TComponent); override;
End;
Procedure Register;
IMPLEMENTATION
procedure TCngListBox.Change;
begin
FLastSel := ItemIndex;
if assigned(FOnChange) then FOnChange(self);
end;
procedure TCngListBox.Click;
begin
inherited Click;
if FLastSel <> ItemIndex then Change;
end;
constructor TCngListBox.Create;
begin
Inherited Create(AOwner);
FLastSel := –1;
end;
procedure Register;
begin
RegisterComponents('FreeWare',[TCngListBox]);
end;
END.
MainManu
Как рисовать картинки в пунктах меню (через OwnerDraw)?
Nomadic советует: Смотри пример:unit DN_Win;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus, StdCtrls,
type TDNForm = class(TForm)
MainMenu1: TMainMenu;
cm_MainExit: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure cm_MainExitClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
BM:TBitmap;
Procedure WMDrawItem(var Msg:TWMDrawItem); message wm_DrawItem;
Procedure WMMeasureItem(var Msg:TWMMeasureItem); message wm_MeasureItem;
end;
var DNForm : TDNForm;
implementation
{$R *.DFM}
var Comm, yMenu : word;
procedure TDNForm.FormCreate(Sender: TObject);
begin
{картинку в меню}
yMenu:=GetSystemMetrics(SM_CYMENU);
comm:=cm_MainExit.Command;
ModifyMenu(MainMenu1.Handle, 0, mf_ByPosition or mf_OwnerDraw, comm, 'Go');
end;{TDNForm.FormCreate}
procedure TDNForm.cm_MainExitClick(Sender: TObject);
begin
DNForm.Close;
end;{TDNForm.cmExitClick}
{для прорисовки меню}
Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);
Begin
with Msg.MeasureItemStruct^ do begin
if ItemID=comm then begin
ItemWidth:=yMenu;
Itemheight:=yMenu;
end;
end;
End;{WMMeasureItem}
{}
Procedure TDNForm.WMDrawItem(var Msg:TWMDrawItem);
var
MemDC:hDC;
BM:hBitMap;
mtd:longint;
Begin
with Msg.DrawItemStruct^ do begin
if ItemID=comm then begin
BM:=LoadBitMap(hInstance,'dver');
MemDC:=CreateCompatibleDC(hDC); {hDC входит в структуру TDrawItemStruct}
SelectObject(MemDC,BM);
{rcItem входит в структуру TDrawItemStruct}
if ItemState=ods_Selected then mtd:=NotSrcCopy
else mtd:=SrcCopy;
StretchBlt(hDC, rcItem.left, rcItem.top, yMenu, yMenu, MemDC, 0, 0, 24, 23, mtd);
DeleteDC(MemDC);
DeleteObject(BM);
end;
end{with}
End;{TDNForm.WMDrawItem}
end.
Memo
Получение данных из компонента Memo
Delphi 1Для получения содержимого буфера используйте метод GetTextBuf, или воспользуйтесь приведенным ниже кодом (естественно, откорректируйте его под себя).
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
LineNo : integer;
ColNo : integer;
begin
LineNo:=SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0);
ColNo:=Memo1.SelStart;
if LineNo>0 then begin
While SendMessage(Memo1.Handle, EM_LINEFROMCHAR, ColNo, 0) = LineNo do ColNo:=ColNo-1;
ColNo:=Memo1.SelStart-ColNo-1;
end else ColNo:=Memo1.SelStart;
Panel1.Caption:='Строка '+IntToStr(LineNo)+' ; Колонка '+IntToStr(ColNo);
{Здесь вы можете получить текст через Memo1.Lines[LineNo].Text[ColNo] …}
end;
Предупреждение! Данный код был написан в среде WinNT/D2 с использованием элемента управления richedit. Я тестировал то же самое, но с компонентом Memo и в D1, но этот код я забыл дома. Код выше написан по памяти и не тестировался, но я думаю он должен работать. Если вы переберетесь на D2, измените вызов sendmessage на следующий:
SendMessage(Memo1.Handle, EM_EXLINEFROMCHAR, 0, ColNo)
Изменение поведения Delete в компоненте Memo
Delphi 1Просто меняю обработчик Memo OnKeyDown следующим образом:
if Key = VK_DELETE then begin
здесь делайте все, что вы хотите
end;
if Key = VK_BACK then begin
аналогично
end;
Вероятно, лучшим решением было бы использование конструкции CASE, но я не уверен, что она поймет как нужно VK_??. Возможно, после обработки нужно вызвать унаследованный обработчик, т.е. дать поработать обработчику верхнего уровня, у которого мы стырили управление. Не хотите подумать над этим?
Чтобы понять, где мы сейчас находимся, используйте SelStart, например, так:
var
Lpos, Cpos : Integer;
Lpos := SendMessage(memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0);
Cpos := SendMessage(memo1.Handle, EM_LINEINDEX, Lpos, 0);
CPos := Memo1.SelStart-CPos;
Ответ: поскольку vk_? имеет целочисленный тип, то это будет работать:
case Key of
VK_DELETE :
begin
Key := 0; {этим мы не позволяем сообщению keydown передаваться дальше,
например, форме или компонентам}
выполняем нужный код;
end;
VK_BACK:
begin
Key := 0; {этим мы не позволяем сообщению keydown передаваться дальше,
например, форме или компонентам}
выполняем нужный код;
end;
end;
Вставка текста в TMemo II
Delphi 1Используйте сообщение Windows API EM_REPLACESEL:
Сделайте список с вашими стандартными фразами, и используйте события "OnClick" или "OnMouseDown" в комбинации с "Alt", "Shift" или "Ctrl". Пример: Когда пользователь нажимает клавишу "Alt" в комбинации с правой кнопкой мыши, выводится список заранее подготовленных фраз и выбранная вставляется в ваш TMemo-компонент. Для вставки строки в Memo:
EM_REPLACESEL
wParam = 0; /* не используется, должен быть ноль */
lParam = (LPARAM) (LPCSTR) lpszReplace; /* адрес новой строки */
Для замены текущего выбранного текста в поле редактирования, приложение должно послать сообщение EM_REPLACESEL, где параметр lpszReplace содержит новый текст.Возвращаемое значение Данное сообщение значение не возвращает. Комментарии Используйте сообщение EM_REPLACESEL, если вы хотите изменять только часть текста поля редактирования. Если вам нужно заменить весь текст, используйте сообщение WM_SETTEXT. В случае отсутствия выбранного текста, замещающий текст вставляется в текущую позицию курсора.
Параметр Описание lpszReplace Значение lParam. Указатель на терминированную нулем строку, содержащую замещающий текст. { Указатель на строку } (из справки по Windows API)
procedure TForm1.Button1Click(Sender: TObject);
begin
with Memo1 do begin
SelStart:=10;
SelLength:=0;
SelText:='Эта строка включается в Memo, начиная с 10-й позиции ';
end;
end;
Для вставки строки и замены некоторого существующего текста:
procedure TForm1.Button1Click(Sender: TObject);
begin
with Memo1 do begin
SelStart:=10;
SelLength:=20;
SelText:='Эта строка включается в Мемо, начиная с 10-й позиции и замещает собой 20 символов ';
end;
end;
Поместите текст, который вы хотите вставить, в переменную PChar, затем вставьте текст в Memo, используя команду SetSelTextBuf, где SelStart устанавливается в позицию курсора TMemo. Это классно работает.
Другая полезность: вы можете обхойти предел TMemo в 32K в случае, если вы загружаете в него текст, пользуясь методом/командой Lines.LoadfromFile. Компонент имеет внутренний предел в 32K. Если вы загружаете нужный файл в указатель, и используете команду/метод SetTexBuf, то в этом случае в TMemo можно загрузить текста вплоть до 64K.
NoteBook
Включение/Выключение закладки Notebook II
Delphi 2В обработчике события OnChange вашего TTabbedNotebook разместите код примерно такого содержания:
if (NewTab = 0) and (IWantToDisableTab0) then AllowChange := False;
if (NewTab = 1) and (IWantToDisableTab1) then AllowChange := False;
…
Да, можно использовать конструкцию Case, но If в данном случае я посчитал удобнее.
OutLine
Раскрытие пути к элементу TOutline по его индексу
Delphi 1Когда я писал этот код, у меня была цель по индексу TOutlineNode (который являлся результатом поиска) раскрыть его путь (т.е. раскрыть дочерние узлы, ведующие к нему), не затрагивая при это остальные узлы. Следующая процедура в качестве параметра принимает индекс, после чего раскрывает путь к элементу с этим индексом. Процедура подразумевает работу с объектом TOutline, имеющим имя Outline.
var Outline: TOutline;
procedure TSearchDlg.ExpandPathToFoundItem(const FoundItemIndex: Longint);
{------------------------------------------------------------------------------
Открываем путь к данному элементу (элемент определяется номером индекса).
До корневого элемента необходимо раскрывать только родителей.
-----------------------------------------------------------------------------}
var
ItemIndex: Longint;
Found: Boolean;
LastCh: Longint;
Path: String;
ItemText: String;
SepPos: Integer;
OldSep: String;
begin
{Сохраняем старый ItemSpearator}
OldSep:=Outline.ItemSeparator;
{Устанавливаем новый ItemSeparator}
Outline.ItemSeparator:='\';
{Получаем полный путь к TOutlineNode и добавляем '\'. Это делается для упрощения последующего алгоритма}
Path:=Outline.Items[FoundItemIndex].FullPath+'\';
{Зацикливаемся до тех пор, пока не будет достигнут конец пути}
while Length(Path) > 0 do begin
{Определяем в пути позицию первого '\'}
SepPos:=Pos('\',Path);
{Изолируем элемент TOutlineNode}
ItemText:=Copy(Path,1,SepPos-1);
{Определяем индекс TOutlineNode}
ItemIndex:=Outline.GetTextItem(ItemText);
{Раскрываем его}
Outline.Items[ItemIndex].Expand;
{Вырезаем из строки раскрытый TOutlineNode}
Path:=Copy(Path,SepPos+1,Length(Path)-SepPos+1);
end;
{Восстанавливаем оригинальный ItemSeparator}
Outline.ItemSeparator:=OldSep;
end;
Детали
Давайте присвоим элементу желаемый путь:
"My Computer\Hardware\SoundCard\Base Adress"
На первом шаге возвращается приведенный выше путь. Затем изолируется подстрока «My Computer». Затем с помощью метода «GetTextItem» определяется индекс TOutlineNode «My Computer». Метод «Expand» раскрывает это дерево. Впоследствие «My Computer» вырезается из пути, и новым путем становится «Hardware\SoundCard\Base Adress».
Затем определяется индекс «Hardware», раскрывается, и снова выразается. Данная процедура повторяется до тех пор, пока не останется пути, который можно раскрыть. После чего полностью раскрывается путь передаваемой TOutlineNode.
PageControl
Динамические PageControl/TabSheet I
Delphi 2Динамическое создание Page Control'ов и Tab Sheet'ов:
var
T : TTabSheet;
P : TPageControl;
begin
// Создаем PageControl
// При создании получаем ссылку на PageControl, чтобы в дальнейшем на него ссылаться.
P := TPageControl.Create(application);
with P do begin
Parent := Form1; // устанавливаем его как элемент управления формы.
Top := 30;
Left := 30;
Width := 200;
Height := 150;
end; // with tpagecontrol
// Создаем 3 страницы
T := TTabSheet.Create(P);
with T do begin
Visible := True; // Это необходимо, или форма не будет корректно перерисовываться
Caption := 'Страница 1';
PageControl := P; // Назначаем Tab в Page Control
end; // with
T := TTabSheet.Create(P);
with T do begin
Visible := True; // Это необходимо, или форма не будет корректно перерисовываться
Caption := 'Страница 2';
PageControl := P; // Назначаем Tab в Page Control
end; // with
T := TTabSheet.Create(P);
with T do begin
Visible := True; // Это необходимо, или форма не будет корректно перерисовываться
Caption := 'Страница 3';
PageControl := P; // Назначаем Tab в Page Control
end; // with
// Создаем 3 кнопки, 1 на страницу
with tbutton.create(application) do begin
Parent := P.Pages[0]; // «Указываем» кнопке родительскую страницу
Caption := 'Привет, страница 1';
Left := 0;
Top := 0;
end; // with
with tbutton.create(application) do begin
Parent := P.Pages[1]; // «Указываем» кнопке родительскую страницу
Caption := 'Привет, страница 2';
Left := 50;
Top := 50;
end; // with
with tbutton.create(application) do begin
Parent := P.Pages[2]; // «Указываем» кнопке родительскую страницу
Caption := 'Привет, страница 3';
Left := 100;
Top := 90;
end; // with
// Это должно быть сделано, или Tab первоначально не синхронизируется
// с правильной страницей. Только в случае, если у вас более чем одна страница.
P.ActivePage := P.Pages[1];
P.ActivePage := P.Pages[0]; // Реально показываемая страница
end;
Динамические PageControl/TabSheet II
В данном документе показана технология динамического добавления страниц компонента PageControl (объектов TTabSheet) к элементу управления Windows 95/NT PageControl (объект TPageControl). Оба этих объекта объявлены в модуле ComCtrls. Поэтому убедитесь в том, что ComCtrls указан в списке используемых модулей.Как динамически создать PageControl
Прежде, чем мы приступим к динамическому созданию страниц, давайте динамически создадим PageControl (если он еще не на форме). Это делается посредством вызова конструктора TPageControl Create с параметром owner, равным Self. Конструктор Create возвращает объектную ссылку на вновь созданный объект PageControl и назначает его переменной 'PageControl'. Вторым шагом будет установка свойства PageControl Parent в Self. Свойство Parent определяет где должен быть отображен новый PageControl; в нашем случае это будет сама форма. Вот кусок кода, демонстрирующий вышесказанное:var
PageControl : TPageControl;
PageControl := TPageControl.Create(Self);
PageControl.Parent := Self;
Примечание: При разрушении формы разрушаются также PageControl и ее закладки, поскольку они принадлежат форме.
Как динамически создавать закладки
Существует два основных способа добавления новых страниц к PageControl. Сначала вы должны динамически создать TTabSheet следующим образом:var
TabSheet : TTabSheet;
TabSheet := TTabSheet.Create(Self);
Затем ему необходимо присвоить заголовок следующей командой:
TabSheet.Caption := 'Закладка 1';
И, наконец, самая важное действие заключается в том, что новой странице необходимо сообщить, какому объекту PageControl она принадлежит. Это делается с помощью присваивания свойством TTabSheet PageControl переменной-ссылки TPageControl, типа той, которую мы создали выше (PageControl). Вот кусок кода, демонстрирующий вышесказанное:
TabSheet.PageControl := PageControl;
Как динамически добавлять к страницам элементы управления
Ключевым моментом при создании и размещении элемента управления на странице TabSheet является назначение свойства Parent на переменную-ссылку класса TTabSheet. Вот пример:var
Button : TButton;
Button := TButton.Create(Self);
Button.Caption := 'Кнопка 1';
Button.Parent := TabSheet;
Более подробно об объектах TPageControl и TTabSheet вы можете узнать в онлайн-документации, или посмотреть код файла ComCtrls.pas, расположенного в вашем каталоге ..\Delphi 2.0\SOURCE\VCL.
Полный код примера
// Код использует форму с единственной на ней кнопкой.
unit DynamicTabSheetsUnit;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons;
type TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure TestMethod(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
uses ComCtrls;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
PageControl : TPageControl;
TabSheet : TTabSheet;
begin
// Создаем PageControl
PageControl := TPageControl.Create(Self);
PageControl.Parent := Self;
// Создаем первую страницу и связываем ее с PageControl
TabSheet := TTabSheet.Create(Self);
TabSheet.Caption := 'Закладка 1';
TabSheet.PageControl := PageControl;
// Создаем первую страницу
with TButton.Create(Self) do begin
Caption := 'Кнопка 1';
OnClick := TestMethod; // Назначаем обработчик события
Parent := TabSheet;
end;
// Создаем вторую страницу и связываем ее с PageControl
TabSheet := TTabSheet.Create(Self);
TabSheet.Caption := ' Закладка 2';
TabSheet.PageControl := PageControl;
end;
procedure TForm1.TestMethod(Sender: TObject);
begin
ShowMessage('Привет');
end;
end.
Клавиши-акселераторы для TPageControl
Delphi 2Тема: Создание акселераторов, работающих с TPageControl TPageControl, расположенный на закладке Win95 палитры компонентов, в настоящий момент не может работать с акселераторами. Тем не менее, в наших силах создать потомок TPageControl, поддерживающий вышеназванную характеристику. В приведенном ниже коде показана реализация такого компонента. Наследник TPageControl осуществляет захват и обработку сообщения CM_DIALOGCHAR. Это позволяет перехватывать комбинации клавиш, которые могут быть акселератороми для данной формы. Обработчик события CMDialogChar использует функцию IsAccel, которая позволяет определить, имеет ли отношение перехваченный код клавиш к акселератору одной из страниц TPageControl. В этом случае делаем страницу активной и передаем ей фокус.
unit tapage;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls;
type TAPageControl = class(TPageControl)
private
procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;
end;
procedure Register;
implementation
procedure TAPageControl.CMDialogChar(var Msg: TCMDialogChar);
var
i: Integer;
S: String;
begin
if Enabled then
for I := 0 to PageCount - 1 do
if IsAccel(Msg.CharCode, Pages[i].Caption) and Pages[I].TabVisible then begin
Msg.Result := 1;
ActivePage := Pages[I];
Change;
Exit; // выход из цикла.
end;
inherited;
end;
procedure Register;
begin
RegisterComponents('Test', [TAPageControl]);
end;
end.
Panel
Создание панелей во время работы приложения
Delphi 1…я могу просто догадываться, не видя ваш код, но вы установили у панелей свойство parent? Чтобы отобразить элементы управления на вашей форме, вам НЕОБХОДИМО вставить в обработчик события формы OnCreate следующие две строки:
MyPanel := TPanel.Create(Self);
MyPanel.Parent := Self;
PopupMenu
Вызов контекстного меню в позиции курсора II
Delphi 1…вызов popup-меню связан с координатами экрана. Координаты, получаемые в вашем обрабочике события, вероятно относятся к объекту, который создал это сообщение. Для преобразования координат вам необходимо воспользоваться функцией ClientToScreen. Вот пример вызова контекстного меню, вызываемого при щелчке правой кнопкой мыши на узле TTreeView. Этот пример не в точности отвечает на ваш вопрос, но у меня нет желания расчитывать wParams прямо сейчас. Я думаю вы можете воспользоваться предложенной мною идеей и развить ее в нужном направлении.
procedureTfrmExplorer.TreeViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var P : TPoint;
begin
if Button<>mbRight then exit;
TreeMenu.AutoPopup := False;
if TreeView.GetNodeAt(X,Y)<>NIL then begin
TreeView.Selected := TreeView.GetNodeAt(X,Y);
P.X := X;
P.Y:=Y;
P := TreeView.ClientToScreen(P);
TreeMenu.Popup(P.X,P.Y);
end;
end;
Иконки в PopupMenu
Delphi 2
type TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem; /**** Элемент для Menu Bar ****/
Open1: TMenuItem; /**** Элемент для Menu File ****/
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{private declarations}
public
{public declarations}
Icn, Txt, MnuItm: TBitmap;
end;
procedure TForm2.FormCreate(Sender: TObject);
var
R: TRect;
HIcn: HIcon;
Ic: TIcon;
Index: Word;
FileName: PChar;
begin
/** Получаем иконку определенного приложения **/
Ic:=TIcon.Create;
Ic.Handle:=ExtractAssociatedIcon(Hinstance, /* задаем путь и имя файла */, Index);
/** Создаем для текста изображение **/
Txt:=TBitmap.Create;
with Txt do begin
Width:=Canvas.TextWidth(' Тест');
Height:=Canvas.TextHeight(' Тест');
Canvas.TextOut(0, 0, ' Тест');
end;
/** Копируем иконку в bitmap для изменения его размера. Вы не можете менять размер иконки **/
Icn:=TBitmap.Create;
with Icn do begin
Width:=32;
Height:=32;
Brush.Color:=clBtnFace;
Canvas.Draw(0, 0, Ic);
end;
/** Создаем окончательное изображение, куда мы помещаем иконку и текст **/
MnuItm:=TBitmap.Create;
with MnuItm do begin
Width:=Txt.Width+18;
Height:=18;
with Canvas do begin
Brush.Color:=clBtnFace;
Pen.Color:=clBtnFace;
Brush.Style:=bsSolid;
Rectangle(0, 0, Width, Height);
CopyMode:=cmSrcAnd;
StretchDraw(Rect(0, 0, 16, 16), Icn);
CopyMode:=cmSrcAnd;
Draw(16, 8-(Txt.Height div 2), Txt);
end;
end;
end;
procedure TForm2.FormShow(Sender: TObject);
var
ItemInfo: TMenuItemInfo;
hBmp1 : THandle;
begin
HBmp1:=MnuItm.Handle;
with ItemInfo do begin
cbSize := SizeOf(ItemInfo);
fMask := MIIM_TYPE;
fType := MFT_BITMAP;
dwTypeData := PChar(MakeLong(hBmp1, 0));
end;
/** Заменяем MenuItem Open1 законченным изображением **/
SetMenuItemInfo(GetSubMenu(MainMenu1.Handle, File1.MenuIndex), Open1.MenuIndex, true, ItemInfo);
end;
В меню существуют некоторые проблемы масштабированием и палитрой иконки. Я также ищу лучшее решение, но это все, что я вам могу сейчас дать.
Листинг был изменен для того, чтобы помещать иконки в «чЕкнутое» состояние меню (просто это делает Win95). Это позволяет вам иметь «чЕкнутое» и «нечЕкнутое» состояние.
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus,ShellAPI;
type TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Open1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
Icn, MnuItm : TBitmap;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
R: TRect;
HIcn: HIcon;
Ic: TIcon;
Index: Word;
begin
{ /** Получаем иконку некоторого приложения **/ }
Index := 0;
{ 11-я иконка в файле }
Ic:=TIcon.Create;
Ic.Handle:=ExtractAssociatedIcon(Hinstance, 'c:\win95\system\shell32.dll', Index);
{ /** Копируем иконку в bitmap для изменения его размера. Вы не можете менять размер иконки **/ }
Icn:=TBitmap.Create;
with Icn do begin
Width:=32;
Height:=32;
Canvas.Brush.Color := clbtnface;
Canvas.Draw(0,0,Ic);
end;
{ /** Создаем окончательное изображение, куда мы помещаем иконку и текст **/ }
MnuItm:=TBitmap.Create;
with MnuItm do begin
Width :=18;
Height:=18;
with Canvas do begin
Brush.Color:=clbtnface;
Pen.Color:=clbtnface;
CopyMode:=cmSrcAnd;
StretchDraw(Rect(0,0,16,16), Icn);
end;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
var
ItemInfo: TMenuItemInfo;
hBmp1 : THandle;
begin
HBmp1:=MnuItm.Handle;
with ItemInfo do begin
cbSize := SizeOf(ItemInfo);
fMask := MIIM_CHECKMARKS;
fType := MFT_BITMAP;
hBmpunChecked := HBmp1; { Неотмеченное (Unchecked) состояние }
hBmpChecked := HBmp1; { Отмеченное (Checked) состояние }
end;
{ /** Заменяем MenuItem Open1 законченным изображением **/ }
SetMenuItemInfo(GetSubMenu(MainMenu1.Handle, File1.MenuIndex), Open1.MenuIndex, true, ItemInfo);
end;
end.
ProgressBar
ProgressBar — невидимка
Письмо читателяЗдравствуйте Валентин! Заказчик моего проекта обратился с просьбой — "Сделать прогресс индикатор как в приложениях Нортона. Чтоб был в статус строке и НИКАКИХ рамок". ProgressBar в StatusBar — нет проблем, но как быть с рамкой от ProgressBar? ProgressBar всегда вычерчивает рамку и не имеет методов ее управления. Однако появилась интересная идея, воплотившаяся в компонент с новым свойством ShowFrame. Решение оказалось на удивление простым.
unit SProgress;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls;
type TVSProgressBar = class(TProgressBar)
procedure WMNCPAINT(var Msg: TMessage); message WM_NCPAINT;
private
{ Private declarations }
FShowFrame: boolean;
procedure SetShowFrame(Value: boolean);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property Align;
property Anchors;
property BorderWidth;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property Hint;
property Constraints;
property Min;
property Max;
property Orientation;
property ParentShowHint;
property PopupMenu;
property Position;
property ShowFrame: boolean read FShowFrame write SetShowFrame;
property ShowHint;
property Smooth;
property Step;
property TabOrder;
property TabStop;
property Visible;
property OnContextPopup;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;
procedure Register;
implementation
{ TVSProgressBar }
constructor TVSProgressBar.Create(AOwner: TComponent);
begin
Inherited;
FShowFrame:= True;
end;
procedure TVSProgressBar.SetShowFrame(Value: boolean);
begin
if FShowFrame <> Value then begin
FShowFrame:= Value;
RecreateWnd;
end;
end;
procedure TVSProgressBar.WMNCPAINT(var Msg: TMessage);
var
DC: HDC;
RC: TRect;
begin
if ShowFrame then begin
Inherited; // если рамка – родитель сам разберется
Invalidate;
end else begin
DC := GetWindowDC(Handle);
try
Windows.GetClientRect(Handle, RC); // площадка под ProgressBar
with RC do begin // учтем 3D эффект
Right:= Right + 2;
Bottom:= Bottom + 2;
end;
Windows.FillRect(DC, RC, Brush.Handle); // зальем площадку цветом подложки
finally
ReleaseDC(Handle, DC);
end;
end;
end;
procedure Register;
begin
RegisterComponents('Controls', [TVSProgressBar]);
end;
end.
Теперь ProgressBar может появиться на форме «неожиданно», как бы из ничего, если ShowFrame:= False.
C уважением, VS
Query
Можно ли использовать результаты выполнения одного TQuery для другого TQuery?
Nomadic отвечает: Если Вы работаете с локальными БД, то Вам поможет –DbiMakePermanent(SourceQuery.Handle, RName, false);
Можно ли вызвать хранимую процедуру через TQuery, если она не возвращает курсора?
Nomadic отвечает: В случае MS SQL нужно написать:Query1.Sql := 'declare @res' + #13#10 + 'exec MyFunc :Param1, :Param2, @res OUTPUT';
Query1.Open;
Result := Query1.FieldByName( 'Column1' ).Value;
Query1.Close;
TQUERY и TDBGRID
Delphi 11. После ключевого слова where используйте оператор order
Select fname, lname, title
from T_EMPLOYEE
where title = 'MGR'
order by lname, fname
2. Попробуйте использовать событие ColEnter.
Две и более команд в свойстве TQUERY.SQL
Delphi 1Я предлагаю вас попытаться подключить новый запрос к существующему TQuery.
Query1.Sql.Clear;
Query1.Close;
Query1.Sql.Add('select * from «monitor.dbf» order by location,dept');
Query1.Open;
Query1.Refresh;
Хитрость кроется в закрытии вашего запроса перед назначением нового.
RichEdit
Как вставить в нужное место Rich Text в TRichEdit?
Nomadic советует: Вы можете послать сообщение EM_STREAMIN с параметром SFF_SELECTION методом Perform для замены текущего Selection. Выдержка из Help:EM_STREAMINwParam = (WPARAM)(UINT) uFormat; // Integer
lParam = (LPARAM)(EDITSTREAM FAR *) lpStream; // EDITSTREAM^
The EM_STREAMIN message replaces the contents of a rich edit control with the specified data stream. ParametersuFormat
One of the following data formats, optionally combined with the SFF_SELECTION flag:If the SFF_SELECTION flag is specified, the stream replaces the contents of the current selection. Otherwise, the stream replaces the entire contents of the control.
Value Meaning SF_TEXT Text SF_RTF Rich-text format lpStream
Pointer to an EDITSTREAM structure. The control reads (streams in) the data by repeatedly calling the function specified by the structure's pfnCallback member. Return Value Returns the number of characters read.
Как указать максимальный размер текста для TRichEdit?
Nomadic советует: У этого компонента есть свойство MaxLength, которое работает некорректно. Поэтому лучше пользоватьсяRichEdit.Perform(EM_LIMITTEXT, нужный размер, 0);
Причем перед каждом открытии файла это действие необходимо повторять.
Если Вы передаете в качестве размера 0, то ОС ограничивает размер OS Specific Default Value. Реально, по результатам моих экспериментов, поставить можно размер, чуть меньший доступной виртуальной памяти. Я ограничился 90% от свободной виртуалки.
Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться сообщением EM_EXLIMITTEXT.
Позиция курсора в TRichEdit
Delphi 2
Procedure TForm1.GetPosition(Sender: TRichEdit);
var
iX, iY: Integer;
TheRichEdit: TRichEdit;
begin
iX:= 0;
iY:= 0;
TheRichEdit:= TRichEdit(Sender);
iY:= SendMessage(TheRichEdit.Handle, EM_LINEFROMCHAR, TheRichEdit.SelStart, 0);
iX:= TheRichEdit.SelStart - SendMessage(TheRichEdit.Handle, EM_LINEINDEX, iY, 0);
Panel1.Caption:= IntToStr(iY + 1) + ':' + IntToStr(iX + 1);
end;
procedure TForm1.RichEditMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
GetPosition(RichEdit);
end;
procedure TForm1.RichEditKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
GetPosition(RichEdit);
end;
RadioGroup
Группа радиокнопок и ActiveControl
На форме я имею группу радиокнопок. Я хотел бы вызывать контекстно-зависимую подсказку, если пользователь нажал F1. Для данной конкретной группы радиокнопок я установил HelpContext равным 22, но при любом вызове ActiveControl.HelpContext это возвращает (0). Все другие элементы управления работают как положено. Что я делаю неправильно? Нет. Проблема в том, что ActiveControl – RadioButton, а не RadioButtonGroup. Поместите следующий код в обработчик события формы OnShow, он должен решить вашу проблему:procedure TForm1.FormShow(Sender: TObject);
var c: integer;
begin
with RadioGroup1 do begin
for c := 0 to ControlCount – 1 do TRadioButton(Controls[c]).HelpContext := HelpContext;
end;
end;
– Ralph Friedman
ScrollBar
Мерцание ScrollBar
TScrollBar в Delphi мигает при получении фокуса. Как избежать этого мерцания? Такая же проблема и при перемещении стандартного бегунка полосы прокрутки. Лечится одинаково: установкой свойства TabStop в False. – Rick RogersSpeedButton
Speedbutton и Glyph
Могу ли я из ресурсов поочередно загружать глифы для кнопок speedbutton и, если да, то как это сделать? Например, если в вашем проекте используется TDBGrid, то иконки кнопок компонента DBNavigator могут линковаться вашей программой, и их можно загрузить для использования в ваших speedbutton следующим образом:SpeedButton.Caption := '';
SpeedButton1.Glyph.LoadFromResourcename(HInstance,'DBN_REFRESH');
SpeedButton1.NumGlyphs := 2;
Другие зарезервированные имена:
DBN_PRIOR, DBN_DELETE, DBN_CANCEL, DBN_EDIT, DBN_FIRST, DBN_INSERT, DBN_LAST, DBN_NEXT, DBN_POST
Все имена должны использовать верхний регистр.
– Dennis Passmore
StringGrid
Обновление картинки в ячейке StringGrid
SottNick советует: Если в таблице вы используете событие OnDrawCell для помещения в ячейку рисунка, причем различного, в зависимости, например, от соответствующего значения в двумерном массиве, и вам надо, чтобы после изменения значения в массиве обновилось изображение (Refresh не подходит, т.к. будет мелькать), то измените значение у ячейки (DrawGrid не годится):StringGrid1.Cells[i,j]:='';
или
StringGrid1.Cells[i,j]:=StringGrid1.Cells[i,j];
если там что-то хранится.
Многострочность в заголовках колонок StringGrid
У меня есть StringGrid, который выглядит очень красивым, за исключением заголовков колонок, где я хотел бы иметь их размер равным 1 ячейке, но с заголовком, размещенным в нескольких строках, например,
Индекс Фондовой Биржи
показывалось бы как
Индекс
Фондовой
Биржи
было бы классно, если можно было этот заголовок размещать еще и по центру.
Рисовать сами ячейки вы можете в обработчике события OnDrawCell. Для определения ячейки (заголовок?), обрабатываемой в текущий момент, используйте параметр GridState.
Я выводил тест с помощью обычных методов рисования (которые хорошо "приживаются" в данном компоненте), с поддержкой вертикального выравнивания, полей и переноса слов. Вот сам код:
TFTVerticalAlignment = (vaTop, vaMiddle, vaBottom);
procedure DrawTextAligned(const Text: string; Canvas: TCanvas; var Rect: TRect; Alignment: TAlignment; VerticalAlignment: TFTVerticalAlignment; WordWrap: Boolean);
var
P : array[0..255] of Char;
H : Integer;
T : TRect;
F : Word;
begin
StrPCopy(P, Text);
T := Rect;
with Canvas, Rect do begin
F := DT_CALCRECT or DT_EXPANDTABS or DT_VCENTER or TextAlignments[Alignment];
if WordWrap then F := F or DT_WORDBREAK;
H := DrawText(Handle, P, -1, T, F);
H := MinInt(H,Rect.Bottom - Rect.Top);
if VerticalAlignment = vaMiddle then begin
Top := ((Bottom+Top) - H) div 2;
Bottom := Top + H;
end else if VerticalAlignment = vaBottom then Top := Bottom - H - 1;
F := DT_EXPANDTABS or DT_VCENTER or TextAlignments[Alignment];
if WordWrap then F := F or DT_WORDBREAK;
DrawText(Handle, P, –1, Rect, F);
end;
end;
– Rick Roger
StringGrid без выделенной ячейки
Я пытаюсь показать StringGrid без выделенной ячейки. Первая нефиксированная ячейка всегда имеет состояние "инвертированного" цвета. Я не хочу позволить пользователю редактировать сетку, но эта выделенная ячейка производит впечатление того, что сетка имеет возможность редактирования… Вам необходимо создать обработчик события OnDrawCell. Это легче чем вы думаете. Вот образец кода, который сделает вас счастливым:
procedure TForm.sgrDrawCells(Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState);
var
ACol: longint absolute Col;
ARow: longint absolute Row;
Buf: array[byte] of char;
begin
if State = gdFixed then Exit;
with sgrGrid do begin
Canvas.Font := Font;
Canvas.Font.Color := clWindowText;
Canvas.Brush.Color := clWindow;
Canvas.FillRect(Rect);
StrPCopy(Buf, Cells[ACol,ARow]);
DrawText(Canvas.Handle, Buf, -1, Rect, DT_SINGLELINE or DT_VCENTER or DT_NOCLIP or DT_LEFT);
end;
end;
– Jeff Fisher
Один щелчок на StringGrid вместо трех
Как сделать так, чтобы после ПЕРВОГО щелчка на ячейке возможно было бы начать редактировать ее содержимое? Включите goAlwaysShowEditor в свойство TStringGrid Options. – Rick RogersStringGrid как DBGrid
Delphi 1Ну это может выглядеть приблизительно так (возможно нужна некоторая доработка, написал от руки, не проверяя):
table.first;
row := 0;
grid.rowcount := table.recordCount;
while not table.eof do begin
for i := 0 to table.fieldCount-1 do
grid.cells[i,row] := table.fields[i].asString;
inc(row);
table.next;
end;
У меня тоже имееются свои причины использования TStringGrid. Вот мой код, который загружает данные из отфильтрованной таблицы. Он не очень изящен, т.к. реально является лишь черновиком. У меня это работает, а большего мне и не нужно. Работает очень быстро, даже в случае сотни загруженных колонок. Есть много ссылок на внешние переменные. Надеюсь что они не слишком заумные.
PROCEDURE TformLookupDB.FillCells;
VAR
Row, i :INTEGER
w :INTEGER
grid :TStringGrid
BEGIN
doGrid.RowCount := 0;
IF NOT ASSIGNED(fDB) THEN EXIT;
Row := 0;
FOR i := LOW(fColWidths) TO HIGH(fColWidths) DO fColWidths[i] := 100
// Данный временный объект-сетка используется для предохранения от огромного
// количества подразумеваемых событий Application.ProcessMessages,
// инициируемых базой данных, и вызывающих противное моргание объекта
// doGrid. Итак, мы загружаем данные в объект-сетку
// и затем копируем их в стобцы, начиная с верхней части.
grid := TStringGrid.Create(Self);
grid.Visible := FALSE;
WITH fDB DO TRY
grid.ColCount := fFields.Count;
DisableControls;
// Фильтр был установлен с помощью свойства Self.Filter
First;
WHILE NOT EOF DO TRY
grid.RowCount := Row+1;
FOR i := 0 TO grid.ColCount-1 DO BEGIN
grid.Cells[i,Row] :=FieldByName(fFields.Strings[i]).AsString
w := doGrid.Canvas.TEXTWIDTH(grid.Cells[i,Row]);
IF fColWidths[i]<w THEN fColWidths[i] := w;
END
INC(Row);
FINALLY
Next;
END
FINALLY
doGrid.RowCount := grid.RowCount;
doGrid.ColCount := grid.ColCount;
FOR i := 0 TO grid.ColCount-1 DO BEGIN
doGrid.Cols[i] := grid.Cols[i];
doGrid.ColWidths[i] := fColWidths[i] + 4
END
grid.Free;
EnableControls
END
END;
`Авторазмер` для StringGrid
…да, реально это утомляет, но эту проблему можно решить программным путем (это нужно делать после того, как вы загрузите данные, или же, если вы загружаете данные по столбцам, их загружать в самом цикле, приведенном ниже):i, j, temp, max: integer;
for i := 0 to grid.colcount-1 do begin
max := 0;
for j := 0 to grid.rowcount-1 do begin
temp := grid.canvas.textWidth(grid.cells[i,j]);
if temp > max then max := temp;
end;
grid.colWidths[i] := max + grid.gridLineWidth +1;
end;
Вероятно, вам необходимо будет добавить +1, чтобы текст не прилипал к границам ячеек.
Выравнивание колонок StringGrid III
Вот некоторый код, который делает то, что вы хотите:procedure WriteText(ACanvas: TCanvas; const ARect: TRect; DX, DY: Integer; const Text: string; Format: Word);
var
S: array[0..255] of Char;
B, R:TRect;
begin
with ACanvas, ARect do begin
case Format of
DT_LEFT:
ExtTextOut(Handle, Left + DX, Top + DY, ETO_OPAQUE or ETO_CLIPPED,@ARect, StrPCopy(S, Text), Length(Text), nil);
DT_RIGHT:
ExtTextOut(Handle, Right - TextWidth(Text) - 3, Top + DY,ETO_OPAQUE or ETO_CLIPPED, @ARect, StrPCopy(S, Text),Length(Text), nil);
DT_CENTER:
ExtTextOut(Handle, Left + (Right - Left - TextWidth(Text)) div 2, Top + DY, ETO_OPAQUE or ETO_CLIPPED, @ARect,StrPCopy(S, Text), Length(Text), nil);
end;
end;
end;
procedure TBEFStringGrid.DrawCell(Col, Row: Longint; Rect: TRect; State: TGridDrawState);
var
procedure Display(const S: string; Alignment: TAlignment);
const Formats: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
begin
WriteText(Canvas, Rect, 2, 2, S, Formats[Alignment]);
end;
begin
{ здесь задаем аргументы Col и Row, и форматируем как угодно ячейки }
case Row of
0: { Центрирование заголовков колонок }
if (Col < ColCount) then Display(Cells[Col,Row], taCenter)
else
{ Все другие данные имеют правое центрирование }
Display(Cells[Col,Row], taRight);
end;
end;
Выравнивание колонок StringGrid IV
Delphi 1Создайте ваш собственный метод drawcell на примере того, что приведен ниже:
procedure Tsearchfrm.Grid1DrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState);
var l_oldalign : word;
begin
if (row=0) or (col<2) then grid1.canvas.font.style:= grid1.canvas.font.style+[fsbold]; {устанавливаем заголовок в жирном начертании}
if col<>1 then begin
l_oldalign:=settextalign(grid1.canvas.handle, ta_right);
{NB использует для рисования правую сторону квадрата}
grid1.canvas.textrect(rect,rect.right-2, Rect.top+2,grid1.cells[col,row]);
settextalign(grid1.canvas.handle,l_oldalign);
end else begin
grid1.canvas.textrect(rect, rect.left+2, rect.top+2, grid1.cells[col,row]);
end;
grid1.canvas.font.style:= grid1.canvas.font.style-[fsbold];
end;
Покрашенный StringGrid I
Delphi 1…вы можете попробовать использовать StringGrid. У него имеется свойство Objects, через которое вы можете назначать объекты. Создайте объект, содержащий переменную типа TColor, и назначьте это Objects[col,row], что позволит иметь к нему доступ в любое время. Назначьте событие OnDrawCell StringGrid, позволяющее рисовать текст ячейки правильного цвета. Чтобы убедиться, что ячейка выбрана, воспользуйтесь свойством Selection, содержащим то, что выбрал пользователь. Все это должно выглядеть приблизительно так:
type TStrColor = class(TObject)
public
Color : TColor; {вы могли бы также определить частные и публичные методы доступа}
end;
…
procedure TForm1.FormCreate(Sender:TObject)
var i,j : Integer;
begin
With StringList1 do
for i := 0 to ColCount-1
for j := 0 to RowCount-1 Objects[i,j] := TStrColor.Create;
end;
…
procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState);
var OldColor : TColor;
begin
with StringGrid1.Canvas do begin
OldColor := Font.Color;
Font.Color := (StringGrid1.Objects[col,row] as TStrColor).Color;
TextOut(Rect.Left+2, Rect.Top+2, StringGrid1.Cells[Col,Row]);
Font.Color := OldColor;
end;
end;
…
procedure TForm1.ProcessSelection(Sender: TObject);
var i, j : Integer;
begin
With StringGrid1.Selection do
For i := left to right do
for j := top to bottom do
MessageDlg(IntToStr(i) + ',' + IntToStr(j) + '-' + IntToStr((StringGrid1.Objects[i,j] as tstrcolor).color), mtInformation, [mbOk], 0);
end;
Этот компонент не позволяет делать многочисленный выбор….
Покрашенный StringGrid II
Delphi 1В данном модуле демонстрируется техника изменения цвета у выводимого в StringGrid текста.
unit Strgr;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Grids, StdCtrls, DB;
type TForm1 = class(TForm)
StringGrid1: TStringGrid;
procedure StringGrid1DrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.StringGrid1DrawCell(Sender: TObject; Col, Row: Longint; Rect: TRect; State: TGridDrawState);
const CharOffset = 3;
begin
with StringGrid1.canvas do begin
font.color := clMaroon;
textout(rect.left + CharOffset, rect.top + CharOffset, 'L');
font.color := clNavy;
textout(rect.left + CharOffset + TextWidth('L'), rect.top + CharOffset, 'loyd');
end;
end;
end.
Редактирование в StringGrid
Delphi 1…правда, я этого не пробовал, но в голову пришли две идеи: 1. Нажмите на втором поле редактировании, переведите фокус на другое поле (например, x.focus, где x не сетка), сбросьте goEditing и selectRow и затем верните фокус назад сетке. (Эта техника работала у меня в нескольких местах, например, в градах и мемах.) 2. Нажмите на втором поле редактирования, и после сброса goEditing и selectRow, попробуйте создать tGridRect, подсвечивающий нужную вам строку, после чего делайте grid.Selection := gridRect;
Tabbednotebook
Tabbednotebook и куча ресурсов
Тема: Как избежать использования кучи ресурсов (Resource Heap) при работе с TabbedNotebook Данный документ расскажет о том, как с помощью Object Pascal можно управлять числом активных handlesWindows (оконных дескрипторов), в особенности кучей ресурсов пользователя (User Resource heap), а также следить за этими показателями. О чем этот документ? Попробую коротко и доходчиво: Windows следит за каждым элементом, имеющим фокус, через его дескриптор (Handle). Исходя из этого, Windows не может одновременно поддерживать несколько оконных дескрипторов (4-байтных указателей), и в этом совете мы приведем простой пример кода, позволяющего «легко» загружать ресурсы и обходить эти ограничения, встающие перед разработчиками Delphi. USER DLL в действительности является библиоткой, распределяющей и поддерживающей ресурсы для всех окон и связанных структур данных, включая элементы управления, имеющие фокус, и другие неупомянутые объекты, но вместе с тем необходимо помнить, что эта библиотека работает под Windows. С этим связаны ограничения при работе с ресурсами USER DLL, и эта та проблема, над которой мы будем работать в этом совете. Данный пример добавляет загрузку ресурса для каждого элемента управления, добавляемого на форму, здесь мы берем 4 байта из кучи USER в 64K[1]. Почему мы уверены в том, что у нас это получится? Мы будем разрушать[2] дескрипторы окон, которые Windows, согласно своей архитектуре, должна помнить. Разрушая эти дескрипторы, мы, таким образом, избегаем освобождения пользовательских (USER) ресурсов, это означает, что нам не нужно будет снова создавать вышеуказанные объекты. Наоборот, текущая архитектура VCL обладает способностью следить за вышеуказанными объектами, которые, в действительности, являются указателями на структуру. Так, зная, что VCL поддерживает дескриптор и windows создаст новый дескриптор КАК ТРЕБУЕТСЯ, то вместо поддержания постоянно одного дескриптора (как это подразумевалось при создании архитектуры Windows), мы можем управлять пользовательскими (USER) ресурсами вручную, позволяя разработчику легко загружать их по мере необходимости. Данный пример демонстрирует работу с дескрипторами пользовательских (USER) ресурсов компонента Delphi TTabbedNoteBook (в части освобождения дескрипторов страниц), Delphi DestroyHandle (процедура TWinControl для удаления пользовательских (USER) дескрипторов), и работу вызова Windows API LockWindowUpdate (блокировка нежелательной перерисовки). Технология освобождения дескриптора страницы TTabbedNoteBook может работать и с любыми потомками TWinControl. TWinControl – класс предка, который умеет создавать и разрушать оконные дескрипторы; CreateHandle & DestroyHandle. Демонстрационный код Следующий код с приведенными обработчиками событий является «отрывком» из большого проекта с компонентами TTimer, TTabbedNotebook (с множеством страниц) и большим разнообразием визуальных элементов управления на каждой странице компонента. (Позже мы подчеркнем преимущества кода, приведенного ниже, перед его добавлением в ваш проект) Приведенный код должен располагаться соответственно в обработчиках событий OnTimer компонента TTimer и OnChange компонента TTabbedNotebook. Вот каким должен быть ваш новый код: <Модуль с объявленными в нем TTabbedNotebook и TTimer>…
Implementation
Type TSurfaceWin = class(TWinControl);
procedure TForm1.Timer1Timer(Sender: TObject);
begin
{Данный код заменяет заголовок формы на системную информацию,
содержащую в процентах free SYSTEM, GDI, &USER для windows.}
caption := 'SYSTEM: ' +
inttostr(getfreesystemresources(GFSR_SYSTEMRESOURCES)) + ' GDI: ' +
inttostr(getfreesystemresources(GFSR_GDIRESOURCES)) + ' USER: ' +
inttostr(getfreesystemresources(GFSR_USERRESOURCES));
end;
procedure TForm1.TabbedNotebook1Change(Sender: TObject; NewTab: Integer; var AllowChange: Boolean);
begin
{LockWindowUpdate запрещает перерисовку данного окна}
LockWindowUpdate(handle);
{Причина использования TSurfaceWin в том, что вызов DestroyHandle в TWinControl объявлен как абстрактный, поэтому данный вызов возможен только его потомками, реализовавшими данную процедуру. Следующая строка читает индекс текущей страницы TabbedNotebook и разрушает ее дескриптор при перемещении на другую страницу. ПРИМЕЧАНИЕ: Даже если мы уничтожаем дескриптор, Windows помнит страничный объект и переназначает/создает новый при нажатии на другой закладке. }
TSurfaceWin(TabbedNotebook1.pages.objects[tabbedNotebook1.pageindex]).DestroyHandle;
{Выключаем блокировку формы, чтобы любой элемент управления мог перерисовывать себя}
LockWindowUpdate(0);
end;
Доступ к страницам Tabbednotebook
Delphi 1При добавлении компонентов во время выполнения программы, вам необходимо присвоить для каждого компонента свойству parent (контейнер) _страницу_ компонента notebook, а не сам notebook. Вы можете сделать это следующим образом (пример дан для кнопки):
MyButton := TButton.Create(Form1); {как обычно…}
…
…
MyButton.Parent := TTabPage(TabbedNotebook1.Pages.Objects[n]);
{ <== где 'n' – индекс желаемой страницы ==> }
Свойство notebook 'Pages' имеет тип StringList и содержит список заголовков и объектов 'TTabPage'.
Я сам пользовался этой техникой несколько месяцев. Не могу вспомнить где я сам раздобыл эту информацию, но в документации про это ничего не сказано. Может кто-нибудь знает, где об этом написано?
При добавлении компонента на страницу TabbedNotebook во время выполнения приложения, указатель на желаемую страницу для свойства Parent нового компонента должен быть назначен перед тем, как он будет реально показан. Способ получить доступ ко всем страницам TTabbedNotebook во время выполнения программы – с помощью свойства-массива Objects свойства TabbedNotebook Pages. Другими словами, страничные компоненты хранятся как объекты, присоединенные к имени страницы в списке строк свойства Pages. В следующим коде показано создание кнопки на второй странице компонента TabbedNotebook1:
var NewButton : TButton;
begin
NewButton := TButton.Create(Self);
NewButton.Parent := TWinControl(TabbedNotebook1.Pages.Objects[1])
…
Вот как страница TNotebook может быть использована в качестве родителя для вновь создаваемого на ней компонента:
NewButton.Parent := TWinControl(Notebook1.Pages.Objects[1])
Вот как страница (закладка) TTabSet может быть использована в качестве родителя для вновь создаваемого на ней компонента:
NewButton.Parent := TWinControl(TabSet1.Tabs.Objects[1])
TabControl
Над какой закладкой курсор?
YoungHacker советует: Получение позиции мышиного курсора для TabControl над какой закладкой находится курсор.function Form1.ItemAtPos(TabControlHandle : HWND; X, Y : Integer) : Integer;
var
HitTestInfo : TTCHitTestInfo;
HitIndex : Integer;
begin
HitTestInfo.pt.x := X;
HitTestInfo.pt.y := Y;
HitTestInfo.flags := 0;
HitIndex := SendMessage(TabControlHandle, TCM_HITTEST, 0, Longint(@HitTestInfo));
Result := HitIndex;
end;
Table
Создание таблицы в модуле
Delphi 3Объект TTable может быть создан с владельцем, а может и без оного. Поскольку вы объявляете его локально в процедуре, то владелец в этом случае не требуется. Если владелец не задан, то забота об освобождении объекта ложится на вас. В противном случае объект освобождается владельцем всякий раз, когда освобождается сам владелец. Имеет смысл? Чтобы создать таблицу без владельца, сделайте следующее:
procedure CreateATableInAUnit;
var myTable : TTable;
begin
myTable := TTable.Create(nil);
try
myTable.DatabaseName := 'MyDB';
myTable.TableName := 'MyTable.db';
mytable.IndexName := 'MyIndex';
myTable.Open;
{другой код}
finally
myTable.Free;
end;
end;
TabSet
Изменение количества закладок в TTabSet во время выполнения программы
Delphi 1Вначале сделайте где-то в вашем коде следующее объявление:
TabSet1: TTabSet; { подразумевается, что это принадлежит Form1 }
Затем следующей строкой мы очищаем заголовки всех закладок:
Form1.TabSet1.Tabs.Clear;
Для того, чтобы добавить новую закладку с определенным именем, воспользуйтесь следующим кодом:
Form1.TabSet1.Tabs.Add('какой-то заголовок');
Пожалуйста, помните о том, что я назначил имя в предположении, что вы имеете ссылку на юнит, где оно определено [но не исключаю возможности, что вы можете получить ссылку на закладку и через обработчика соответствующего события, что еще проще, но мы то с вами должны знать все!]. Если вам нужно сослаться на объект из другого модуля, просто добавьте к вызову имя модуля (и добавьте этот модуль в список «uses»), например так:
Unit1.Form1.TabSet1.Tabs.Add('Заголовок');
Поскольку «TabSet1.Tabs» имеет тип TStrings, вы можете использовать любой из доступных методов этого типа (AddObject, LoadFromFile и т.д.).
Timer
Остановка таймера на `полпути`
Delphi 1
Timer1.Enabled := False;
Timer1.Enabled := True;
Это полностью «сбрасывает» таймер, другими словами, перезапускает его.
BTW: изменение интервала (в другое значение) также производит сброс таймера.
Вы можете включать и выключать ваш таймерный компонент, устанавливая соответствующее свойство, например:
Timer1.Enabled := True; { или False, если вы хотите выключить его }
Но при этом свои 5 секунд таймер продолжает отсчитывать. Если вы хотите изменить это, присвойте ему другой интервал, например так:
Timer1.Interval := 100;
TreeView
Поточность TreeView
Delphi 2На пустой форме у меня располагается TTreeView. Затем я сохраняю это в файле, используя WriteComponent. Это работает как положено; я могу из DOS c помощью команды "type" посмотреть двоичный файл и увидеть его содержимое, типа строк TTreeView и имя объекта. По крайней мере файл записывается и создается впечатление его "наполненности". Затем я освобождаю компонент TTreeView, открываю поток, делаю ReadComponent и, затем, InsertControl. И получаю исключение "TreeView1 has no parent window" (TreeView1 не имеет родительского окна). Это происходит из-за того, что при установке определенных свойств TreeView требуется дескриптор окна элемента управления, а для этого необходимо иметь родителя. Решение заключается в создании пустого TreeView и передаче его в качестве параметра ReadComponent - вы наверняка меня спросите, почему ReadComponent необходим параметр, правильно? Смотрите дальше.
procedure TForm1.Button1Click(Sender: TObject);
var TreeView : TTreeView;
begin
with TFileStream.Create('JUNK.STR', fmCreate) do try
WriteComponent(TreeView1);
TreeView1.Name := 'TreeView';
Position := 0;
TreeView := TTreeView.Create(Self);
TreeView.Visible := false;
TreeView.Parent := Self;
ReadComponent(TreeView);
TreeView.Top := TreeView1.Top + TreeView1.Height + 10;
TreeView.Visible := true;
finally
Free;
end;
end;
Два небольших замечания:
1. Убедитесь в отсутствии конфликта имен. Данный код делает форму владельцем второго TreeView и при ее освобождении разрушает компонент. Я просто переименовываю существующий TreeView перед загрузкой 'клона'.
2. Я установил свойство visible в false перед установкой свойства parent, этим я предотвратил показ только что созданного TreeView до момента загрузки его из потока.
– Mike Scott
Получение доступа к узлам TreeView
Delphi 2Небольшие хитрости для работы с узлами TreeView: Если вы хотите производить поиск по дереву, может быть для того, чтобы найти узел, соответствующий определенному критерию, то НЕ ДЕЛАЙТЕ ЭТО ТАКИМ ОБРАЗОМ:
for i := 0 to MyTreeView.Items.Count) do begin
if MyTreeView.Items[i].Text = 'Банзай' then break;
end;
…если вам не дорого время обработки массива узлов.
Значительно быстрее будет так:
Noddy := MyTreeView.Items[0];
Searching := true;
while (Searching) and (Noddy <> nil) do begin
if Noddy.text = SearchTarget then begin
Searching := False;
MyTreeView.Selected := Noddy;
MyTreeView.SetFocus;
end else begin
Noddy := Noddy.GetNext
end;
end;
В моей системе приведенный выше код показал скорость 33 милисекунды при работе с деревом, имеющим 171 узел. Первый поиск потребовал 2.15 секунд.
Оказывается, процесс индексирования очень медленный. Я подозреваю, что при каждой индексации свойства Items, вы осуществляете линейный поиск, но это нигде не засвидетельствовано, поэтому я могу ошибаться.
Вам действительно не нужно просматривать все дерево, чтобы найти что вам нужно – получить таким образом доступ к MyTreeView.Items[170] займет много больше времени, чем получения доступа к MyTreeView.Items[1].
Как правило, для отслеживания позиции в дереве TreeView, нужно использовать временную переменную TTreeNode, а не использовать целочисленные индексы. Возможно, свойство ItemId как раз и необходимо для такого применения, но, к сожалению, я никак не могу понять абзац в электронной документации, касающийся данного свойства:
«Свойство ItemId является дескриптором TTreeNode типа HTreeItem и однозначно идентифицирует каждый элемент дерева. Используйте это свойство, если вам необходимо получить доступ к элементам дерева из внешнего по отношению к TreeView элемента управления.»
«Я разговаривал с деревьями…вот почему они ушли от меня…»– Peter Kane(Spike Milligan)
Хочется выделять некоторые стpочки в TTreeView жирным или бледным. Как?
Nomadic советует: Грхм… Господа, но если речь про bold… Матчасть учить надо 8-).procedure SetNodeState(node: TTreeNode; Flags: Integer);
var tvi: TTVItem;
begin
FillChar(tvi, Sizeof(tvi), 0);
tvi.hItem := node.ItemID;
tvi.mask := TVIF_STATE;
tvi.stateMask := TVIS_BOLD or tvis_cut;
tvi.state := Flags;
TreeView_SetItem(node.Handle, tvi);
end;
И вызываем:
SetNodeState(TreeView1.Selected, TVIS_BOLD); // Текст жирным
SetNodeState(TreeView1.Selected, TVIS_CUT); // Иконку бледной
(Ctrl+X)
SetNodeState(TreeView1.Selected, TVIS_BOLD or TVIS_CUT); // Текст жирным
SetNodeState(TreeView1.Selected, 0); // Ни того, ни другого
Когда-то (мечтательно закатив глаза в потолок) в API было еще и TVIS_DISABLE. Снесли собаки. А рекомендуемую стилистику употребления этого добра смотри в MS Internet News.
UpdateSQL
Что нужно знать о принципе и порядке работы с TUpdateSQL для работы с неживыми запросами?
Nomadic советует: Кидаешь UpdateSQL на форму, после чего в том SQL, который ты собираешься редактировать, устанавливаешь в UpdateObject имя этого UpdateSQL. После этих дел по дабл-клику на UpdateSQL выдаётся редактор, в котором ты должен для каждой из таблиц,входящих в твой запрос, указать набор полей, являющихся уникальным ключём таблицы, и набор полей, которые требуется редактировать. В общем случае возможны глюки с редактированием, если в числе изменяемых полей будут элементы ключа. Указав все поля, давишь кнопку Generate SQL и в результате у тебя генерятся запросы на редактирование, добавление и удаление, которые прописываются в том же UpdateSQL. Обычно эти запросы никакого дополнительного редактирования не требуют. После всех этих дел ты можешь нормально редактировать запрос, как обычную таблицу. Hекоторые моменты. Для того, чтобы всё это нормально работало, нужно, чтобы в TQuery были включены RequestLive и CashedUpdates. Соответственно, для подтверждения изменений нужно вызывать TQuery.ApplyUpdates и TQuery.CommitUpdates, либо TDatabase.ApplyUpdates, а для отмены – CancelUpdates. Если меняешь структуру таблиц, то не забывай менять списки полей в UpdateSQL, иначе можешь получить неприятный сюрприз – будешь долго сидеть и думать, почему при редактировании/добавлении некоторые поля не прописываются :-). – Отрезано – Hасчёт CachedUpdates. Сия хреновина придумана для того, чтобы обеспечить сохранение/отмену редактирования/добавления/удаления сразу нескольких записей. Принцип совершенно элементарен: если CachedUpdates включен, то все производимые изменения в датасете по команде Post фиксируются не в базе, а во временном файле на винте клиента. Для того, чтобы прописать изменения в таблице (физически), необходимо вызвать для соответствующего запроса последовательно методы ApplyUpdates и CommitUpdates, а для отмены ВСЕХ изменений (начиная от последнего выполненного CommitUpdates), вызвать CancelUpdates. Кроме того, метод ApplyUpdates у TDataBase. Этому методу нужен список датасетов, и он производит их обновление в одной транзакции. Практическое применение, например, такое: на форме редактирования с гридом и набором кнопок Добавить, Удалить, Редактировать, ОК, Отмена, вешаешь на первые три кнопки обработчики с Insert, Delete и Edit соответственно, на OK – такой примерно обработчик:with DataSet do begin
if State in [dsEdit,dsInsert] then Post;
ApplyUpdates;
CommitUpdates;
end;
а на Отмену такой:
with DataSet do begin
if State in [dsEdit,dsInsert] then Cancel;
CancelUpdates;
end;
В результате юзер может редактировать хоть всю таблицу, но если успеет спохватиться, то может отменить все свои художества. Только желательно на выходе из формы проверить, сохранены ли изменения, и если нет, то напомнить/переспросить.
Лучше использовать конструкцию «State in dsEditModes»
Разное
Создание компонентов для работы с базами данных
Тема: Создание компонентов для работы с базами данных, позволяющих работать с самими данными Обзор Данный документ описывает минимально необходимые шаги, необходимые для создания компонента для работы с базами данных, который может отображать данные отдельного поля. Примером такого компонента может служить панель со свойствами DataSource и DataField, похожая на компонент TDBText. Для получения дополнительных примеров обратитесь к Руководству по написанию компонентов "Making a Control Data-Aware". Как пользоваться данным документом Для наилучшего понимания данного документа, вы должны быть знакомы с механизмом функционирования элементов управления для работы с базами данных и основополагающими принципами создания компонент, такими, как • создание компонентов на основе существующих • перекрытие конструкторов и деструкторов • создание новых свойств • чтение и запись значений свойств • назначение обработчиков событий Основные шаги по созданию компоненты, осуществляющей навигацию по данным • Создайте или наследуйте компонент, который допускает свое отображение, но не ввод данных. Например, вы могли бы использовать компонент TMemo с установленным в True свойством ReadOnly. В примере, приведенном в данном документе, мы используем TCustomPanel. TCustomPanel позволяет себя отображать, но не вводить данные. • Добавьте к вашему компоненту data-link object (объект для связи с данными). Данный объект позволяет управлять связью между компонентом и таблицей базы данных. • Добавьте к компоненту свойства DataField и DataSource. • Добавьте методы для получения и установления DataField и DataSource. • Добавьте к компоненту метод DataChange, позволяющий управлять событиями OnDataChange объекта data-link. • Перекройте конструктор компонента для создания datalink и перехвата метода DataChange. • Перекройте деструктор компонента для очищения datalink. Создание TDBPANEL • Создайте или наследуйте компонент, который допускает свое отображение, но не ввод данных. В качестве отправной точки для нашего примера мы будем использовать TCustomPanel. Выберите соответствующий пункт меню для создания нового компонента (он меняется от версии к версии Delphi), определите TDBPanel как имя класса, и TCustomPanel в качестве наследуемого типа. Определите любую страницу Палитры компонентов. • Добавьте DB и DBTables в список используемых модулей. • Добавьте data-link объект в секцию private вашего компонента. Данный пример отображает данные одного поля, поэтому мы используем TFieldDataLink для обеспечения связи между нашим новым компонентом и DataSource. Имя нового data-link объекта – FDataLink.{ пример }
private
FDataLink: TFieldDataLink;
• Добавьте к компоненту свойства DataField и DataSource. Мы добавим соответствующий код для методов записи/чтения в последующих шагах.
Примечание: Наш новый компонент будет иметь свойства DataField и DataSource, FDataLink также будет иметь собственные свойства DataField и Datasource.
{ пример }
published
property DataField: string read GetDataField write SetDataField;
property DataSource: TDataSource read GetDataSource write SetDataSource;
• Добавьте частные методы для чтения/записи значений свойств DataField и DataSource, и свойств DataField и DataSource для FDataLink.
{ пример }
private
FDataLink: TFieldDataLink;
function GetDataField: String;
function GetDataSource: TDataSource;
procedure SetDataField(Const Value: string);
procedure SetDataSource(Value: TDataSource);
.
.
implementation
.
.
function TDBPanel.GetDataField: String;
begin
Result := FDataLink.FieldName;
end;
function TDBPanel.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TDBPanel.SetDataField(Const Value: string);
begin
FDataLink.FieldName := Value;
end;
procedure TDBPanel.SetDataSource(Value: TDataSource);
begin
FDataLink.DataSource := Value;
end;
• Добавьте частный метод DataChange, назначая событие объекта datalink OnDataChange. В методе DataChange добавьте код для отображения данных поля актуальной базы данных, связь с которой обеспечивает объект data-link. В нашем примере мы назначаем значение поля FDataLink заголовку панели.
{ пример }
private
.
.
procedure DataChange(Sender: TObject); = nil then Caption := '';
implementation
.
.
procedure TDBPanel.DataChange(Sender: TObject);
begin
if FDataLink.Field
else Caption := FDataLink.Field.AsString;
end;
• Перекройте метод конструктора компонента Create. При реализации Create, создайте объект FDataLink и назначьте частный метод DataChange событию FDataLink OnDataChange.
{ пример }
public
constructor Create(AOwner: TComponent); override;
.
.
implementation
.
.
constructor TMyDBPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDataLink := TFieldDataLink.Create;
FDataLink.OnDataChange := DataChange;
end;
• Перекройте метод деструктора компонента Destroy. При реализации Destroy, установите OnDataChange в nil (чтобы избежать GPF), и освободите FDatalink.
{ пример }
public
.
.
destructor Destroy; override;
.
.
implementation
.
.
destructor TDBPanel.Destroy;
begin
FDataLink.OnDataChange := nil;
FDataLink.Free;
inherited Destroy;
end;
• Сохраните модуль и установите компонент (смотрите документацию Users Guide и Component Writers Guide для получения дополнительной информации по сохранению модулей и установке компонентов).
• Для тестирования функциональности компонента расположите на форме компоненты TTable, TDatasource, TDBNavigator и TDBPanel. Установите TTable DatabaseName и Tablename в 'DBDemos' и 'BioLife', а свойство Active в True. Установите свойство TDatasource Dataset в Table1. Установите TDBNavigator и свойство TDBPanel DataSource в Datasource1. Имя TDBpanel DataField должно быть установлено в 'Common_Name'. Запустите приложение и, используя навигатор и перемещаясь по записям, убедитесь в том, что TDBPanel обнаруживает изменение данных и отображает значение соответствующего поля.
Полный код компонента
unit Mydbp;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, DB, DBTables;
type TDBPanel = class(TCustomPanel)
private
FDataLink: TFieldDataLink;
function GetDataField: String;
function GetDataSource: TDataSource;
procedure SetDataField(Const Value: string);
procedure SetDataSource(Value: TDataSource);
procedure DataChange(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property DataField: string read GetDataField write SetDataField;
property DataSource: TdataSource read GetDataSource write SetDataSource;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TDBPanel]);
end;
function TDBPanel.GetDataField: String;
begin
Result := FDataLink.FieldName;
end;
function TDBPanel.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TDBPanel.SetDataField(Const Value: string);
begin
FDataLink.FieldName := Value;
end;
procedure TDBPanel.SetDataSource(Value: TDataSource);
begin
FDataLink.DataSource := Value;
end;
procedure TDBPanel.DataChange(Sender: TObject);
begin
if FDataLink.Field = nil then Caption := ''
else Caption := FDataLink.Field.AsString;
end;
constructor TDBPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDataLink := TFieldDataLink.Create;
FDataLink.OnDataChange := DataChange;
end;
destructor TDBPanel.Destroy;
begin
FDataLink.Free;
FDataLink.OnDataChange := nil;
inherited Destroy;
end;
end.
Динамическое создание компонент во время работы приложения
Delphi 1Использовать формы и компоненты Delphi очень просто. Если управлять этими объектами посредством Инспектора Объектов, то эту задачу можно отнести к числу тривиальных. Динамически создать объект также несложно. В этом документе мы обсудим некоторые вопросы, касающиеся динамического создания компонент во время работы приложения. (вам следует помнить, что понятие "динамическое" весьма субъективно, поскольку Delphi все объекты создает динамически. Информация, предоставленная здесь — для программиста, который сам собирается создавать/менять свойства/разрушать объекты во время выполнения программы) Все типы (формы или компоненты) могут создаваться динамически. Чтобы это сделать, необходимо объявить переменную нужного типа в секции VAR вашего кода. Это не создает экземпляр объекта, это создает указатель. Данный указатель расположен в сегменте данных (если переменная объявлена глобально) или в стеке (если переменная объявлена локально в процедуре или функции). Для того, чтобы создать экземпляр класса, вам необходимо вызвать конструктор. Это распределит память в глобальной компьютерной куче для экземпляра класса. При попытке получить доступ к компоненте прежде, чем мы распределим память, мы получим ошибку общей защиты. Конструктор Create() является классовым методом, наследуемым от класса TObject. Create() возвращает указатель. Данный метод может потребовать (а может и нет) один или несколько параметров. В большинстве компонентов (все объекты, наследуемые от TComponent, имеют право называться компонентами), конструктор на входе требует один параметр, указывающий на "владельца" и имеющий тип TComponent. При динамическом создании компонента в большинстве случаев владелецем становится "Self". Если вы в этот момент находитесь в одном из методов формы, "Self" в данном контексте будет ссылаться на саму форму. Если владелец является действительным объектом, освобождение этого объекта влечет за собой автоматическое освобождение "дочернего" компонента. Другим распространенным параметром является "Application". Он может использоваться в случае, когда визуальный компонент не должен быть показан программой пользователю. Тем не менее, большинство компонентов не требуют назначения владельца, так что нет ничего необычного в том, что требуемый параметр owner устанавливается в Nil. Но вы должны помнить о том, что впоследствии вы не сможете изменить владельца объекта. Если конструктору при создании был передан Nil, то после использования компонента вы должны сами освобождать его вызовом Free. После создания оконных компонентов (т.е. тех компонентов, которые являются наследниками TWinControl), но еще перед тем, как они будут отображены, у них необходимо установить свойство Parent. Место установки свойства Parent является хорошим местом для установки других свойств экземпляра данного компонента, включая обработчики событий (например, Width, Color, OnClick). Обработчики событий идентичны тем, которые определены в Инспекторе Объектов. Просто присвойте имени свойства компонента для события, которое вы хотите обработать, имя метода обработчика события, которое вы ожидаете. В примере 1, приведенном ниже, при нажатии на кнопку будет вызван метод с именем "myclick". Пожалуйста имейте в виду, что список входных параметров одного метода должен в точности соответствовать списку выходных параметров другого. Пример 1:
var b1 : TButton;
begin
.
.
.
b1 := TButton.Create(Self);
with b1 do begin
Left := 20;
Top := 20;
Width := 90;
Height := 50;
Caption := 'моя кнопка';
Parent := Form1;
OnClick := MyClick; { процедура, определенная где-то еще }
end;
.
.
.
end;
В следующем примере показано как можно во время выполнения программы динамически создать кнопку, щелкая по другой кнопке, размещенной на форме во время проектирования (к этому моменту она уже создана). Это уже другой путь создания кнопки. Все способы рабочие. Также имейте в виду, что кнопки, не освобождаемые в данном коде, будут освобождаться при разрушении формы.
unit Unit1;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure myClick(Sender: TObject);
end;
var Form1: TForm1;
const i : integer = 0;
implementation
{$R *.DFM}
procedure TForm1.myClick(Sender: TObject);
begin
with Sender as TButton do Self.Caption := ClassName + ' ' + Name;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
with TButton.Create(self) do begin
Left := 20;
Top := 30 + i;
Width := 120;
Height := 40;
Name := 'ThisButton' + IntToStr(i);
Caption := 'There' + IntToStr(i);
OnClick := MyClick; { процедура, определенная где-то еще }
Parent := Form1;
end; {end with}
inc(i, 40);
end; {end button1.click}
end.
Решение для динамически создаваемых компонентов
Delphi 1Предупреждение: Если вы просто хотите во время выполнения приложения создавать компоненты необходимого вам типа, ознакомьтесь с файлом delphi\doc\VB2Delph.wri и следуйте его рекомендациям, лучшего способа изучения этой темы пока не существует. Данный совет повествует об использовании в Delphi RTTI. Во-первых, в вашем приложении необходимо зарегистрировать все классы, экземпляры которых вы собираетесь в каком-то месте кода создавать. Сделать это можно с помощью функций RegisterClass(), RegisterClasses() и RegisterClassAlias(). Пример:
procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterClasses([TButton, TEdit, TMemo, TLabel]);
end;
Это может навести вас на мысль об ограничениях, но Delphi строгий язык. Если вы хотите истинно динамическое создание объектов в слаботипизированной среде позднего связывания, используйте динамический язык типа Smalltalk. У меня есть подозрение, что Delphi использует этот механизм регистрации для регистрации всех компонентов в DCL при его запуске, позволяя этим самым создавать любой компонент во время разработки.
Создание компонентов. Используйте функцию FindClass() для получения ссылки на класс компонента, который вы хотите создать, и вызывайте его метод Create. Легко, не правда ли? В примере у меня имеется приведение типа SomeComponent к TControl, после чего я уже могу установить свойство parent (я могу делать это, поскольку я знаю, что все зарегистрированные мною классы являются потомками TControl). Для того, чтобы визуальный компонент появился на форме, вам необходимо установить свойство parent.
Пример:
procedure TForm1.CreateClick(Sender: TObject);
begin
SomeComponent:= TComponentClass(FindClass(ClassName.Text)).Create(Self);
(SomeComponent as TControl).Parent := Self;
end;
Теперь, когда вы имеете созданный компонент, как установить его свойства без использования самого большого блока case во вселенной? Очень просто: для получения информации о свойстве из структуры run-time type information (RTTI) используется функция GetPropInfo(), после чего для установления значений используется набор функций SetXXXXProp(). (Примечание: эти функции не задокументированы в файлах помощи Delphi. OO-программисты, как я понимаю, пользуются примерами из чужого кода и не изобретают свой велосипед.) У каждой функции SetXXXXProp() имеется функция-сателлит GetXXXXProp(), позволяющая узнать значения свойств объекта.
Пример:
procedure TForm1.SetPropertyClick(Sender: TObject);
var
PropType: PTypeInfo;
PropInfo: PPropInfo;
begin
PropInfo := GetPropInfo(SomeComponent.ClassInfo, PropertyName.Text);
PropType := PropInfo^.PropType;
case PropType^.Kind of
tkInteger:
SetOrdProp(SomeComponent, PropInfo, StrToInt(PropertyValue.Text));
tkChar:
SetOrdProp(SomeComponent, PropInfo, Ord(PropertyValue.Text[1]));
tkEnumeration:
SetOrdProp(SomeComponent, PropInfo, GetEnumValue(PropType, PropertyValue.Text));
tkFloat:
SetFloatProp(SomeComponent, PropInfo, StrToFloat(PropertyValue.Text));
tkString:
SetStrProp(SomeComponent, PropInfo, PropertyValue.Text);
end;
end;
Вы также можете установить значения свойств Set, Class и Method, но это будет немного сложнее. Немного позже я объясню как это можно сделать.
Это все. Вы проведете время с большой пользой, изучая исходный код VCL, и удивляясь, когда вы все там увидите собственными глазами.
Это прекрасный способ, но он имеет потенциал для массового злоупотребления. Необходимо понимание других путей достижения этой цели и выбор соответствующей техники при создании своих проектов в Delphi.
Как правильно создавать органы управления в runtime?
Nomadic советует: Примерно таким образом (Описываем метод-обработчик события OnClick формы):{ Example }
procedure TForm1.OnClick(ASender: TObject);
var btnTemp: TButton;
begin
{ Creating }
btnTemp := TButton.Create(Self);
{ You can use 'with btnTemp do' operator below }
{ Inserting to Form }
btnTemp.Parent := Self;
{ Initialization }
btnTemp.Caption := 'I''m glad to see You';
btnTemp.SetBounds(20, 20, 80, 20);
{ You must define this event handler named 'OnBtnTempClick' }
btnTemp.OnClick := OnBtnTempClick;
{ Ready to show }
btnTemp.Visible := true;
{ Done. }
end;
Как создать клон (копию, достаточно близкую к оригиналу) произвольного компонента?
Nomadic советует:{ Здесь процедyра CreateClone, которая креатит компоненту ОЧЕНЬ ПОХОЖУЮ на входную. С такими же значениями свойств. Присваивается все, кроме методов. }
function CreateClone(Src: TComponent): TComponent;
var F: TStream;
begin
F := nil;
try
F := TMemoryStream.Create;
F.WriteComponent(Src);
RegisterClass(TComponentClass(Src.ClassType));
F.Position := 0;
Result := F.ReadComponent(nil);
finally
F.Free;
end;
end;
Как заставить произвольный компонент реагировать на изменения в TDataSource?
Nomadic советует: TFieldDataLink. За D2 не скажу, а в D1 в Help'е его нет, реализован в \DELPHI\SOURCE\VCL\DBTABLES.PAS.type TMyForm = class(TForm)
{…}
Table1: TTable;
DataSource1: TDataSource;
private
FDL : TFieldDataLink;
procedure RecChange(Sender: TObject);
public
{...}
end;
procedure TMyForm.FormCreate(Sender: TObject);
begin
FDL:=TFieldDataLink.Create;
FDL.OnDataChange :=RecChange;
FDL.DataSource := DataSource1;
FDL.FieldName := 'MyFieldName';
end;
procedure TTabEditDlg.FormDestroy(Sender: TObject);
begin
FDL.Free;
end;
procedure TTabEditDlg.MasterChange(Sender: TObject);
begin
{… тут реагируй на изменения …}
end;
За отслеживание различных событий, происходящих с TDataSource, в иерархии VCL отвечает класс TDataLink. TFieldDataLink – наследник, который выполняет маскирование событий, не относящихся к конкретному столбцу набора данных.
Если надо отслеживать изменения в любом столбце набора, используйте TDataLink. Если необходимо отслеживать события для некоторого подмножества строк набора данных, посмотрите на реализацию TGridDataLink.
Доступ к другим компонентам из базового
Delphi 1Список-свойство Components[] существует во всех потомках TComponent и используется для хранения ссылок на все собственные компоненты. При вызове «mycomponent := TSomeComponent.Create(aComponent)», ссылка на mycomponent помещается в список aComponent Components[]. В большинстве случаев, в методе Create в качестве владельца компонентов определена форма, и ссылки на компоненты помещаются в список Components[] самой формы. Метод FindComponent() (упомянутый где-то еще) только производит поиск компонентов в текущем списке Components[]. Если объект, который вы хотите найти, принадлежит другому компоненту, вы должны просканировать его список компонентов. В зависимости от того, как вы создаете свою базу и другие компоненты, вы можете осуществить рекурсивный алгоритм поиска, который стартует в верхней части дерева собственника набора компонентов (вероятно, формы), спускаясь вниз и проходя по списку Components[] каждого вновь найденного компонента, пока желаемый объект не будет найден. Хорошей альтернативой может служить способ, при котором вы всегда определяете базовый компонент в качестве владельца всех других ваших «подкомпонентов» (при их создании). После этого будет работать поиск по свойству вашего базового компонента Components[].
CANVAS.TEXTWIDTH
Delphi 1Установить размер шрифта для панели можно следующим образом:
With StatusBar1.Panels[1] do begin
Text := Edit1.Text;
Canvas.Font.Size := StatusBar1.Font.Size;
Width := Canvas.TextWidth(Text) + 10;
end;
Создание компонента
Delphi 1…чтобы сгруппировать свойства наподобие Font, вам необходимо создать наследника (подкласс) TPersistent. Например:
TBoolList = class(TPersistent)
private
FValue1: Boolean;
FValue2: Boolean
published
property Value1: Boolean read FValue1 write FValue1;
property Value2: Boolean read FValue2 write FValue2;
end;
Затем, в вашем новом компоненте, для этого подкласса необходимо создать ivar. Чтобы все работало правильно, вам =необходимо= перекрыть конструктор.
TMyPanel = class(TCustomPanel)
private
FBoolList: TBoolList;
public
constructor Create(AOwner: TComponent); override;
published
property BoolList: TBoolList read FBoolList write FBoolList;
end;
Затем добавьте следующий код в ваш конструктор:
constructor TMyPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBoolList := TBoolList.Create;
end;
Циклический опрос компонентов
Delphi 1
procedure TForm1.FormCreate(Sender: TObject);
var I : integer;
begin
for I:= 0 to ComponentCount -1 do
if (Components[I] IS TEdit) then
(Components[I] AS TEdit).{Вашпараметр} := {ваше значение};
end;
Если вам необходимо идентифицировать конкретный набор edit-компонентов, поместите их на панели и сделайте примерно так:
procedure TForm1.FormCreate(Sender: TObject);
var I : integer;
begin
with MyPanel do for I:= 0 to ControlCount -1 do
if (Controls[I] IS TEdit) then
(Controls[I] AS TEdit).{Вашпараметр} := {Ваше значение};
end;
В контексте примера, Edit1, Edit2 и т.д. есть то же самое, что и Edit[1], Edit[2]. Если вы хотите иметь доступ к серии элементов управления как к элементам массива, поместите их в TList.
MyArr := TList.Create;
MyArr.Add(Edit1);
MyArr.Add(Edit2);
…
For i := 0 To MyArr.count - 1 Do
(MyArr.items[i] As TEdit).Enabled := False;
MyArr.Free;
procedure TForm1.FormCreate(Sender: TObject);
var I: Integer;
begin
for I := 0 to ComponentCount -1 do
if Components[I] is TEdit then
TEdit(Components[I]).Whatever := 10;
end;
Для получения доступа используйте:
TButton(mylist.items[i]).property := sumpin;
или
TButton(mylist.items[i]).method;
Это хорошее решение для пакетной обработки компонентов или для получения доступа при линейном способе. Для решения вашей проблемы есть еще более легкое решение, которое требует предварительной работы в режиме проектирования. Установите свойство tag и получите преимущество в том, что все компоненты являются производными от TComponent и имеют это свойство.
Procedure TMyForm.MyButtonHandler(Sender: TObject);
Begin
Case (Sender As TComponent).Tag Of
1 : { что-то делаем }
2 : { делаем что-то еще }
.
.
End;
End;
Просто укажите в событии OnClick на MyButtonHandler для тех кнопок, в которых вы хотите использовать общий обработчик события.
Мне надо добавить много строк в TListbox или в TCombobox или в TMemo или в TRichEdit, при этом сам объект постоянно мигает, перерисовываясь. Как избавиться от этого?
Двумя словамиNomadic скупо отвечает: A: BeginUpdate/EndUpdate.
Как мне создать компонент типа TField?
Delphi 1Наверное вы хотели создать класс, а не компонент? Класс является программируемым устройством, а не частью формы. Если вы поместили класс в модуль (скажем, myclass.pas) и вставили в вашу программу строку «uses myclass;», то воспользоваться им можно следующим образом:
type aninstance: tMyclass;
begin
new (aninstance);
{эквивалент aninstance := tMyclass.create; }
…
{ здесь используем aninstance }
…
dispose(aninstance);
{ эквивалент aninstance.free; }
end;
Инкрементация строкового поля
Delphi 1Свойства text элемента управления является строкой, в свою очередь являющейся массивом символом. Вы не можете осуществить преобразование символа в строку. Тем не менее, вы можете получить доступ ко всем символам строки через их индекс. Попробуйте это:
var s : string;
begin
s := RevField.text;
s[1] := chr(ord(s[1]) + 1);
RevField.text := s;
end;
Здесь кроются 2 проблемы:
1. Для увеличения значения вам необходимо извлекать символы из строки.
2. Хотя вы можете получить доступ к отдельным символам через выделение подстроки, данный метод не срабатывает у некоторых свойств, таких как, например, свойство TStringField Text.
Лучшим решением, по-видимому, будет написание специфической функции. Например, в случае, если revision-символ всегда является конечным символом строки, функция могла бы выглядеть следующим образом:
function IncrementTrailingVersionLetter(Str: string): string;
begin
Str[Length(Str)] := Char(Ord(Str[Length(Str)]) + 1);
IncrementTrailingVersionLetter := Str;
end;
и использовать ее следующим образом:
with RevField do Text := IncrementTrailingVersionLetter(Text);
Классы
TForm
fsStayOnTop ~не наверху~
Delphi 1Тема: fsStayOnTop ~не наверху~ От: Philip Kapusta 74170,3550 Почему, если присвоить свойству FormStyle значение fsStayOnTop, форма так и не остается на самом верху? Просто добавьте application.RestoreTopMosts в обработчик события формы OnPaint. Это ошибка. Могли бы вы рассказать об этом чуть-чуть поподробнее? Delphi где-то в неправильном месте осуществляет вызов NormalizeTopMosts? Borland говорит что это Windows, но это случается когда StayonTop-форма НЕ является главной формой. (Некоторые английские программисты чтобы получить эту отговорку потратили несколько сотен долларов, звоня в американскую службу помощи по телефону 1-800). – Fred S.
Без иконки в панели задач?
Если вы не хотите, чтобы ваше приложение имело иконку в панели задач, добавьте следующие строки в исходный код проекта:Application.CreateHandle;
ShowWindow(Application.Handle, SW_HIDE);
Application.ShowMainForm := FALSE;
Да, чуть не забыл, есть еще одна вещь. При нормальном поведении TApplication создает дескриптор и показывает окно прежде, чем далее начнет что-то «происходить». Чтобы избежать этого, вам необходимо создать модуль, содержащий единственную строчку в секции initialization:
IsLibrary := True;
… и поместить этот модуль ПЕРВЫМ в .DPR-файле в списке используемых модулей. Этим мы «одурачиваем» TApplication, и оно думает что оно запущено из DLL, тем самым изменяя свое обычное поведение.
– Neil J. Rubenking
Передача переменных форме
Delphi 1
…поможете мне создать функцию, с помощью которой я передам переменные в TFormClass? Проблема в том, что MyDlg.Execute() не захотела компилироваться, поскольку, как сообщил мне компилятор, я не могу использовать MyDlg (определенный как: TForm). Эта функция может выглядеть примерно так:
function ExecuteDialog(FormClass: TFormClass; var Data): Boolean;
Я могу вам дать еще один совет: сделать все ваши формы наследниками одного класса, в котором объявлены виртуальные методы SetData и GetData.
{ ----------------------- }
unit ExecFrms;
interface
uses Forms, Controls;
type TExecForm = class(TForm)
public
procedure GetData(var Data); virtual; abstract;
procedure SetData(var Data); virtual; abstract;
end;
TExecFormClass = class of TExecForm;
function ExecuteDialog(FormClass: TExecFormClass; var Data): Boolean;
implementation
function ExecuteDialog(FormClass: TExecFormClass; var Data): Boolean;
begin
with FormClass.Create(Application) do try
SetData(Data);
Result := ShowModal = mrOK;
if Result then GetData(Data);
finally
Release;
end;
end;
end.
{ ----------------------- }
Как вы можете видеть, я поместил функцию ExecuteDialog в тот же самый модуль.
После того как Delphi создаст форму, вы должны в модуле формы сделать четыре вещи:
1. вручную измените предка формы, с TForm на TExecForm;
2. добавьте ExecFrms в список используемых модулей;
3. добавьте тип записи для хранения данных, необходимых диалогу; и
4. перекрыть методы SetData и GetData.
{ ----------------------- }
unit MyDlgs;
interface
uses WinTypes, WinProcs, Classes, Graphics, Forms,Controls, Buttons, StdCtrls, Spin, ExtCtrls, ExecFrms;
type
{ Запись для данных, необходимых модальной форме... }
TMyDlgData = record
FormCaption: string;
FormWidth: Integer;
end;
TMyDlg = class(TExecForm)
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
HelpBtn: TBitBtn;
Bevel1: TBevel;
Edit1: TEdit;
SpinEdit1: TSpinEdit;
public
procedure SetData(var Data); override;
procedure GetData(var Data); override;
end;
var MyDlg: TMyDlg;
implementation
{$R *.DFM}
procedure TMyDlg.SetData(var Data);
begin
with TMyDlgData(Data) do begin
Edit1.Text := FormCaption;
SpinEdit1.Value := FormWidth;
end;
end;
procedure TMyDlg.GetData(var Data);
begin
with TMyDlgData(Data) do begin
FormCaption := Edit1.Text;
FormWidth := SpinEdit1.Value;
end;
end;
end.
{ ----------------------- }
Затем создаем и выполняем диалог, который должен выглядеть приблизительно так:
{ Добавьте ExecFrms и MyDlgs в список USES вызывающего модуля. }
procedure TForm1.GetNewCaptionAndWidthBtnClick(Sender: TObject);
var Data: TMyDlgData;
begin
Data.FormCaption := Caption;
Data.FormWidth := Width;
if ExecuteDialog(TMyDlg, Data) then begin
Caption := Data.FormCaption;
Width := Data.FormWidth;
end;
end;
Не поверите: данный код работает еще со времён Turbo Vision!
– Ed Jordan
Освобождение экземпляров формы
Delphi 1В нашем примере для решения задачи мы передаем конструктору переменную формы. Затем, при закрытии формы, мы сбрасываем эту переменную. Естественно, эта технология подразумевает написание некоторого кода, поэтому, если вы не расположены к этому действию, пропустите мое дальнейшее повествование.
TMyForm = class(TForm)
…
private
FormVar: ^TMyForm;
public
constructor Create(AOwner: TComponent; var AFormVar: TMyForm);
destructor Destroy; override;
end;
constructor TMyForm.Create(AOwner: TComponent; var AFormVar: TMyForm);
begin
FormVar := @AFormVar;
inherited Create;
.....
end;
destructor TMyForm.Destroy;
begin
FormVar^ := nil;
inherited Destroy;
end;
MyForm := TMyForm.Create(Self, MyForm);
MyOtherForm := TMyForm.Create(Self, MyOtherForm);
Этот код при разрушении окна автоматически сбрасывает все, что вы передаете в AFormVar, в nil.
Как вы, наверное, заметили, частный член FormVar реально является указателем на указатель. Так, читая содержимое памяти, адрес которой содержится в FormVar, мы реально получаем переменную формы. Таким образом мы можем просто установить ее в nil.
– Jeff Fisher
Условие создания главной формы?
Delphi 2Существует ли в Delphi возможность создавать главную форму по условию? Я хочу использовать условие IF (в зависимости от передаваемого параметра) для того, чтобы определить какая форма будет главной при старте приложения. Фактически «другую» форму НЕ нужно будет загружать. Хитрость здесь заключается в том, что мы предоставляем компилятору весь необходимый для создания форм код, но не допускаем его выполнения (IF FALSE THEN), при этом компилятор не ругается, а мы тем временем (во время выполнения приложения) выбираем и создаем главную форму. Вот пример кода, измененный .DPR-файл, который при старте случайным образом выбирает из друх форм главную:
begin
IF FALSE THEN BEGIN
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
END;
Randomize;
IF Random < 0.5 THEN Application.CreateForm(TForm1, Form1)
ELSE Application.CreateForm(TForm2, Form2);
Application.Run;
end.
Пара «подходящих» для CreateForm форм заключено в никогда не выполнимый блок, тем самым приводя компилятор в состояние свинячего восторга.
– Neil Rubenking
Динамическое создание и циклическое связывание форм
Тема: Динамическое создание и циклическое связывание форм Как сделать простой метод, переключающий между формами? Как мне добавить возвращаемые результаты к моей ShowModal-форме? Как мне создавать экземпляры форм во время выполнения приложения? Необходимый для осуществления этого метод очень прост. В моем примере я использую 3 формы с именами Mainform, Form1 и Form2. На Mainform я установил кнопку, которая выводит Form1, из нее вы можете вызвать любое количество форм (перемещаться между ними) через соответствующие кнопки, расположенные на этих формах. В моем примере "переключение" происходит между формами Form1 и Form2. Шаг 1. Разместите следующие две строчки в секции interface той формы, которая у вас будет главной:const
mrNext = 100;
mrPrevious = 101;
Шаг 2. Разместите на главной форме кнопку и добавьте следующий код в обработчик события ее нажатия:
var
MyForm: TForm;
R, CurForm: Integer;
begin
R := 0;
CurForm := 1;
while R <> mrCancel do begin
Case CurForm of
1: MyForm := TForm1.Create(Application);
2: MyForm := TForm2.Create(Application);
end;
try
R := MyForm.ShowModal;
finally
MyForm.Free;
end;
case R of
MrNext : Inc(CurForm);
MrPrevious : Dec(CurForm);
end;
// эти 2 строчки позволят нам не выходить за границы
if CurForm < 1 then CurForm := 2
else if CurForm > 2 then CurForm := 1;
end; // while
end;
Шаг 3. Добавьте формы 1 и 2 (и любые другие, какие вы хотите иметь) в список используемых модулей формы mainform.
Шаг 4. В форме Form1 и Form2 добавьте MainForm в список используемых модулей (чтобы они видели константы.)
Шаг 5. На форму Form1, Form2, и все последующие, добавьте 2 TBitBtn'а, с заголовками «Next» и «Previous». In the Onclick Events for these buttons add the following line of code.
Если это кнопка Next, добавьте: ModalResult := mrNext;
Если это кнопка Previous, добавьте: ModalResult := mrPrevious;
Как заставить формы минимизироваться на панель задач с анимацией?
Nomadic советует: Дело-то вот в чем: Главным окном программы дельфийской является не главная форма, а окно TApplication, которое имеет нулевые размеры, поэтому его не видно. Именно для него показывается иконка на панели задач. Когда пользователь нажимает кнопку минимизации на главной форме, команда минимизации передается этому окну, и сворачивается именно оно, а для остальных просто делается hide. А так как окно TApplication имеет нулевые размеры, то и анимации никакой не видно. А чтобы этого избежать, необходимо: В исходном тесте модуля проекта после вызова Application.Initialize выполнить вызов
// В исходном тесте модуля проекта после вызова Application.Initialize
SetWindowLong(Application.Handle, GWL_EXSTYLE, GetWindowLong(Application.Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);
В исходном тексте модуля главной формы перекрыть следующие методы –
// // В классе формы
// Интерфейс
protected
procedure CreateParams(var p: TCreateParams); override;
procedure WMSysCommand(var m: TMessage); message WM_SYSCOMMAND;
// Реализация
procedure TMainForm.CreateParams(var p: TCreateParams);
begin
inherited;
p.WndParent := 0;
end;
procedure TMainForm.WMSysCommand(var m: TMessage);
begin
m.Result := DefWindowProc(Handle, m.Msg, m.wParam, m.lParam);
end;
Вместо SetWindowLong в MDI-приложениях лучше использовать
ShowWindow(Application.Handle, SW_HIDE);
Перемещение формы не за заголовок III
Ситников Митрий советует: В следующем примере показано как можно передвигать форму если пользователь "захватил" Client-пространство:
unit Main;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
MX: integer;
MY: integer;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if Shift<>[ssLeft] then begin
MX:=X;
MY:=Y;
end else begin
Left:=Left+X-MX;
Top:=Top+Y-MY;
end;
end;
end.
Перемещение формы не за заголовок IV
Как мне переместить форму, не имеющую заголовка? Выберите элемент управления (или саму форму) и напишите это в его (ее) обработчике события OnMouseDown (данный пример дан только для формы):procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
Perform(WM_SYSCOMMAND, SC_MOVE+2, 0);
end;
Классно! Намного проще метода NCHitTest, который я предлагал. Хотя многое из того, чтобы вы мне написали, я не понял. Для чего нужно прибавлять 2 к параметру SC_MOVE? В справке по API об этом ничего не сказано.
Ну хорошо, есть недокументированный способ сообщить Windows о необходимости перемещения окна таким же способом, что и с помощью заголовка (это может вызвать неадекватную реакцию системы, не делайте этого!). Другим способом перемещения окна является перекрытие WMNCHITTEST и возвращения им значения HTCAPTION. Тем не менее, обычно я предпочитаю пользоваться методом SC_MOVE+2, поскольку он не требует создания потомков, а только создание обработчика OnMouseDown. Отчасти аналогично, вы можете добавлять константы SC_SIZE к WM_SYSCOMMAND для получения размера окна подобно тому, как если бы вы потянули его за бордюрчик. В основном мы добавляем код hittest – 9. В следующем классе определена панель, которая сама изменяет свои размеры при щелчке в ее нижнем правом углу, и сама перемещается, если вы щелкнули по ней где-то еще.
Type TMovablePanel = Class(TPanel)
Private
Procedure wmNCHitTest(Var Message : TWMNCHitTest); message WM_NCHITTEST;
Protected
Procedure MouseDown(Button : TMouseButton; Shift : TShiftState; X, Y : Integer); override;
End;
Procedure TMovablePanel.wmNCHitTest(Var Message : TWMNCHitTest);
Begin
With Message, ScreenToClient(Pos) Do
If (X < Width - 10) And (Y < Height - 10) Then
Message.Result := HTCAPTION
Else Message.Result := HTCLIENT;
End;
Procedure TMovablePanel.MouseDown(Button : TMouseButton; Shift : TShiftState; X, Y : Integer);
Begin
If Button = mbLeft Then Begin
ReleaseCapture;
Perform(WM_SYSCOMMAND, SC_SIZE + HTBOTTOMRIGHT - 9, 0);
End Else Inherited MouseDown(Button, SHift, X, Y);
End;
– Robert Wittig
Как работать с формой, куда динамически передаются страницы (PageControl) из форм-хранителей (с использованием наследования)?
Nomadic советует: Кидаю проект-болванку, сделанную перед началом работы над основным -unit Unit1; //базовая форма хранителя страницы
interface
uses ...
type TBPgFrm = class(TForm)
Panel1: TPanel;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
Label1: TLabel;
public
function PgInit: boolean; virtual;
function PgValid: boolean; virtual;
end;
implementation
{$R *.DFM}
function TBPgFrm.PgInit: boolean;
begin
result:= MessageDlg(Label1.Caption+': PgInit', mtConfirmation, mbOkCancel, 0)=mrOK;
end;
function TBPgFrm.PgValid: boolean;
begin
result:= MessageDlg(Label1.Caption+': PgValid', mtConfirmation, mbOkCancel, 0)=mrOK;
end;
end.
unit Unit2; //главная форма проекта; содержит первую страницу
interface //и кнопки Cancel, Prev & Next/Finish.
uses ...
type TPagesDlg = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
Prev: TButton;
CancelBtn: TButton;
Next: TButton;
Label1: TLabel;
procedure CancelBtnClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure NextClick(Sender: TObject);
procedure PrevClick(Sender: TObject);
privateFrms: TList;
procedure AddForms;
end;
var PagesDlg: TPagesDlg;
implementation
uses Unit1, Unit3, Unit4, Unit5;
{$R *.DFM}
procedure TPagesDlg.AddForms; //размещение динамических страниц
var i: word;
begin
Frms:= TList.Create;
Frms.Add(TBPgFrm1.Create(Self));
Frms.Add(TBPgFrm2.Create(Self));
for i:= 0 to 1 do TBPgFrm(Frms[i]).TabSheet1.PageControl := PageControl1
end;
procedure TPagesDlg.CancelBtnClick(Sender: TObject);
begin
Close;
end;
procedure TPagesDlg.FormDestroy(Sender: TObject);
var i: word;
begin
for i:= Frms.Count-1 downto 0 do TBPgFrm(Frms[i]).Free;
Frms.Free;
end;
procedure TPagesDlg.NextClick(Sender: TObject);
var
i: word;
vi: Boolean;
begin
Next.Enabled:= false;
if PageControl1.PageCount=1 then AddForms;
i:= PageControl1.ActivePage.PageIndex;
if i=0 then vi:= true
else vi:= TBPgFrm(Frms[i-1]).PgValid;
if vi then
with PageControl1 do
if i=PageCount-1 then begin
CancelBtnClick(Sender);
exit;
end else begin
ActivePage:= FindNextPage(ActivePage, True, false);
if ActivePage.PageIndex=PageCount-1 then Next.Caption:= 'Finish';
Prev.Enabled:= true;
if TBPgFrm(Frms[i]).PgInit then Next.Enabled:= true
else PrevClick(Sender);
end else Next.Enabled:= true;
end;
procedure TPagesDlg.PrevClick(Sender: TObject);
begin
Prev.Enabled:= false;
with PageControl1 do begin
ActivePage:= FindNextPage(ActivePage, false, false);
Prev.Enabled:= ActivePage.PageIndex>0;
end;
Next.Caption:= 'Next';
Next.Enabled:= true;
end;
end.
unit Unit3; //наследник с RadioGroup.
interface
uses ...
type TBPgFrm3 = class(TBPgFrm)
RadioValid: TRadioGroup;
public
function PgValid: boolean; override;
end;
implementation
{$R *.DFM}
function TBPgFrm3.PgValid: boolean;
begin
result:= RadioValid.ItemIndex=0;
end;
end.
unit Unit4; // наследник с CheckBox.
interface
uses ...
type TBPgFrm2 = class(TBPgFrm)
CheckValid: TCheckBox;
public
function PgValid: boolean; override;
end;
implementation
{$R *.DFM}
function TBPgFrm2.PgValid: boolean;
begin
result:= CheckValid.Checked;
end;
end.
В Delphi 4 появились новые возможности, в частности, возможность докинга визуальных компонент, в частности, форм, на различные DockSite, в том числе и на TPageControl. Это более удобно. Кроме того, Вы имеете возможность использования TFormLoader из библиотеки VG Library.
IMHO файл *.dfm – это компилированный ресурс с определением установок формы. А можно ли как-то увидеть этот ресуpс в исходном виде?
Nomadic советует: 1. File|Open… ТвояФорма.DFM – увидишь текст; 2. «Delphi\bin\convert ТвояФорма.DFM» — получится ТвояФорма.TXT (можно и наоборот). Идею в массы: в DN/VC/NC можно настроить viewer'ом .DFM .BAT'ник, который скажет convert;wpview;del – и заглядывать в .DFM не открывая Delphi. Кстати, функции, которые реализуют это преобразование, доступны для использования в личных целях :) CLASSES.PAS: […]{ Object conversion routines }
procedure ObjectBinaryToText(Input, Output: TStream);
procedure ObjectTextToBinary(Input, Output: TStream);
procedure ObjectResourceToText(Input, Output: TStream);
procedure ObjectTextToResource(Input, Output: TStream);
Определение перемещения формы
Кто-нибудь знает как мне определить перемещение пользователем главной формы приложения (не изменение ее размеров), кроме как использования таймера и проверки значений свойств Form.Top и Form.Left? Вам можно воспользоваться обработчиками следующих системных сообщений: 1. WM_WINDOWPOSCHANGING (возникает перед перемещением), 2. WM_WINDOWPOSCHANGED (возникает после перемещения), или 3. WM_MOVE (возникает после перемещения) – Robert WittigМожно ли сделать так – одновременно иметь на экране всегда доступную форму – например, "Навигатор", и, открывая модальные формы, иметь всегда доступ к форме "Навигатор"?
Nomadic советует: Обманом можно все.procedure ShowAlmostModal(FormModal:TForm);
begin
NavigatorForm.Enabled:=false;
FormModal.ShowModal
end;
И вот это привесь на OnShow почти модальной формы
procedure FormShow(Sender:Tobject);
begin
NavigatorForm.Enabled:=true;
end;
Как создать окна непрямоугольной формы и работать с ними?
Nomadic советует: Достаточно создать регион нужной формы и вызвать SetWindowRgn —HRGN rgn := CreateEllipticRgn(10,10,100,100);
SetWindowRgn(hMyWnd,rgn); // Вот и будет круглое окно
При этом регион этот теперь используется Windows и будет уничтожен при закрытии окна.
Попробуйте вот этот обpаботчик OnCreate : На меня это произвело впечатление.
procedure TForm1.FormCreate(Sender: TObject);
const W=36*pi/180;
var
R,R1,R2: HRgn;
X,Y,i:integer;
function S(a:integer;R:integer):integer;
begin
Result:=round(R*sin(W*a));
end;
function C(a:integer;R:integer):integer;
begin
Result:=round(R*cos(W*a));
end;
function GetStarReg(X,Y,R:integer):HRGN;
var P : array [0..4] of TPoint;
begin
P[0] := Point(X, Y-R);
P[1] := Point(X-S(4,R), Y-C(4,R));
P[2] := Point(X-S(8,R), Y-C(8,R));
P[3] := Point(X-S(2,R), Y-C(2,R));
P[4] := Point(X-S(6,R), Y-C(6,R));
Result := CreatePolygonRgn(P, 5, WINDING);
end;
begin
X:=Width div 2;
Y:=Height div 2;
R:=GetStarReg(X,Y,100);
i:=1;
repeat
R1:=GetStarReg(X-S(i,120),Y-C(i,110),40);
CombineRgn(R,R,R1,RGN_OR);
inc(i,2);
until i>9;
R1:=GetStarReg(X,Y,30);
CombineRgn(R,R,R1,RGN_DIFF);
R1:=CreateEllipticRgn(3,3,Width-6,Height-6);
R2:=CreateEllipticRgn(20,10,Width-20,Height-10);
CombineRgn(R1,R1,R2,RGN_DIFF);
CombineRgn(R,R,R1,RGN_OR);
SetWindowRgn(Handle, R, True);
end;
Как запретить кнопку Close [×] в заголовке окна?
Nomadic советует: Вот кусок, который делает все, что тебе нужно:procedure TForm1.FormCreate(Sender: TObject);
var Style: Longint;
begin
Style := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, Style And Not WS_SYSMENU);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (Key = VK_F4) and (ssAlt in Shift) then begin
MessageBeep(0);
Key := 0;
end;
end;
{ Disable close button }
procedure TForm1.Button1Click(Sender: TObject);
var SysMenu: HMenu;
begin
SysMenu := GetSystemMenu(Handle, False);
Windows.EnableMenuItem(SysMenu, SC_CLOSE, MF_DISABLED or MF_GRAYED);
end;
{ Enable close button }
procedure TForm1.Button2Click(Sender: TObject);
begin
GetSystemMenu(Handle, True);
Perform(WM_NCPAINT, Handle, 0);
end;
Но это окно можно закрыть из TaskBar'а.
Мерцание формы
Как бы это осуществить рисование в окне без его дурацкого мерцания и без помощи создания виртуального изображения в памяти? WM_SETREDRAW здесь поможет? Попробуйте этот код. Даже если некоторые компоненты имеют пару BeginUpdate / EndUpdate, то для таких компонентов, как TTreeView, интенсивное рисование может послужить причиной перемещения полосы прокрутки и появления других «барабашек». В таких ситуаций вместо дескриптора элемента управления используйте родительский дескриптор.procedure BeginScreenUpdate(hwnd : THandle);
begin
if (hwnd = 0) then hwnd := Application.MainForm.Handle;
SendMessage(hwnd, WM_SETREDRAW, 0, 0);
end;
procedure EndScreenUpdate(hwnd : THandle; erase : Boolean);
begin
if (hwnd = 0) then hwnd := Application.MainForm.Handle;
SendMessage(hwnd, WM_SETREDRAW, 1, 0);
RedrawWindow(hwnd, nil, 0, DW_FRAME + RDW_INVALIDATE + RDW_ALLCHILDREN + RDW_NOINTERNALPAINT);
if (erase) then Windows.InvalidateRect(hwnd, nil, True);
end;
– Jeff Johnson
Минимизация модального окна
Мне нужно открыть из моей формы модальное окно, т.е. приостановить работу в моей форме до обработки этого модального окна. Но при этом я теряю возможность убрать (минимизировать) мою форму Nomadic советует:function TMyForm.Execute: TModalResult;
begin
Show;
try
SendMessage(Handle, CM_ACTIVATE, 0, 0);
ModalResult := 0;
repeat
Application.HandleMessage;
if Application.Terminated then ModalResult := mrCancel;
if ModalResult = mrCancel then CloseModal;
until ModalResult <> 0;
Hide;
Result := ModalResult;
SendMessage(Handle, CM_DEACTIVATE, 0, 0);
finally
Hide;
end;
end;
Конечно, в TMyForm должно быть FormStyle := fsStayOnTop;
Прозрачная форма
Dmitry V. Koreyba советует: Высылаю прогу которая делает прозрачной форму. Может кому-нибудь поможет в его дизайнерских изысканиях.var FullRgn, ClientRgn, CtlRgn : THandle;
procedure TForm1.DoInvisible;
var
AControl : TControl;
A, Margin, X, Y, CtlX, CtlY : Integer;
begin
Margin := (Width - ClientWidth) div 2;
FullRgn := CreateRectRgn(0, 0, Width, Height);
X := Margin;
Y := Height - ClientHeight - Margin;
ClientRgn := CreateRectRgn(X, Y, X + ClientWidth, Y + ClientHeight);
CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF);
for A := 0 to ControlCount - 1 do begin
AControl := Controls[A];
if (AControl is TWinControl) or (AControl is TGraphicControl) then
with AControl do begin
if Visible then begin
CtlX := X + Left;
CtlY := Y + Top;
CtlRgn := CreateRectRgn(CtlX, CtlY, CtlX + Width, CtlY + Height);
CombineRgn(FullRgn, FullRgn, CtlRgn, RGN_OR);
end;
end;
end;
SetWindowRgn(Handle, FullRgn, TRUE);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteObject(ClientRgn);DeleteObject(FullRgn);
DeleteObject(CtlRgn);
end;
procedure TForm1.DoVisible;
begin
FullRgn := CreateRectRgn(0, 0, Width, Height);
CombineRgn(FullRgn, FullRgn, FullRgn, RGN_COPY);
SetWindowRgn(Handle, FullRgn, TRUE);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DoInvisible;
end;
Каким образом можно изменить системное меню формы?
Nomadic советует: Hе знаю как насчет акселераторов,надо поискать, а вот добавить пункт меню(Item) — пожалуйстаtype TMyForm=class(TForm)
procedure wmSysCommand(var Message:TMessage); message WM_SYSCOMMAND;
end;
const
ID_ABOUT = WM_USER+1;
ID_CALENDAR=WM_USER+2;
ID_EDIT = WM_USER+3;
ID_ANALIS = WM_USER+4;
implementation
procedure TMyForm.wmSysCommand;
begin
case Message.wParam of
ID_CALENDAR:DatBitBtnClick(Self);
ID_EDIT :EditBitBtnClick(Self);
ID_ANALIS:AnalisButtonClick(Self);
end;
inherited;
end;
procedure TMyForm.FormCreate(Sender: TObject);
var SysMenu:THandle;
begin
SysMenu:=GetSystemMenu(Handle,False);
InsertMenu(SysMenu, Word(-1), MF_SEPARATOR, ID_ABOUT, '');
InsertMenu(SysMenu, Word(-1), MF_BYPOSITION, ID_Calendar, 'Calendar');
InsertMenu(SysMenu, Word(-1), MF_BYPOSITION, ID_Analis, 'Analis');
InsertMenu(SysMenu, Word(-1), MF_BYPOSITION, ID_Edit, 'Edit');
end;
Как сделать MDI-приложение, в котором способны сливаться не только меню дочернего и главного окна, но и полосы инструментов?
Nomadic советует:Вариант 1. CoolBar.
procedure TMainForm.SetBands(AControls: array of TWinControl;ABreaks: array of boolean);
var i: integer;
begin
with CoolBar do begin
for i:=0 to High(AControls) do begin
if Bands.Count=succ(i) then TCoolBand.Create(Bands);
with Bands[succ(i)] do begin
if Assigned(Control) then Control.Hide;
MinHeight:=AControls[i].Height;
Break:=ABreaks[i];
Control:=AControls[i];
Control.Show;
Visible:=true;
end
end;
for i:=High(AControls)+2 to pred(Bands.Count) do Bands[i].Free
end
end;
и
procedure TMsgForm.FormActivate(Sender: TObject);
begin
MainForm.SetBands([ToolBar],[false])
end;
Примечание:
Оба массива равны по длине. CoolBar.Bands[0] должен существовать всегда,.. на нём я размешаю «глобальные» кнопки. СoolBar[1] тоже можно сделать в DesignTime с Break:=false и придвинуть поближе с началу. При CoolBar.AutoSize:=true возможно «мигании» (при добавлении на новую строку) так что можно добавить:
AutoSize:=false; try … finally AutoSize:=true;
Вариант 2.
TMainForm
…
object SpeedBar: TPanel
...
Align = alTop
BevelOuter = bvNone
object ToolBar: TPanel
...
Align = alLeft
BevelOuter = bvNone
end
object RxSplitter1: TRxSplitter
...
ControlFirst = ToolBar
ControlSecond = ChildBar
Align = alLeft
BevelOuter = bvLowered
end
object ChildBar: TPanel
...
Align = alClient
BevelOuter = bvNone
end
end
TMdiChild {прародитель всех остальных}
..
object pnToolBar: TPanel
…
Align = alTop
BevelOuter = bvNone
Visible = False
end
end;
procedure TMDIForm.FormActivate(Sender: TObject);
begin
pnToolBar.Parent:=MainForm.ChildBar;
pnToolBar.Visible:=True;
end;
procedure TMDIForm.FormDeactivate(Sender: TObject);
begin
pnToolBar.Visible:=false;
pnToolBar.Parent:=self
{pnToolBar.Visible:=false}
end;
Заполнение изображением MDI-формы IV
Nomadic советует: Я делал так:type
…. = class(TForm)
....
procedure FormCreate(Sender:TObject);
procedure FormDestroy(Sender:TObject);
....
private
FHBrush: HBRUSH;
FCover: TBitmap;
FNewClientInstance: TFarProc;
FOldClientInstance: TFarProc;
procedure NewClientWndProc(var Message:TMessage);
....
protected
....
procedure CreateWnd; override;
....
end;
.....
implementation
{$R myRes.res} //ресурс с битмапом фона
procedure .FormCreate(...);
var LogBrush:TLogbrush;
begin
FCover:=TBitmap.Create;
FCover.LoadFromResourceName(hinstance,'BMPCOVER');
With LogBrush do begin
lbStyle:=BS_PATTERN;
lbHatch:=FCover.Handle;
end;
FHBrush:=CreateBrushIndirect(Logbrush);
end;
procedure .FormDestroy(...);
begin
DeleteObject(FHBrush);
FCover.Free;
end;
procedure .CreateWnd;
begin
inherited CreateWnd;
if (ClientHandle <> 0) then begin
if NewStyleControls then
SetWindowLong(ClientHandle, GWL_EXSTYLE, WS_EX_CLIENTEDGE or GetWindowLong(ClientHandle, GWL_EXSTYLE));
FNewClientInstance:=MakeObjectInstance(NewClientWndProc);
FOldClientInstance:=pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, longint(FNewClientInstance));
end;
end;
procedure .NewClientWndProc(var Message:TMessage);
procedure Default;
begin
with Message do
Result := CallWindowProc(FOldClientInstance, ClientHandle, Msg, wParam, lParam);
end;
begin
with Message do begin
case Msg of
WM_ERASEBKGND:
begin
FillRect(TWMEraseBkGnd(Message).DC, ClientRect,FHBrush);
Result := 1;
end;
else
Default;
end;
end;
end;
Предотвращение закрытия формы
Igor Nikolaev aKa The Sprite советует: Следующий текст убирает команду закрыть из системного меню и одновременно делает серой кнопку закрыть в заголовке формы:procedure TForm1.FormCreate(Sender: TObject);
var hMenuHandle:HMENU;
begin
hMenuHandle := GetSystemMenu(Handle, FALSE);
IF (hMenuHandle <> 0) THEN DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
Немедленный TrayIcon после старта приложения
Нужно чтобы при запуске приложения сразу исчезала с экрана главная форма и появлялась TrayIcon. В Ваших «Советы по Дельфи» на данный вопрос я нашел два решения (раздел Классы/TForm) к сожалению ни одно решения на моем компьютере не работало :-(. В связи с этим было решено продолжить поиск, и решение было найдено: На Главную форму приложения помещаем компонент (TEdit или другой любой, который может иметь фокус), затем устанавливаем свойства:Visible:=True;
TabOrder:=0;
В обработчик события OnEnter записываем (этот код взял из «Советов по Дельфи»):
Application.Minimize;
ShowWindow(Application.Handle, SW_HIDE);
Button1.SetFocus; //Устанавливаем фокус на другой компонент формы (у меня был Button1 )
Edit1.Visible:=False; //Делаем добавочный компонент невидимым – т.к. он больше нам не нужен
Механизм работы:
При запуске приложения создается форма и фокус получает компонент со свойством TabOrder:=0, при получении фокуса вызывается процедура OnEnter для нашего компонента и происходит скрытие формы.
Для восстановления формы необходим код:
ShowWindow(Application.Handle, SW_RESTORE);
Application.Restore;
Для реализации TrayIcon был использован компонент TRxTrayIcon избиблиотеки RxLib ver.2.75 Данное решение имеет один недостаток – незначительное мерцание формы при ее сворачивании.
-----------------------------------------------------------------
С уважением Пащенко Андрей Владимирович (Bibigon)
г.Архангельск, 2000.
Заполнение формы изображением
Почитал я тут ваши 'Советы ……' и решил дополнить ответ по теме создание фона на форме раздела классы\tform Чтобы заполнить вашу форму повторяющимся изображением нужно 1. Разместить на форме image 2. Присвоить его свойству visible значение false 3. В обработчике события формы OnCreate разместить следующий код :form1.brush.bitmap:=image1.picture.bitmap;
Хочу заметить , что при использовании этого св-ва св-ва color & style не действительны! А самое главное при изменении размеров формы ваше повторяюшееся изображение будет автоматически перересовываться и вам не понадобится обрабатывать событие paint & resize.
С уважением, Dmitry Morsin
Создание консольных приложений
Создание консольных приложений. (Об этом в советах немножко есть, но очень не конкретно) Как уже отмечалось в совете [000092] (да и в Хелпе) в консольных приложениях в Delphi можно использовать в принципе весь дельфийский арсенал. Правда и работать они будут лишь под Windows. (Кстати этот способ можно применить для модернизации программ на Паскале под Windows). Этот код был использован для вывода результатов работы программы проверки (неважно чего) чтобы не приходилось смотреть файл с результатами. Главная проблема была в том, что консоль (если запуск был из Windows) оставалась висеть позади формы до её закрытия. Вреда конечно никакого, но не приятно. Если же запуск из Нортона или т.п., то всё идёт нормальноProgram MyProgram;
{$APPTYPE CONSOLE}
uses
Windows, Forms, Dialogs, SysUtils, StdCtrls, Controls; // и (или) т.п.
…
var
…
SH,SW: integer;
MainForm: TForm; // если нужна форма
Memo: TMemo;
// могут быть также любые другие визуальные компоненты
…
// здесь могут быть процедуры и функции, т.е всё как в обычном Паскале
Begin
… // здесь какой-то код
{ а здесь, перед выводом формы, есть два пути:}
{ так}
FreeConsole; // Отцепиться от консоли, т.е она просто исчезнет (в случае запуска из Windows) и останется только форма
{ или так}
// Handle:= GetForegroundWindow; // Получить Handle консоли
// ShowWindow(Handle, SW_HIDE); // Спрятать консоль
// а в конце, перед завершением
// ShowWindow(Handle, SW_SHOW); // Показать консоль
{ для помещения формы в центр экрана}
SH:= Screen.Height;
SW:= Screen.Width;
MainForm:= TForm.Create(nil);
with MainForm do try
BorderStyle:= bsSizeable;
Height:= 390;
Width:= 390;
Left:= (SW - Width) div 2;
Top:= (SH - Height) div 2;
Caption:= 'Моя программа';
// здесь могут быть и другие компоненты
Memo:= TMemo.Create(MainForm);
with Memo do begin
Parent:= MainForm;
Align:= alClient;
BorderStyle:= bsNone;
Font.Name:= 'Courier New Cyr';
Font.Size:= 9;
ScrollBars:= ssVertical;
Lines.LoadFromFile('MyProgram.txt');
end;
ShowModal;
finally
Free;
end;
{ или можно вывести сообщение, например в случае неудачи (или наоборот)}
with CreateMessageDialog('Текст сообщения', mtInformation, [mbOk]) do try
Caption := 'Заголовок';
ShowModal;
finally
Free;
end;
// это для второго пути, иначе она так и останется висеть свёрнутой
// ShowWindow(Handle, SW_SHOW); // Показать консоль
End.
С уважением, Михаил Чумак.
События приложения
Delphi 1…проблема в том, что когда приложение Delphi минимизировано, десктиптор окна в этом случае совершенно другой. Объект Application в действительности дескриптор собственного окна! Application.Handle является окном, которое активно при минимизированном приложении. Когда вы минимизируете ваше приложение, все формы просто прячутся (hidden). Обратите внимание на методы Application Minimize и Restore. Также обратите внимание, что у TApplication есть два недокументированных события, OnMinimize и OnRestore. Они принадлежат приложению, поскольку в TForm нет обработчиков событий, возникающих при минимизации главного окна. Немного странно. Я думаю так сделано для поддержки SDI-приложений.
Нужны ли мне формы в сервере приложений?
Nomadic отвечает: Да. Необязательно, чтобы они были видимы, но должна присутствовать хотя бы одна. Чтобы сделать главную форму невидимой, установитеApplication.ShowMainForm := False
в файле проекта.
Пример:
begin
Application.ShowMainForm := False;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Создание формы на основе строки
Обзор
В данном документе рассказывается о том, как в Delрhi можно создать экземпляр формы на основе строки, содержащей имя типа. Код примера прилагается.На кого расчитан данный документ?
На любого программиста, имеющего начальные знания для работы с Delphi. Имеет отношение к любой версии Delphi.Создание формы на основе строки
Чтобы можно было создать экземпляр формы на основе строки, содержащей имя типа, вы должны в первую очередь зарегистрировать данный тип в Delphi. Это выполняется функцией "RegisterClass". RegisterClass описан следующим образом:procedure RegisterClass(AClass: TPersistentClass);
AClass – класс TPersistent. Другими словами, класс, который вы хотите регистрировать, в какой-то точке должен наследоваться от TPersistent. Поскольку все элементы управления Delphi, включая формы, соблюдают это требование, то проблем быть не должно. Но такой способ не пройдет, если регистрируемые классы наследуются непосредственно от TObject.
После регистрации класса, вы можете найти указатель на тип, передавая строку в FindClass. Функция возвратит ссылку на класс, которую можно использовать для создания формы. Небольшой поясняющий пример:
procedure TForm1.Button2Click(Sender: TObject);
var
b : TForm;
f : TFormClass;
begin
f := TFormClass(findClass('Tform2'));
b := f.create(self);
b.show;
end;
Данный код создаст тип TForm2, который мы зарегистрировали с помощью RegisterClass.
Демонстрационный проект
Создайте новый проект, затем добавьте 4 формы так, чтобы в общей сложности получилось 5. В реальном проекте вы можете заполнить их необходимыми элементами управления, для данного же примера это не важно. В первой форме разместите поле редактирования и кнопку. Удалите все формы, кроме главной, из списка AutoCreate. Наконец, скопируйте приведенный ниже код в unit1, он позволит вам создавать форму по имени типа класса, введенному в поле редактирования.unit Unit1;
interface
uses Unit2, Unit3, Unit4, Unit5, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterClass(Tform2);
RegisterClass(Tform3);
RegisterClass(Tform4);
RegisterClass(Tform5);
end;
procedure TForm1.Button1Click(Sender: TObject);
var f : Tformclass;
begin
f := tformclass(findClass(edit1.text));
with f.create(self) do show;
end;
Показ логотипа при запуске приложения III
Своим опытом делится Nomadic : A: Смотрите пример в X:\DELPHI\DEMOS\DB\MASTAPP\mastapp.dpr. Удобно использовать функцию ShowSplashWindow из rxLib.Показ логотипа при запуске приложения IV
Как добавить логотип к вашему приложению Логотип (заставка) является важной составляющей вашего приложения. Он позволяет занять время во время загрузки и сообщить пользователю дополнительные сведения о программе. Логотип сделает ваше приложение более профессиональным. Кроме того, заставка позволяет не только отличить ваше приложение от другого, но и отличить одну версию приложения от другой. Имеется множество типов заставок (Splash Screen). Самый распространный тип - показ логотипа во время загрузки приложения. Обычно такие экраны отображают имя приложения, автора, версию, авторские права и изображение или иконку, идентифицирующую приложение. Также, некоторые приложения используют этот экран для показа линейки прогресса при выполнении длительного процесса. Примером такого типа экрана может быть диалог с выводом числа процентов выполненного запроса к базе данных, файловая задача, или задача обработки чисел. При длительных процессах наличие такого диалога означает вежливость программы по отношению к пользователю. Надеюсь, вы оценили преимущества заставок. Давайте теперь попробуем создать простую заставку своими руками. 1. Добавьте форму в ваш проект --> File | New Form.. Комментарий: Заставка (Splash Screen) похожа на любую другую форму. 2. Измените свойство формы Name на SplashScreen 3. Измените свойство формы BorderStyle на bsNone 4. Измените свойство формы Position на poScreenCenter 5. Сделайте заставку привлекательной и функциональной путем добавления на нее необходимых компонентов и изображений. (компоненты Label, Panel, Image, Shape и Bevel) 6. Отредактируйте свойства добавленных компонентов 7. Выберите в меню Delphi IDE Options | Project 8. Уберите SplashScreen-форму из списка Auto-create-списка (списка автоматически создаваемых форм) Комментарий: Вы динамически создаете экземпляр заставки 9. Добавьте модуль, содержащий TSplashScreen, в список используемых модулей главной формы вашего приложения. Пример:unit Unit1;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes,Graphics, Controls, Forms, Dialogs, StdCtrls, unit2; <– поместите сюда
Комментарий: В нашем примере TSplashScreen объявлен в Unit2
10. Выберите в меню Delphi IDE View | Project Source
11. Вставьте между ключевым словом begin и перед любым Application.Create() следующий код:
SplashScreen := TSplashScreen.Create(Application);
SplashScreen.Show;
SplashScreen.Refresh;
12. Измените поведение главной формы приложения при наступлении события OnShow. Добавьте следующий код:
SplashScreen.Free;
Комментарий: Реализация заставки с линейкой прогресса ничуть не сложнее, чем приведенный выше пример. Необходимо всего лишь вовремя выводить ее на экран: перед тем, как процесс начнется, и убирать только после того, как он закончится. Различие заключается в осуществлении связи (реализации механизма) между процессом и заставкой для правильного обновления линейки прогресса.
13. Запустите приложение. В приведенном выше примере, если скорость вашего компьютера значительна, то заставки вы можете и не увидеть. Следующий код демонстрирует технику создания заставки для вашего приложения — только будьте осмотрительней при его использовании.
Добавьте следующий код на этапе #11:
for x:= 1 to 10000000 do begin
x:=x;
end;
{PROJECT1.DPR}
program Project1;
uses Forms, Unit1 in 'UNIT1.PAS' {Form1}, Unit2 in 'UNIT2.PAS' {SplashScreen};
{$R *.RES}
var x: longint;
begin
SplashScreen:= TSplashScreen.Create(Application);
SplashScreen.Show;SplashScreen.Refresh;
for x:= 1 to 10000000 do begin
x:=x;
x:=x;
end;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
{UNIT1.PAS}
unit Unit1;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, unit2;
type TForm1 = class(TForm)
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormShow(Sender: TObject);
begin
splashscreen.free;
end;
end.
{UNIT2.PAS}
unit Unit2;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;
type TSplashScreen = class(TForm)
Panel1: TPanel;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Shape1: TShape;
Shape2: TShape;
Shape3: TShape;
private
{ Private declarations }
public
{ Public declarations }
end;
var SplashScreen: TSplashScreen;
implementation
{$R *.DFM}
end.
Как правильно закрыть и удалить форму? Почему моя MDI Child форма при закрывании просто минимизируется?
Своим опытом делится Nomadic: A: Обрабатывайте событие OnClose для формы и выставляйте в нем параметр Action в caFree. Дело в том, что его значение по умолчанию для MDI Child форм caMinimize. Кстати, если сделать Action := caNone, то форму нельзя будет закрыть.Как установить максимальный и минимальный размер формы
Если вы хотите контролировать изменение пользователем размера вашей формы, воспользуйтесь установкой значения MinMax. (Если для этих целей вы используете метод resize, это работает, но выглядит не так хорошо.) Примечание: Чтобы совсем запретить пользователю изменять размеры формы, задайте одинаковые значения для ее минимального и максимального значения. Вот пример того, как можно объявить и использовать в вашем приложении обработку системного сообщения wm_GetMinMaxInfo:unit MinMax;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs;
type TForm1 = class(TForm)
private
{ Private declarations }
procedure WMGetMinMaxInfo(var MSG: Tmessage); message WM_GetMinMaxInfo;
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMGetMinMaxInfo(var MSG: Tmessage);
Begin
inherited;
with PMinMaxInfo(MSG.lparam)^ do begin
with ptMinTrackSize do begin
X := 300;
Y := 150;
end;
with ptMaxTrackSize do begin
X := 350;
Y := 250;
end;
end;
end;
end.
TIniFile
Проблемы ini-файла
Кто-нибудь имел какие-нибудь проблемы при использовании модуля TIniFile? Я думаю здесь какая-то детская проблема с кэшированием!!! Вот что я делал:(* c:\test.ini уже существует *)
myIni := TIniFile.Create('c:\test.ini');
With myIni do begin
…. (добавляем новую секцию в test.ini
end;
myIni.Free;
RenameFile('c:\test.ini', 'c:\test1.ini');
Что я получил:
1. test1.ini НЕ ИМЕЕТ добавленной мною секции;
2. всякий раз при создании или открытии нового файла в том же самом каталоге с помощью File Manager, 'c:\test.ini' появляется вновь, и у него СУЩЕСТВУЕТ секция, которую я добавлял.
Я решил эту проблему добавлением следующей строки перед IniFile.Free:
WritePrivateProfileString(nil, nil, nil, PChar(IniFileName));
Для получения дополнительной информации обратитесь к электронной справке к разделу 'WritePrivateProfileString'.
– Tony Chang
Как создать Ini-файл в директории программы?
По умолчанию ini-файл создается в Windows-директории (например: TIniFile.Create('MFile.ini')), что приводит к «захламлению» оной. Более (эко-)логично (за исключением случаев, когда программа делается для CD-ROM) если ini-файл создается в той же директории что и главная программа. Вот пример чтения и записи ini файла из директории программы:function ReadIni(ASection, AString : String) : String;
var
sIniFile: TIniFile;
sPath : String[60];
begin
GetDir(0,sPath);
sIniFile := TIniFile.Create(sPath + '\Name.INI');
Result := sIniFile.ReadString(ASection, AString, S);
sIniFile.Free;
end;
procedure WriteIni(ASection, AString, AValue: String);
var
sIniFile: TIniFile;
sPath : String[60];
begin
GetDir(0,sPath);
sIniFile := TIniFile.Create(sPath + '\Name.INI');
sIniFile.WriteString(ASection, AString, AValue);
sIniFile.Free;
end;
TRegistry
Дополненный TRegistry, умеет работать с значениями типа REG_MULTI_SZ (Windows NT, Windows 2000)
Кондратюк Виталий советует:unit Reg;
{$R-,T-,H+,X+}
interface
uses Registry, Classes, Windows, Consts, SysUtils;
type TReg = class(TRegistry)
public
procedure ReadStringList(const name : string; list : TStringList);
procedure WriteStringList(const name : string; list : TStringList);
end;
implementation
//*** TReg *********************************************************************
//------------------------------------------------------------------------------
// Запись TStringList ввиде значения типа REG_MULTI_SZ в реестр
//------------------------------------------------------------------------------
procedure TReg.WriteStringList(const name : string; list : TStringList);
var
Buffer : Pointer;
BufSize : DWORD;
i, j, k : Integer;
s : string;
p : PChar;
begin
{подготовим буфер к записи}
BufSize := 0;
for i:=0 to list.Count-1 do inc(BufSize, Length(list[i])+1);
inc(BufSize);
GetMem(Buffer, BufSize);
k := 0;
p := Buffer;
for i:=0 to list.Count-1 do begin
s := list[i];
for j:=0 to Length(s)-1 do begin
p[k] := s[j+1];
inc(k);
end;
p[k] := chr(0);
inc(k);
end;
p[k] := chr(0);
{запись в реестр}
if RegSetValueEx(CurrentKey, PChar(name), 0, REG_MULTI_SZ, Buffer, BufSize) <> ERROR_SUCCESS then raise ERegistryException.CreateResFmt(@SRegSetDataFailed, [name]);
end;
//------------------------------------------------------------------------------
// Чтение TStringList ввиде значения типа REG_MULTI_SZ из реестра
//------------------------------------------------------------------------------
procedure TReg.ReadStringList(const name : string; list : TStringList);
var
BufSize,DataType: DWORD;
Len, i: Integer;
Buffer: PChar;
s: string;
begin
if list = nil then Exit;
{чтение из реестра}
Len := GetDataSize(Name);
if Len < 1 then Exit;
Buffer := AllocMem(Len);
if Buffer = nil then Exit;
try
DataType := REG_NONE;
BufSize := Len;
if RegQueryValueEx(CurrentKey, PChar(name), nil, @DataType, PByte(Buffer), @BufSize) <> ERROR_SUCCESS then raise ERegistryException.CreateResFmt(@SRegGetDataFailed, [name]);
if DataType <> REG_MULTI_SZ then raise ERegistryException.CreateResFmt(@SInvalidRegType, [name]);
{запись в TStringList}
list.Clear;s := '';
for i:=0 to BufSize-2 do begin
// BufSize-2 т.к. последние два нулевых символа
if Buffer[i] = chr(0) then begin
list.Add(s);
s := '';
end else s := s + Buffer[i];
end;
finally
FreeMem(Buffer);
end;
end;
end.
Как я могу определить доступные сервера приложений на этой машине через Registry?
Nomadic советует: Прочитайте ключ под HKEY_CLASSES_ROOT\CLSID\*, просматривая его насчёт ключей, которые имеют подключ "Borland DataBroker". Эти вхождения и являются серверами приложений. Ниже пример, который загружает имена доступных серверов приложений в Listbox:uses Registry;
procedure TForm1.FormCreate(Sender: TObject);
var
I: integer;
TempList: TStringList;
begin
TempList := TStringList.Create;
try
with TRegistry.Create do try
RootKey := HKEY_CLASSES_ROOT;
if OpenKey('CLSID', False) then GetKeyNames(TempList);
CloseKey;
for I := 1 to TempList.Count - 1 do
if KeyExists('CLSID\' + TempList[I] + '\Borland DataBroker') then begin
if OpenKey('CLSID\' + TempList[I] + '\ProgID', False) then begin
Listbox1.Items.Add(ReadString(''));
CloseKey;
end;
end;
finally
Free;
end;
finally
TempList.Free;
end;
end;
OLE+
ActiveX
Ошибка 'EOLESYS..OPERATION UNAVAILABLE' (операция недоступна) при использовании GETACTIVEOLEOBJECT
Delphi 3Это происходит при использовании сервера автоматизации 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. Мы не регистрируем это автоматически в таблице, поэтому, чтобы воспользоваться его функциональным назначением, вы должны получить этот интерфейс и использовать его методы для регистрации.
Ошибка 'TACTIVEFORMX DECLARATION MISSING OR INCORRECT' (определение TACTIVEFORMX отсутствует или неправильно)
Delphi 3Обычно это происходит при неправильном порядке изменения имени ActiveForm (смотри README.TXT). Если сначала изменяется имя CoClass, а затем делается обновление (refresh), возникает AV. При дальнейшей попытке изменить имя в Инспекторе Объектов вы получите ошибку «TActiveFormX declaration missing or incorrect» (определение TActiveFormX отсутствует или неправильно). Для решения проблемы откройте .DFM-файл и измените строчку:
object ActiveFormX: TActiveFormX
на
object MyForm: TMyForm
Лицензирование активных форм и ActiveX
Delphi 3Почему 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 могут нанести вред компьютеру!
Добавление IPERSISTPROPERTYBAG к активным элементам управления
Delphi 3Данный совет рассказывает о том, как можно добавить интерфейс 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>
Заголовок кнопки теперь будет говорить вам «Привет». В нашем примере заголовок будет доступен только с помощью данного метода. Для того, чтобы рулить другими свойствами, следуйте нашему примеру и изменяйте имя свойства, которое вы хотите использовать.
Использование ChartFX
Delphi 1Это код, который я использую для установки chartfx.
chart1.Opendata[cod_values]:=makelong(no_of_series, no_of_classes);
{установка последовательных значений}
chart1.closedata[cod_values]:=0;
unit TstChart;
interface
uses= WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Menus, Dialogs, StdCtrls, Buttons, ExtCtrls, Tabs, ChartFX, {Похоже, действительно необходимо включить этот модульв список, чтобы иметь доступ к константам, например к COD_VALUES} VBXCtrl, Chart2fx;
type TF_Chart = 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 := NB.Pages;
NB.PageIndex := 0;
Build1(Chart2);
Build2(Chart2); {добавляем значения для Chart2: length... и т.д.}
end;
procedure TF_Chart.TBClick(Sender: TObject);
begin
NB.PageIndex := TB.TabIndex;
end;
Procedure TF_Chart.Build1(Ch : TChartFX);
begin
{Эта процедура изменяет свойства, которые могут устанавливаться во время разработки или временя выполнения. В коментариях подробно указано чем занимается метод Design}
with Ch do begin
Adm[CSA_GAP] := 25.0;
{Design: Используйте свойство AdmDlg для изменения координаты Y}
pType := BAR or CT_LEGEND;
{Design: Изменяем свойство ChartType с 1 - lineна 2 - bar.}
DecimalsNum[CD_YLEG] := 0;
{Design: Изменяем свойство Decimals с 2 до 0}
Stacked := CHART_STACKED;
{Design: Изменяем свойство Stacked с 0 - None на 1 - Normal}
RightGap := 20;
{Design: Тоже}
OpenData[COD_COLORS] := 2;
Color[0] := clBlack;
Color[1] := clYellow;
CloseData[COD_COLORS] := 0;
{Фу!!}
{Design: Для изменения цветов 2 серий:1) Убедитесь, что ThisSerie установлен в 0. ИзменитеThisColor на clBlack.2) Установите ThisSerie в 1. Измените ThisColor наclYellow.}
Title[CHART_TOPTIT] := 'Статьи и заголовки';
Title[CHART_LEFTTIT] := 'CCM';
Title[CHART_BOTTOMTIT] := 'Карты';
{Design: щелкните на свойстве TitleDlg и установите верхний, левый и нижний заголовки}
end;
end;
Procedure TF_Chart.Build2(Ch : TChartFX);
{Данная процедура устанавливает свойства, которые не могут (насколько я определил это) быть установлены в режиме разработки}
const
XAbbrevs : array[0..4] of string[4] =('Acc', 'Bar', 'Mas', 'Amex', 'Din');
SeriesTitles : array[0..1] of string[8] =('Статьи', 'Заголовки');
XTitles : array[0..4] of string[20] = ('Access', 'Barclaycard', 'Mastercard', 'American Express', 'Diners');
{естественно, вы должны нормально читать из базы данных xTitles и значения}
Values : array[0..1, 0..4] of double =((50, 60, 70, 80, 90),(30, 35, 25, 37, 42));
var i, SerieNo : integer;
begin
with Ch do begin
LegendWidth := 120;
{Установка количества серий, количества значений ******************}
OpenData[COD_INIVALUES] := MAKELONG(2, 5);
CloseData[COD_INIVALUES] := 0;
{*********************************************************}
OpenData[COD_VALUES] := 2;
{если вы пропускаете приведенное выше утверждение, (в котором вы вводите номер SERIES и VALUES), и CloseData ниже, назначение значений не создает ошибки, но и не работает! Назначение значений Legend и KeyLeg работает без OpenData/CloseData}
ThisSerie := 0;
for i := 0 to 1 do SerLeg[i] := SeriesTitles[i];
for i := 0 to 4 do= begin
Legend[i] := XTitles[i];
KeyLeg[i] := XAbbrevs[i];
end;
SerieNo := 0;
for SerieNo := 0 to 1 do begin
ThisSerie := SerieNo;
for i := 0 to 4 do Value[i] := Values[SerieNo, i];
end;
CloseData[COD_VALUES] := 0;
end;
end;
procedure TF_Chart.FormResize(Sender: TObject);
var w, h : longint;
begin
w := NB.Width;
H := NB.Height;
{при необходимости увеличиваем/уменьшаем размер диаграммы}
Chart1.Width := W – 18;
Chart1.Height := H – 12;
Chart2.Width := W – 18;
Chart2.Height := H – 12;
{перемещаем кнопку выхода в правый угол}
ExitBtn.Left := SpeedPanel.Width – 32;
end;
end.
CHARTFX – минимум максимум
Delphi 2Так можно сделать с ChartFX в Delphi 2…. Я думаю то же самое будет и в D1…
cfxStockTrends.Adm[CSA_MIN] := X; //устанавливаем минимум по оси Y
cfxStockTrends.Adm[CSA_MAX] := Y; //Устанавливаем максимум по оси Y
Пример CHARTFX
Delphi 1Документация, поставляемая с 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}
Управление свойством Font через сервер автоматизации
Данный документ предназначен главным образом тем программистам, кто использует OLE/COM и хочет встроить объект Font (типа Delphi-го TFont) в свой сервер автоматизации. Интерфейс IFontDisp для COM будет иметь ту же функциональность, что и Delphi-ий TFont. Например, если у вас имеется клиент автоматизации, содержащий объект со свойством Font, и в сервере автоматизации для изменения атрибутов текста вы хотите иметь те же методы (наприр, имя шрифта, жирное или наклонное начертание). Для хранения и управления шрифтом сервер автоматизации может применять реализацию интерфейса IFontDisp. Приведенный ниже демонстрационный проект содержит элементы и шаги, необходимые для реализации интерфейса IFontDisp в сервере автоматизации COM, и осуществление взаимодействия между клиентом автоматизации COM и интерфейсом. Ниже вы найдете полный листинг исходных модулей, и некоторые комментарии относительно проекта. Демонстрационный проект содержит следующие модули: Project1_TLB: Паскалевская обертка для библиотеки типов, содержащей определение интерфейса. Unit1: Реализация интерфейса: код, содержащий описание свойств интерфейса и реализующий его методы. Unit2: Главная форма сервера автоматизации. Данный модуль не является обязательным, но он в ходе тестирования обеспечивает обратную связь, так что мы можем видеть как отрабатываются вызовы наших методов. FontCli: Клиент автоматизации, получающий ссылку на интерфейс, и использующий его методы. Ниже приведены общие шаги для достижения цели. Вы можете сравнить каждый из этих шагов с кодом модулей, приведенных ниже. 1. Выберите пункт меню File|New|ActiveX|Automation Object и в Мастере Automation Object Wizard выберите в качестве имени класса MyFontServer. Создайте единственное свойство с именем MyFont и типом IFontDisp. Для получения дополнительной информции смотри Developer's Guide, chapter 42 (руководство разработчика, глава 42), там подробно описана работа с библиотеками типов и создание интерфейсов в редакторе библиотеки типов. 2. В предыдущем шаге при добавлении интерфейса с помошью редактора библиотеки типов вы должны были получить паскалевский модуль-обертку (в нашем примере модуль имеет имя Unit1). Unit1 будет содержать обертку реализаций методов получения и назначения свойства MyFont. На данном этапе вы обеспечите хранение значений свойства MyFont в форме FFont (TFont) и добавите код реализации, наполняющий функциональностью методы получения и установки (get/set). Unit1 использует Unit2. Unit2 содержит форму, компонент Memo и StatusBar для отображения каждого реализованного метода, для диагностических целей. 3. Создайте Unit2, содержащий форму с компонентами TMemo и TStatusBar. Форма используется для отображения жизнедеятельности в модуле Unit1.pas. Это шаг не является строго обязательным, он помогает понять что происходит в данный момент между клиентом автоматизации и сервером. 4. Создайте клиент автоматизации. В нашем случае модуль имеет имя 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
Использование CHARTFX.VBX
Delphi 1Хотя это можно было бы пообсуждать и здесь, но для ChartFX существует контекстно-зависимая подсказка. Киньте компонент на форму, выберите его и нажмите F1.
VBX в приложениях DELPHI: как распространять?
Delphi 1Чтобы использовать любые элементы управления VBX с компилированным Delphi EXE-файлом, вам необходимо распространить BIVBX11.DLL (расположен в каталоге \WINDOWS\SYSTEM – Borland при установке копирует его туда).
Расскажите, как использовать ChartFX?
Nomadic советует: Лyчше на простеньком примере.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.
Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch?
Как осуществить минимальный тест на корректность глобального идентификатора (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;
Если этот кусок кода работает, а проблема остается, то Вам требуется шаг за шагом пройти через код клиента и найти, где он дает трещину. Если не сможете этого обнаружить, Вам придется запустить сервер под отладчиком и установить связь с клиентом, чтобы Вы могли произвести отладку рядом со местом, дающем слабину.
DCOM
В чем разница между сокетами, DCOM и OLE Enterprise при использовании их в качестве транспорта?
Nomadic отвечает: Sockets (TCP/IP): • на клиентах и сервере требуется наличие стека TCP/IP; • не требуется дополнительной настройки клиентов; DCOM: • на клиентах и серверах требуется наличие DCOM (входит в состав Windows NT 4.0, для Windows 95 доступен как опция) • требуется настройка клиентов (DCOM Configuration Utility — DCOMCNFG.EXE); • встроенная поддержка модели безопасности Windows NT; • поддержка обратных вызовов (методов); CORBA • на клиентах и серверах требуется наличие Common Object Request Broker; • требуется настройка клиентов; • поддержка обратных вызовов (методов); OLE Enterprise: • на клиентах и серверах требуется наличие OLE Enterprise; • требуется настройка клиентов; • поддержка обратных вызовов (методов);DDE
DDE – передача текста
Delphi 1Вот я как работаю с Excel:
type
DDEClientConv1.SetLink('Excel','Sheet1');
try
DDEClientConv1.OpenLink;
DDEClientItem1.DDEItem:= 'R1C1';
DDEClientConv1.PokeData(DDEClientItem1.DDEItem, StrPCopy(P, SomeString)));
finally
DDEClientConv1.CloseLink;
end;
Как вы можете здесь видеть, свойство DDEItem определяется сервером. Если ваш сервер является приложением Delphi, то DDEItem – имя DDEServerItem. На вашем месте я бы не стал так долго заниматься отладкой DDE-программ. Воспользуйтесь синхронизацией, позволяющей понять при отладке правильность действий.
Управление Program Manager в Win95 с помощью DDE
Delphi 1Для управления программными группами в Program Manager с помощью DDE мною был использован следующий модуль. За основу был взят код Steve Texeira (sp) из руководства Dephi Developers Guide. Работает под Win 3.1 и '95.
unit Pm;
interface
uses SysUtils, Classes, DdeMan;
type
EProgManError = class(Exception);
TProgMan = class(TComponent)
private
FDdeClientConv: TDdeClientConv;
procedure InitDDEConversation;
function ExecMacroString(Macro: String): Boolean;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
Procedure CreateGroup(GroupName: String; ShowGroup:Boolean);
procedure DeleteGroup(GroupName: String);
procedure DeleteItem(ItemName: String);
procedure AddItem(CmdLine, ItemName: String);
end;
implementation
uses Utils;
const
{ DDE-макростроки для Program Manager }
SDDECreateGroup = '[CreateGroup(%s)]';
SDDEShowGroup = '[ShowGroup(%s, 1)]';
SDDEDeleteGroup = '[DeleteGroup(%s)]';
SDDEDeleteItem = '[DeleteItem(%s)]';
SDDEAddItem = '[AddItem(%s, "%s", %s)]';
constructor TProgMan.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
InitDDEConversation;
end;
destructor TProgMan.Destroy;
begin
if Assigned(FDDEClientConv) then FDdeClientConv.CloseLink;
inherited Destroy;
end;
function TProgMan.ExecMacroString(Macro: String): Boolean;
Begin
StringAsPchar(Macro);
Result := FDdeClientConv.ExecuteMacro(@Macro[1], False);
End;
Procedure TProgMan.InitDDEConversation;
begin
FDdeClientConv := TDdeClientConv.Create(Self);
If NOT FDdeClientConv.SetLink('PROGMAN', 'PROGMAN') then
raise EProgManError.Create('Не могу установить DDE Link');
end;
Procedure TProgMan.CreateGroup(GroupName: String; ShowGroup:Boolean);
Begin
{ Удаляем группу, если она существует }ExecMacroString(Format(SDDEDeleteGroup, [GroupName]));
If NOT ExecMacroString(Format(SDDECreateGroup, [GroupName])) then
raise EProgManError.Create('Не могу создать группу ' + GroupName);
If ShowGroup then
If not ExecMacroString(Format(SDDEShowGroup, [GroupName])) then
raise EProgManError.Create('Не могу показать группу ' + GroupName);
End;
Procedure TProgMan.DeleteGroup(GroupName: String);
Begin
if NOT ExecMacroString(Format(SDDEDeleteGroup, [GroupName])) then
raise EProgManError.Create('Не могу удалить группу ' + GroupName);
End;
Procedure TProgMan.DeleteItem(ItemName: String);
Begin
if NOT ExecMacroString(Format(SDDEDeleteGroup, [ItemName])) then
raise EProgManError.Create('Не могу удалить элемент ' + ItemName);
End;
Procedure TProgMan.AddItem(CmdLine, ItemName: String);
Var
P: PChar;
PSize: Word;
Begin
PSize := StrLen(SDDEAddItem) + (Length(CmdLine) *2) + Length(ItemName) + 1;
GetMem(P, PSize);
try
StrFmt(P, SDDEAddItem, [CmdLine, ItemName, CmdLine]);
if NOT FDdeClientConv.ExecuteMacro(P, False) then
raise EProgManError.Create('Не могу добавить элемент ' + ItemName);
finally
FreeMem(P, PSize);
end;
End;
end.
GROUPFILE и ADDITEM для групп
Delphi 1Вот код для создания файла группы и добавления в группу файла-элемента. Чтобы использовать эту процедуру, определите DDE clientconv App как ProgMan.
procedure TMainForm.CreateWinGroup(Sender: TObject);
var
Name: string;
Name1: string;
Macro: string;
Macro1: string;
Cmd, Cmd1: array[0..255] of Char;
begin
{destDir - dos-каталог, хранящий YourFile.Ext'}
Name := 'GroupName';
Name1 := destDir + 'YourFile.Ext, FileName_in_Group ';
Macro := Format('[CreateGroup(%s)]', [Name]) + #13#10;
Macro1 :=Format('[Additem(%s)]',[Name1]) +#13#10;
StrPCopy(Cmd, Macro);
StrPCopy(cmd1, Macro1);
DDEClient.OpenLink;
if not DDEClient.ExecuteMacro(Cmd, False) then
MessageDlg('Невозможно создать группу '+Name, mtInformation, [mbOK], 0)
else begin
DDEClient.ExecuteMacro(Cmd1, False);
end;
DDEClient.CloseLink;
end;
Как можно работать с DDE под Delphi, используя вызовы API?
Delphi 3Кстати, достаточно легко: следующий пример демонстрирует как можно научить общаться клиентскую программу с программой-сервером. Обе программы полностью созданы на Delphi. В итоге мы имеем 2 проекта, 3 формы и 3 модуля. Для работы с DDE-запросами данный пример использует методы DDE ML API. Сервер должен начать свою работу перед тем, как клиент будет загружен. Данный пример демонстрирует 3 способа взаимодействия между клиентом и сервером: 1. Клиент может "пропихивать" (POKE) данные на сервер. 2. Сервер может автоматически передавать данные клиенту, после чего клиент обновляет свой вид на основе результатов, полученных от сервера. 3. Данные сервера изменяются, после чего клиент делает запрос серверу для получения новых данных и обновляет свой вид. Как работает программа. Ниже приведены 8 файлов, сконкатенированных в единое целое. Каждый файл имеет следующую структуру: { *** НАЧАЛО КОДА FILENAME.EXT *** } КОД { *** КОНЕЦ КОДА FILENAME.EXT *** }, поэтому вам остается всего-лишь взять код, расположенный между маркерами { *** }, скопировать в файл с соответствующим именем, и собрать оба проекта в среде Delphi.
{ *** НАЧАЛО КОДА DDEMLCLI.DPR *** }
program Ddemlcli;
uses Forms,Ddemlclu in 'DDEMLCLU.PAS' {Form1};
{$R *.RES}
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
{ *** КОНЕЦ КОДА DDEMLCLI.DPR *** }
{ *** НАЧАЛО КОДА DDEMLCLU.DFM *** }
object Form1: TForm1
Left = 197
Top = 95
Width = 413
Height = 287
HorzScrollBar.Visible = False
VertScrollBar.Visible = False
Caption = 'Демонстрация DDEML, Клиентское приложение'
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
Menu = MainMenu1
PixelsPerInch = 96
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
TextHeight = 16
object PaintBox1: TPaintBox
Left = 0
Top = 0
Width = 405
Height = 241
Align = alClient
Color = clWhite
ParentColor = False
OnPaint = PaintBox1Paint
end
object MainMenu1: TMainMenu
Top = 208
object File1: TMenuItem
Caption = '&Файл'
object exit1: TMenuItem
Caption = 'В&ыход'
OnClick = exit1Click
end
end
object DDE1: TMenuItem
Caption = '&DDE'
object RequestUpdate1: TMenuItem
Caption = '&Запрос на обновление'
OnClick = RequestUpdate1Click
end
object AdviseofChanges1: TMenuItem
Caption = '&Сообщение об изменениях'
OnClick = AdviseofChanges1Click
end
object N1: TMenuItem
Caption = '-'
end
object PokeSomeData: TMenuItem
Caption = '&Пропихивание данных'
OnClick = PokeSomeDataClick
end
end
end
end
{ *** КОНЕЦ КОДА DDEMLCLU.DFM *** }
{ *** НАЧАЛО КОДА DDEMLCLU.PAS *** }
{***************************************************}
{ }
{ Delphi 1.0 DDEML Демонстрационная программа }
{ Copyright (c) 1996 by Borland International }
{ }
{***************************************************}
{ Это демонстрационное приложение, демонстрирующее использование DDEML API в клиентском приложении. Оно использует серверное приложение DataEntry, которое является частью данной демонстрации, и служит для ввода данных и отображения их на графической панели.
Сначала вы должны запустить приложение-сервер (в DDEMLSRV.PAS), а затем стартовать клиента. Если сервер не запущен, клиент при попытке соединения потерпит неудачу.
Интерфейс сервера определен списком имен (Service, Topic и Items) в отдельном модуле с именем DataEntry (DATAENTR.TPU). Сервер делает Items доступными в формате cf_Text; они преобразовываются и хранятся локально как целые. }
unit Ddemlclu;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, VBXCtrl, ExtCtrls, DDEML, Menus, StdCtrls;
const NumValues = 3;
type
{ Структура данных, представленная в примере }
TDataSample = array [1..NumValues] of Integer;
TDataString = array [0..20] of Char; { Размер элемента как текста }
{ Главная форма }
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
exit1: TMenuItem;
DDE1: TMenuItem;
RequestUpdate1: TMenuItem;
AdviseofChanges1: TMenuItem;
PokeSomeData: TMenuItem;
N1: TMenuItem;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure RequestUpdate1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure AdviseofChanges1Click(Sender: TObject);
procedure PokeSomeDataClick(Sender: TObject);
procedure Request(HConversation: HConv);
procedure exit1Click(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
{ Private declarations }
public
Inst: Longint;
CallBackPtr: ^TCallback;
ServiceHSz : HSz;
TopicHSz : HSz;
ItemHSz : array [1..NumValues] of HSz;
ConvHdl : HConv;
DataSample : TDataSample;
end;
var Form1: TForm1;
implementation
const
DataEntryName : PChar = 'DataEntry';
DataTopicName : PChar = 'SampledData';
DataItemNames : array [1..NumValues] of pChar = ('DataItem1', 'DataItem2', 'DataItem3');
{$R *.DFM}
{ Локальная функция: Процедура обратного вызова для DDEML }
function CallbackProc(CallType, Fmt: Word; Conv: HConv; hsz1, hsz2: HSZ; Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
begin
CallbackProc := 0; { В противном случае смотрите доказательство }
case CallType of
xtyp_Register:
begin
{ Ничего ... Просто возвращаем 0 }
end;
xtyp_Unregister:
begin
{ Ничего ... Просто возвращаем 0 }
end;
xtyp_xAct_Complete:
begin
{ Ничего ... Просто возвращаем 0 }
end;
xtyp_Request, Xtyp_AdvData:
begin
Form1.Request(Conv);
CallbackProc := dde_FAck;
end;
xtyp_Disconnect:
begin
ShowMessage('Соединение разорвано!');
Form1.Close;
end;
end;
end;
{ Посылка DDE запроса для получения cf_Text данных с сервера. Запрашиваем данные для всех полей DataSample, и обновляем окно для их отображения. Данные с сервера получаем синхронно, используя DdeClientTransaction.}
procedure TForm1.Request(HConversation: HConv);
var
hDdeTemp : HDDEData;
DataStr : TDataString;
Err, I : Integer;
begin
if HConversation <> 0 then begin
for I := Low(ItemHSz) to High(ItemHSz) do begin
hDdeTemp:= DdeClientTransaction(nil, 0, HConversation, ItemHSz[I], cf_Text, xtyp_Request, 0, nil);
if hDdeTemp <> 0 then begin
DdeGetData(hDdeTemp, @DataStr, SizeOf(DataStr), 0);
Val(DataStr, DataSample[I], Err);
end; { if }
end; { for }
Paintbox1.Refresh; { Обновляем экран }
end; { if }
end;
procedure TForm1.FormCreate(Sender: TObject);
var I : Integer;
{ Создаем экземпляр окна DDE-клиента. Создаем окно, используя унаследованный конструктор, инициализируем экземпляр данных.}
begin
Inst:= 0;
{ Должен быть нулем для первого вызова DdeInitialize }
CallBackPtr:= nil;
{ MakeProcInstance вызывается из SetupWindow }
ConvHdl:= 0;
ServiceHSz := 0;
TopicHSz:= 0;
for I := Low(DataSample) to High(DataSample) do begin
ItemHSz[I]:= 0;
DataSample[I] := 0;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
{ Уничтожаем экземпляр клиентского окна. Освобождаем дескрипторы DDE строк, и освобождаем экземпляр функции обратного вызова, если она существует. Также, для завершения диалога, вызовите DdeUninitialize. Затем, для завершения работы, вызовите разрушителя предка. }
var I : Integer;
begin
if ServiceHSz <> 0 then DdeFreeStringHandle(Inst, ServiceHSz);
if TopicHSz <> 0 then DdeFreeStringHandle(Inst, TopicHSz);
for I := Low(ItemHSz) to High(ItemHSz) do
if ItemHSz[I] <> 0 then DdeFreeStringHandle(Inst, ItemHSz[I]);
if Inst <> 0 then DdeUninitialize(Inst); { Игнорируем возвращаемое значение }
if CallBackPtr <> nil then FreeProcInstance(CallBackPtr);
end;
procedure TForm1.RequestUpdate1Click(Sender: TObject);
begin
{ Генерируем запрос DDE в ответ на выбор пункта меню DDE | Request.}
Request(ConvHdl);
end;
procedure TForm1.FormShow(Sender: TObject);
{ Завершаем инициализацию окна сервера DDE. Выполняем те действия, которые требует правильное окно. Инициализируем использование DDEML. }
var
I: Integer;
InitOK: Boolean;
begin
CallBackPtr := MakeProcInstance(@CallBackProc, HInstance);
{ Инициализируем DDE и устанавливаем функцию обратного вызова. Если сервер отсутствует, вызов терпит неудачу. }
if CallBackPtr <> nil then begin
if DdeInitialize(Inst, TCallback(CallBackPtr), AppCmd_ClientOnly,0) = dmlErr_No_Error then begin
ServiceHSz:= DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
TopicHSz:= DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
InitOK := True;
{for I := Low(DataItemNames) to High(DataItemNames) do begin }
for I := 1 to NumValues do begin
ItemHSz[I]:= DdeCreateStringHandle(Inst, DataItemNames[I], cp_WinAnsi);
InitOK := InitOK and (ItemHSz[I] <> 0);
end;
if (ServiceHSz <> 0) and (TopicHSz <> 0) and InitOK then begin
ConvHdl := DdeConnect(Inst, ServiceHSz, TopicHSz, nil);
if ConvHdl = 0 then begin
ShowMessage('Не могу инициализировать диалог!');
Close;
end
end else begin
ShowMessage('Не могу создать строки!');
Close;
end
end else begin
ShowMessage('Не могу осуществить инициализацию!');
Close;
end;
end;
end;
procedure TForm1.AdviseofChanges1Click(Sender: TObject);
{ Переключаемся на режим DDE Advise с помощью пункта меню DDE | Advise (уведомление). При выборе этого пункта меню все три элемента переключаются на уведомление. }
var
I: Integer;
TransType: Word;
TempResult: Longint;
begin
with TMenuITem(Sender) do begin
Checked := not Checked;
if Checked then TransType:= (xtyp_AdvStart or xtypf_AckReq)
else TransType:= xtyp_AdvStop;
end; { with }
for I := Low(ItemHSz) to High(ItemHSz) do
if DdeClientTransaction(nil, 0, ConvHdl, ItemHSz[I], cf_Text,TransType, 1000, @TempResult) = 0 then ShowMessage('Не могу выполнить транзакцию-уведомление');
if TransType and xtyp_AdvStart <> 0 then Request(ConvHdl);
end;
procedure TForm1.PokeSomeDataClick(Sender: TObject);
{ Генерируем DDE-Poke транзакцию в ответ на выбор пункта меню DDE | Poke. Запрашиваем значение у пользователя, которое будем "проталкивать" в DataItem1 в качестве иллюстрации Poke-функции.}
var
DataStr: pChar;
S: String;
begin
S := '0';
if InputQuery('PokeData', 'Задайте проталкиваемую (Poke) величину', S) then begin
S := S + #0;
DataStr := @S[1];
DdeClientTransaction(DataStr, StrLen(DataStr) + 1, ConvHdl, ItemHSz[1], cf_Text, xtyp_Poke, 1000, nil);
Request(ConvHdl);
end;
end;
procedure TForm1.exit1Click(Sender: TObject);
begin
close;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
{ После запроса обновляем окно. Рисуем график объема текущих продаж.}
const
LMarg = 30; { Левое поле графика }
var
I,Norm: Integer;
Wd: Integer;
Step : Integer;
ARect: TRect;
begin
Norm := 0;
for I := Low(DataSample) to High(DataSample) do begin
if abs(DataSample[I]) > Norm then Norm := abs(DataSample[I]);
end; { for }
if Norm = 0 then Norm := 1; { В случае если у нас все нули }
with TPaintBox(Sender).Canvas do begin
{ Рисуем задний фон }
Brush.color:= clWhite;
FillRect(ClipRect);
{ Рисуем ось }
MoveTo(0, ClipRect.Bottom div 2);
LineTo(ClipRect.Right, ClipRect.Bottom div 2);
MoveTo(LMarg, 0);
LineTo(LMarg, ClipRect.Bottom);
{ Печатаем текст левого поля }
TextOut(0, 0, IntToStr(Norm));
TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom + Font.Height, IntToStr(-Norm));
TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom div 2, '0');
{ Печатаем текст оси X }
{ Теперь рисуем бары на основе нормализованного значения. Вычисляем ширину баров (чтобы они все вместились в окне) и ширину пробела между ними, который приблизительно равен 20% от их ширины. }
{ SelectObject(PaintDC, CreateSolidBrush(RGB(255, 0, 0)));
SetBkMode(PaintDC, Transparent);}
ARect := ClipRect;
Wd := (ARect.Right - LMarg) div NumValues;
Step := Wd div 5;
Wd := Wd - Step;
with ARect do begin
Left := LMarg + (Step div 2);
Top := ClipRect.Bottom div 2;
end; { with }
{ Выводим бары и текст для оси X }
For i := Low(DataSample) to High(DataSample) do begin
with ARect do begin
Right := Left + Wd;
Bottom:= Top - Round((Top-5) * (DataSample[I] / Norm));
end; { with }
{ Заполняем бар }
Brush.color:= clFuchsia;
FillRect(ARect);
{ Выводим текст для горизонтальной оси }
Brush.color:= clWhite;
TextOut(ARect.Left, ClipRect.Bottom div 2 - Font.Height, StrPas(DataItemNames[i]));
with ARect do Left := Left + Wd + Step;
end; { for }
end; { with }
end;
end.{ *** КОНЕЦ КОДА DDEMLCLU.PAS *** }
{ *** НАЧАЛО КОДА DDEMLSVR.DPR *** }
program Ddemlsvr;
uses Forms,Ddesvru in 'DDESVRU.PAS' {Form1}, Ddedlg in '\DELPHI\BIN\DDEDLG.PAS' {DataEntry};
{$R *.RES}
begin
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TDataEntry, DataEntry);
Application.Run;
end.
{ *** КОНЕЦ КОДА DDEMLSVR.DPR *** }
{ *** НАЧАЛО КОДА DDESVRU.DFM *** }
object Form1: TForm1
Left = 712
Top = 98
Width = 307
Height = 162
Caption = 'Демонстрация DDEML, Серверное приложение'
Color = clWhite
Font.Color = clWindow
TextFont.Height = -13
Font.Name = 'System'
Font.Style = []
Menu = MainMenu1
PixelsPerInch = 96
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
TextHeight = 16
object Label1: TLabel
Left = 0
Top = 0
Width = 99
Height = 16
Caption = 'Текущие значения:'
end
object Label2: TLabel
Left = 16
Top = 24
Width = 74
Height = 16
Caption = 'Data Item1:'
end
object Label3: TLabel
Left = 16
Top = 40
Width = 74
Height = 16
Caption = 'Data Item2:'
end
object Label4: TLabel
Left = 16
Top = 56
Width = 74
Height = 16
Caption = 'Data Item3:'
end
object Label5: TLabel
Left = 0
Top = 88
Width = 265
Height = 16
Caption = 'Выбор данных | Ввод данных для изменения значений.'
end
object Label6: TLabel
Left = 96
Top = 24
Width = 8
Height = 16
Caption = '0'
end
object Label7: TLabel
Left = 96
Top = 40
Width = 8
Height = 16
Caption = '0'
end
object Label8: TLabel
Left = 96
Top = 56
Width = 8
Height = 16
Caption = '0'
end
object MainMenu1: TMain
MenuLeft = 352
Top = 24
object File1: TMenuItem
Caption = '&Файл'
object Exit1: TMenuItem
Caption = '&Выход'
OnClick = Exit1Click
end
end
object Data1: TMenuItem
Caption = '&Данные'
object EnterData1: TMenuItem
Caption = '&Ввод данных'
OnClick = EnterData1Click
end
object Clear1: TMenuItem
Caption = '&Очистить'
OnClick = Clear1Click
end
end
end
end
{ *** КОНЕЦ КОДА DDESVRU.DFM *** }
{ *** НАЧАЛО КОДА DDESVRU.PAS *** }
{***************************************************}
{ }
{ Delphi 1.0 DDEML Демонстрационная программа }
{ Copyright (c) 1996 by Borland International }
{ }
{***************************************************}
{ Данный демонстрационный пример использует библиотеку DDEML на стороне сервера кооперативного приложения. Данный сервер является простым приложением для ввода данных и позволяет оператору осуществлять ввод трех элементов данных, которые становятся доступными через DDE "заинтересованным" клиентам.
Данный сервер предоставляет свои услуги (сервисы) для данных со следующими именами:
Service: 'DataEntry'
Topic : 'SampledData'
Items : 'DataItem1', 'DataItem2', 'DataItem3'
В-принципе, в качестве сервисов могли бы быть определены и другие темы. Полезными темами, на наш взгляд, могут быть исторические даты, информация о сэмплах и пр..
Вы должны запустить этот сервер ПЕРЕД тем как запустите клиента (DDEMLCLI.PAS), в противном случае клиент не сможет установить связь.
Интерфейс для этого сервера определен как список имен (Service, Topic и Items) в отдельном модуле с именем DataEntry (DATAENTR.TPU). Сервер делает Items доступными в формате cf_Text; они преобразовываются и хранятся у клиента локально как целые. }
unit Ddesvru;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Menus, DDEML, { DDE APi }ShellApi;
const
NumValues = 3;
DataItemNames : array [1..NumValues] of PChar = ('DataItem1', 'DataItem2', 'DataItem3');
type
TDataString = array [0..20] of Char; { Размер элемента как текста }
TDataSample = array [1..NumValues] of Integer;
{type
{ Структура данных, составляющих образец }
{ TDataSample = array [1..NumValues] of Integer;
{ TDataString = array [0..20] of Char; { Размер элемента как текста }
const
DataEntryName: PChar = 'DataEntry';
DataTopicName: PChar = 'SampledData';
type TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
Data1: TMenuItem;
EnterData1: TMenuItem;
Clear1: TMenuItem;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
procedure Exit1Click(Sender: TObject);
function MatchTopicAndService(Topic, Service: HSz): Boolean;
function MatchTopicAndItem(Topic, Item: HSz): Integer;
function WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
function AcceptPoke(Item: HSz; ClipFmt: Word;Data: HDDEData): Boolean;
function DataRequested(TransType: Word; ItemNum: Integer; ClipFmt: Word): HDDEData;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure EnterData1Click(Sender: TObject);
procedure Clear1Click(Sender: TObject);
private
Inst : Longint;
CallBack : TCallback;
ServiceHSz : HSz;
TopicHSz : HSz;
ItemHSz : array [1..NumValues] of HSz;
ConvHdl : HConv;
Advising : array [1..NumValues] of Boolean;
DataSample : TDataSample;
public
{ Public declarations }
end;
var Form1: TForm1;
implementation
uses DDEDlg; { Форма DataEntry }
{$R *.DFM}
procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;
{ Глобальная инициализация }
const
DemoTitle: PChar = 'DDEML демо, серверное приложение';
MaxAdvisories = 100;
NumAdvLoops : Integer = 0;
{ Локальная функция: Процедура обратного вызова для DDEML }
{ Данная функция обратного вызова реагирует на все транзакции, генерируемые DDEML. Объект "target Window" (окно-цель) берется из глобально хранимых, и для реагирования на данную транзакцию, тип которой указан в параметре CallType, используются подходящие методы этих объектов.}
function CallbackProc(CallType, Fmt: Word; Conv: HConv; HSz1, HSz2: HSZ; Data: HDDEData; Data1, Data2: Longint): HDDEData; export;
var
ItemNum: Integer;
begin
CallbackProc := 0; { В противном случае смотрите доказательство }
case CallType of
xtyp_WildConnect:
CallbackProc := Form1.WildConnect(HSz1, HSz2, Fmt);
xtyp_Connect:
if Conv = 0 then begin
if Form1.MatchTopicAndService(HSz1, HSz2) then CallbackProc := 1; { Связь! }
end;
{ После подтверждения установки соединения записываем дескриптор связи как родительское окно.}
xtyp_Connect_Confirm:
Form1.ConvHdl := Conv;
{ Клиент запрашивает данные, делает прямой запрос или отвечает на уведомление. Возвращаем текущее состояние данных.}
xtyp_AdvReq, xtyp_Request:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then CallbackProc := Form1.DataRequested(CallType, ItemNum, Fmt);
end;
{ Отвечаем на Poke-запрос ... данная демонстрация допускает только Pokes для DataItem1. Для подтверждения получения запроса возвращаем dde_FAck, в противном случае 0.}
xtyp_Poke:
begin
if Form1.AcceptPoke(HSz2, Fmt, Data) then CallbackProc := dde_FAck;
end;
{ Клиент сделал запрос для старта цикла-уведомления. Имейте в виду, что мы организуем "горячий" цикл. Устанавливаем флаг Advising для указания открытого цикла, который будет проверять данные на предмет их изменения.}
xtyp_AdvStart:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then begin
if NumAdvLoops < MaxAdvisories then begin
{ Произвольное число }
Inc(NumAdvLoops);
Form1.Advising[ItemNum] := True;
CallbackProc := 1;
end;
end;
end;
{ Клиент сделал запрос на прерывание цикла-уведомления.}
xtyp_AdvStop:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then begin
if NumAdvLoops > 0 then begin
Dec(NumAdvLoops);
if NumAdvLoops = 0 then Form1.Advising[ItemNum] := False;
CallbackProc := 1;
end;
end;
end;
end; { Case CallType }
end;
{ Возращает True, если данные Topic и Service поддерживаются этим приложением. В противном случае возвращается False.}
function TForm1.MatchTopicAndService(Topic, Service: HSz): Boolean;
begin
Result := False;
if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
if DdeCmpStringHandles(ServiceHSz, Service) = 0 then Result := True;
end;
{ Определяем, один ли Topic и Item поддерживается этим приложением. Возвращаем номер заданного элемента (Item Number) (в пределах 1..NumValues), если он обнаружен, и ноль в противном случае.}
function TForm1.MatchTopicAndItem(Topic, Item: HSz): Integer;
var I : Integer;
begin
Result := 0;
if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
for I := 1 to NumValues do
if DdeCmpStringHandles(ItemHSz[I], Item) = 0 then
Result := I;
end;
{ Отвечаем на запрос wildcard-соединения (дословно - дикая карта, шаблон). Такие запросы возникают всякий раз, когда клиент пытается подключиться к серверу с сервисом или именем топика, установленного в 0. Если сервер обнаруживает использование такого рода шаблона, он возвращает дескриптор массива THSZPair, содержащего найденные по шаблону Service и Topic.}
function TForm1.WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
var
TempPairs: array [0..1] of THSZPair;
Matched : Boolean;
begin
TempPairs[0].hszSvc:= ServiceHSz;
TempPairs[0].hszTopic:= TopicHSz;
TempPairs[1].hszSvc:= 0; { 0-завершает список }
TempPairs[1].hszTopic:= 0;
Matched := False;
if (Topic= 0) and (Service = 0) then Matched := True { Шаблон обработан, элементов не найдено }
else
if (Topic = 0) and (DdeCmpStringHandles(Service, ServiceHSz) = 0) then Matched := True
else if (DdeCmpStringHandles(Topic, TopicHSz) = 0) and (Service = 0) then Matched := True;
if Matched then
WildConnect := DdeCreateDataHandle(Inst, @TempPairs, SizeOf(TempPairs), 0, 0, ClipFmt, 0)
else WildConnect := 0;
end;
{ Принимаем и проталкиваем данные по просьбе клиента. Для демонстрации этого способа используем только значение DataItem1, изменяемое Poke.}
function TForm1.AcceptPoke(Item: HSz; ClipFmt: Word; Data: HDDEData): Boolean;
var
DataStr: TDataString;
Err: Integer;
TempSample: Integer;
begin
if (DdeCmpStringHandles(Item, ItemHSz[1]) = 0) and (ClipFmt = cf_Text) then begin
DdeGetData(Data, @DataStr, SizeOf(DataStr), 0);
Val(DataStr, TempSample, Err);
if IntToStr(TempSample) <> Label6.Caption then begin
Label6.Caption:= IntToStr(TempSample);
DataSample[1] := TempSample;
if Advising[1] then DdePostAdvise(Inst, TopicHSz, ItemHSz[1]);
end;
AcceptPoke := True;
end else AcceptPoke := False;
end;
{ Возвращаем данные, запрашиваемые значениями TransType и ClipFmt. Такое может произойти в ответ на просьбу xtyp_Request или xtyp_AdvReq. Параметр ItemNum указывает на поддерживаемый (в диапазоне 1..NumValues) и требуемый элемент (обратите внимание на то, что данный метод подразумевает, что вызывающий оператор уже установил достоверность и ID требуемого пункта с помощью MatchTopicAndItem). Соответствующие данные из переменной экземпляра DataSample преобразуются в текст и возвращаются клиенту.}
function TForm1.DataRequested(TransType: Word; ItemNum: Integer; ClipFmt: Word): HDDEData;
var ItemStr: TDataString; { Определено в DataEntry.TPU }
begin
if ClipFmt = cf_Text then begin
Str(DataSample[ItemNum], ItemStr);
DataRequested := DdeCreateDataHandle(Inst, @ItemStr, StrLen(ItemStr) + 1, 0, ItemHSz[ItemNum], ClipFmt, 0);
end else DataRequested := 0;
end;
{ Создаем экземпляр окна DDE сервера. Вызываем унаследованный конструктор, затем устанавливаем эти объекты родителями экземпляров данных. }
procedure TForm1.FormCreate(Sender: TObject);
var I : Integer;
begin
Inst:= 0; { Должен быть нулем для первого вызова DdeInitialize }
@CallBack := nil; { MakeProcInstance вызывается из SetupWindow }
for I := 1 to NumValues do begin
DataSample[I] := 0;
Advising[I] := False;
end; { for }
end;
{ Разрушаем экземпляр окна DDE сервера. Проверяем, был ли создан экземпляр процедуры обратного вызова, если он существует. Также, для завершения диалога, вызовите DdeUninitialize. Затем, для завершения работы, вызовите разрушителя предка.}
procedure TForm1.FormDestroy(Sender: TObject);
var I : Integer;
begin
if ServiceHSz <> 0 then DdeFreeStringHandle(Inst, ServiceHSz);
if TopicHSz <> 0 then DdeFreeStringHandle(Inst, TopicHSz);
for I := 1 to NumValues do
if ItemHSz[I] <> 0 then DdeFreeStringHandle(Inst, ItemHSz[I]);
if Inst <> 0 then DdeUninitialize(Inst); { Игнорируем возвращаемое значение }
if @CallBack <> nil then FreeProcInstance(@CallBack);
end;
procedure TForm1.FormShow(Sender: TObject);
var
I : Integer;
{ Завершаем инициализацию окна DDE сервера. Процедура инициализации использует DDEML для регистрации сервисов, предусмотренных данным приложением. Помните о том, что реальные имена, использованные в регистрах, определены в отдельном модуле (DataEntry), поэтому они могут быть использованы и клиентом. }
begin
@CallBack:= MakeProcInstance(@CallBackProc, HInstance);
if DdeInitialize(Inst, CallBack, 0, 0) = dmlErr_No_Error then begin
ServiceHSz:= DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
TopicHSz := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
for I := 1 to NumValues do
ItemHSz[I] := DdeCreateStringHandle(Inst, DataItemNames[I],cp_WinAnsi);
if DdeNameService(Inst, ServiceHSz, 0, dns_Register) = 0 then
ShowMessage('Ошибка в процессе регистрации.');
end;
end;
procedure TForm1.EnterData1Click(Sender: TObject);
{ Активизируем диалог ввода данных и обновляем хранимые данные по окончании ввода.}
var I: Integer;
begin
if DataEntry.ShowModal = mrOk then begin
with DataEntry do begin
Label6.Caption := S1;
Label7.Caption := S2;
Label8.Caption := S3;
DataSample[1] := StrToInt(S1);
DataSample[2] := StrToInt(S2);
DataSample[3] := StrToInt(S3);
end; { with }
for I := 1 to NumValues do
if Advising[I] then DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
end; { if }
end;
procedure TForm1.Clear1Click(Sender: TObject);
{ Очищаем текущую дату. }
var I: Integer;
begin
for I := 1 to NumValues do begin
DataSample[I] := 0;
if Advising[I] then DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
end;
Label6.Caption := '0';
Label7.Caption := '0';
Label8.Caption := '0';
end;
end.
{ *** КОНЕЦ КОДА DDESVRU.PAS *** }
{ *** НАЧАЛО КОДА DDEDLG.DFM *** }
object DataEntry: TDataEntry
Left = 488
Top = 132
ActiveControl = OK
BtnBorderStyle = bsDialog
Caption = 'Ввод данных'
ClientHeight = 264
ClientWidth = 199
Font.Color = clBlack
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
PixelsPerInch = 96
Position = poScreenCenter
OnShow = FormShow
TextHeight = 13
object Bevel1: TBevel
Left = 8
Top = 8
Width = 177
Height = 201
Shape = bsFrame
IsControl = True
end
object OKBtn: TBitBtn
Left = 16
Top = 216
Width = 69
Height = 39
Caption = '&OK'
ModalResult = 1
TabOrder = 3
OnClick = OK
BtnClickGlyph.Data = {
BE060000424DBE06000000000000360400002800000024000000120000000100
0800000000008802000000000000000000000000000000000000000000000000
80000080000000808000800000008000800080800000C0C0C000C0DCC000F0CA
A600000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000F0FBFF00A4A0A000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00030303030303
0303030303030303030303030303030303030303030303030303030303030303
03030303030303030303030303030303030303030303FF030303030303030303
03030303030303040403030303030303030303030303030303F8F8FF03030303
03030303030303030303040202040303030303030303030303030303F80303F8
FF030303030303030303030303040202020204030303030303030303030303F8
03030303F8FF0303030303030303030304020202020202040303030303030303
0303F8030303030303F8FF030303030303030304020202FA0202020204030303
0303030303F8FF0303F8FF030303F8FF03030303030303020202FA03FA020202
040303030303030303F8FF03F803F8FF0303F8FF03030303030303FA02FA0303
03FA0202020403030303030303F8FFF8030303F8FF0303F8FF03030303030303
FA0303030303FA0202020403030303030303F80303030303F8FF0303F8FF0303
0303030303030303030303FA0202020403030303030303030303030303F8FF03
03F8FF03030303030303030303030303FA020202040303030303030303030303
0303F8FF0303F8FF03030303030303030303030303FA02020204030303030303
03030303030303F8FF0303F8FF03030303030303030303030303FA0202020403
030303030303030303030303F8FF0303F8FF03030303030303030303030303FA
0202040303030303030303030303030303F8FF03F8FF03030303030303030303
03030303FA0202030303030303030303030303030303F8FFF803030303030303
030303030303030303FA0303030303030303030303030303030303F803030303
0303030303030303030303030303030303030303030303030303030303030303
0303
}
Margin = 2
NumGlyphs = 2
Spacing = -1
IsControl = True
end
object CancelBtn: TBitBtn
Left = 108
Top = 216
Width = 69
Height = 39
Caption = '&Отмена'
TabOrder = 4
Kind = bkCancel
Margin = 2
Spacing = -1
IsControl = True
end
object Panel2: TPanel
Left = 16
Top = 88
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 1
object Label1: TLabel
Left = 24
Top = 8
Width = 5
Height = 13
end
object Label2: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Значение 2:'
end
object Edit2: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
object Panel1: TPanel
Left = 16
Top = 16
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 0
object Label4: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Значение 1:'
end
object Edit1: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
object Panel3: TPanel
Left = 16
Top = 144
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 2
object Label6: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Значение 3:'
end
object Edit3: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
end
{ *** КОНЕЦ КОДА DDEDLG.DFM *** }
{ *** НАЧАЛО КОДА DDEDLG.PAS *** }
{***************************************************}
{ }
{ Delphi 1.0 DDEML Демонстрационная программа }
{ Copyright (c) 1996 by Borland International }
{ }
{***************************************************}
{ Данный модуль определяет интерфейс сервера DataEntry DDE
(DDEMLSRV.PAS). Здесь определены имена Service, Topic,и Item, поддерживаемые сервером, и также определенаструктура данных, которая может использоватьсяклиентом для локального хранения "показательных" данных.
Сервер Data Entry Server делает свои "показательные"данные доступными в текстовом виде (cf_Text)сформированными в виде трех различных топика (Topics).Клиент может их преобразовывать в целое дляиспользования со структурой данных, которая здесь определена.}
unit Ddedlg;
interface
uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons, StdCtrls, Mask, ExtCtrls;
type TDataEntry = class(TForm)
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
Bevel1: TBevel;
Panel2: TPanel;
Label1: TLabel;
Label2: TLabel;
Panel1: TPanel;
Label4: TLabel;
Panel3: TPanel;
Label6: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
procedure OKBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
S1, S2, S3: String;
{ Public declarations }
end;
var DataEntry: TDataEntry;
implementation
{$R *.DFM}
procedure TDataEntry.OKBtnClick(Sender: TObject);
begin
S1 := Edit1.Text;
S2 := Edit2.Text;
S3 := Edit3.Text;
end;
procedure TDataEntry.FormShow(Sender: TObject);
begin
Edit1.Text := '0';
Edit2.Text := '0';
Edit3.Text := '0';
Edit1.SetFocus;
end;
end.
{ *** КОНЕЦ КОДА DDEDLG.PAS *** }
Как добавить группу в Program Manager?
Delphi 1
interface
procedure CreateGroup;
implementation
procedure TSetupForm.CreateGroup;
{ Для установки группы в Program Manager используем компонент TProgMan }
var
ItemList: TStringList;
GroupName: String;
ItemName: String;
i: word;
begin
{ Получаем из INI-файла строку GroupName }
GroupName := IniFile.ReadString('General', 'PMGroup', '');
{ Если один есть, устанавливаем группу }
if GroupName <> '' then begin
ItemList := TStringList.Create;
try
{ читаем элементы для установки }
IniFile.ReadSectionValues('PMGroup', ItemList);
with TProgMan.Create(Self) do try
CreateGroup(GroupName);
for i := 0 to ItemList.Count – 1 do begin
{ получаем имя файла }
ItemName := Copy(ItemList.Strings[i], 1, Pos('=', ItemList.Strings[i]) – 1);
{ прибавляем путь к имени файла и добавляем элемент }
AddItem(GetTarget(ItemList.Values[ItemName][1]) + ItemName, ItemName);
end;
finally
Free;
end;
finally
ItemList.Free;
end;
end;
end;
OLE
OLE-автоматизация в Delphi 1
Delphi 1Delphi 16 также может осуществлять автоматизацию OLE, как она может и многое другое. Другое дело, что у нее нет компонентов-инкапсуляторов, и нет традиционных объектов, делающих работу с OLE такой же легкой, как это происходит с другими вещами в Delphi. Delphi32 таки должен иметь какие-то характеристики для работы с OLE (я так надеюсь). Так, если вы собираетесь делать какие-то действия с любым типом OLE-сервера, то для этого вам необходимо будет использовать все нудные и противные рутинки из набора Windows SDK. Но будет лучше, если всем этим будет заправлять специализированный компонент. Но этот вопрос уже не к Borland.
OLE сервер
Delphi 1Следующий код компилируется без проблем. Он не так ясен и понятен, но он может вам помочь:
unit Unit1;
interface
function OLEfunction(x, y, z: integer): integer; cdecl; export;
implementation
function OLEfunction(x, y, z: integer): integer;
begin
end;
procedure buildOLEstructure;
var F: pointer;
begin
F := @OLEfunction; { Компилируется без проблем … }
end;
end.
Используйте метод, приведенный ниже. Вы должны объявить одну вызывающую функцию к каждой комбинации параметров, которые вы собираетесь передавать. Затем вы вызываете вызывающую функцию (сорри) и передаете ей как указатель функцию, которую вы хотите вызвать (еще раз сорри). Непонятно? Поясню на примере:
library pcdecl;
function olefunction(a1: pchar; a2: longint; x: integer): integer; cdecl; export;
begin
end;
function callolefunction(func: pointer; a1: pchar; a2: longint; x: integer): integer; assembler;
asm
push x { помещаем параметры в обратном порядке }
push word ptr a2 + 2 { если 32-битная величина передается в этих двух шагах, то начинаем с самой «высокой» (high) части }
push word ptr a2
push word ptr a1 + 2
push word ptr a1
call func
add sp, 10 { восстанавливаем стек добавлением вытолкнутых байтов. Обратите внимание на то, что func не была вытолкнута }
end;
procedure buildolefunction;
var
f: pointer;
reslt: integer;
begin
f := @olefunction;
{ --- }
reslt := callolefunction(f, 'Здравствуй, мир', 1000000, 25);
{ --- }
end;
begin
{ --- }
end.
На моем компьютере это компилируется без проблем. Должно работать и у вас. Предупреждение. Обращение к методам должно быть немного другим, нежели к функциям.
Как я могу избавиться от 'зарегистрированного' имени сервера, если я не хочу использовать его далее?
Nomadic советует: Запустите исполняемый файл сервера с ключом /UNREGSERVER:MYSERVER.EXE /UNREGSERVER
Это обычный путь разрегистрации саморегистрирующегося сервера автоматизации OLE.
Миграция
Delphi 2
Совместимость D1/D2
Какая может быть причина того, что программа, работающая в среде W31, не работает в W95 ? Похоже на то, что данные, сохраненные в двоичном файле, читаются неправильно. Имеется масса отличий в фундаментальных типах между Delphi 1.0 и Delphi 2.0, которые могут повлиять на двоичный файл. Вот некоторые из них: 1. строки в Delphi 1.0 не эквивалентны строкам по умолчанию (длинным) в версии 2.0 2. «integer» 16-битный в Delphi 1.0 и 32-битный в 2.0 3. записи автоматически упаковываются в Delphi 1.0, но не в Delphi 2.0 – Rick RogersDelphi 3
Куда из Delphi 3 делся модуль для работы с ReportSmith? А мои любимые модули работы с OLE: ole2, oleauto и olectl?
Одной строкойNomadic отвечает: Они лежат в X:\DELPHI3\LIB\DELPHI2.
Ошибки
Delphi 1
Ошибка маски редактирования на быстрых пентиумах
Delphi 1Данное поведение уже упоминалось ранее. Это, похоже, происходит только на быстрых машинах. Если у вас имеется исходный код RTL, вы можете сделать следующие изменения: В MASK.PAS, замените
for I := Low(NewKeyState) to High(NewKeyState) do NewKeyState[I] := 0;
На
NewKeyState := KeyState;
– Steve Schafer
PASDBK16.DLL вызывает GPF
Delphi 1Кто-нибудь может мне сказать, почему я получаю эту ошибку, да еще с рекомендацией завершить работу Delphi? При попытке запустить мое приложение в среде ID, я получаю сообщение «PASDBK16.DLL caused a GPF at 0002:21e6 Shutdown of delphi is recommended» (PASDBK16.DLL вызвало GPF по адресу 0002:21e6. Рекомендуется завершить работу Delphi). Если я завершаю работу Delphi, снова его запускаю и пытаюсь после этого выполнить приложение, то получаю ошибку «Application is already running terminate before compiling» (Работа приложения уже прервана перед компиляцией). У меня возникла сегодня такая же проблема, и мой коллега нашел ее решение. Если каталог разработки вы делаете каталогом общего доступа, то при наличии разных проектов может случиться так, что настройки компилятора одного из проектов будут использованы при сборке другого, использующего тот же путь. Проблема в модулях общего доступа, которые компилируются по разным путям. Решение заключается в определении выходного (output) каталога для вашего приложения и полной пересборки проекта (не забудьте при этом создать соответствующий каталог). После этого проблема должна исчезнуть. – Sjef van der Velde
Ошибка переполнения диска
Delphi 1Попробуйте удалить из вашего проекта все, кроме dpr, pas и dfm-файлов, и перекомпилить его. Похоже, один из файлов вашего проекта был испорчен. У меня была аналогичная проблема, и я смог ее решить только таким способом.
Delphi 2
Ошибка чтения потока
Каждый раз при запуске Delphi 2.01 я получаю ошибку «Stream Read Error» (ошибка чтения потока). Как мне отделаться от этого? Удалите DSK– и DSM– файлы из вашего проектного каталога. – Ralph FriedmanDelphi 5
Ошибка в ProgressBar
В ProgressBar представлено свойство BorderWidth. На мой взгляд, ребята из Inprise допустили очередную ошибку. В этом свойстве отсутствует «защита от дурака». Если BorderWidth < Int(Heigth*0.3) – все нормально, вы управляете высотой "бегущего" индикатора. Если (BorderWidth > Int(Heigth*0.3)) and (BorderWidth < Int(Heigth*0.5)) – индикатор исчезает. Тогда зачем он нужен? При BorderWidth = Int(Heigth*0.5) – получите сообщение – "Error. Division by zero". При больших значениях BorderWidth – вместо индикатора "дыра". К сожалению, исправить эту ошибку можно только в исходнике. C уважением, VS.DLL
Разное
Синхронизация DLL с открытым набором данных
Delphi 2Тема: Синхронизация DLL с открытым набором данных В данном совете показано как с помощью Object Pascal динамически, на лету, связать DLL с активной базой данных, таким образом дающей программисту возможность воспользоваться Modularize-характеристикой. (Независимо от текущего режима, будь то разработка приложения, или его выполнение) Технология динамической линковки DLL к EXE полезна во многих случаях. Например, работа с пакетами для создания 'plug-in' модулей (A/R, A/P, General Ledger и др.) или Point of Sale package с Current Stock, FIFO/LIFO Ordering, Vendor Tracking, и пр. модули. Данная статья дает работающий пример того, как это сделать с единственной dll, 'Editdll.dll', и предоставит разработчику материал, расказывающий о том, как организовать в вашем приложении подключаемые модули. Предварительные условия: Хорошее знание работы компонента TTable, умение использовать DLL, BDE API и знание BDE hCursor. *WIN API для динамической загрузки любых DLL. Пример приложения Приведенная ниже форма, EditForm, работает с таблицей COUNTRY, расположенной в каталоге DBDEMO. При нажатии пользователем кнопки 'Edit' или при двойном щелчке на записи (строке), возникает диалоговое окно, расположенное в 'EditDll.dll' и демонстрирующее специфическую информацию, относящуюся к данной записи. В этой "точке" DLL синхронизирует себя не только с набором данных (и сессией), но и с текущей записью. Это означает, что полозователь изменяет те же самые данные, что он видит в EditForm! Ну а теперь углубимся в код демонстрационного приложения. (Для удобства просто скопируйте отсюда эти файлы и вставьте в ваше приложение) Проект главной формы
{ MAINDB.DPR }
program maindb;
uses Forms, mainform in 'mainform.pas' {dbmainform};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TDBMainForm, DBMainForm);
Application.Run;
end.
{ MAINFORM.PAS }
unit mainform;
interface
uses SysUtils, Windows, Messages, Classes, Graphics, Controls, StdCtrls, Forms, DBCtrls, DB, DBGrids, DBTables, Grids, ExtCtrls, BDE;
type TDBMainForm = class(TForm)
Table1Name: TStringField;
Table1Capital: TStringField;
Table1Continent: TStringField;
Table1Area: TFloatField;
Table1Population: TFloatField;
DBGrid1: TDBGrid;
DBNavigator: TDBNavigator;
Panel1: TPanel;
DataSource1: TDataSource;
Panel2: TPanel;
Table1: TTable;
EditButton: TButton;
procedure FormCreate(Sender: TObject);
procedure EditButtonClick(Sender: TObject);
procedure DBGrid1DblClick(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var DBMainForm: TDBMainForm;
implementation
{$R *.DFM}
procedure TDBMainForm.FormCreate(Sender: TObject);
begin
Table1.Open;
end;
// {ПРИМЕЧАНИЕ: DBHandle - дескриптор базы данных & DSHandle - курсор
// рассматриваемой записи. Кроме того, если вы имеете цель в
// динамической загрузке DLL во время выполнения приложения,
// используйте вызовы API LoadLibrary, GetProcAddress и
// FreeLibrary вместо подразумевающихся вызовов загрузки при
// запуске. Пример использования API для динамической загрузки: }
// Type
// {Для GetProcAddress}
// BDEDataSync =
// function(const DBHandle: HDBIDB; const DSHandle: HDBICur): Boolean;
// stdcall;
// {Организация перехвата ошибок загрузки DLL}
// EDLLLoadError = class(Exception);
// var h: hwnd;
// p: BDEDataSync;
// LastError: DWord;
// begin
// UpdateCursorPos;
// Try
// h := loadLibrary('EDITDLL.DLL');
// {Примечание для пользователей Delphi 1.0: Поскольку Win32
// LoadLibrary при неудачной загрузке DLL возвращает NULL,
// поэтому для поиска ошибки необходим вызов GetLastError,
// Win16 LoadLibrary возвращает значение ошибки (меньше чем
// HINSTANCE_ERROR), которая для выяснения причин неудачной
// загрузки может затем провериться с помощью Win16API SDK.}
// if h = 0 then begin
// LastError := GetLastError;
// Raise EDLLLoadError.create(IntToStr(LastError) +
// ': Невозможно загрузить DLL');
// end;
// try
// p := getProcAddress(h, 'EditData');
// if p(DBHandle, Handle) then Resync([]);
// finally
// freeLibrary(h);
// end;
// Except
// On E: EDLLLoadError do
// MessageDLG(E.Message, mtInformation, [mbOk],0);
// end;
// end;
// {или}
function EditData(const DBHandle: HDBIDB; const DSHandle: HDBICur): Boolean; stdcall external 'EDITDLL.DLL' name 'EditData';
procedure TDBMainForm.EditButtonClick(Sender: TObject);
begin
with Table1 do begin
UpdateCursorPos;// Вызываем процедуру EditData из EditDll.dll.
if EditData(DBHandle, Handle) then Resync([]);
end;
end;
procedure TDBMainForm.DBGrid1DblClick(Sender: TObject);
begin
EditButton.Click;
end;
end.
Проект EDIT DLL
{ EDITDLL.DPR }
library editdll;
uses SysUtils, Classes, editform in 'editform.pas' {DBEditForm};
exports EditData;
begin
end.
{ EDITFORM.PAS }
unit editform;
interface
uses SysUtils, Windows, Messages, Classes, Graphics, Controls, StdCtrls, Forms, DBCtrls, DB, DBTables, Mask, ExtCtrls, BDE;
type
TTableClone = class;
TDBEditForm = class(TForm);
ScrollBox: TScrollBox;
Label1: TLabel;
EditName: TDBEdit;
Label2: TLabel;
EditCapital: TDBEdit;
Label3: TLabel;
EditContinent: TDBEdit;
Label4: TLabel;
EditArea: TDBEdit;
Label5: TLabel;
EditPopulation: TDBEdit;
DBNavigator: TDBNavigator;
Panel1: TPanel;
DataSource1: TDataSource;
Panel2: TPanel;
Database1: TDatabase;
OKButton: TButton;
private
TableClone: TTableClone;
end;
{ TTableClone }
TTableClone = class(TTable)
private
SrcHandle: HDBICur;
protected
function CreateHandle: HDBICur; override;
public
procedure OpenClone(ASrcHandle: HDBICur);
end;
function EditData(const DBHandle: HDBIDB; const DSHandle: HDBICur): Boolean; stdcall;
var DBEditForm: TDBEditForm;
implementation
{$R *.DFM}
{ Экспорт }
function EditData(const DBHandle: HDBIDB; const DSHandle: HDBICur): Boolean; stdcall;
var DBEditForm: TDBEditForm;
begin
DBEditForm := TDBEditForm.Create(Application);
with DBEditForm do try
// Устанавливаем дескриптор Database1 на открытую в текущий момент базу данных
Database1.Handle := DBHandle;
TableClone := TTableClone.Create(DBEditForm);
try
TableClone.DatabaseName := 'DB1';
DataSource1.DataSet := TableClone;
TableClone.OpenClone(DSHandle);
Result := (ShowModal = mrOK);
if Result then begin
TableClone.UpdateCursorPos;
DbiSetToCursor(DSHandle, TableClone.Handle);
end;
finally
TableClone.Free;
end;
finally
Free;
end;
end;
{ TTableClone }
procedure TTableClone.OpenClone(ASrcHandle: HDBICur);
begin
SrcHandle := ASrcHandle;
Open;
DbiSetToCursor(Handle, SrcHandle);
Resync([]);
end;
function TTableClone.CreateHandle: HDBICur
begin
Check(DbiCloneCursor(SrcHandle, False, False, Result));
end;
end.
{ EDITFORM.DFM }
object DBEditForm: TDBEditForm
Left = 201
Top = 118
Width = 354
Height = 289
ActiveControl = Panel1
Caption = 'DBEditForm'
Font.Color = clWindow
TextFont.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 346
Height = 41
Align = alTop
TabOrder = 0
object DBNavigator: TDBNavigator
Left = 8
Top = 8
Width = 240
Height = 25
DataSource = DataSource1
Ctl3D = FalseParent
Ctl3D = False
TabOrder = 0
end
object OKButton: TButton
Left = 260
Top = 8
Width = 75
Height = 25
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 1
end
end
object Panel2: TPanel
Left = 0
Top = 41
Width = 346
Height = 221
Align = alClient
BevelInner = bvLoweredBorder
Width = 4
Caption = 'Panel2'
TabOrder = 1
object ScrollBox: TScrollBox
Left = 6
Top = 6
Width = 334
Height = 209
HorzScrollBar.Margin = 6
HorzScrollBar.Range = 147
VertScrollBar.Margin = 6
VertScrollBar.Range = 198
Align = alClient
AutoScroll = False
BorderStyle = bsNone
TabOrder = 0
object Label1: TLabel
Left = 6
Top = 6
Width = 28
Height = 13
Caption = 'Name'
FocusControl = EditName
end
object Label2: TLabel
Left = 6
Top = 44
Width = 32
Height = 13
Caption = 'Capital'
FocusControl = EditCapital
end
object Label3: TLabel
Left = 6
Top = 82
Width = 45
Height = 13
Caption = 'Continent'
FocusControl = EditContinent
end
object Label4: TLabel
Left = 6
Top = 120
Width = 22
Height = 13
Caption = 'Area'
FocusControl = EditArea
end
object Label5: TLabel
Left = 6
Top = 158
Width = 50
Height = 13
Caption = 'Population'
FocusControl = EditPopulation
end
object EditName: TDBEdit
Left = 6
Top = 21
Width = 135
Height = 21
DataField = 'Name'
DataSource = DataSource1
MaxLength = 0
TabOrder = 0
end
object EditCapital: TDBEdit
Left = 6
Top = 59
Width = 135
Height = 21
DataField = 'Capital'
DataSource = DataSource1
MaxLength = 0
TabOrder = 1
end
object EditContinent: TDBEdit
Left = 6
Top = 97
Width = 135
Height = 21
DataField = 'Continent'
DataSource = DataSource1
MaxLength = 0
TabOrder = 2
end
object EditArea: TDBEdit
Left = 6
Top = 135
Width = 65
Height = 21
DataField = 'Area'
DataSource = DataSource1
MaxLength = 0
TabOrder = 3
end
object EditPopulation: TDBEdit
Left = 6
Top = 173
Width = 65
Height = 21
DataField = 'Population'
DataSource = DataSource1
MaxLength = 0
TabOrder = 4
end
end
end
object DataSource1: TDataSource
Left = 95
Top = 177
end
object Database1: TDatabase
DatabaseName = 'DB1'
LoginPrompt = False
SessionName = 'Default'
Left = 128
Top = 176
end
end
Как вызывать функцию 16-битной DLL из 32-битного приложения?
Из советов Nomadic'a: Надо использовать Thunks. Кусок работающего только под Windows 95 кода —const
Gfsr_SystemResources = 0;
Gfsr_GdiResources = 1;
Gfsr_UserResources = 2;
var
hInst16: THandle;
GFSR: Pointer;
{ Undocumented Kernel32 calls. }
function LoadLibrary16(LibraryName: PChar): THandle; stdcall; external kernel32 index 35;
procedure FreeLibrary16(HInstance: THandle); stdcall; external kernel32 index 36;
function GetProcAddress16(Hinstance: THandle; ProcName: PChar): Pointer; stdcall; external kernel32 index 37;
procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk';
{ QT_Thunk needs a stack frame. }
{$StackFrames On}
{ Thunking call to 16-bit USER.EXE. The ThunkTrash argumentallocates space on the stack for QT_Thunk. }
function NewGetFreeSystemResources(SysResource: Word): Word;
var ThunkTrash: array[0..$20] of Word;
begin
{ Prevent the optimizer from getting rid of ThunkTrash. }
ThunkTrash[0] := hInst16;
hInst16 := LoadLibrary16('user.exe');
if hInst16 < 32 then raise Exception.Create('Can''t load USER.EXE!');
{ Decrement the usage count. This doesn't really free the library, since USER.EXE is always loaded. }
FreeLibrary16(hInst16);
{ Get the function pointer for the 16-bit function in USER.EXE. }
GFSR := GetProcAddress16(hInst16, 'GetFreeSystemResources');
if GFSR = nil then raise Exception.Create('Can''t get address of GetFreeSystemResources!');
{ Thunk down to USER.EXE. }
asm
push SysResource { push arguments }
mov edx, GFSR { load 16-bit procedure pointer }
call QT_Thunk { call thunk }
mov Result, ax { save the result }
end;
end;
Как написать DLL, которую можно было-бы выполнить с помощью RunDll, RunDll32?
Из советов Nomadic'a : Вы должны определить в программе вызываемую снаружи функцию. Функция должна быть __stdcall (или WINAPI, что то же самое ;)) и иметь четыре аргумента. Первый – HWND окна, порождаемого rundll32 (можно использовать в качестве owner'а своих dialog box'ов), второй – HINSTANCE задачи, третий – остаток командной строки (LPCSTR, даже под NT), четвертый – не знаю ;). Hапример –int __stdcall __declspec(dllexport) Test (HWND hWnd, HINSTANCE hInstance, LPCSTR lpCmdLine, DWORD dummy) {
MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK);
return 0;
}
Исполняем таким образом –
rundll32 test.dll,_Test@16 this is a command line
выдаст message box со строкой «this is a command line».
На Паскале –
Function test(hWnd: Integer; hInstance: Integer; lpCmdLine: PChar; dummy: Longint): Integer; StdCall; export;
begin
Windows.MessageBox(hWnd, lpCmdLine, 'Command Line', MB_OK);
Result := 0;
end;
Давненько я ждал эту информацию! Сел проверять и наткнулся на очень забавную вещь. А именно – пусть у нас есть исходник на Си пpимерно такого вида:
int WINAPI RunDll(HWND hWnd, HINSTANCE hInstance, LPCSTR lpszCmdLine, DWORD dummy);
……
int WINAPI RunDllW(HWND hWnd, HINSTANCE hInstance, LPCWSTR lpszCmdLine, DWORD dummy);
……
и .def-файл примерно такого вида:
EXPORTS
RunDll
RunDllA=RunDll
RunDllW
то rundll32 становится разборчивой — под NT вызывает UNICODE-версию. Под 95, разумеется, ANSI.
Продукты третьих фирм
Adobe
Читаем 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(constviewMode: WideString; offset: Single);
procedure setViewRect(left: Single; top: Single; width: Single; height: Single);
procedure printPages(from: Integer; to_: Integer);
procedureprintPagesFit(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.
Надеюсь этот пример будет Вам полезен.
Vista Software Apollo
Какие есть рекомендации по использованию Apollo SDE?
Nomadic советует: 1. При работе с Аполло (если у тебя базы используются и досовскими задачами) — то в dbgrid'e поставь значение Font→Charset = OEM_Charset. И не забудь сразу после открытия базы вызывать метод Apollo1.SetTranslate(True). Если твое приложение будет работать с базами одновременно с досовскими, то советую перед открытием баз вызывать метод Apollo1.SysProp(SDE_SP_SETOBUFFER, Pointer(0)); для отключения буферизации операций чтения/записи в базы. 2. Если ты пишешь приложение, которое будет использовать базы только в кодировке Windows (CP1251), то тебе достаточно будет указать в dbgrid'e значение Font→Charset = Russian_Charset. Если базы в 866 кодиpовке, то: 1. Использование TTable + TApollo: === Cut ====TTable.Open;
TApollo.SetTranslate(True);
TTable.Refresh;
=== Cut ====
2. Использование TApTable:
=== Cut ====
TApTable.Open;
TApTable.SetTranslate(True);
TApTable.Refresh;
=== Cut ====
И вместо закорючек будут родные русские буквы. Правда, только при выполнении программы. В дизайнере на этапе проектирования псевдографика так и останется.
Microsoft Excel
Не работает передача данных по OLE в русский Excel
Nomadic отвечает: A: (SM): Дело в том что в VCL твои команды OLE2 передаются Excel'у в русском контексте (не знаю, как это правильно назвать). Для исправления необходимо найти в файле OLEAUTO.pas в функции GetIDsOfNames строчкуif Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount, LOCALE_SYSTEM_DEFAULT, DispIDs) <> 0 then
и заменить ее на
if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount, ((LANG_ENGLISH+SUBLANG_DEFAULT*1024)+SORT_DEFAULT* 65536), DispIDs) <> 0 then
После этого у меня Excel стал понимать нормальные английские команды :)). Необходимая комбинация для установки английского языка взята из C-шных хедеров.
Microsoft Word
Как отследить открытие и закрытие документов в приложении Microsoft Word?
Nomadic советует: В копилку. Исходный код, FAQ — желающие могут взять с Internet сами (информация взята с http://www.softmosis.ca, проверено — работает).Основной модуль, регистрация и вызов
…
public
{ Public declarations }
FWordApp: _Application;
FWordDoc: _Document;
FWordSink: TWordConnection;
…
procedure StartWordConnection(WordApp: _Application; WordDoc: _Document; var WordSink: TWordConnection);
var
PointContainer: IConnectionPointContainer;
Point: IConnectionPoint;
begin
try
// TWordConnection is the COM object which receives the
// notifications from Word. Make sure to free WordSink when
// you are done with it.
WordSink := TWordConnection.Create;
WordSink.WordApp := WordApp;
WordSink.WordDoc := WordDoc;
// Sink with a Word application
OleCheck(WordApp.QueryInterface(IConnectionPointContainer, PointContainer));
if Assigned(PointContainer) then begin
OleCheck(PointContainer.FindConnectionPoint(ApplicationEvents, Point));
if Assigned(Point) then Point.Advise((WordSink as IUnknown), WordSink.AppCookie);
end;
// Sink with a Word document advise
OleCheck(WordDoc.QueryInterface(IConnectionPointContainer, PointContainer));
if Assigned(PointContainer) then begin
OleCheck(PointContainer.FindConnectionPoint(DocumentEvents, Point));
if Assigned(Point) then Point.Advise((WordSink as IUnknown), WordSink.DocCookie);
end;
excepton E: Exception do
ShowMessage(E.Message);
end;
end;
procedure TmainForm.btnStartClick(Sender: TObject);
begin
FWordApp := CoApplication_.Create;
FWordDoc := FWordApp.Documents.Add(EmptyParam, EmptyParam);
FWordApp.Visible := True;StartWordConnection(FWordApp, FWordDoc, FWordSink);
end;
procedure TmainForm.btnExitClick(Sender: TObject);
begin
FWordApp := CoApplication_.Create;
FWordDoc := FWordApp.Documents.Add(EmptyParam, EmptyParam);
FWordApp.Visible := True;
StartWordConnection(FWordApp, FWordDoc, FWordSink);
end;
procedure tmainform.btnexitclick(sender: tobject);
begin
FWordApp.Quit(EmptyParam, EmptyParam, EmptyParam);
end;
Модуль отслеживания линков
unit ConnectionObject;
interface
uses Word_TLB, dialogs;
type TWordConnection = class(TObject, IUnknown, IDispatch)
protected
{IUnknown}
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
{ IDispatch }
function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
public
WordApp: _Application;
WordDoc: _Document;
AppCookie, DocCookie: Integer;
end;
implementation
{ IUnknown Methods }
uses windows, activex, main;
procedure LogComment(comment: string);
begin
Form1.Memo1.Lines.Add(comment);
end;
function TWordConnection._AddRef: Integer;
begin
Result := 2;
end;
function TWordConnection._Release: Integer;
begin
Result := 1;
end;
function TWordConnection.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
Result := E_NOINTERFACE;
Pointer(Obj) := nil;
if (GetInterface(IID, Obj)) then Result := S_OK;
if not Succeeded(Result) then
if (IsEqualIID(IID, DocumentEvents) or IsEqualIID(IID, ApplicationEvents)) then
if (GetInterface(IDispatch, Obj)) then Result := S_OK;
end;
{ IDispatch Methods }
function TWordConnection.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TWordConnection.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
Pointer(TypeInfo) := nil;
Result := E_NOTIMPL;
end;
function TWordConnection.GetTypeInfoCount(out Count: Integer): HResult;
begin
Count := 0;
Result := E_NOTIMPL;
end;
function TWordConnection.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
//This is the entry point for Word event sinking
Result := S_OK;
case DispID of
1: ; // Startup
2: ShowMessage('quit'); // Quit
3: ; // Document change
4: ; // New document
5: ; // Open document
6: ShowMessage('close'); // Close document
else Result := E_INVALIDARG;
end;
end;
end.
Автоматизация WORD 7
Delphi 3Вы можете воспользоваться любым интерфейсом, предлагаемым сервером автоматизации Word. Все реализованные интерфейсы вы можете увидеть при загрузке MSWORD8.OLB в Delphi, данный файл представляет собой библиотеку типов Word 7. Для исполнения VB в Word вы можете использовать свойство WordBasic Application. Следующий пример демонстрирует оба метода:
implementation
uses ComObj;
{$R *.DFM}
var V: OleVariant;
procedure TForm1.Button1Click(Sender: TObject);
begin
V := CreateOleObject('Word.Application');
V.ShowMe;
V.WordBasic.FileNew;
V.WordBasic.Insert('тест');
V.Run('mymac');
V.WordBasic.FileSave;
end;
end.
ReportSmith
Передача переменных отчета в ReportSmith III
…вы говорите можно передавать переменные? В документации только красивые схемы. Я пытаюсь передать две даты, но мне необходимо чтобы первую дату ввел пользователь, вторую я вычисляю в Delphi сам и передаю результат ReportSmith. Вот кусор работающего у меня кода, передающий использующийся при выборе Timestamp. Я использую строковую переменную просто как способ проверить строку прежде, чем я ее добавлю в отчет. Если вы хотите, можете это убрать. Примечание: убедитесь в том, что переменная, которой вы передаете значение, написана верно. Переменные отчета Reportsmith ЧУСТВИТЕЛЬНЫ К РЕГИСТРУ.Var S: String;
Begin
ExportReport.InitialValues.Clear;
S :='@SQLDate=<'''+FormatDateTime('mm/dd/yyyy hh:nn:ss',ATimeStamp)+'''>';
ExportReport.InitialValues.Add(S);
ExportReport.RUN;
End;
– Steve McWhirter
SQLAnywhere
Как правильно работать с SQLAnywhere через BDE→ODBC→SAW?
Nomadic советует: 1. Необходимо поставить patch на ODBC-драйвер (доступен на www.sybase.com); 2. Достаточно флажка Keys in SQL Statistics в ODBC-администpатоpе, для того, чтобы исчезла необходимость ставить втоpичные индексы по ключевым полям; 3. Если Вы пользуетесь BDE 3.5, то обновите ее до версии 4.x, или замените idodbc.dll на тот, который идет в комплекте поставки BDE 3.0.Разное
Ресурсы
Пример ресурсной таблицы строк
Delphi 1Как мне создать ресурсную таблицу строк (Resource String Table), про которую упоминается в функции FmtLoadStr, но не сказано как создать эту таблицу, про это вообще нигде не сказано! Создайте файл в приведенном ниже формате и обзовите его, скажем (подойдите к этому творчески), strings.rc:
STRINGTABLE LOADONCALL MOVEABLE DISCARDABLE
{
1, "UNPACK.INI"
2, "AcrobatClass"
3, "ACROEXCH.EXE"
4, "^.PDF"
5, "Extensions"
6, "ACROEXCH.EXE"
7, "PDF"
8, "AABSETUP.EXE"
9, "DelFiles-"
10, "INI-"
11, "UNPACK.INI"
12, "ACROSRCH.DLL"
13, "Regedit"
14, "ACROREAD.EXE"
15, "ACRO_LE.EXE"
}
Затем, с помощью компилятора ресурсов Borland (BRCC.EXE в вашем каталоге Delphi\Bin), скомпилируйте это в файл ресурсов:
BRCC strings.rc
Вы получите файл с именем strings.res. В вашем .DPR-файле после строки {$R *.RES} добавьте строку {$R STRINGS.RES}, после этого строковые ресурсы будут компилироваться с вашимexe-файлом.
– Ralph Friedman
Компиляция ресурсов
У меня имеется приблизительно 36 маленьких растровых изображений, которые я хочу сохранить в файле и затем прилинковать его к exe. Как мне поместить их в res-файл? Самый простой путь – создать файл с именем «BITMAPS.RC» и поместить в него список ваших .BMP-файлов:BMAP1 BITMAP BMAP1.BMP
BMAP2 BITMAP BMAP2.BMP
CLOCK BITMAP CLOCK.BMP
DBLCK BITMAP DBLCK.BMP
DELOK BITMAP DELOK.BMP
LUPE BITMAP LUPE.BMP
OK BITMAP OK.BMP
TIMEEDIT BITMAP TIMEEDIT.BMP
Затем загрузите Resource Workshop (RW) и выберите пункт меню File|Project Open. В выпадающем списке «File Type» (тип файла) выберите RC-Resource Script и откройте файл, который вы только что создали. После того, как RW загрузит ваш файл, выберите пункт меню File|Project save as. Выберите объект RES-Resource из выпадающего списка «File Type» (тип файла). В поле редактирования «New File name» задайте имя нового файла, скажем, BITMAPS.RES. Нажмите OK. Теперь у вас есть файл ресурса. В вашем модуле Delphi добавьте после строки {$R *.RES} строку {$R BITMAPS.RES}. После компиляции вы получите exe-файл с скомпилированными ресурсами. Для получения доступа к ресурсам во время выполнения программы нужно сделать следующее:
myImage.Picture.Bitmap.Handle := LoadBitmap(HInstance, 'TIMEEDIT');
В качестве предостережения: убедитесь в том, что имена (в самой левой колонке) изображений в .RC файле написаны в верхнем регистре, при вызове также необходимо писать их имена в верхнем регистре.
-Ralph Friedman
Ошибка дублирования идентификатора ресурса
Delphi 1У вас есть исходный код VCL? Если да, то в этом случае ее можно всю перекомпилировать, добавив каталог к вашему библиотечному пути (Library path) в опциях среды (Environment Options | Library). Я думаю это нужно сделать, чтобы отделаться от этой ошибки. При другом способе необходимо вычислить вызывающую проблему директиву $R, временно удалить ее, и осуществить перекомпиляцию. Временно выключить директиву $R можно добавлением '.' перед $ (но это не единственный путь выключить ее). Вероятно, вы сабкласситесь от VCL. Убедитесь в том, что идентификатор ресурса для вашей иконки уникальный. Просто загрузите ее в любой редактор ресурсов, и измените ее номер. После этого вы должны пересобрать вашу библиотеку.
Сохранение и выдёргивание ресурсов в DLL или EXE
Письмо читателяИногда возникает необходимость вшить ресурсы в исполняемый файл Вашего приложения (например чтобы предотвратить их случайное удаление пользователем, либо, чтобы защитить их от изменений). Данный пример показывает как вшить любой файл как ресурс в EXE-шнике. Совместимость: Delphi 3.x (или выше) Далее рассмотрим, как создать файл ресурсов, содержащий корию какого-либо файла. После создания такого файла его можно легко прицепить к Вашему проекту директивой {$R}. Файл ресурсов, который мы будем создавать имеет следующий формат:
+ заголовок
+ заголовок для нашего RCDATA ресурса
+ собственно данные - RCDATA ресурс
В данном примере будет показано, как сохранить в файле ресурсов только один файл, но думаю, что так же легко Вы сможете сохранить и несколько файлов.
Заголовок ресурса выглядит следующим образом:
TResHeader = record
DataSize: DWORD; // размер данных??????
HeaderSize: DWORD; // размер этой записи
ResType: DWORD; // нижнее слово = $FFFF => ordinal
ResId: DWORD; // нижнее слово = $FFFF => ordinal
DataVersion: DWORD; // *
MemoryFlags: WORD;
LanguageId: WORD; // *
Version: DWORD; // *
Characteristics: DWORD; // *
end;
Поля, помеченные звёздочкой, Мы не будем использовать. Приведённый код создаёт файл ресурсов и копирует его в данный файл:
Листинг 1:
procedure CreateResourceFile(
DataFile, ResFile: string; // имена файлов
ResID: Integer // id ресурсов
);
var
FS, RS: TFileStream;
FileHeader, ResHeader: TResHeader;
Padding: array[0..SizeOf(DWORD)-1] of Byte;
begin
{ Open input file and create resource file }
FS := TFileStream.Create( // для чтения данных из файла
DataFile, fmOpenRead);
RS := TFileStream.Create( // для записи файла ресурсов
ResFile, fmCreate);
{ Создаём заголовок файла ресурсов - все нули, за исключением HeaderSize, ResType и ResID }
FillChar(FileHeader, SizeOf(FileHeader), #0);
FileHeader.HeaderSize := SizeOf(FileHeader);
FileHeader.ResId := $0000FFFF;
FileHeader.ResType := $0000FFFF;
{ Создаём заголовок данных для RC_DATA файла
Внимание: для создания более одного ресурса необходимо повторить следующий процесс, используя каждый раз различные ID ресурсов }
FillChar(ResHeader, SizeOf(ResHeader), #0);
ResHeader.HeaderSize := SizeOf(ResHeader);
// id ресурса - FFFF означает "не строка!"
ResHeader.ResId := $0000FFFF or (ResId shl 16);
// тип ресурса - RT_RCDATA (from Windows unit)
ResHeader.ResType := $0000FFFF or (WORD(RT_RCDATA) shl 16);
// размер данных - есть размер файла
ResHeader.DataSize := FS.Size;
// Устанавливаем необходимые флаги памяти
ResHeader.MemoryFlags := $0030;
{ Записываем заголовки в файл ресурсов }
RS.WriteBuffer(FileHeader, sizeof(FileHeader));
RS.WriteBuffer(ResHeader, sizeof(ResHeader));
{ Копируем файл в ресурс }
RS.CopyFrom(FS, FS.Size);
{ Pad data out to DWORD boundary - any oldrubbish will do!}
if FS.Size mod SizeOf(DWORD) <> 0 then
RS.WriteBuffer(Padding, SizeOf(DWORD) - FS.Size mod SizeOf(DWORD));
{ закрываем файлы }
FS.Free;
RS.Free;
end;
Данный код не совсем красив, и отсутствует обработка ошибок. Правильнее будет создать класс, включающий в себя данный пример. Извлечение ресурсов из EXE теперь рассмотрим пример, показывающий, как извлекать ресурсы из исполняемого модуля. Вся процедура заключается в создании потока ресурса, создании файлового потока и копировании из потока ресурса в поток файла.
Листинг 2:
procedure ExtractToFile(Instance:THandle; ResID: Integer; ResType, FileName:String);
var
ResStream: TResourceStream;
FileStream: TFileStream;
begin
try
ResStream := TResourceStream.CreateFromID(Instance, ResID, pChar(ResType));
try
//if FileExists(FileName) then
//DeleteFile(pChar(FileName));
FileStream := TFileStream.Create(FileName, fmCreate);
try
FileStream.CopyFrom(ResStream, 0);
finally
FileStream.Free;
end;
finally
ResStream.Free;
end;
excepton E:Exception do
begin
DeleteFile(FileName);
raise;
end;
end;
end;
Всё, что требуется, это получить Instance exe-шника или dll (у Вашего приложения это Application.Instance или Application.Handle, для dll Вам прийдётся получить его самостоятельно :) ResID тот же самый ID , который был присвоен ресурсу ResType WAVEFILE, BITMAP, CURSOR, CUSTOM – это типы ресурсов, с которыми возможно работать, но у меня получилось успешно проделать процедуру только с CUSTOM FileName – это имя файла, который мы хотим создать из ресурса
Пока ..
Igor Nikolaev aKa The Sprite
[spritesoft@bos.ru]
IDE
Копирование проекта в новый каталог
…я скопировал все файлы (и программу, и базу данных) демонстрационного приложения в новый каталог, чтобы поэкспериментировать с программой, не трогая оригинал… Самый простой путь сделать это: 1. «Save Project As» (сохранить проект как) в ваш новый каталог. 2. Для каждого PAS-файла проекта сделайте операцию «Save As» (сохранить как) 3. Запустите View/ProjectManager для проверки отсутствия ссылок на старый каталог Если вы уже скопировали PAS-файлы в новый каталог, то в качестве альтернативы к п.(2) могу предложить воспользоваться кнопками плюс/минус в Менеджере Проекта (Project Manager), это поможет вам удалить старое и добавить файлы из нового каталога. – Mike OrrissИспользование Tools Interface
Delphi 2…я все еще ищу *крутой* способ отрисовки содержимого окна редактирования IDE, и уже добрался до списка дескрипторов окон. Я так понял, что для этого нужно использовать инструментальный интерфейс (Tools Interface), только c помощью него, да? Ну и как этим чудом воспользоваться? Приведенный ниже код может использоваться для включения заголовка исходного кода, представляющего собой шапку с информацией об авторских правах, авторе, версии и пр. при добавлении нового модуля или формы к вашему проекту. TIAddInNotifier - класс, реализованный в ToolIntf и позволяющий "захватывать" такие события, как открытие файлов, их закрытие, открытие и закрытие проекта и др. Я перекрыл процедуру FileNotification для захвата событий AddedToProject и RemovedFromProject. В обработчике события AddedToProject вы можете получить доступ к новому модулю проекта, особенно это касается процедуры InsertHeader. Я создал наследника класса TIEditorInterface, расположенного в файле EditIntf.pas, и создал собственную процедуру InsertHeader. VCSNotifier создается в другом модуле и здесь не показан. Приведенный ниже код является частью моей программы, осуществляющей контроль версий dll. При создании код "живет" до тех пор, пока работает Delphi. При получении кода AddedToProject, я проверяю наличие файла (должен быть новым), и что он является .pas-файлом. Затем я создаю VCSEditorInterface, мой унаследованный интерфейс, и использую мою процедуру InsertHeader. В самой процедуре InsertHeader я создаю экземпляр TIEditReader для чтения нового модуля и TIEditWriter для его изменения.
unit VCSNtfy;
interface
uses SysUtils, Dialogs, Controls, ToolIntf, EditIntf;
type
TIVCSNotifier = class(TIAddInNotifier)
public
procedure FileNotification(NotifyCode: TFileNotification; const FileName: string; var Cancel: Boolean); override;
end;
TIVCSEditorInterface = class(TIEditorInterface)
public
procedure InsertHeader;
end;
var
VCSNotifier : TIVCSNotifier;
VCSModuleInterface : TIModuleInterface;
VCSEditorInterface : TIVCSEditorInterface;
implementation
uses FITIntf, FITStr, Classes;
{ ************************* Начало VCSNotifier **************************** }
procedure TIVCSNotifier.FileNotification(NotifyCode: TFileNotification; const FileName: string; var Cancel : Boolean);
var TmpFileName : string;
begin
case NotifyCode of
fnRemovedFromProject:
VCSProject.Remove(LowerCase(ExtractFileName(FileName)));
fnAddedToProject:
begin
if (not FileExists(FileName)) and (ExtractFileExt(FileName) = '.pas') then begin
{ новый файл с исходным кодом }
VCSModuleInterface := ToolServices.GetModuleInterface(FileName);
if VCSModuleInterface <> nil then begin
VCSEditorInterface := TIVCSEditorInterface(VCSModuleInterface.GetEditorInterface);
VCSEditorInterface.InsertHeader;
VCSEditorInterface.Free;
end;
VCSModuleInterface.Free;
end;
TmpFileName := LowerCase(ExtractFileName(FileName));
if VCSProject.RecycleExists(TmpFileName) then begin
if MessageDlg('Вы хотите извлечь текущие ' + ' записи из таблицы Recycle' + #13 + #10 + ' ' + VCSProject.ProjectName + '/' + TmpFileName + '?', mtConfirmation,[mbYes,mbNo], 0 ) = mrYes then begin
VCSProject.Recycle(TmpFileName);
end;
end;
end;
end;
end;
{ ************************* Конец TIVCSNotifier *************************** }
{ ********************* Начало TIVCSEditorInterface ************************ }
procedure TIVCSEditorInterface.InsertHeader;
var
Module, TmpFileName, UnitName, InsertText, Tmp : string;
Reader : TIEditReader;
Writer : TIEditWriter;
APos : Integer;
F : TextFile;
begin
TmpFileName := ExtractFileName(FileName);
UnitName := SwapStr(TmpFileName, '.pas', '');
SetLength(Module, 255);
Reader := CreateReader;
try
Reader.GetText(0, PChar(Module), Length(Module));
finally
Reader.Free;
end;
APos := Pos('unit ' + UnitName, Module);
if APos > 0 then begin
try
InsertText := '';
AssignFile(F, VCSConfig.HeaderFileLocation);
Reset(F);
while not EOF(F) do begin
Readln(F, Tmp);
InsertText := InsertText + #13 + #10 + Tmp;
end;
CloseFile(F);
InsertText := InsertText + #13 + #10;
Writer := CreateWriter;
try
Writer.CopyTo(APos - 1);
Writer.Insert(PChar(InsertText));
finally
Writer.Free;
end;
except On E : EStreamError do
MessageDlg('Не могу создать шапку', mtInformation, [mbOK], 0);
end;
end;
end;
{ ********************* Конец TIVCSModuleInterface ************************** }
end.
– Jim Poe
Зависание Delphi 4(5)
Сергей Сахаров советует: Delphi 4(5) виснут при запуске. Видеокарта S3 Virge. Решение: Добавьте в реестр строку:[HKEY_CURRENT_CONFIG\Display\Settings]
"BusThrottle"="on"
Если не помогает, то попробуйте добавить в system.ini:
[Display] "BusThrottle"="On"
Эта проблема устранена в Delphi 4sp3.
Ошибка 1157 cmplib32.dll
Delphi 2Cannot open c:\delphi 2.0\bin\cmplib32.dll Error code 1157 (Не могу открыть c:\delphi 2.0\bin\cmplib32.dll, код ошибки 1157). Что за ошибка такая с кодом 1157? Я пробовал удалить все DCU-файлы и переустановить PAS– и DFM-файлы, но ошибка не исчезла. Как это исправить? Убедитесь в том, что все требуемые DLL находятся в search-пути. – Mike Orriss
2% ресурсов, в режиме редактирования
Delphi 1Если у вас открыты все формы (показаны или минимизированы), а в редакторе кода открыты все модули, ресурсы очень быстро исчерпываются. Попробуйте закрыть все формы и модули, и открыть только те, которыми вы будете пользоваться. В противном случае при компиляции вы можете завесить Delphi и саму машину.
Активизация и использование в IDE окна CPU
Delphi 2Предупреждение: Окно CPU еще до конца не оттестировано и может иногда приводить к ошибкам. Если у вас есть проблемы с отладчиком, или при запуске вашей программы вы не можете им воспользоваться, окно CPU может помочь решить ваши проблемы. Обычно его не требуется включать, если только у вас не «особый случай». В Delphi 2 эта характеристика встроена, но по умолчанию выключена, называется это окно CPU window, или DisassemblyView. Она легка в использовании, может быть полезной в отладке и сравнении кода при его оптимизации. Для активизации этой характеристики, запустите REGEDIT и отредактируйте регистры описанным ниже образом. Найдите ключ HKEY_CURRENT_USER\Software\Borland\Delphi\2.0\Debugging. Создайте по этому пути строковый ключ с именем «ENABLECPU». Значение нового ключа должно быть строкой «1». Это все. Теперь в Delphi IDE появился новый пункт меню View|CPUWindow. При его активизации выводится новое окно. Теперь, чтобы понять какое мощное средство оказалось в ваших руках, сделаем сравнительный анализ генерируемого кода для двух примеров, имеющих одинаковую функциональность, но достигающую ее разными путями. Создайте 2 одинаковых обработчика события. В каждом обработчике события разместите приведенный ниже код. Установите точку прерывания на первой строчке каждого обработчика. Запустите приложение и активизируйте события. Сравните ассемблерный код обоих методов. Один короче? В этом случае он будет исполняться быстрее. Достойными для такого рода анализа могут быть участки кода, многократно выполняемые в процессе работы программы, или критические ко времени выполнения. Хорошим примером, где различный код выполняет одну и ту же работу, но делает это с разной скоростью, является использование конструкции «with object do». Исходный код с многократным использованием конструкции «with object do» будет длиннее, но ассемблерный код короче. Вспомните, сколько раз вы устанавливали свойства для динамически создаваемых объектов? Код:
with TObject.create do begin
property1 := ;
property2 := ;
property3 := ;
end;
будет выполняться быстрее, чем
MyObj := TObject.create;
MyObj.Property1 := ;
MyObj.Property2 := ;
MyObj.Property3 := ;
Описание типов файлов для Delphi
Delphi 3Формат .CAB-файлов Это формат файлов, который Delphi предлагает теперь своим пользователям для размещения в Интернете. Cabinet-формат является эффективным средством для упаковки нескольких файлов. Cabinet-формат имеет две ключевых характеристики: в отдельном кабинете (.cab-файл) могут храниться несколько файлов, и сжатие данных выполняется в зависимости от типа файлов, что значительно увеличивает коэффициент сжатия. Создание Cabinet-файла зависит также от количества упаковываемых файлов и ожидаемого к ним типа доступа (последовательный, произвольный, одновременный ко всем файлам или доступ к нескольким файлам в одно и тоже время). Delphi не пользуется преимуществами сжатия файлов в зависимости от их типа. Формат .LIC-файлов В действительности, как такового, формата .lic-файла не существует. Обычно это такие же текстовые файлы, содержащие одну или две ключевых строки. Формат .INF-файлов Все inf-файлы состоят из секций и пунктов. Каждая именованная секция содержит соответствующие пункты. Все inf-файлы начинаются с заголовочной секции. После заголовка включенные секции могут располагаться в любом порядке. Каждый заголовок представляет собой строку с [Именем Заголовка]. Далее следуют пункты: ItemA = ItemDetail. Для получения дополнительной информации обратитесь к документу «Device Information File Reference». Формат .dpr-файлов .dpr-файл является центральным файлом delphi-проекта. Для программы он является первой точкой входа. dpr содержит ссылки на другие файлы проекта и связывает формы с соответствующими модулями. Данный файл нужно редактировать с предельной осторожностью, так как неумелые действия могут привести к тому, что вы не сможете загрузить ваш проект. Этот файл является критическим при загрузке и перемещении (копировании) проекта. Формат .pas-файлов Это стандартный текстовый файл, который можно редактировать в текстовом редакторе. Данный файл нужно редактировать с некоторой долей осторожности, поскольку это может закончиться потерей некоторых преимуществ двух других инструментов. К примеру, добавление кода для кнопки с декларацией типа никак не отразится на соответствующем .dfm-файле формы. Все pas-файлы являются критическими при пересборке проекта. Формат .dfm-файлов Данный файл содержит описание объектов, расположенных на форме. Содержимое файла можно увидеть в виде текста, вызвав правой кнопкой мыши контекстное меню и выбрав пункт «view as text», или же с помощью конвертора convert.exe (расположенного в каталоге bin), также позволяющего перевести файл в текстовый вид и обратно. Данный файл нужно редактировать очень осторожно, поскольку это может закончиться тем, что IDE не сможет загрузить форму. Этот файл является критическим при перемещении и пересборке проекта. Формат .DOF-файлов Данный текстовый файл содержит текущие установки для опций проекта, как например, настройки компилятора и компоновщика, каталоги, условные директивы и параметры командной строки. Данные установки могут быть изменены пользователем путем изменений настроек проекта. Формат .DSK-файлов Данный текстовый файл хранит информацию относительно состояния вашего проекта, как например, открытое окно и его координаты. Подобно .DOF-файлу, данный файл создается на основе текущей обстановки проекта. Формат .DPK-файлов Данный файл содержит исходный код пакета (аналогично .DPR-файлу стандартного проекта Delphi). Подобно файлу .DPR, .DPK-файл также является простым текстовым файлом, который можно редактировать (см. предупреждение выше) в стандартном редакторе. Одной из причин, по которой вы можете это сделать – использование компилятора командной строки. Формат .DCP-файлов Данный бинарный image-файл состоит фактически из реально скомпилированного пакета. Информация о символах и дополнительных заголовках, требуемых IDE, полностью содержится в .DCP-файле. Чтобы собрать (build) проект, IDE должен иметь доступ к этому файлу. Формат .DPL-файла В действительности это выполняемый runtime-пакет. Данный файл является Windows DLL с интегрированными Delphi-специфическими характеристиками. Данный файл необходим в случае развертывания приложения, использующего пакеты. Формат .DCI-файла Данный файл содержит как стандартные, так и определенные пользователем шаблоны кода, используемых в IDE. Файл может редактироваться стандартным текстовым редактором, или в самой IDE. Как и любой текстовый файл данных, используемый Delphi, редактировать его самостоятельно не рекомендуется. Формат .DCT-файла Это «частный» бинарный файл, содержащий информацию об определенных пользователями шаблонах компонентов. Данный файл не может быть отредактирован никакими способами через IDE. Поскольку данный файл является «личным» файлом IDE, то совместимость с последующими версиями Delphi не гарантируется. Формат .TLB-файла .TLB-файл является «частным» двоичным файлом библиотеки типов. Обеспечивает информацией для идентификации типов объектов и интерфейсов, доступных в ActiveX сервере. Подобно модулю или заголовочному файлу, .TLB служит в качестве хранилища для необходимой символьной информации приложения. Поскольку данный файл является «личным», то совместимость с последующими версиями Delphi не гарантируется. Формат .DRO-файла Данный текстовый файл содержит информацию об объектном хранилище. Каждый пункт данного файла содержит специфическую информацию о каждом доступном элементе в хранилище объектов. Хотя этот файл и является простым текстовым файлом, мы настоятельно не рекомендуем править его вручную. Хранилище может редактироваться только с помощью меню Tools|Repository в самом IDE. Формат .RES-файла Это стандартный двоичный windows-формата файл ресурсов, включающий в себя информацию о приложении. По умолчанию, Delphi создает новый .RES-файл при каждой компиляции проекта в исполняемое приложение. Формат .DB-файла Файлы с таким расширением – стандартные файлы Paradox. Формат .DBF-файла Файлы с таким расширением – стандартные dBASE-файлы. Фомат .GDB-файла Файлы с таким расширением – стандартные Interbase-файлы. Формат .DMT-файла Этот «частный» бинарный файл содержит встроенные и определенные пользователем шаблоны меню. Данный файл не может быть отредактирован никакими способами через IDE. Поскольку данный файл является «личным», то совместимость с последующими версиями Delphi не гарантируется. Формат .DBI-файла Данный текстовый файл содержит информацию, необходимую для инициализации Database Explorer. Данный файл не может быть отредактирован никакими способами через Database Explorer. Формат .DEM-файла Данный текстовый файл содержит некоторые стандартные, привязанные к стране, форматы компонента TMaskEdit. Как и любой текстовый файл данных, используемый Delphi, редактировать его самостоятельно не рекомендуется. Формат .OCX-файла .OCX-файл является специализированной DLL, которая содержит все или несколько функций, связанных с элементом управления ActiveX. Файл OCX задумывался как «обертка», которая содержала бы сам объект, и средства для связи с другими объектами и серверами.
Определение работы Delphi III
Delphi 1
function DelphiLoaded : boolean;
{ Определение работающей Delphi. Во всяком случае, дает правильный результат если Delphi минимизирован, или имеет открытый проект. Также, правильный результат получается, если вызывающее приложение автономно, или запущено из-под IDE. Код написан на основе идей Wade Tatman wtatman@onramp.net - Mike O'Hanlon, The Pascal Factory, найденных в Delphi-Talk List. }
function WindowExists(ClassName, WindowName: string): boolean;
{ Проверяем наличие определенного окна Window, используя для этого паскалевские строки вместо PChars. }
var
PClassName, PWindowName: PChar;
AClassName, AWindowName: array[0..63] of char;
begin
if ClassName = '' then PClassName := nil
else PClassName := StrPCopy(@AClassName[0], ClassName);
if WindowName = '' then PWindowName := nil
else PWindowName := StrPCopy(@AWindowName[0], WindowName);
if FindWindow(PClassName, PWindowName) <> 0 then WindowExists := true
else WindowExists := false;
end; {WindowExists}
begin {DelphiLoaded}
DelphiLoaded := false;
if WindowExists('TPropertyInspector', 'Object Inspector') then
if WindowExists('TMenuBuilder', 'Menu Designer') then
if WindowExists('TApplication', 'Delphi') then
if WindowExists('TAlignPalette', 'Align') then
if WindowExists('TAppBuilder', '') then DelphiLoaded := true;
end; {DelphiLoaded}
Следующая программа возвращает TRUE при запуске в Delphi IDE (ПРИМЕЧАНИЕ: это _не_ сработает, если подпрограмма в DLL).
function InIDE: Boolean;
begin
Result := Bool(PrefixSeg) and Bool(PWordArray(MemL[DSeg:36])^[8]));
end; { InIDE }
Работа с IDE из программы
Вот три подпрограммы, работающие у меня в связке D1 и Win 3.1x:function LaunchedFromDelphiIDE: Boolean;
{----------------------------------------------------------------}
{ Осуществляем проверку запущенности приложения из-под Delphi }
{ IDE. Идея взята из сообщения в Delphi-Talk от Ed Salgado }
{ из Eminent Domain Software. }
{----------------------------------------------------------------}
begin
LaunchedFromDelphiIDE := Bool(PrefixSeg) {т.е. не DLL}
and Bool(PWordArray(MemL[DSeg:36])^[8]);
end; {LaunchedFromDelphiIDE}
function DelphiLoaded: Boolean;
{----------------------------------------------------------------}
{ Проверяем, загружена ли Delphi. Дает правильные результаты }
{ - если вызывающее приложение запущено отдельно, или из-под IDE}
{ - если Delphi имеет открытый проект }
{ - если Delphi минимизирована. }
{ Автор идеи Wade Tatman (wtatman@onramp.net). }
{----------------------------------------------------------------}
begin
DelphiLoaded := false;
if WindowExists('TPropertyInspector', 'Object Inspector') then
if WindowExists('TMenuBuilder', 'Menu Designer') then
if WindowExists('TAppBuilder', '(AnyName)') then
if WindowExists('TApplication', 'Delphi') then
if WindowExists('TAlignPalette', 'Align') then
DelphiLoaded := true;
end; {DelphiLoaded}
function DelphiInstalled: Boolean;
{----------------------------------------------------------------}
{ Проверяем наличие Delphi.ini, ищем в нем путь к Библиотеке }
{ Компонентов, после чего проверяем ее наличие по этому пути. }
{----------------------------------------------------------------}
var IniFile: string;
begin
DelphiInstalled := false;
IniFile := WindowsDirectory + '\Delphi.ini';
if FileExists(IniFile) then
if FileExists(GetIni(IniFile, 'Library', 'ComponentLibrary')) then
DelphiInstalled := true;
end; {DelphiInstalled}
Я уверен, что один из приведенных выше методов вам поможет. Последние две подпрограммы используют некоторые другие инкапсуляции Windows API и классов Delphi, и они определены следующим образом:
function WindowExists (WindowClass, WindowName: string): Boolean;
{----------------------------------------------------------------}
{ С помощью паскалевских строк проверяем наличие определенного }
{ окна. Для поиска только имени окна (WindowName), используем }
{ WindowClass '(AnyClass)'; для поиска только класса окна }
{ (WindowClass), используем WindowName '(AnyName)'. }
{----------------------------------------------------------------}
var
PWindowClass, PWindowName: PChar;
AWindowClass, AWindowName: array[0..63] of Char;
begin
if WindowClass = '(AnyClass)' then PWindowClass := nil
else PWindowClass := StrPCopy(PChar(@AWindowClass), WindowClass);
if WindowName = '(AnyName)' then PWindowName := nil
else PWindowName := StrPCopy(PChar(@AWindowName), WindowName);
if FindWindow(PWindowClass, PWindowName) <> 0 then WindowExists := true
else WindowExists := false;
end; {WindowExists}
function WindowsDirectory: string;
{----------------------------------------------------------------}
{ Возвращаем путь к каталогу Windows (без обратной косой черты) }
{----------------------------------------------------------------}
const BufferSize = 144;
var ABuffer: array[0..BufferSize] of Char;
begin
if GetWindowsDirectory(PChar(@ABuffer), BufferSize) = 0 then WindowsDirectory := ''
else WindowsDirectory := StrPas(PChar(@ABuffer));
end; {WindowsDirectory}
function GetIni(const IniFile, Section, Entry: string): string;
{----------------------------------------------------------------}
{ Получаем инициализационную 'profile' строку из определенного }
{ пункта (Entry) определенной секции [Section] определенного }
{ INI-файла (дополняем '.ini', если отсутствует). Возвращаем }
{ нулевую строку, если IniFile, Section или Entry не найден. }
{----------------------------------------------------------------}
var
IniFileVar: string;
IniFileObj: TIniFile;
begin
if StrEndsWith(IniFile, '.ini') then IniFileVar := IniFile
else IniFileVar := IniFile + '.ini';
IniFileObj := TIniFile.Create(IniFileVar);
GetIni := IniFileObj.ReadString(Section, Entry, '');
IniFileObj.Free;
end; {GetIni}
Как исправить проблемы с вызовом помощи при одновременно стоящих Delphi 1 и Delphi 2?
Nomadic отвечает: A: (AP): Решаются так… В regedit убейте из секции HKLM\SOFTWARE\Microsoft\Windows\Help все, что равно «…\help». Изменив соответствующие пути, импортируйте в реестр следующий файлик:REGEDIT4
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\AppPaths\delphi32.exe]
@="C:\\DELPHI2\\BIN\\delphi32.exe
"Path"="C:\\DELPHI2\\HELP"
Защита
Борьба с SoftIce
Igor Nikolaev aKa The Sprite пишет: Hаткнулся в инете на некий модуль StopIce, и любопытство сделало своё дело. Как долго я смеялся… :)))) Для тех, кто не в курсе: посмотрите export NmSymIsSoftIceLoaded (или что-то подобное) в nmtrans.dll. Вот полный юнит против SOFTICE, при обнаружении отладчика перезагружает компьютер:unit StopIce;
interface
implementation
uses Windows;
Function IsSoftIce95Loaded: boolean;
Var hFile: Thandle;
Begin
result := false;
hFile := CreateFileA('\\.\SICE', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if (hFile <> INVALID_HANDLE_VALUE) then begin
CloseHandle(hFile);
result := TRUE;
end;
End;
Function IsSoftIceNTLoaded: boolean;
Var hFile: Thandle;
Begin
result := false;
hFile := CreateFileA('\\.\NTICE', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if (hFile <> INVALID_HANDLE_VALUE) then begin
CloseHandle(hFile);
result := TRUE;
end;
End;
function WinExit(flags: integer): boolean;
function SetPrivilege(privilegeName: string; enable: boolean): boolean;
var
tpPrev, tp: TTokenPrivileges;
token: THandle;
dwRetLen: DWord;
begin
result := False;
OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, token);
tp.PrivilegeCount := 1;
if LookupPrivilegeValue(nil, pchar(privilegeName), tp.Privileges[0].LUID) then begin
if enable then tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
else tp.Privileges[0].Attributes := 0;
dwRetLen := 0;
result := AdjustTokenPrivileges(token, False, tp, SizeOf(tpPrev), tpPrev, dwRetLen);
end;
CloseHandle(token);
end;
begin
if SetPrivilege('SeShutdownPrivilege', true) then begin
ExitWindowsEx(flags, 0);
SetPrivilege('SeShutdownPrivilege', False)
end;
end;
initialization
if IsSoftIce95Loaded or IsSoftIceNTLoaded then begin
WinExit(EWX_SHUTDOWN or EWX_FORCE);
Halt;
end;
end.
Файлы помощи
Не могу открыть файл помощи…
Я создал файл помощи для моего приложения и назвал его KidsHelp.hlp При запуске в системе, в которой файл был создан, программа находит его без проблем. Данная машина имеет конфигурацию Pentium 120 с установленной Windows 95. При запуске программы на второй системе, с Windows 3.1, при выборе пункта меню «Using Help» программа не может открыть файл. Я создал файл помощи с помощью программы «HC31.exe». В самом проекте я не указывал полный путь к файлу помощи, я указал только его имя. 1. Для решения этой проблемы я делаю две вещи: 2. Всегда располагаю файл помощи в том же каталоге, что и приложение Назначаю файл помощи в обработчике события главной формы OnCreate таким образом:Application.HelpFile := ChangeFileExt(Application.ExeName, '.HLP');
– Neil Rubenking
Как сделать так, чтобы в приложении вызывался хелп с окошечком для поиска раздела?
Nomadic советует: 1.unit {$IFDEF WIN32} Windows {$ELSE} WinProcs {$ENDIF};
function WinHelp(Wnd: HWnd; HelpFile: PChar; Command: Word; Data: LongInt): Bool;
Здесь цитата из WinAPI Help:
HELP_CONTEXTPOPUP An unsigned long integer containing the context number for a topic. Displays in a pop-up window a particular Help topic identified by a context number that has been defined in the [MAP] section of the .HPJ file.2. То же самое, что делает макрос «Search()» для WinHelp-а.
procedure TForm1.HelpSearchFor;
var S: String;
begin
S := '';
Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP';
Application.HelpCommand(HELP_PARTIALKEY, LongInt(@S));
end;
Как заставить Help-файлы нормально отображать русский текст под Windows 3.x?
Nomadic советует: Удалось вылечить дописыванием в файл проекта в графу Options строчки FORCEFONT=Arial Cyr, причем HC31 ругается что нет такого шрифта, но зато хелп потом нормально показывается практически под любой руссифицированной виндой. Проверял с [Win31+CyrWin], [Win311Rus], [Win95PE], [Win95Rus]. На NT не проверял. Причем шрифты в тексте ноомально переключаются и будут не только Arial. Вот кусок который надо вставить в HPJ файл перед компиляцией –[OPTIONS]
FORCEFONT=Arial Cyr
Графика
256-цветное изображение из res-файла
Вот функция, правильно читающая 256-цветные изображения из файла ресурсов.function LoadBitmap256(hInstance: HWND; lpBitmapName: PChar): HBITMAP;
var
hPal, hRes, hResInfo: THandle;
pBitmap: PBitmapInfo;
nColorData: Integer;
pPalette: PLogPalette;
X: Integer;hPalette: THandle;
begin
hResInfo:= FindResource(hInstance, lpBitmapName, RT_BITMAP);
hRes:= LoadResource(hInstance, hResInfo);
pBitmap:= Lockresource(hRes);
nColorData:= pBitmap^.bmiHeader.biClrUsed;
hPal := GlobalAlloc(GMEM_MOVEABLE, (16 * nColorData));
{hPal := GlobalAlloc(GMEM_MOVEABLE, (SizeOf(LOGPALETTE) + (nColorData * SizeOf(PALETTEENTRY)));}
pPalette := GlobalLock(hPal);
pPalette^.palVersion := $300;
pPalette^.palNumEntries := nColorData;
for x := 0 to nColorData do begin
pPalette^.palPalentry[X].peRed := pBitmap^.bmiColors[X].rgbRed;
pPalette^.palPalentry[X].peGreen := pBitmap^.bmiColors[X].rgbGreen;
pPalette^.palPalentry[X].peBlue := pBitmap^.bmiColors[X].rgbBlue;
end;
hPalette := CreatePalette(pPalette^);
GlobalUnlock(hRes);
GlobalUnlock(hPal);
GlobalFree(hPal);
end;
end.
– Mark Lussier
Как записать содержимое окна OpenGL в 'bmp' файл?
Nomadic советует: Вот что попробовал – вроде получилось:bt := TBitmap.Create;
bt.Width := gr.Width;
bt.Height := gr.Height;
bt.Canvas.CopyRect(ClientRect, gr.Canvas, gr.ClientRect);
bt.SaveToFile('e:\bt.bmp');
bt.Free;
(gr – объект, в канве которого я рисую с помощью OpenGL)
Как создать disable'ный битмап из обычного (emboss etc)?
Nomadic советует: CreateMappedBitmap() :-) Один из параметров указатель на COLORMAP, в нем для 16 основных цветов делаешь перекодировку, цвета подберешь сам из принципа: • все самые яркие → в GetSysColor(COLOR_3DLIGHT); • самые темные → GetSysColor(COLOR_3DSHADOW); • нейтральные, которые бyдyт прозрачными → GetSysColor(COLOR_3DFACE); Так на самом деле вот как делается данная задача:procedure Tform1.aaa(bmpFrom, bmpTo:Tbitmap);
var
TmpImage,Monobmp:TBitmap;
IRect:TRect;
begin
MonoBmp := TBitmap.Create;
TmpImage:=Tbitmap.Create;
TmpImage.Width := bmpFrom.Width;
TmpImage.Height := bmpFrom.Height;
IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height);
TmpImage.Canvas.Brush.Color := clBtnFace;
try
with MonoBmp do begin
Assign(bmpFrom);
Canvas.Brush.Color := clBlack;
if Monochrome then begin
Canvas.Font.Color := clWhite;
Monochrome := False;
Canvas.Brush.Color := clWhite;
end;
Monochrome := True;
end;
with TmpImage.Canvas do begin
Brush.Color := clBtnFace;
FillRect(IRect);
Brush.Color := clBlack;
Font.Color := clWhite;
CopyMode := MergePaint;
Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);
CopyMode := SrcAnd;
Draw(IRect.Left, IRect.Top, MonoBmp);
Brush.Color := clBtnShadow;
Font.Color := clBlack;
CopyMode := SrcPaint;
Draw(IRect.Left, IRect.Top, MonoBmp);
CopyMode := SrcCopy;
bmpTo.assign(TmpImage);
TmpImage.free;
end;
finally
MonoBmp.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
aaa(image1.picture.bitmap,image2.picture.bitmap);
Image2.invalidate;
end;
Писал это не я. Это написал сам Борланд (некузявно было бы взглянуть на класс TButtonGlyph. Как раз из него я это и выдернул). Ну а если уже совсем хорошо разобраться, то можно заметить функцию ImageList_DrawEx, в которой можно на 25 и 50 процентов уменьшить яркость (но визуально это очень плохо воспринимается). Соответственно параметры ILD_BLEND25, ILD_BLEND50, ILD_BLEND-A-MED. Естественно, что последний абзац работает только с тройкой.
Denis Tanayeff
Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал.
#define CO_GRAY 0x00C0C0C0L
hMemDC = CreateCompatibleDC(hDC);
hOldBitmap = SelectObject(hMemDC, hBits);
// hBits это собственно картинка, которую надо «засерить»
GetObject(hBits, sizeof(Bitmap), (LPSTR) &Bitmap);
if (GetState(BS_DISABLED)) // Blt disabled
{
hOldBrush = SelectObject(hDC, CreateSolidBrush(CO_GRAY));//CO_GRAY
PatBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth, Bitmap.bmHeight, PATCOPY);
DeleteObject(SelectObject(hDC, hOldBrush));
lbLogBrush.lbStyle = BS_PATTERN;
lbLogBrush.lbHatch =(int)LoadBitmap(hInsts, MAKEINTRESOURCE(BT_DISABLEBITS));
hOldBrush = SelectObject(hDC, CreateBrushIndirect(&lbLogBrush));
BitBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth, Bitmap.bmHeight, hMemDC, 0, 0, 0x00A803A9UL); // DPSoa
DeleteObject(SelectObject(hDC, hOldBrush));
DeleteObject((HGDIOBJ)lbLogBrush.lbHatch);
}
Компонент для работы с FLIC-анимацией
Новостная группа: comp.lang.pascal.delphi.components Тема: Компонент для работы с FLIC-анимацией: отправной пункт. От: Paul Kuczora <paul@kuczora.demon.co.uk> Дата: Чет, 03 Авг 95 16:51:19 GMT В качество ответа на целый круг вопросов, я включил в свой ответ два файла: aaplay1.inc — include-файл с интерфейсом для библиотеки aaplay.dll aaplay1.pas — сырой скелет компонента для проигрывания FLIC-анимации Я разработал это глядя на другой компонент (это был полнофункциональный плейер, работающий как форма), и вынужден был сохранить некоторые вещи неприкосновенными (попробуй тут сделай иначе :-) Для работы вам понадобится библиотека aaplay.dll от Autodesk, которую вы можете найти на множестве мест (например, я так предполагаю, на Encarta CD). Для полного счастья вы можете обратиться к файлу помощи для Animation Player for Windows, который, не удивляйтесь, содержит справку для этой DLL — на первой странице найдите в ее самой нижней части указание на эту библиотеку, и перед вами предстанет полная справка по вызовам этой самой DLL. Надеюсь что помог вам… ВНИМАНИЕ! Это мой первый код, написанный для Windows (спасибо Delphi), поэтому он рекомендуется только для ознакомления.{ ============================================================================ }
{ aaplay1.inc }
{ (c) P W Kuczora }
{ 17-го апреля 1995 }
{ Заголовочный файл, содержащий константы и определения типов для aaplay1.pas }
const
NULL = 0;
NULLPTR = ^0;
{
Доступные Флаги wMode: integer;
Используются в aaLoad, aaReLoad
Первые восемь бит wMode используются в aa_flags.
}
AA_MEMORYLOAD = $1; { Загрузка в память }
AA_HIDEWINDOW = $2; { Скрывать окно анимации }
AA_NOPALETTE = $4 ; { Анимация без палитры }
AA_RESERVEPALETTE = $8; { Резервировать при старте всю палитру }
AA_LOOPFRAME = $10; { Циклическая загрузка кадров }
AA_FULLSCREEN = $20; { Использовать полноэкранный режим воспроизведения }
AA_STOPNOTIFY = $40; { Исключать любые уведомляющие сообщения }
AA_STOPSTATUS = $80; { Исключать сообщения об изменении статуса }
AA_NOFAIL = $100; { Уменьшение типа нагрузки при ошибке }
AA_DONTPAINT = $200; { Не делать paByVal-анимацию при загрузке }
AA_BUILDSCRIPT = $400; { lpzFileName – скрипт, не имя }
AA_ALLMODES = $FF;
{
Доступные флаги для режимов звука – wMode: integer;
Используются в aaSound
}
AA_SNDFREEZE = $1; { Заморозка кадров при проигрывании звуков }
AA_SNDDEVICEID = $100; { ID устройства, не имя }
AA_SNDBUILDALIAS = $200; { создавать псевдоним звукового устройства }
{
aaNotify позволяет извещать приложение о проигрывании определенных кадров.
lPosition – позиция, на которой должно происходить уведомление.
wParam для этого сообщения – hAa, а lParam копируется из этого вызова.
При установке сообщения возвращается TRUE.
Следующее значение определяет необходимость завершения цикла анимации по окончании проигрывания звука. Если звук отсутствует, анимация зацикливается навсегда.
}
AA_LOOPSOUND = $FFFF;
{
Автоматическоеуведомление посылается при перезагрузке в скрипте анимации.
lParam для этого сообщения определен ниже
}
AA_ANIMATIONLOADED = 0;
{
Типы параметров
Используется с aaGetParm и aaSetParm.
}
AA_STATUS = 1; { Получить текущий статус }
AA_FILETYPE = 2; { Получить тип анимации на диске }
AA_MODE = 3; { Получить/установить флаги анимации }
AA_WINDOW = 4; { Установить/получить окно анимации }
AA_SPEED = 5; { Установить/получить текущую скорость }
AA_DESIGNSPEED = 6; { Получить скорость на этапе дизайна }
AA_FRAMES = 7; { Получить число кадров }
AA_POSITION = 8; { Установить/получить позицию текущего кадра }
AA_LOOPS = 9; { Установить/получить число циклов }
AA_X = 10; { Установить/получить позицию выводимого окна }
AA_Y = 11; { Установить/получить позицию выводимого окна }
AA_CX = 12; { Установить/получить размеры выводимого окна }
AA_CY = 13; { Установить/получить размеры выводимого окна }
AA_ORGX = 14; { Установить/получить начало выводимого окна }
AA_ORGY = 15; { Установить/получить начало выводимого окна }
AA_WIDTH = 16; { Получить ширину анимации }
AA_HEIGHT = 17; { Получить высоту анимации }
AA_RPTSOUND = 18; { Установить/получить повторения звуков }
AA_PAUSE = 19; { Установить/получить время паузы }
AA_DELAYSND = 20; { Установить/получить время задержки звука }
AA_TRANSIN = 21; { Установить/получить тип входного перехода }
AA_TRANSOUT = 22; { Установить/получить тип выходного перехода }
AA_TIMEIN = 23; { Установить/получить время входного перехода }
AA_TIMEOUT = 24; { Установить/получить время выходного перехода }
AA_CALLBACK = 25; { Установить/получить окно обратного вызова }
AA_ANIMWND = 26; { Получить дескриптор окна анимации }
AA_MODFLAG = 100; { Установить/получить флаг изменения скрипта }
AA_SCRIPTNAME = 101; { Установить/получить имя скрипта }
AA_ANIMATION = 102; { Получить/установить скрипт анимации }
AA_ANIMATIONCOUNT = 103; { Получить счетчик скрипта анимации }
AA_SCRIPTCONTENTS = 104; { Получить содержание скрипта }
AA_LASTERROR = 1001; { Получить код последней ошибки }
AA_LASTERRORMESSAGE = 1002; { Получить/установить сообщение о последней ошибке }
{
Типы параметров
Используется с aaSetParmIndirect
}
AA_SETMODE = $1; { Получить/установить флаги анимации }
AA_SETWINDOW = $2; { Установить/получить окно анимации }
AA_SETSPEED = $4; { Установить/получить текущую скорость }
AA_SETPOSITION = $8; { Установить/получить позицию текущего кадра }
AA_SETLOOPS = $10; { Установить/получить число циклов }
AA_SETX = $20; { Установить/получить левую координату выводимого окна }
AA_SETY = $40; { Установить/получить левую координату выводимого окна }
AA_SETCX = $80; { Установить/получить верхнюю координату выводимого окна }
AA_SETCY = $100; { Установить/получить верхнюю координату выводимого окна }
AA_SETORGX = $200; { Установить/получить ширину выводимого окна }
AA_SETORGY = $400; { Установить/получить ширину выводимого окна }
AA_SETRPTSOUND = $800; { Установить/получить повторения звуков }
AA_SETPAUSE = $1000; { Установить/получить время паузы }
AA_SETDELAYSND = $2000; { Установить/получить время задержки звука }
AA_SETTRANSIN = $4000; { Установить/получить тип входного перехода }
AA_SETTRANSOUT = $8000; { Установить/получить тип выходного перехода }
AA_SETTIMEIN = $10000; { Установить/получить время входного перехода }
AA_SETTIMEOUT = $20000; { Установить/получить время выходного перехода }
AA_SETCALLBACK = $40000; { Установить/получить окно обратного вызова }
AA_ALL = $FFFFFFFF; { Получить/установить все параметры }
{
Значения статуса для анимации
}
AA_STOPPED = 1; { Загружена, но не воспроизводится }
AA_QUEUED = 2; { Анимация ожидает воспроизведение }
AA_PLAYING = 3; { Анимация воспроизводится }
AA_PAUSED = 4; { Анимация в режиме паузы }
AA_DONE = 5; { Анимация закончила воспроизведение }
{ и ожидает вызов aaStop }
{
Определения типов файла
}
AA_FLI = $1; { Формат Autodesk Animator Fli }
AA_DIB = $2; { Формат Windows DIB }
AA_NUMTYPES = $2; { Количество типов }
AA_SCRIPT = $3; { Скрипт без анимации }
{
Типы переходов
}
AA_CUT = 0; { Простая остановка одной и запуск другой }
AA_FADEBLACK = $1; { Уход/выход из черного }
AA_FADEWHITE = $2; { Уход/выход из белого }
{
Коды ошибок, возвращаемые aaGetParm(xxx, AA_LASTERROR)
}
AA_ERR_NOERROR = 0; { Неизвестная ошибка }
AA_ERR_NOMEMORY = $100; { 256 – Ошибка нехватки памяти }
AA_ERR_BADHANDLE = $101; { 257 – Плохой дескриптор }
AA_ERR_NOTIMERS = $102; { 258 – Невозможно запустить таймер }
AA_ERR_BADSOUND = $103; { 259 – Плохое звуковое сопровождение }
AA_ERR_NOSCRIPT = $104; { 260 – Требуется скрипт }
AA_ERR_WRITEERR = $105; { 261 – Ошибка записи (для сценария) }
AA_ERR_BADANIMATION = $106; { 262 – Невозможно открыть анимацию }
AA_ERR_BADWINDOWHANDLE = $200; { 512 – Плохой дескриптор окна }
AA_ERR_WINDOWCREATE = $201; { 513 – Невозможно создать окно }
AA_ERR_DLGERROR = $202; { 514 – Ошибка диалога }
AA_ERR_INVALIDSTATUS = $300; { 768 – Неверный статус }
AA_ERR_BADDIBFORMAT = $301; { 769 – Плохой dib-файл }
AA_ERR_BADFLIFORMAT = $302; { 770 – Плохой fli-файл }
AA_ERR_UNRECOGNIZEDFORMAT = $303; { 771 – Нераспознанный формат }
AA_ERR_NOSOUND = $304; { 772 – Звук не поддерживается }
AA_ERR_NOTVALIDFORSCRIPTS = $305; { 773 – Неправильный сценарий }
AA_ERR_INVALIDFILE = $306; { 774 – Плохой дескриптор файла }
AA_ERR_NOSCRIPTS = $307; { 775 – Нет файлов-скриптов }
AA_ERR_SPEED = $400; { 1024 – Неверная скорость }
AA_ERR_LOOPS = $401; { 1025 – Неверные циклы }
AA_ERR_RPTSOUND = $402; { 1026 – Неверный повтор звука }
AA_ERR_PAUSE = $403; { 1027 – Неверная пауза }
AA_ERR_TRANSIN = $404; { 1028 – Неверный переход }
AA_ERR_TIMEIN = $405; { 1029 – Неверный переход }
AA_ERR_TRANSOUT = $406; { 1030 – Неверное время перехода }
AA_ERR_TIMEOUT = $407; { 1031 – Неверное время перехода }
AA_ERR_DELAYSND = $408; { 1032 – Неверная задержка звука }
AA_ERR_INVALIDTYPE = $409; { 1033 – Неверный тип параметра }
AA_ERR_DUPLICATENOTIFY = $500; { 1280 – Дублирование уведомления }
AA_ERR_NOSWITCH = $600; { 1536 – Отсутствие ключей в скрипте }
AA_ERR_PARSELOOPS = $601; { 1537 – Плохие циклы в скрипте }
AA_ERR_PARSESPEED = $602; { 1538 – Плохая скорость в скрипте }
AA_ERR_BADRPTSOUND = $603; { 1539 – Плохое повторение звука в скрипте }
AA_ERR_PARSEPAUSE = $604; { 1540 – Плохая пауза в скрипте }
AA_ERR_PARSETRANS = $605; { 1541 – Плохой переход в скрипте }
AA_ERR_PARSEDELAYSND = $606; { 1542 – Плохая задержка звука в скрипте }
AA_ERR_TOOMANYLINKS = $607; { 1543 – Слишком много ссылок }
{
dwFlags: integer; может быть любым из нижеперечисленных
Используется в aaGetFile.
}
AA_GETFILE_MUSTEXIST = $1;
AA_GETFILE_NOSHOWSPEC = $2;
AA_GETFILE_SAVE = $4;
AA_GETFILE_OPEN = $8;
AA_GETFILE_USEDIR = $10;
AA_GETFILE_USEFILE = $20;
AA_GETFILE_SOUND = $40;
AA_GETFILE_SCRIPT = $80;
AA_GETFILE_ANIMATION = $100;
{
wMode: integer; Значения
Используется в aaSave
}
AA_SAVE_IFMODIFIED = $1;
AA_SAVE_AS = $2;
AA_SAVE_CANCEL = $4;
{
Возможности
Используется в aaGetCaps
}
AA_CAP_TIMER = 1;
AA_CAP_SOUND = 2;
AA_CAP_SCRIPT = 3;
{
Статусные сообщения анимации
Используйте RegisterWindowMessage для получения номеров реальных сообщений.
}
AA_NOTIFY = 'AAPLAY Уведомление'; { Сообщение-уведомление }
AA_STOP = 'AAPLAY Стоп'; { Стоп-сообщение }
{
Это посылается в первом слове lParam с сообщением AA_ERROR.
Это указывает на возникшую ошибку
}
AA_BADPLAY = 1; { Ошибка при попытке воспроизведения }
AA_BADNOTIFY = 2; { Ошибка при попытке послать уведомление }
AA_BADSCRIPT = 3; { Ошибка в сценарии при попытке }
{ воспроизведения }
{ ========================================================================== }
unit TMediaPlayer)
procedure OpenAA;
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
AAParameters: AAPARMS;
FlicHandle: AAHandle;
PlayWinHandle: THandle;
StatusWinHandle: THandle;
CallbackWinHandle: THandle;
published
{ Published declarations }
end;
procedure Register;
{ Внешние вызовы AAPLAY.DLL }
function aaOpen : boolean;
procedure aaClose;
function aaGetCaps(wType: word) : word;
function aaLoad(lpzFileName: PChar; WinHnd: HWnd; wMode: word; x, y, wid, hght, orgx, orgy: integer): AAHandle;
function aaReLoad(hAa: AAHandle; lpzFileName: PChar; wMode, wMask: word) : boolean;
function aaUnload(hAa: AAHandle): boolean;
function aaPlay(hAa: AAHandle) : boolean;
function aaNotify(hAa: AAHandle; lPosition, lParam: longint) : boolean;
function aaCancel(hAa: AAHandle; lLoPos, lHiPos: longint) : word;
function aaStop(hAa: AAHandle) : boolean;
function aaPause(hAa: AAHandle) : boolean;
function aaPrompt(hAa: AAHandle; lpName: PChar) : boolean;
function aaGetParm(hAa: AAHandle; wType: word) : longint;
function aaGetParmIndirect(hAa: AAHandle; lpAp: AAPARMSPtr; wSize: word) : boolean;
function aaSetParm(hAa: AAHandle; wType: word; wValue1, lValue2: longint): AAHandle;
function aaSetParmIndirect(hAa: AAHandle; dwType: longint; lpAp: AAPARMSPtr; wMask: word): boolean;
function aaShow(hAa: AAHandle; bShow: boolean) : boolean;
function aaSound(hAa: AAHandle; device, ffile: PChar; wMode: word): boolean;
function aaGetFile(dwFlags: word; lpszPath: PChar; wBufLen: word; lpszDriver: PChar; wDrvLen: word) : integer;
function aaSave(hAa: AAHandle; wMode: word) : integer;
implementation
{ =========================================================================== }
procedure Register;
begin
RegisterComponents('Samples', [TAAPlayer]);
end;
{ --------------------------------------------------------------------------- }
procedure TAAPlayer.OpenAA;
var
FileSuffix, tempstr: string[12];
a,b: integer;
begin
{ tempstr := ExtractFilename(AAPlayer.Filename); }
{ a := StrPos(tempstr,'.');
if (a > 0) then begin
b := a;
while (b <= StrLen(tmpstr)) do begin
FileSuffix := FileSuffix + StrUpper(tempstr[b]);
b := b+1;
end;
if ((FileSuffix = '.FLC') or (FileSuffix = '.FLI')) then begin }
{ AutoEnable := False;
EnabledButtons := [btRecord,btEject];
}{ end;
end;
}
end;
{ =========================================================================== }
{ Внешние вызовы 'AAPLAY.DLL' }
{$F+}
{ =========================================================================== }
{ --------------------------------------------------------------------------- }
function aaOpen : boolean; external 'AAPLAY';
{ --------------------------------------------------------------------------- }
procedure aaClose; external 'AAPLAY';
{
' AAOpen и AAClose в действительности не нужны, за исключением обработки
' ошибки в Windows, которая предохраняет освобождение библиотек в процедуре
' выхода Windows (Windows Exit Proc, WEP).
'
' Поэтому мы используем AAClose для освобождения библиотек при закрытии
' последней задачей AAPlay DLL.
}
{ --------------------------------------------------------------------------- }
function aaGetCaps(wType: word) : word; external 'AAPLAY';
{
' Получение возможностей
}
{ --------------------------------------------------------------------------- }
function aaLoad(lpzFileName: PChar; WinHnd: HWnd; wMode: word; x, y, wid, hght, orgx, orgy: integer): AAHandle; external 'AAPLAY';
{
' aaLoad загружает анимацию.
'
' Имя файла в lpzFileName
' и режим загрузки в wMode.
}
{ --------------------------------------------------------------------------- }
function aaReLoad(hAa: AAHandle; lpzFileName: PChar; wMode, wMask: word): boolean; external 'AAPLAY';
{
' aaReLoad загружает файл новый анимации
' "в дескриптор" старой анимации.
'
' Уведомления теряются, но палитра и окно
' сохраняются.
}
{ --------------------------------------------------------------------------- }
function aaUnload(hAa: AAHandle): boolean; external 'AAPLAY';
{
' aaUnload выгружает загруженную анимацию.
'
' Возвращается FALSE, если
' hAa не является дескриптором загруженной анимации.
}
{ --------------------------------------------------------------------------- }
function aaPlay(hAa: AAHandle) : boolean; external 'AAPLAY';
{
' aaPlay воспроизводит загруженную анимацию.
'
' Возвращается TRUE, если после возврата aaPlay анимация не останавливается.
}
{ --------------------------------------------------------------------------- }
function aaNotify(hAa: AAHandle; lPosition, lParam: longint) : boolean; external 'AAPLAY';
{
' aaNotify позволяет извещать приложение о воспроизведении
' определенных кадров анимации.
'
' lPosition -позиция, в которой должно происходить уведомление.
'
' wParam для данного сообщения - hAa, а lParam копируется из этого вызова.
'
' Возвращается TRUE, если уведомление установлено.
}
{ --------------------------------------------------------------------------- }
function aaCancel(hAa: AAHandle; lLoPos, lHiPos: longint) : word; external 'AAPLAY';
{
' aaCancel позволяет приложению отменить уведомления, установленные aaNotify.
'
' lLoPos и lHiPos задает верхний и нижний предел позициям.
'
' Возвращает количество отмененных уведомлений.
}
{ --------------------------------------------------------------------------- }
function aaStop(hAa: AAHandle) : boolean; external 'AAPLAY';
{
' aaStop прекращает воспроизведение анимации.
'
' При остановке воспроизведения aaStop возвращает TRUE.
}
{ --------------------------------------------------------------------------- }
function aaPause(hAa: AAHandle) : boolean; external 'AAPLAY';
{
' aaPause приостанавливает воспроизведение.
'
' Возвращается TRUE, если после возврата aaPause анимация переходит в режим паузы.
'
' Для продолжения воспроизведения анимации используйте aaPlay.
}
{ --------------------------------------------------------------------------- }
function aaPrompt(hAa: AAHandle; lpName: PChar) : boolean; external 'AAPLAY';
{
' aaPrompt позволяет выводить диалог для получения данных от пользователя.
'
' При получении данных дескриптор меняется, и, таким образом, вступают
' в силу новые параметры. Старый дескриптор не уничтожается до тех пор,
' пока не будет создан новый.
'
' Если новый дескриптор не может быть создан, aaPrompt возвращает NULL,
' в противном случае возвращается новый дескриптор.
}
{ --------------------------------------------------------------------------- }
function aaGetParm(hAa: AAHandle; wType: word) : longint; external 'AAPLAY';
{
' aaGetParm возвращает информацию об анимации.
'
' Некоторая информация может быть установлена с помощью aaSetParm,
' и другая информация - информация о состоянии, поддерживаемая AAPLAY.
}
{ --------------------------------------------------------------------------- }
function aaGetParmIndirect(hAa: AAHandle; lpAp: AAPARMSPtr; wSize: word): boolean; external 'AAPLAY';
{
' aaGetParmIndirect возвращает ту же информацию, что и aaGetParm,
' в структуре, удобной для легкого доступа из приложений Visual Basic.
}
{ --------------------------------------------------------------------------- }
function aaSetParm(hAa: AAHandle; wType: word; wValue1, lValue2: longint): AAHandle; external 'AAPLAY';
{
' aaSetParm устанавливает информацию для анимации
}
{ --------------------------------------------------------------------------- }
function aaSetParmIndirect(hAa: AAHandle; dwType: longint; lpAp: AAPARMSPtr; wMask: word): boolean; external 'AAPLAY';
{
' aaSetParmIndirect устанавливает параметры анимации из структуры.
}
{ --------------------------------------------------------------------------- }
function aaShow(hAa: AAHandle; bShow: boolean) : boolean; external 'AAPLAY';
{
' aaShow позволяет показать в окне отдельный кадр анимации.
'
' Mode определяет способ рисования анимации.
'
' Параметры окна возможно задать с помощью aaSetParm или aaSetParmIndirect.
'
' aaShow возвращает TRUE, если анимация была отрисована без ошибок.
}
{ --------------------------------------------------------------------------- }
function aaSound(hAa: AAHandle; device, ffile: PChar; wMode: word): boolean; external 'AAPLAY';
{
' aaSound открывает и закрывает канал звукового сопровождения анимации.
'
' Звуковой канал будет открыт, если аргумент file не будет равен null
' и не будет пустым, в противном случае канал будет закрыт.
'
' Если устройство равно null, то для выбора подходящего устройства
' используется формат файла.
}
{ --------------------------------------------------------------------------- }
function aaGetFile(dwFlags: word; lpszPath: PChar; wBufLen: word; lpszDriver: PChar; wDrvLen: word) : integer; external 'AAPLAY';
{
' Открывает системного диалоговое окно стандартного типа ("открыть файл"),
' предлагающее пользователю выбрать файл.
'
' <dwFlags> определяет характеристики диалогового окна.
' Список возможных флагов:
' AA_GETFILE_MUSTEXIST Выбранный файл должен удовлетворять условиям
' флагов OpenFile(), в противном случае диалог
' издаст системный звук.
' AA_GETFILE_NOSHOWSPEC НЕ показывать путь в поле редактирования.
' По умолчанию путь к файлу показывается.
' AA_GETFILE_SAVE Кнопка Ok имеет заголовок "Save".
' AA_GETFILE_OPEN Кнопка Ok имеет заголовок "Open".
' AA_GETFILE_USEFILE Взять имя файла из параметра lpszPath
' AA_GETFILE_UDEDIR Взять каталог из параметра lpszPath
' AA_GETFILE_SOUND Получить звуковой файл и драйвер
' AA_GETFILE_SCRIPT Получить файл со скриптом
' AA_GETFILE_ANIMATION Получить файл анимации (без скриптов)
'
' <lpszPath> - строковый буфер LPSTR, куда после выполнения диалога
' пишется полное имя пути.
' <wBufLen> - длина данного буфера.
'
' <lpszDriver> - строковый буфер LPSTR для хранения выбранного
' звукового устройства.
' <wDrvLen> - длина данного буфера.
'
' Возвращаемые значения: 0, если была нажата кнопка Cancel
' -1, если OpenFile() потерпело неудачу,
' а AA_GETFILE_MUSTEXIST не определен.
' В противном случае возвращается дескриптор DOS-файла.
' При возврате из aaOpenFile данный дескриптор "не открыт".
}
{ --------------------------------------------------------------------------- }
function aaSave(hAa: AAHandle; wMode: word) : integer; external 'AAPLAY';
{
' Сохранение скрипта
}
{ --------------------------------------------------------------------------- }
{$F-}
{ Окончание внешних вызовов 'AAPLAY.DLL' }
{ =========================================================================== }
end.
{ =========================================================================== }
Dr Paul Kuczora.
-
Paul Kuczora c home.london.uk
(на создание файла потрачен один день)
Как сделать, чтобы орган управления, например, сложная линия, хваталась только за некий контур, и пропускала мышь под себя в других местах?
Nomadic советует: Надо обрабатывать сообщение CM_HITTEST (Это сообщение получают даже потомки от TGraphicsControl, не имеющего своего HWND). Например, так:procedure TLine.CMHitTest(var Message: TWMNCHitTest);
begin
if PointInLineReg(Message.XPos, Message.YPos) then begin
Message.Result := 1;
end else begin
Message.Result := 0;
end;
end;
Для органов управления Windows, если Вы не используете VCL, требуется обрабатывать сообщение WM_NCHITTEST.
Как быстро нарисовать тень в заданном регионе?
Nomadic советует:procedure TForm2.DrawShadows(WDepth, HDepth : Integer);
var
Dst, RgnBox : TRect;
hOldDC : HDC;
OffScreen : TBitmap;
Pattern : TBitmap;
Bits : array[0..7] of WORD;
begin
Bits[0] := $0055;
Bits[1] := $00aa;
Bits[2] := $0055;
Bits[3] := $00aa;
Bits[4] := $0055;
Bits[5] := $00aa;
Bits[6] := $0055;
Bits[7] := $00aa;
hOldDC := Canvas.Handle;
Canvas.Handle := GetWindowDC(Form1.Handle);
OffsetRgn(ShadeRgn, WDepth, HDepth);
GetRgnBox(ShadeRgn, RgnBox);
Pattern := TBitmap.Create;
Pattern.ReleaseHandle;
Pattern.Handle := CreateBitmap(8, 8, 1, 1, @(Bits[0]));
Canvas.Brush.Bitmap := Pattern;
OffScreen := TBitmap.Create;
OffScreen.Width := RgnBox.Right-RgnBox.Left;
OffScreen.Height := RgnBox.Bottom-RgnBox.Top;
Dst := Rect(0, 0, OffScreen.Width, OffScreen.Height);
OffsetRgn(ShadeRgn, 0, –RgnBox.Top);
FillRgn(OffScreen.Canvas.Handle, ShadeRgn, Canvas.Brush.Handle);
OffsetRgn(ShadeRgn, 0, RgnBox.Top);
// BitBlt работает быстрее CopyRect
BitBlt(OffScreen.Canvas.Handle, 0, 0, OffScreen.Width, OffScreen.Height, Canvas.Handle, RgnBox.Left, RgnBox.Top, SRCAND);
Canvas.Brush.Color := clBlack;
FillRgn(Canvas.Handle, ShadeRgn, Canvas.Brush.Handle);
BitBlt(Canvas.Handle, RgnBox.Left, RgnBox.Top, OffScreen.Width, OffScreen.Height, OffScreen.Canvas.Handle, 0, 0, SRCPAINT);
OffScreen.Free;
Pattern.Free;
OffsetRgn(ShadeRgn, –WDepth, –HDepth);
ReleaseDC(Form1.Handle, Canvas.Handle);
Canvas.Handle := hOldDC;
end;
Комментарии:
Функция рисует тень сложной формы на форме Form2 (извиняюсь за стиль). Для определения формы тени используется регион ShadeRgn, который был создан где-то раньше (например в OnCreate). Относительно регионов см. Win32 API.
Как рисовать на органе управления, например, на TPanel?
Nomadic советует: У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas. Если свойство Canvas недоступно, Вы можете достучаться до него созданием потомка и переносом этого свойства в раздел Public.{ Example. We recommend You to create this component through Component Wizard.
In Delphi 1 it can be found as 'File|New Component…', and can be found
as 'Component|New Component…' in Delphi 2 or above. }
type
TcPanel = class(TPanel)
public
property Canvas;
end;
У меня есть маленькое замечание.
Если у объекта нет свойства Canvas (у TDBEdit вроде-бы нет), то, по крайней меpе в D3, можно использовать класс TControlCanvas. Примерное использование:
var
cc: TControlCanvas;
…
cc := TControlCanvas.Create;
cc.Control := yourControl;
…
и далее как обычно можно использовать методы Canvas.
Как мне из Handle битовой картинки, получить адрес битового изображения в памяти?
Nomadic советует: Вот кусок одного моего класса, в котором есть две интересные вещицы — проецирование файлов в память и работа с битмэпом в памяти через указатель. Сразу оговорюсь, что все это работает только под Win95/NT.type
TarrRGBTriple=array[byte] of TRGBTriple;
ParrRGBTriple=^TarrRGBTriple;
{организует битмэп размером SX,SY;true_color}
procedure TMBitmap.Allocate(SX,SY:integer);
var DC:HDC;
begin
if BM<>0 then DeleteObject(BM); {удаляем старый битмэп, если был}
BM:=0;
PB:=nil;
fillchar(BI,sizeof(BI),0);
with BI.bmiHeader do {заполняем структуру с параметрами битмэпа}
begin
biSize:=sizeof(BI.bmiHeader);
biWidth:=SX;
biHeight:=SY;
biPlanes:=1;
biBitCount:=24;
biCompression:=BI_RGB;
biSizeImage:=0;
biXPelsPerMeter:=0;
biYPelsPerMeter:=0;
biClrUsed:=0;
biClrImportant:=0;
FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)}
if (biWidth or biHeight)<>0 then begin
DC:=CreateDC('DISPLAY',nil,nil,nil);
{замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу разместить выделяемый битмэп в спроецированном файле, что позволяет ускорять работу и экономить память при генерировании большого битмэпа}
{!} BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0);
DeleteDC(DC); {в PB получаем указатель на битмэп-----^^}
if BM=0 then Error('error creating DIB');
end;
end;
end;
{эта процедура загружает из файла true-color'ный битмэп}
procedure TMBitmap.LoadFromFile(const FileName:string);
var
HF:integer; {file handle}
HM:THandle; {file-mapping handle}
PF:pchar; {pointer to file view in memory}
i,j: integer;
Ofs:integer;
begin
{открываем файл}
HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite);
if HF<0 then Error('open file '''+FileName+'''');
try
{создаем объект-проецируемый файл}
HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil);
if HM=0 then Error('can''t create file mapping');
try
{собственно проецируем объект в адресное }
PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0);
{получаем указатель на область памяти, в которую спроецирован файл}
if PF=nil then Error('can''t create map view of file');
try
{работаем с файлом как с областью памяти через указатель PF}
if PBitmapFileHeader(PF)^.bfType<>$4D42 then Error('file format');
Ofs:=PBitmapFileHeader(PF)^.bfOffBits;
with PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do begin
if (biSize<>40) or (biPlanes<>1) then Error('file format');
if (biCompression<>BI_RGB) or (biBitCount<>24) then Error('only true-color BMP supported');
{выделяем память под битмэп}
Allocate(biWidth,biHeight);
end;
for j:=0 to BI.bmiHeader.biHeight-1 do
for i:=0 to BI.bmiHeader.biWidth-1 do
{Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе}
Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i];
finally
UnmapViewOfFile(PF);
end;
finally
CloseHandle(HM);
end;
finally
FileClose(HF);
end;
end;
{эта функция - реализация Pixels read}
function TMBitmap.GetPixel(X,Y:integer):PRGB;
begin
if (X>=0) and (X<BI.bmiHeader.biWidth) and (Y>=0) and (Y<BI.bmiHeader.biHeight) then
Result:=PRGB(PB+(Y)*FLineSize+X*3)
else Result:=PRGB(PB);
end;
Если у вас на форме есть компонент TImage, то можно сделать так:
var BMP:TMBitmap;
B:TBitmap;
…
BMP.LoadFromFile(…);
B:=TBitmap.Create;
B.Handle:=BMP.Handle;
Image1.Picture.Bitmap:=B;
и загруженный битмэп появится на экране.
Можно ли запустить OpenGL под Windows'95, и как поставлять его с программой?
Nomadic советует: Надо сразу отметить, что для работы Microsoft OpenGL 1.1 требуется только наличие в системе двух динамических библиотек. Они различны для Windows 95 и для Windows NT. Они всегда инсталлируется вместе с системой, если эта система – Windows 95 OSR2 или более поздняя, или если это Windows NT. Однако, если Вы столкнулись с машиной, где OpenGL отсутствует (Windows 95 OSR1 и более ранние), то достаточно их взять из диcтpибyтива OSR2 (GLU32.DLL и OPENGL32.DLL) и записать в GetSystemDirectory – и запycкайте OpenGL-приложения на здоpовье. Более эффективную реализацию OpenGL для Win32 от фирмы SGI я бы советовал стянуть с www.sgi.com или www.opengl.org (SGI OpenGL for Windows). Кроме того, оттуда же советую скачать дополнительную библиотеку функций-утилит, позволяющую упростить работу в OpenGL (GLUT). Возможно, что Вам понравится какой-нибудь API более высокого уровня, типа SCiTech MGL (www.scitechsoft.com).Как вывести на экран текст с 'красивым' обрезанием по длине (если текст не помещается на экране)?
Одной строкойNomadic советует: Используй вызов DrawTextEx, установив в параметре dwDTFormat значение DT_PATH_ELLIPSIS.
При работе программ на Delphi 1 под Windows 95 в hicolor-режимах на иконках TBitBtn'ов обнаруживаются странные коричневые артефакты. Как от них избавиться?
Одной строкойNomadic советует: A: (AB): Залить фон битмапа синим цветом.
Получение контекста устройства для элемента управления
Одной строкой
{Bitmap в TImage}
HDC := TImage.Picture.bitmap.canvas.handle;
DC – что нибудь с Canvas.handle
Отладка
Hard mode без перерыва II
Delphi 1ОПРЕДЕЛЕНИЕ: «hard mode» является режимом Windows, при которой не происходит никакой обработки сообщений. Это происходит при отрисовке меню или некоторых операциях ядра. Это означает, что в этом состоянии Delphi не может «заморозить» ваше приложение, не блокируя Windows. Обычно это возникает вследствие многочисленных вызовов SendMessage. В этом случае, для выхода из Hard mode, необходимо «встряхнуть» систему. Вполне достаточно, если ваш отладчик покажет вам системно-модальное окно (messagebox), говорящее вам о том, что вы находитесь в hard mode! Для этого попробуйте поставить дополнительный breakpoint (точку останова) на строчке, *предшествующей* вашему breakpoint. В этом случае вы получите предупреждение о том, что система находится в hard mode, и этот же диалог «вышибет» систему из этого состояния. При нажатии на OK, вторая точка останова сработает как положено. ПРИМЕЧАНИЕ: Поскольку работа отладчика построена на обработке сообщений, то он не может остановить работу в точке останова, если он «думает», что система вошла в режим hard mode, поскольку в этом случае вы не сможете ничего сделать, и система просто напросто зависнет.
При возникновении ошибки во время отладки программы машина перезагружается. Что делать?
Nomadic отвечает: A: Снести QEMM. Начисто. Простое отключение его функций не помогает. Впрочем, это исправлено в QEMM 9.0.Разное
Переустановка Delphi 2.0
Delphi 2Данный совет поможет вам в вопросе переустановки Delphi 2.0. Если вам понадобиться дополнительная помощь, пожалуйста, свяжитесь со службой «Горячей линии» по телефону (408) 461-9195. Рекомендации по переустановке Delphi 2 • Перед переустановкой Delphi 2.0, запустите утилиту удаления, щелкнув на иконке «add/remove program» (добавить/удалить программу) в Панели Управления Windows 95, или щелкнув на иконке «uninstall» в программной группе Delphi 2.0 в Windows NT. ‣ Не запускайте процедуру удаления с Delphi 2.0 CD. • Перед удалением и переустановкой Delphi 2.0 завершите работу приложений, использующих Borland Database Engine и закройте Local InterBase Server (если он запущен), щелкнув на иконке Local InterBase (правой кнопкой мыши в системной панели задач Windows 95) и выбрав «shutdown». • Установка Delphi 2.0 в Windows NT требует Windows NT версии 3.51 или более поздней. • Перед установкой Delphi 2.0 убедитесь в том, что в Windows установлен самый последний service pack. Пакеты Service pack распространяются фирмой Microsoft Corporation. Хорошим источником является Интернет-сервер корпорации, расположенный по адресу www.microsoft.com. • Если в вашей системе уже установлена Delphi 1.0, Delphi 2.0 вы должны установить в другой каталог. Единственный каталог, рекомендуемый для общего пользования обоими версиями Delphi, каталог IDAPI. • Перед установкой убедитесь в том, что вы имеете права администратора системы. • Установка Delphi 2.0 на сетевой сервер не поддерживается. • Для установки Delphi 2.0 на компьютере, не имеющего привода CD-ROM, используйте сетевое соединение, или соединение через последовательный порт с использованием кабеля для параллельного или последовательного порта, копируйте установочные файлы с Delphi 2.0 CD во временный каталог компьютера, на котором вы хотите провести установку, и затем запустите программу установки из временного каталога компьютера, не имеющего CD-ROM. После успешной установки вы можете удалить файлы, которые вы скопировали во временный каталог. • Если на компьютере запущен stacker, переименуйте VSTACKER.386 (расположенный в вашем каталоге windows\system) в VSTACKER.$$$. Перезапустите Windows и снова запустите программу установки. • Если вы выключили поддержку виртуальной памяти, вам необходимо ее снова активизировать, так как программе установки требуется по меньшей мере 64Мб виртуальной памяти. • Ваша операционная система должна поддерживать длинные имена файлов. • Если на машине установлен Paradox, то перед установкой Delphi снимите со всех файлов блокировки. Ошибки установки • Если мастер онлайн-регистрации не завершил до конца процедуру онлайновой регистрации, запустите снова процедуру установки и нажмите кнопку Cancel (отмена) на запрос онлайновой регистрации. Пожалуйста заполните и вышлите регистрационную карточку, включаемую в поставку вашего продукта Delphi 2.0. • Если в процессе установки вы получите пустое диалоговое окно, отмените установку и пробуйте снова, пока установка не пройдет успешно. • Если в процессе установки вы получите одно из следующих сообщений об ошибке: «out of disk space» (недостаточно места на диске), «no temp var» (нет временных переменных), «error 101» (ошибка 101) «error 102"(ошибка 102) Освободите дисковое пространство и/или убедитесь в наличие переменных среды и временного каталога. На диске, куда устанавливается Delphi, во временном каталоге должно быть достаточно свободного места. • Если в процессе установки вы получите следующую ошибку: «Install Shield error filename –51» (ошибка Install Shield при работе с файлом –51), то попробуйте сделать следующее: 1. Скопируйте все файлы (КРОМЕ CTL3D32.DLL) из каталога runimage\delphi20\windows\system32, расположенного на Delphi 2.0 CD, во временную директорию вашего жесткого диска. 2. Сбросьте флажок «read only» (только для чтения) во всех файлах, скопированных во временный каталог. 3. Скопируйте файлы в ваш каталог windows\system, или windows\system32 для системы Windows NT. 4. Снова запустите установку. Другая информация, необходимая для успешной установки • Попробуйте выполнить установку с вашего жесткого диска. Чтобы сделать это, удалите Delphi 2.0, затем просто скопируйте файлы из каталога установки Delphi 2.0 CD во временный каталог вашего диска, после чего запустите из этого каталога программу установки. После успешной установки скопированные во временный каталог файлы можно удалить. • Временно переименуйте файл win.ini (расположенный в вашем каталоге Windows) в win.in$, перезагрузите систему и переустановите или перезапустите Delphi 2.0. Если это поможет, то причиной невозможности в установке Delphi могут быть любые программы, указанные в секции run или load файла win.ini, или нестандартные драйверы принтера. • Загрузите стандартный видеодрайвер, поставляемый с вашей системой Windows. • Проверьте атрибут «read-only» (только для чтения) для файлов, расположенных в каталогах Windows и windows\system. Вопросы, которые могут возникнуть после установки • Если при попытке установки 32-битного ODBC драйвера для BDE вы получаете сообщение об ошибке «odbc is corrupt or not installed correctly» (ODBC испорчен или неправильно установлен) или «BDECFG32.EXE Error» (ошибка BDECFG32.EXE), то в первую очередь вам нужно установить 32-битный менеджер ODBC, доступный в InterSolv и Microsoft. Хорошим источником является Интернет-сервер корпорации Microsoft, расположенный по адресу www.microsoft.com. • Если вы установили Delphi 1.0 после установки Delphi 2.0, и Delphi 2.0 загружает файлы помощи от Delphi 1.0, удалите любые ссылки на файлы помощи Delphi 1.0 из файла WINHELP.INI, расположенного в вашем каталоге Windows.
Как проводить локализацию своих приложений?
Nomadic советует: В Delphi 3 и 4 есть специальные механизмы, позволяющие приложение «переделать» на любой язык после компиляции. Для D3 надо посмотреть в хелпе, по-моему, internationalization или что-то в этом роде. Для D4 вообще все делается ОЧЕНЬ просто: 1. берется проект, компилируется; 2. тут-же, не закрывая проект, вызвается New|Resource DLL Wizard, в нем указывается, какие формы и модули должны подвергнуться переводу на другой язык; 3. в результате работы Wizard появляется проект (sic!) с RC и DFM. Открываем формы, и переделываем все сообщения + размер (соотв. длине сообщений); 4. Компилируем. В результате получается файл xxxxxxx.rus, где xxxxxxx – название исходного проекта; 5. Запускаем xxxxxxx.exe. Видим некий не наш язык. Подкладываем в каталог с этим exe изготовленный файл xxxxxxx.rus, и запускаем exe повторно. Видим абсолютно ВЕЗДЕ переведенные сообщения. p.s. файл RUS можно подставлять и убирать по вкусу.crtdll.dll в программах на Delphi
Здравствуйте. Тут открыл кое-что, возможно, давным давно всем известное. :) Поделюсь на всякий случай. Сначала немного о корнях проблемы. Не секрет, что в Delphi модуль Math поставляется только с Enterprise-версией программы. А платить больше тысячи долларов только за то, чтобы воспользоваться парой функций совсем не хочется (мне, например, простенькой atan2 часто не хватало). Простым решением является «заимствование» модуля Math из пиратской Enterpise-версии, но это, вообще-то, воровство. Самому же создавать матеатическую библитеку с нуля – занятие неблагодарное (по крайней мере достаточно трудоёмкое). Не работая плотно на MSVC я как-то был не в курсе наличия библиотеки crtdll.dll в Windows (насколько мне удалось выяснить, она таки является частью операционной системы, по крайней мере ставится вместе с Windows 9x/NT/2000). С её помощью можно решить указанную проблему, воспользовавшись готовым решением, а именно – объявить все необходые функции из math.h в своей программе и наслаждаться. :) Пример с atan2:function atan2(x, y: double): Double; stdcall; external 'crtdll.dll' name 'atan2';
Проверено – работает. Поскольку метод открылся буквально только что, я ещё не успел сделать модуль-обёртку для всех математических функций. Видимо, сделаю и отдам во всеобщее пользование.
Да, в crtdll.dll много фукнций, не связанных с математикой, в частности, если вы в программе используете PChar, то можно воспользоваться набором сишных strcmp, strcpy…, так же доступны isalpha, isdigit…, и, наконец, bsearch и qsort. :)
С уважением,
Марк Шевченко.
Как сказать VCL, чтобы клавиши shortcut пунктов главного меню главной формы действовали только в этой форме (но не в модальных окнах, к примеру)?
Nomadic советует: Знакомая проблема. Лечится так:function WindowHook(var Message: TMessage): Boolean;
procedure .FormCreate(Sender: TObject);
begin
// MainForm
Application.HookMainWindow(WindowHook);
function .WindowHook;
begin
Result := False;
with Message do
case Msg of
CM_APPKEYDOWN, CM_APPSYSCOMMAND: Msg := WM_NULL;
При использовании MS SQL Server 6.5 в NT Performance Monitor исчезли все датчики, кроме SQL
Nomadic советует: Кто виноват: Дело в следующем – при инсталляции NT страна была поставлена US, затем сменена на Russia. В реестре для Perfomance Monitor существует (может существовать) сколь угодно подуровней с названием счетчиков и описанием к ним. При инсталляции все естестественно ставилось в ветвь 409 (US), а ветви 419 (Russia) просто не было. Потом default location была сделана Russia. Perfomance Monitor не мог найти 419 и брал все счетчики из 409. Hо тут пришел SQL и как умная программа при инсталляции создал ветвь 419 и запихал туда свои счетчики. Теперь Perfomance Monitor видит что текущая locale 419, в реестре она есть и берет оттуда счетчики, а они там только для SQL естественно. Что делать: Запускаешь regedit (regedt32), находишь где лежат описания счетчиков. Точно я не помню, под рукой NT нет, но примерно так – HKEY_LOCAL_MACHINE/System/CurrentControlSet/Control/PerfLib/409 (419). В каждом разделе по два ключа – список названий счетчиков и список их описаний. Заходишь в 409, открываешь ключ для изменений и при помощи Ctrl-Ins копируешь его содержимое в буфер обмена и жмешь Cancel. Теперь идешь в 419 открываешь тот же ключ, идешь в начало списка и при помощи Shift-Ins вставляешь, жмешь Ok. Так надо сделать и для названий счетчиков и для их описания. Для полного счастья можно и SQL счетчики из 419 в 409 (в конец) скопировать.xWindows — FAQ
Артем Федюк прислал свой сборник любимых функций:(*
Функции собрал Артем Федюк (Киев, 27.11.2000)E-Mail: xartrain@hotmail.comсообщите, пожалуйста о найденных ошибках*)
{H+}//use huge strings
unit XWindows;
INTERFACE
uses classes, windows, shellApi, shlobj, sysUtils, forms, mmsystem, controls, Messages, Registry, IniFiles;
{***************************ПРОЦЕССЫ И УПРАВЛЕНИЕ ИМИ**************************}
procedure execWait(constcomLine:string);
procedure shellExec(const fileName:string);
//также можно использовать Sleep(ms:DWORD);
procedure Delay(msecs : DWORD);
//фактически определяется запущена ли сейчас среда Delphi
function isDelphiRunning:boolean;
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';
procedure applicationInCtrlAltDelList(visi:boolean);
procedure applicationInTaskBar(visi:boolean);
//Запретить/разрешить Ctrl-Alt-Del
procedure CtrlAltDel(state:boolean);
//Окно без закладки в TaskBar
procedure noAppInTaskbar;
//Определение какие приложения уже запущены
procedure ApplicationList(formHandle:THandle; var stringList:TStringList);
{***************************ВРЕМЯ**********************************************}
function SetTime(DateTime:TDateTime):Boolean;
//обновить часы - SendMessage(HWND_TOPMOST,WM_TIMECHANGE,0,0);
{***************************ИНТЕРФЕЙС WINDOWS**********************************}
//Cache,Cookies,Desktop,Favorites,Fonts,Personal,Programs,SendTo,Start Menu,Startup
function ShellFolder(const folderType:string):string;
procedure refreshWindowsDesktop;
procedure Startbutton(visi:boolean);
//убрать/показать TaskBar
procedure TaskBar(visi:boolean);
//оч2истить меню "Документы"
procedure clearDocuments;
//добавить документ в меню 'Документы'
// Для данного файла должно быть зарегистрировано средство просмотра
procedure addFileToDocuments(const fileName:string);
//Значение функции TRUE если мелкий шрифт
function SmallFonts:Boolean;
{! проверить}procedure setWallPaper(const fileName:string; tile:boolean);
{***************************МОНИТОР********************************************}
procedure RunCurrentScreenSaver;
//use application:TApplication object
procedure monitorState(state:boolean);
{***************************КЛАВИАТУРА*****************************************}
procedure RussianKbdLayout;
procedure EnglishKbdLayout;
procedure UkrainianKbdLayout;
{***************************МЫШЬ***********************************************}
//относительные координаты в абсолютные - function ClientToScreen(Pt:TPoint):TPoint;
procedure mouseEmul(absPoint:TPoint; up,down:boolean);
procedure mouseCursor(visi:boolean);
//просимулировать нажатие клавиши мыши
{! Не проверено}procedure SendMouseClick(x,y:integer;wHandle:THandle);
{**8*************************ДИСКОВЫЕ ФУНКЦИИ**********************************}
//8FAT,FAT32,CDFS,NWCOMPA
//0-"A",1-"B",2-"C"
function GetFileSysName(Drive : Byte) : String;
function GetVolumeName(Drive : Byte) : String;
function DriveExists(Drive : Byte) : Boolean;
//'?';'Path2 does not exists';'Removable';'Fixed';'Remote';'CD-ROM';'RAMDISK'
function CheckDriveType(Drive : Byte) : String;
//Определение готовности дисковода к работе
function DiskInDrive(const Drive: char): Boolean;
function HDDSerialNum(const drivePath:string{'C:\'}):integer;
{***************************CD-ROM*********************************************}
function getCdromPath:string;
procedure CDROMOpen;
procedure CDROMClose;
{***************************REGISTRY*******************************************}
procedure StartFromRegistry(appName,appPath:string);
//запускается до WindowsLogon
procedure StartServiceFromRegistry(appName,appPath:string);
procedure StartFromWinIni(appPath:string);
function IsInstalled (FileExe: String): Boolean;
IMPLEMENTATION
(*
Вопрос:
Можно ли как-то уменьшить мерцание при перерисовке компонента?
Ответ:
Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента - то фон компонента перерисовываться не будет.
Пример:
constructor TMyControl.Create;
begin
inherited;
//проверка "if not inIDE" должна быть вставлена в том случае, когда TMyControl - компонент
//чтобы среда IDE Delphi не глючила на этапе разработки
if not inIDE then ControlStyle := ControlStyle + [csOpaque];
end;
...
procedure Register;
begin
RegisterComponents('MyGraphics', [TMyControl]);
inIDE:=True;
end;
*)
procedure mouseCursor(visi:boolean);
Var CState:Integer;
Begin
CState:= ShowCursor(True);
if visi then begin
//Включение курсора
while CState<0 do CState:=ShowCursor(True);
end else begin
//Выключение курсора
while Cstate >= 0 do Cstate := ShowCursor(False);
end;
End;
//Cache,Cookies,Desktop,Favorites,Fonts,Personal,Programs,SendTo,Start Menu,Startup
function ShellFolder(const folderType:string):string;
var registry:TRegistry;
begin
result:='';
Registry := TRegistry.Create;
try
Registry.RootKey := HKey_Current_User;
Registry.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False);
result:= Registry.ReadString(folderType);
finally
Registry.Free;
end;
end;
procedure SetWallpaper(const fileName:string;tile:boolean);
var Reg: TRegIniFile;
begin
Reg:=TRegIniFile.Create('Control Panel');
Reg.WriteString('desktop', 'Wallpaper', fileName);
if tile then Reg.WriteString('desktop', 'TileWallpaper', '1')
else Reg.WriteString('desktop', 'TileWallpaper', '0');
Reg.Free;
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
end;
{procedure setWallPaper(fileName:string);
begin
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, pChar(fileNAme), 0);
end;}
procedure refreshWindowsDesktop;
begin
SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, $A065, 0);
end;
procedure mouseEmul(absPoint:TPoint; up,down:boolean);
begin
//Положение курсора мыши задается в "абсолютных" координатах ("Mickeys"),
//где 65535 "Mickeys" равно ширине экрана.
absPoint.x := Round(absPoint.x * (65535 / Screen.Width));
absPoint.y := Round(absPoint.y * (65535 / Screen.Height));
{Переместим курсор мыши}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE, absPoint.x, absPoint.y, 0, 0);
if down then Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, absPoint.x, absPoint.y, 0, 0);
if up then Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, absPoint.x, absPoint.y, 0, 0);
end;
//просимулировать нажатие клавиши мыши
procedure SendMouseClick(x,y:integer;wHandle:THandle);
begin
sendmessage(wHandle, WM_LBUTTONDOWN, MK_LBUTTON, x+(y shl 16));
sendmessage(wHandle, WM_LBUTTONUP, MK_LBUTTON, x+(y shl 16));
application.processMessages;
end;
procedure monitorState(state:boolean);
begin
if state then SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1)
else SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0);
end;
procedure execWait(const comLine:string);
var
si:Tstartupinfo;
p:Tprocessinformation;
begin
fillChar(Si, SizeOf(Si), 0);
with Si do begin
cb := SizeOf(Si);
dwFlags := startf_UseShowWindow;
wShowWindow := 4;
end;
Createprocess(nil, pChar(comLine), nil, nil, false, Create_default_error_mode, nil, nil, si, p);
Waitforsingleobject(p.hProcess, infinite);
end;
procedure shellExec(const fileName:string);
begin
shellExecute(0, Nil, pChar(fileName), Nil, Nil, SW_NORMAL);
end;
procedure Delay(msecs : DWORD);
var
FirstTick : DWORD;
begin
FirstTick:=GetTickCount;
repeat
Application.ProcessMessages;
until GetTickCount-FirstTick >= msecs;
end;
function HDDSerialNum(const drivePath:string{'C:\'}):integer;
var
SerialNum:Pdword;
a,b:Dword;
buffer:array [0..255] of char;
begin
result:=0;
new(SerialNum);
if getVolumeInformation(pChar(drivePath), buffer, sizeof(buffer), SerialNum, a, b, nil, 0) then result:=SerialNum^;
Dispose(SerialNum);
end;
//фактически определяется запущена ли сейчас среда Delphi
function isDelphiRunning:boolean;
var H1, H2, H3, H4 : Hwnd;
const
A1 : array[0..12] of char = 'TApplication'#0;
A2 : array[0..15] of char = 'TAlignPalette'#0;
A3 : array[0..18] of char = 'TPropertyInspector'#0;
A4 : array[0..11] of char = 'TAppBuilder'#0;
begin
result:=false;
H1 := FindWindow(A1, nil);
H2 := FindWindow(A2, nil);
H3 := FindWindow(A3, nil);
H4 := FindWindow(A4, nil);
if (H1 <> 0) and (H2 <> 0) and (H3 <> 0) and (H4 <> 0) then result:=true;
end;
function getCdromPath:string;
var
w:dword;
Root:string;
i:integer;
begin
result:='';
w:=GetLogicalDrives;
Root := '#:\';
for i := 0 to 25 do begin
Root[1] := Char(Ord('A')+i);
if (W and (1 shl i))>0 then
if GetDriveType(Pchar(Root)) = DRIVE_CDROM then begin
result:=Root;
exit;
end;
end;
end;
//Определение готовности дисковода к работе
function DiskInDrive(const Drive: char): Boolean;
var
DrvNum: byte;
EMode: Word;
begin
result := false;
DrvNum := ord(Drive);
if DrvNum >= ord('a') then dec(DrvNum, $20);
EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
if DiskSize(DrvNum-$40) <> -1 then result := true
else messagebeep(0);
finally
SetErrorMode(EMode);
end;
end;
function soundCardExists:boolean;
begin
if WaveOutGetNumDevs>0 then result:=true
else result:=false;
end;
function SetTime(DateTime:TDateTime):Boolean;
var
st:TSystemTime;
ZoneTime: TTimeZoneInformation;
begin
GetTimeZoneInformation(ZoneTime);
DateTime:=DateTime+ZoneTime.Bias/1440;
with st do begin
DecodeDate(DateTime, wYear, wMonth, wDay);
DecodeTime(DateTime, wHour, wMinute, wSecond, wMilliseconds);
end;
result:=SetSystemTime(st);
SendMessage(HWND_TOPMOST, WM_TIMECHANGE, 0, 0);
end;
//Окно без закладки в TaskBar
procedure noAppInTaskbar;
begin
ShowWindow(Application.Handle, sw_Hide);
end;
//Определение какие приложения уже запущены
procedure ApplicationList(formHandle: THandle; var stringList: TStringList);
var
nd : hWnd;
buff: ARRAY [0..127] OF Char;
begin
stringList.Clear;
Wnd := GetWindow(formHandle, gw_HWndFirst);
WHILE Wnd <> 0 DO BEGIN
{Не показываем:}
IF (Wnd <> Application.Handle) AND {-Собственное окно}
IsWindowVisible(Wnd) AND {-Невидимые окна}
(GetWindow(Wnd, gw_Owner) = 0) AND {-Дочернии окна}
(GetWindowText(Wnd, buff, sizeof(buff)) <> 0) {-Окна без заголовков}
THEN BEGIN
GetWindowText(Wnd, buff, sizeof(buff));
stringList.Add(StrPas(buff));
END;
Wnd := GetWindow(Wnd, gw_hWndNext);
END;
end;
procedure CDROMOpen;
begin
mciSendString('Set cdaudio door open wait', nil, 0, 0);
end;
procedure CDROMClose;
begin
mciSendString('Set cdaudio door closed wait', nil, 0, 0);
end;
//Запретить/разрешить Ctrl-Alt-Del
procedure CtrlAltDel(state:boolean);
var old:Boolean;
begin
old:=True;
if state then
//Восстановить
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, @old, 0)
else
//Убрать
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, @old, 0);
end;
procedure StartButton(visi:boolean);
Var
Tray, Child : hWnd;
C : Array[0..127] of Char;
S : String;
Begin
Tray := FindWindow('Shell_TrayWnd', NIL);
Child := GetWindow(Tray, GW_CHILD);
While Child <> 0 do Begin
If GetClassName(Child, C, SizeOf(C)) > 0 Then Begin
S := StrPAS(C);
If UpperCase(S) = 'BUTTON' then begin
If Visi then ShowWindow(Child, 1)
else ShowWindow(Child, 0);
end;
End;
Child := GetWindow(Child, GW_HWNDNEXT);
End;
End;
//убрать/показать TaskBar
procedure TaskBar(visi:boolean);
begin
if visi then ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_SHOW) // Показать Taskbar
else ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_HIDE); //Скрыть TaskBar
end;
procedure applicationInCtrlAltDelList(visi:boolean);
begin
if visi then begin
//Show
RegisterServiceProcess(GetCurrentProcessID, 0);
end else begin
//Hide
RegisterServiceProcess(GetCurrentProcessID, 1);
end;
end;
procedure applicationInTaskBar(visi:boolean);
begin
if visi then windows.ShowWindow(FindWindow(nil, @Application.Title[1]), SW_SHOW)
else windows.ShowWindow(FindWindow(nil, @Application.Title[1]), SW_HIDE);
end;
procedure RussianKbdLayout;//На русский
var Layout: array[0..KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout, '00000419'), KLF_ACTIVATE);
end;
procedure EnglishKbdLayout;//На английский
var Layout: array[0..KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout, '00000409'), KLF_ACTIVATE);
end;
procedure UkrainianKbdLayout;//На украинский
var Layout: array[0..KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout, pChar(intToHex(LANG_UKRAINIAN+$400, 8))), KLF_ACTIVATE);
end;
//запустить текущий ScreenSaver
procedure RunCurrentScreenSaver;
begin
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
end;
//очистить меню "Документы"
procedure clearDocuments;
begin
SHAddToRecentDocs(SHARD_PATH, nil);
end;
//добавить документ в меню 'Документы'
// Для данного файла должно быть зарегистрировано средство просмотра
procedure addFileToDocuments(const fileName:string);
begin
SHAddToRecentDocs(SHARD_PATH, pchar(fileName));
end;
//Значение функции TRUE если мелкий шрифт
function SmallFonts:Boolean;
var DC:HDC;
begin
DC:=GetDC(0);
Result:=(GetDeviceCaps(DC, LOGPIXELSX) = 96);
{ В случае крупного шрифта будет 120}
ReleaseDC(0, DC);
end;
function DriveExists(Drive : Byte) : Boolean;
begin
Result := Boolean(GetLogicalDrives AND (1 SHL Drive))
end;
//'?';'Path does not exists';'Removable';'Fixed';'Remote';'CD-ROM';'RAMDISK'
function CheckDriveType(Drive : Byte) : String;
var
DriveLetter : Char;
DriveType : UInt;
begin
DriveLetter := Char(Drive + $41);
DriveType := GetDriveType(PChar(DriveLetter + ':\'));
Case DriveType of
0 : Result := '?';
1 : Result := 'Path does not exists';
DRIVE_REMOVABLE : Result := 'Removable';
DRIVE_FIXED : Result := 'Fixed';
DRIVE_REMOTE : Result := 'Remote';
DRIVE_CDROM : Result := 'CD-ROM';
DRIVE_RAMDISK : Result := 'RAMDISK'
Else Result := 'Unknown';
end;
end;
//GetVolumeInformation
function GetFileSysName(Drive : Byte) : String;
var
DriveLetter : Char;
NoMatter : DWORD;
FileSysName : Array[0..MAX_PATH] of Char;
begin
DriveLetter := Char(Drive + $41);
GetVolumeInformation(PChar(DriveLetter + ':\'), Nil, 0, nil, NoMatter, NoMatter, FileSysName, SizeOf(FileSysName));
Result := FileSysName;
end;
function GetVolumeName(Drive : Byte) : String;
var
DriveLetter : Char;
NoMatter : DWORD;
VolumeName : Array[0..MAX_PATH] of Char;
begin
DriveLetter := Char(Drive + $41);
GetVolumeInformation(PChar(DriveLetter + ':\'), VolumeName, SizeOf(VolumeName), nil, NoMatter, NoMatter, Nil, 0);
Result := VolumeName;
end;
procedure StartFromRegistry(appName,appPath:string);
var reg: TRegistry;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', true{canCreate});
reg.WriteString(appname, appPath);
reg.CloseKey;
reg.free;
end;
procedure StartServiceFromRegistry(appName,appPath:string);
var reg: TRegistry;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\RunServices', true{canCreate});
reg.WriteString(appname, appPath);
reg.CloseKey;
reg.free;
end;
procedure StartFromWinIni(appPath:string);
var
WinIni : TIniFile;
WinIniFileName : array[0..MAX_PATH] of char;s : string;
begin
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini');
WinIni := TIniFile.Create(WinIniFileName);
s := WinIni.ReadString('windows', 'run', '');
if s = '' then s := appPath
else s := s + ';' + appPath;
WinIni.WriteString('windows', 'run', s);
WinIni.Free;
end;
function IsInstalled(FileExe: String): Boolean;
var
reg : TRegistry;
temp: String;
begin
result:=False;
reg:= Tregistry.Create;
try
reg.RootKey:= HKEY_LOCAL_MACHINE;
if reg.OpenKey('\Software\Microsoft\Windows\CurrentVersion\App Paths\'+FileExe, false) then begin
if reg.ValueExists('') then begin
temp := reg.readString('Path');
result := FileExists(temp+'\'+FileExe);
end;
end;
finally
reg.Free;
end;
end;
END.
Последние комментарии
45 минут 50 секунд назад
8 часов 50 минут назад
9 часов 10 минут назад
9 часов 35 минут назад
9 часов 39 минут назад
19 часов 9 минут назад