Советы по Delphi
         

Прием файлов из Program Manager II


Для осуществления функции drag/drop из File Manager, вы должны "зарегистрировать" дескриптор принимаемой формы (свойство Handle) Windows API функцией

    DragAcceptFiles(Handle, True);

После этого вы сможете получать сообщения WM_DROPFILES при перетаскивании файлов из File Manager в вашу форму. Для "отключения" этой характеристики необходимо вторично вызвать ту же API функцию, но со вторым параметром равным False.

Для получения имен перетаскиваемых файлов необходимо воспользоваться Windows функцией DragQueryFile, для получения информации при окончании операции Drag/Drop воспользуйтесь функцией DragFinish. DragQueryPt подскажет вам в каком месте формы былы "брошены" перетаскиваемые файлы.

Вам необходимо принимать файлы даже при свернутой форме? Для этого нужно дополнительно создать обработчик события OnMessage объекта Application. Нижеприведенный пример предполагает, что на форме имеется компонент ListBox, свойство Align которого установлено в alClient:

    ... { Private declarations } procedure WMDropFiles(VAR Msg: TWMDropFiles); message WM_DROPFILES;

procedure AppOnMessage(VAR Msg: TMsg; VAR Handled : Boolean); ...
implementation
USES ShellApi;
...
procedure TForm1.WMDropFiles(VAR Msg: TWMDropFiles);
VAR
N : Word; buffer : ARRAY[0..80] OF Char; BEGIN
WITH Msg DO BEGIN FOR N := 0 TO DragQueryFile(Drop, $FFFF, buffer, 80)-1 DO BEGIN DragQueryFile(Drop, N, Buffer, 80); ListBox1.Items.Add(StrPas(Buffer)); END; DragFinish(Drop); END;
END;

procedure TForm1.AppOnMessage(VAR Msg: TMsg;
VAR Handled : Boolean); VAR WMD : TWMDropFiles;
BEGIN
IF Msg.message = WM_DROPFILES then BEGIN MessageBeep(0); WMD.Msg    := Msg.message; WMD.Drop   := Msg.wParam; WMD.Unused := Msg.lParam; WMD.Result := 0; WMDropFiles(WMD); Handled := TRUE; END;
END;

procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Handle, True); DragAcceptFiles(Application.Handle, True); Application.OnMessage := AppOnMessage; end;

[000466]



TDrawGrid Drawcell


    procedure TForm1.DrawGrid1DrawCell(Sender: TObject; Col, Row: Longint;
Rect: TRect; State: TGridDrawState); VAR vRow, vCol : LongInt;
begin
vRow := Row; vCol := Col; WITH Sender AS TDrawGrid, Canvas DO BEGIN IF (vRow=0) OR (vCol=0) THEN Font.Color := clBlack ELSE Font.Color := clRed; TextRect(Rect, Rect.Left, Rect.Top, Format('(%d,%d)',[vRow, vCol])); END; end;

- Neil [000512]



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


    PROCEDURE TForm1.Edit1Exit(Sender: TObject);
BEGIN
IF Edit1.Text<>'' THEN BEGIN TRY StrToDate(Edit1.Text); EXCEPT Edit1.SetFocus; MessageBeep(0); raise Exception.Create('&quot'+Edit1.Text +'&quot - некорректная дата'); END{try}; Edit1.Text:=DateToStr(StrToDate(Edit1.Text)); END{if}; END;
[000015]



Числовая маска компонента Edit c помощью OnKeyPress III


Я предлагаю обработать событие OnKeyPress следующим образом:

    procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if    NOT (Key in ('0'..'9', '.', #8, #13)) // разрешенные клавиши OR (    (Key = '.')                  // пользователь нажал '.' AND (POS ('.', Edit1.Text) > 0)) // десятичная точка уже имеется then begin Key := #0; MessageBeep (MB_OK); end; end;

В коде проверяется, была ли нажатая клавиша цифрой, клавишей [Tab] или [Enter]. Все остальное запрещено (код клавиши не принимается, и устанавливается в ноль) и подается сигнал через компьютерную пищалку.

Если вы не хотите связываться с десятичной дробью, уберите строчку с ключевым словом OR и символ '.' из первого IF-условия. Если вы хотите проверять, что пользователь ввел между LowLimit и HighLimit, воспользуйтесь следующим кодом:

    procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if    NOT (Key in ('0'..'9', #8, #13)) OR (StrToInt (Edit1.Text + Key) < LowLimit) OR (StrToInt (Edit1.Text + Key) > HighLimit) then begin Key := #0; MessageBeep (MB_OK); end; end;

[001555]


    procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
VAR P, L : Byte;
begin
WITH Sender AS TEdit DO BEGIN L := Length(Text); P := Pos('.', Text); END; CASE Key OF '0'..'9' : IF (P>0) AND (L-P>1) THEN Key := #0; '.' : IF P > 0 THEN Key := #0; #8 : {пробел}; ELSE Key := #0; END; end;

Команда Key=#0 в обработчике события OnKeyPress "гасит" нажатую клавишу. Так, если нажата цифровая клавиша, то код ее "гасится", ЕСЛИ уже присутствует десятичная точка и две цифры после нее. Если введена десятичная точка, то она "гасится", ЕСЛИ десятичная точка уже присутствует. Пробел пропускается в любом случае, коды остальных клавиш всегда "гасятся". Во всяком случае теперь вы знаете "куда копать".

- Neil [000550]




Читатель советует:

Посылаю Вам несколько расширенный вариант числовой маски компонента TЕdit c помощью OnKeyPress. В отличие от имеющегося в "Советах", приведенный код не "запирает" поле ввода при заполнении десятичной части, преобразует точку в запятую (для удобства пользователя), не позволяет поставить десятичную запятую перед числом и позволяет стирать знаки в поле ввода клавишей 'Back Space'. Код проверен в Delphi 5.

    procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var                                          //цифровая маска
vrPos,vrLength,vrSelStart : byte;
const
I : byte=1; //I+1 = количество знаков после запятой (в данном случае - 2 знака)
begin
With Sender as TEdit do begin vrLength:=Length(Text); //определяем длину текста vrPos:=Pos(',', Text); //проверяем наличие запятой vrSelStart:=SelStart; //определяем положение курсора end;
Case Key of
'0'..'9' : begin //проверяем положение курсора и количество знаков после запятой If (vrPos>0)and(vrLength-vrPos>I)and(vrSelStart>=vrPos) then Key:=#0; //"погасить" клавишу end; ',','.' : begin //если запятая уже есть или запятую пытаются поставить перед числом или никаких цифр в поле ввода еще нет If (vrPos>0)or(vrSelStart=0)or(vrLength=0) then Key:=#0 //"погасить" клавишу else Key:=#44; //всегда заменять точку на запятую end; #8 : ; //позволить удаление знаков клавишей 'Back Space' else Key := #0; //"погасить" все остальные клавиши end;
end;

С уважением, Михаил Шпанер. [000903]



Денежное поле редактирования


    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.

[001164]



Edit: SetFocus в OnExit


Я пробую выполнить editbox.SetFocus и/или editbox.Clear, но но это не дает никакого эффекта (по крайней мере видимого). Что я делаю неправильно?

Вы посылаете команду на изменение фокуса внутри обработчика, который сам устанавливает фокус, этим вы получаете банальную рекурсию.

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

Следующие строки содержат необходимый код:

    interface ........ const WM_MyExitRtn = WM_USER + 1001; ........ type TForm1 = class(TForm) ......... private bExitInProgress: Boolean; {предохраняемся от рекурсий сообщений} public Procedure WMMyExitRtn(Var msg:TMessage); message WM_MyExitRtn; end; ......... implementation ......... procedure TForm1.DBEdit1Exit(Sender: TObject); begin If not bExitInProgress Then PostMessage(Handle,WM_MyExitRtn,0,LongInt(Sender)); end; ......... procedure TForm1.WMMyExitRtn(var msg:TMessage); begin bExitInProgress := True;           { предохраняемся от рекурсивного вызова } {здесь содержится необходимый код } bExitInProgress := False;          { сбрасываем флаг } end;

[000619]



Хитрый TEdit


Приведу письмо читателя:

...я тоже пишу в Delphi и могу поделиться своим опытом. В дополнение к этому письму, чтобы не быть голословным, прилагаю маленький компонент THintEdit, порожденный от TCustomEdit, который представляет собой с виду обычный TEdit элемент с возможностью автоматического выбора стринговых значений из скрытого списка (так, как это реализовано в Netscape Navigator'е). Описание особенно не нужно, так как выполнено все достаточно элементарно: значения для выбора заносятся в свойство HintList, тип свойства TStrings. При нажатии клавиш вверх/вниз выбираются значения, соответствующие набранным начальным символам.

    unit HintEdit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
THintEdit = class(TCustomEdit) private { Private declarations } FHintList:TStrings; Searching, CanSearch:boolean; CurSPos:integer; protected { Protected declarations } procedure Change; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; public { Public declarations } constructor Create(AOwner: TComponent); override; property HintList:TStrings read FHintList write FHintList; destructor Destroy; override; published { Published declarations } property Anchors; property AutoSelect; property AutoSize; property BiDiMode; property BorderStyle; property CharCase; property Color; property Constraints; property Ctl3D; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property HideSelection; property ImeMode; property ImeName; property MaxLength; property OEMConvert; property ParentBiDiMode; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PasswordChar; property PopupMenu; property ReadOnly; property ShowHint; property TabOrder; property TabStop; property Text; property Visible; property OnChange; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDock; property OnStartDrag; end;
procedure Register;

implementation

{$R *.DCR}

procedure Register;
begin
RegisterComponents('Netscape', [THintEdit]); end;

constructor THintEdit.Create;
begin
inherited; FHintList:=TStringList.Create; Searching:=false; CanSearch:=true; CurSPos:=-1; end;

procedure THintEdit.Change;
var
i,l:integer; begin
if Searching then Exit; if not CanSearch then Exit; if Text='' then exit; l:=Length(Text); for i:=0 to FHintList.Count-1 do if Copy(FHintList[i],1,l)=Text then begin Searching:=true; CurSPos:=i; Text:=FHintList[i]; Searching:=false; SelStart:=Length(Text); SelLength:=-(Length(Text)-l); break; end; inherited; end;

procedure THintEdit.KeyDown;
var
l:integer; begin
if Chr(Key) in ['A'..'z','А'..'Я','а'..'я'] then CanSearch:=true else CanSearch:=false; case Key of VK_DOWN:begin if (CurSPos<HintList.Count-1) and (SelLength>0) then if Copy(FHintList[CurSPos+1],1,SelStart)=Copy(Text,1,SelStart) then begin l:=SelStart; Inc(CurSPos); Text:=FHintList[CurSPos]; SelStart:=Length(Text); SelLength:=-(Length(Text)-l); end; Key:=VK_RETURN; end; VK_UP:begin if (CurSPos>0) and (SelLength>0) then if Copy(FHintList[CurSPos-1],1,SelStart)=Copy(Text,1,SelStart) then begin l:=SelStart; Dec(CurSPos); Text:=FHintList[CurSPos]; SelStart:=Length(Text); SelLength:=-(Length(Text)-l); end; Key:=VK_RETURN; end; VK_RETURN:begin SelStart:=0; SelLength:=Length(Text); end; end; inherited; end;

destructor THintEdit.Destroy;
begin
FHintList.Free; inherited; end;

Константин Хрипков <kostya@softincom.ru>. [000515]



Как ограничить количество вводимого


Олег Кулабухов делится своим опытом:

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

    procedure TForm1.FormCreate(Sender: TObject);
var
cRect : TRect;
bm : TBitmap;
s : string;
begin
Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create;
bm.Width := cRect.Right;
bm.Height := cRect.Bottom;
bm.Canvas.Font := Edit1.Font;
s := 'W';
while bm.Canvas.TextWidth(s) < CRect.Right do
s := s + 'W';
if length(s) > 1 then begin
Delete(s, 1, 1);
Edit1.MaxLength := Length(s);
end;
end;

{Alternatively}

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var
cRect : TRect;
bm : TBitmap;
begin
if ((Ord(Key) <> VK_TAB) and
(Ord(Key) <> VK_RETURN) and
(Ord(Key) <> VK_LEFT) and
(Ord(Key) <> VK_BACK)) then begin
Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create;
bm.Width := cRect.Right;
bm.Height := cRect.Bottom;
bm.Canvas.Font := Edit1.Font;
if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then begin
Key := #0;
MessageBeep(-1);
end;
bm.Free;
end;
end;

[001888]



Как получить позицию курсора в TEdit?


Nomadic лаконично отвечает:

    property SelStart: Integer;

[001716]



Массив Edit-компонентов


    Procedure DoSomethingWithEditControls;
Var K: Integer;
EditArray: Array[0..99] of Tedit; begin
Try
For K:= 0 to 99 do begin EditArray[K]:= TEdit.Create(Self); EditArray[K].Parent:= Self; SetSomeOtherPropertiesOfTEdit; {Устанавливаем необходимые свойства TEdit} Left:= 100; Top:= K*10; OnMouseMove:= WhatToDoWhenMouseIsMoved; {Что-то делаем при перемещении мыши} end; DoWhateverYouWantToDoWithTheseEdits; {Делаем все что хотим с полученным массивом Edit-компонентов} Finally
For K:= 0 to 99 do EditArray[K].Free;
end;

Примечание: узнать доступные свойства компонента можно непосредственно в инспекторе объектов и (или) в текстовом режиме вашей формы (щелкните на форме правой кнопкой мыши и выберите пункт View as Text) [000043]



Матрица на основе TEdit


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

Допустим, если они имеют имена с Edit1 по Edit 9, то можно попробовать сделать так:

    var eds: array[1..3,1..3] of TEdit; ix: integer; ed: TEdit;
for ix := 0 to 8 do begin ed := FindComponent('Edit'+IntToStr(ix+1)) as TEdit; if ed <> nil then eds[ix div 3 + 1,ix mod 3 + 1] := ed; end;

Затем, допустим, вам захотелось скопировать текст из строки 1 в строку 2:

    for ix := 1 to 3 do eds[2,ix].Text := eds[1,ix].Text;

- Mike Orriss [000994]



Ограничение TEdit на ввод не-цифровой информации


Вставьте следующую строку в обработчик события KeyPress:

    if not (Key in [#8,'0'..'9']) then Key := #0;
[000501]



Отслеживаем позицию курсора в 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;

[001541]



Правое выравнивание текста в компоненте Edit


    TEdit1  = class(TEdit) public procedure CreateParams(var Params: TCreateParams); Override; end;
procedure TEdit1.CreateParams(var Params: TCreateParams); begin
inherited CreateParams(Params); Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT; end;

[001581]



Проверка на соответствие содержимого TEdit


Как мне проверить на соответствие содержимое компонента TEdit?

Предположим, вы регулярно пользуетесь компонентами TEdit (в отличие от компонентов TDBEdit), и если так, то наилучшим местом для осуществления проверки на соответствие является обработчик события OnExit компонента TEdit. Данное событие наступает при каждом покидании фокуса компонента.

Обычно, при вводе неправильного текста в поле редактирования, у вас возникает желание послать предупреждение пользователю и вернуть фокус обратно. Тем не менее, в данном решении трудность подстерегает при попытке установить фокус в обработчике события OnExit. Поскольку Windows остается "посередине" при передаче фокуса от одного элемента управления другому в обработчике события OnExit, вы можете получить состояние нестабильного поведения компонентов, если попытаетесь в это время изменить фокус.

Решением в данной ситуации может служить попытка послать сообщение в обработчике события компонента TEdit OnExit вашей форме. Определенное пользователем и посланное сообщение может послужить отправной точкой для начала проверки содержимого поля редактирования. Поскольку посланное сообщение располагается в конце очереди сообщений, то это дает Windows возможность завершить изменение фокуса прежде, чем вы попытаетесь передать фокус другому элементу управления.

Помещенный ниже текст модуля и текстовое представление формы (DFM) призваны продемонстрировать эту технику:

    { *** НАЧАЛО КОДА МОДУЛЯ UNIT1.PAS *** } unit Unit1;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Mask;
const { Определенное пользователем сообщение } um_ValidateInput = wm_User + 100;
type TForm1 = class(TForm) Edit1: TEdit; Edit2: TEdit; Edit3: TEdit; Edit4: TEdit; Button1: TButton; MaskEdit1: TMaskEdit; procedure Edit1Exit(Sender: TObject); private { обработчик определенного пользователем события } procedure ValidateInput(var M: TMessage); message um_ValidateInput; end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.ValidateInput(var M: TMessage); begin { Следующая строка является строкой проверки. Я хочу убедиться в том, } { что первый символ является буквенным символом верхнего регистра. } { Помните о преобразовании типа lParam к TEdit. } if not (TEdit(M.lParam).Text[1] in ['a'..'z']) then begin ShowMessage('Содержимое не отвечает требованиям'); { Орем на пользователя } TEdit(M.lParam).SetFocus;                          { Снова устанавливаем фокус } end; end;
procedure TForm1.Edit1Exit(Sender: TObject); begin { Посылаем сообщение самому себе, говорящее о необходимости } { проверки содержимого. Передаем экземпляр TEdit (Self) как } { lParam сообщения. } PostMessage(Handle, um_ValidateInput, 0, longint(Sender)); end;
end. { *** КОНЕЦ КОДА МОДУЛЯ UNIT1.PAS *** }
{ *** НАЧАЛО КОДА ФАЙЛА UNIT1.DFM *** } object Form1: TForm1 Left = 200 Top = 99 Width = 318 Height = 205 Caption = 'Form1' Font.Color = clWindowText Font.Height = -13 Font.Name = 'System' Font.Style = [] PixelsPerInch = 96 TextHeight = 16 object Edit1: TEdit Left = 32 Top = 32 Width = 121 Height = 24 TabOrder = 0 Text = 'Edit1' OnExit = Edit1Exit end object Edit2: TEdit Left = 160 Top = 32 Width = 121 Height = 24 TabOrder = 1 Text = 'Edit2' OnExit = Edit1Exit end object Edit3: TEdit Left = 32 Top = 64 Width = 121 Height = 24 TabOrder = 2 Text = 'Edit3' OnExit = Edit1Exit end object Edit4: TEdit Left = 160 Top = 64 Width = 121 Height = 24 TabOrder = 3 Text = 'Edit4' OnExit = Edit1Exit end object Button1: TButton Left = 112 Top = 136 Width = 89 Height = 33 Caption = 'Button1' TabOrder = 4 end end { *** КОНЕЦ КОДА ФАЙЛА UNIT1.DFM *** }

[000945]



Расположение текста в правой части TEdit


Есть какое-нибудь простое решение для расположения текста в правой части TEDIT?

Вместо этого используйте однострочный TMemo. WordWrap=False, WantReturns=False. [000421]



TEdit и событие OnEnter


    interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type
TNewComponent = class(TEdit) private { Private declarations } protected { Protected declarations } procedure DoEnter; OverRide; public { Public declarations } constructor Create(AOwner: TComponent); OverRide; destructor Destroy; Override; published { Published declarations } end;
procedure Register;

implementation

procedure TNewComponent.DoEnter;
begin
inherited DoEnter; <нужный вам код> end;

destructor TNewComponent.Destroy;
begin
inherited destroy; end;

constructor TNewComponent.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;

procedure Register;
begin
RegisterComponents('Samples', [TNewComponent]); end;

end.

[001615]



Битное кодирование/декодирование I


Привожу нетестированный код. Автор: Arne de Bruijn.

    { 64-битное декодирование файлов }
{ Arne de Bruijn }
uses dos;
var
Base64:array[43..122] of byte; var
T:text; Chars:set of char; S:string; K,I,J:word; Buf:pointer; DShift:integer; F:file; B,B1:byte; Decode:array[0..63] of byte; Shift2:byte; Size,W:word; begin FillChar(Base64,SizeOf(Base64),255); J:=0; for I:=65 to 90 do begin Base64[I]:=J; Inc(J); end; for I:=97 to 122 do begin Base64[I]:=J; Inc(J); end; for I:=48 to 57 do begin Base64[I]:=J; Inc(J); end; Base64[43]:=J; Inc(J); Base64[47]:=J; Inc(J); if ParamCount=0 then begin WriteLn('UNBASE64 <mime-файл> [<выходной файл>]'); Halt(1); end; S:=ParamStr(1); assign(T,S); GetMem(Buf,32768); SetTextBuf(T,Buf^,32768); {$I-} reset(T); {$I+} if IOResult<>0 then begin WriteLn('Ошибка считывания ',S); Halt(1); end; if ParamCount>=2 then S:=ParamStr(2) else begin write('Расположение:'); ReadLn(S); end; assign(F,S); {$I-} rewrite(F,1); {$I+} if IOResult<>0 then begin WriteLn('Ошибка создания ',S); Halt(1); end; while not eof(T) do begin ReadLn(T,S); if (S<>'') and (pos(' ',S)=0) and (S[1]>=#43) and (S[1]<=#122) and (Base64[byte(S[1])]<>255) then begin FillChar(Decode,SizeOf(Decode),0); DShift:=0; J:=0; Shift2:=1; Size:=255; B:=0; for I:=1 to Length(S) do begin case S[I] of #43..#122:B1:=Base64[Ord(S[I])]; else B1:=255; end; if B1=255 then if S[I]='=' then begin B1:=0; if Size=255 then Size:=J; end else WriteLn('Ошибка символа:',S[I],' (',Ord(S[I]),')'); if DShift and 7=0 then begin Decode[J]:=byte(B1 shl 2); DShift:=2; end else begin Decode[J]:=Decode[J] or Hi(word(B1) shl (DShift+2)); Decode[J+1]:=Lo(word(B1) shl (DShift+2)); Inc(J); Inc(DShift,2); end; end; if Size=255 then Size:=J; BlockWrite(F,Decode,Size); end; end; Close(F); close(T); end.
[000074]



Битное кодирование/декодирование II


Пришло от читателя письмо:

Хочу предложить еще одну реализацию алгоритма декодирования base64. Код проверен, работает без глюков. Евгений.

С удовольствием публикую данный код:

    Const
Base64Table='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';

function Base64Decode(cStr:string):string;
var ResStr:string;
DecStr:string; RecodeLine   : array [1..76] of byte; f1,f2 : word; l:integer; begin l :=length(cStr); ResStr:=''; for f1:=1 to l do if cStr[f1]='=' then RecodeLine[f1]:=0 else RecodeLine[f1]:=pos(cStr[f1],Base64Table)-1; f1:=1; while f1<length(cStr) do begin DecStr:=chr(byte(RecodeLine[f1]   shl 2)+RecodeLine[f1+1] shr 4)+ chr(byte(RecodeLine[f1+1] shl 4)+RecodeLine[f1+2] shr 2)+ chr(byte(RecodeLine[f1+2] shl 6)+RecodeLine[f1+3]); ResStr:=ResStr+DecStr; inc(f1,4); end; Base64Decode:=ResStr; end;
[000782]



Кодирование/декодирование строки


Как закодировать строку?

Вот программа, демонстрирующая методы кодирования и раскодирования строк. Примечание: Мы не отвечаем за уникальность и секретность алгоритма данной фунции.

    { Начало кода }

program Crypt;

uses WinCRT;

const
C1 = 52845; C2 = 22719;
function Encrypt(const S: String; Key: Word): String;
var
I: byte; begin
Result[0] := S[0]; for I := 1 to Length(S) do begin Result[I] := char(byte(S[I]) xor (Key shr 8)); Key := (byte(Result[I]) + Key) * C1 + C2; end; end;

function Decrypt(const S: String; Key: Word): String;
var
I: byte; begin
Result[0] := S[0]; for I := 1 to Length(S) do begin Result[I] := char(byte(S[I]) xor (Key shr 8)); Key := (byte(S[I]) + Key) * C1 + C2; end; end;

var
S: string; begin
Write('>'); ReadLn(S); S := Encrypt(S,12345); WriteLn(S); S := Decrypt(S,12345); WriteLn(S); end.

[000675]



Простой пример XOR шифрования


Пришло от читателя письмо:

Вот ужасно простой пример XOR шифрования - работает без глюков.

    var key, text, longkey, result : string;
i : integer; toto, c : char; begin
for i := 0 to (length(text) div length(key)) do longkey := longkey + key;
for i := 1 to length(text) do begin toto := chr((ord(text[i]) XOR ord(longkey[i]))); // XOR алгоритм result := result + toto; end; end;

Igor N. Semenushkin. [001832]



Проверка кредитной карты


    unit Creditc;

{*****************************************************************************

Модуль Delphi для проверки номера кредитной карты

Версия: 1.1
Дата: Декабрь 20, 1996

Данный модуль создан на основе алгоритма ccard автора Peter Miller.
Автор не против бесплатного использования, но резервирует все права
на данный алгоритм.

авторское право 1996 Shawn Wilson Harvell ( shawn@inet.net )

применение:

Внесите данный модуль в список uses любого модуля, которому
необходим доступ к функции проверки кредитной карты.

IsValidCreditCardNumber( CardNumber, ReturnMessage ) returns Boolean

например, используйте это для уведомления пользователя о недействительности карты.
CardNumber - строка, содержащая номер карты, которую необходимо проверить
ReturnMessage - строка, с помощью которой функция может возвратить любое сообщение
( при этом старое содержимое строки стирается )

возвращает true если номер карточки верен, false - в противном случае.

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

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

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

На момент написания модуля он устойчиво работал под Delphi версий 1 и 2,
для Turbo Pascal необходимо внести некоторые несложные исправления (главным
образом из-за различия реализации функций в модуле SysUtils).

Если вы нашли этот модуль полезным, имеете какие-то пожелания или предложения,
отправьте автору письмо по адресу электронной почты shawn@inet.net

История изменений

версия 1.1 -- Декабрь 20, 1996
исправлена ошибка с Discover card: соответственно увеличина длина маски "database"

версия 1.0 -- Октябрь 26, 1996
первый выпуск

*****************************************************************************}

interface

uses SysUtils;

function IsValidCreditCardNumber( CardNumber: String; var MessageText: String ): Boolean;

implementation

const
CardPrefixes: array[ 1..19 ] of string  = ( '2014', '2149', '300', '301', '302', '303', '304', '305', '34', '36', '37', '38', '4', '51', '52', '53', '54', '55', '6011' );
CardTypes: array[ 1..19 ] of String = ( 'enRoute', 'enRoute', 'Diner Club/Carte Blanche', 'Diner Club/Carte Blanche', 'Diner Club/Carte Blanche', 'Diner Club/Carte Blanche', 'Diner Club/Carte Blanche', 'Diner Club/Carte Blanche', 'American Express', 'Diner Club/Carte Blanche', 'American Express', 'Diner Club/Carte Blanche', 'Visa', 'MasterCard', 'MasterCard', 'MasterCard', 'MasterCard', 'MasterCard', 'Discover' );

function RemoveChar(const Input: String; DeletedChar: Char): String;
var
Index: Word;                    { переменная счетчика                           } begin
{ данная функция удаляет все вхождения указанного символа из переданной ей      } { строки                                                                        } Result := Input; for Index := Length( Result ) downto 1 do if Result[ Index ] = DeletedChar then Delete( Result, Index, 1 ); end;

function ShiftMask( Input: Integer ): Integer;
begin
{ простая оболочка для функции сдвига битов числа                              } result := ( 1 shl ( Input - 12 ) ); end;

function ConfirmChecksum( CardNumber: String ): Boolean;
var
CheckSum: Integer;             { Содержит значение операции                    } Flag: Boolean;                 { флаг готовности                               } Counter: Integer;              { индекс счетчика                               } PartNumber: String;            { используется для извлечения каждой цифры числа} Number: Integer;               { исп-ся для преобразования каждой цифры в число} begin

{************************************************************************** Это, вероятно, самая запутанный код, который вы когда-либо видели, я и сам запутался, когда работал над ним. Основное, что делает данная функция - извлекает каждую цифру из номера карты для использования в формуле проверки контрольной суммы, устанавливаемую компаниями. Алгоритм производит выборку, начиная от последней цифры и заканчивая первой. **************************************************************************}
{ получаем стартовое значение счетчика } Counter := Length( CardNumber  ); CheckSum := 0; PartNumber := ''; Number := 0; Flag := false;
while ( Counter >= 1 ) do begin { получаем текущую цифру } PartNumber := Copy( CardNumber, Counter, 1 ); Number := StrToInt( PartNumber ); { преобразуем в число } if ( Flag ) then { только каждую вторую цифру } begin Number := Number * 2; if ( Number >= 10 ) then Number := Number - 9; end; CheckSum := CheckSum + Number;
Flag := not( Flag );
Counter := Counter - 1; end;
result := ( ( CheckSum mod 10 ) = 0 ); end;

function GetMask( CardName: String  ): Integer;
begin
{ значение по умолчанию } result := 0;
if ( CardName = 'MasterCard' ) then result := ShiftMask( 16 ); if ( CardName = 'Visa' ) then result := ( ShiftMask( 13 ) or ShiftMask( 16 ) ); if ( CardName = 'American Express' ) then result := ShiftMask( 15 ); if ( CardName = 'Diner Club/Carte Blanche' ) then result := ShiftMask( 14 ); if ( CardName = 'Discover' ) then result := ShiftMask( 16 );
end;

function IsValidCreditCardNumber( CardNumber: String; var MessageText: String ): Boolean;
var
StrippedNumber: String;        { используется для хранения числа без дополнительных символов } Index: Integer;                { универсальный счетчик для циклов и т.п.                     } TheMask: Integer;              { число, которое мы будем использовать для маски              } FoundIt: Boolean;              { используется для индикации, когда что-либо найдено          } CardName: String;              { хранит имя типа карты                                       } PerformChecksum: Boolean;      { тип enRoute карты если контрольная сумма не сошлась         } begin

{ сначала избавимся от пробелов и тире } StrippedNumber := RemoveChar( CardNumber, ' ' ); StrippedNumber := RemoveChar( StrippedNumber, '-' );
{ если строка была нулевой длины, то тоже OK } if ( StrippedNumber = '' ) then begin result := true; exit; end;

{ инициализация возвращаемых переменных } MessageText := ''; result := true;
{ устанавливаем нашу переменную-флаг } FoundIt := false;
{ проверка правильности введенных символов в номере карты } for Index := 1 to Length( StrippedNumber ) do begin case StrippedNumber[ Index ] of '0'..'9': FoundIt := FoundIt;   { другими словами не op } else MessageText := 'Неверный введенный символ'; result := false; exit; end; end;
{ теперь давайте определим тип используемой карты } for Index := 1 to 19 do begin if ( Pos( CardPrefixes[ Index ], StrippedNumber ) = 1 ) then begin { мы обнаружили правильный тип } FoundIt := true; CardName := CardTypes[ Index ]; TheMask := GetMask( CardName ); end; end;
{ если тип карты не определен, указываем на это } if ( not FoundIt ) then begin CardName := 'Unknown Card Type'; TheMask := 0; MessageText := 'Неизвестный тип карты '; result := false; exit; end;
{ проверка длины } if ( ( Length( StrippedNumber ) > 28 ) and result ) then begin MessageText := 'Номер слишком большой '; result := false; exit; end;

{ проверка длины } if ( ( Length( StrippedNumber ) < 12 ) or ( ( shiftmask( length( strippednumber ) ) and themask ) = 0 ) ) then begin messagetext := 'неверная длина числа'; result := false; exit; end;
{ проверяем вычисление контрольной суммы } if ( cardname = 'enroute' ) then performchecksum := false else performchecksum := true;
if ( performchecksum and ( not confirmchecksum( strippednumber ) ) ) then begin messagetext := 'неверная контрольная сумма'; result := false; exit; end;
{ если результат равен true, тогда все ok } if ( result ) then messagetext := 'номер верен: тип карты: ' + cardname;
{ если строка была нулевой длины, то тоже OK } if ( strippednumber = '' ) then result := true;
end;

end.

[000304]



Советы по Delphi

DLL и ресурсы


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

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

Главное, что нужно помнить при разработке DLL - вы не должны допускать ситуацию, при которой любое исключение осталось бы неперехваченным (спасибо Pat Ritchey за столь мудрый совет). В теле экспортируемых функций "заверните" все в блоки try..except (которые замечательно обрабатываются Delphi).

Далее, любые ресурсы, которые вы явно создаете при открытии DLL, должны создаваться в обработчике FormCreate (а не в секции Initialization) и освобождаться в обработчике FormClose. Мне кажется, что при вызове DLL (и использовании ее для распределения ресурсов) они не полностью освобождается до тех пор, пока вызывающее приложение не будет закрыто, а при вторичном вызове DLL не перегружается (это мои наблюдения, но, похоже, они верны). По всей видимости, ресурсы, освобожденные в первый раз, во время второго вызова не пересоздаются. У меня была масса проблем до тех пор, пока в коде я не определил "нужное место" для освобождения ресурсов. Но после того, как я переместил работу с ресурсами в обработчики событий FormCreate и FormClose, GPF исчезли.

Кроме того, для освобождения ресурсов вы должны вместо метода Close или Free использовать метод Release.

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

Надеюсь я помог вам.

Mike Leftwich
Ensemble Corp. [000443]



Проблема использования в DLL чисел с плавающей точкой


...если вы DLL создаете не с помощью Delphi, то не делайте так, чтобы возвращаемое функцией значение имело тип числа с плавающей точкой. Вместо этого для возвращаемого значения используйте var-параметр (указатель или ссылочный параметр в C++).

Я допускаю, что ваша DLL компилируется в M$ VC++. Причина кроется в том, что Borland и M$ применяют различные способы возврата чисел с плавающей точкой. Borland C++ и Delphi могут использовать один и тот же метод (через стек математического сопроцессора), но я не уверен в этом.

Так, если вы работаете с процедурами вместо функций, которые должны возвращать OK.

BTW: не используйте одинарную или двойную точность. Они могут быть изменены компилятором. Используйте тип double. [001654]



Делаем ApplyUpdates. Если пpи


Nomadic советует: Использyй ноpмальнyю тpансляцию ошибок в 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;

[001253]



IIS, Novell и ошибки бюджета


Ошибка "INVALID FILENAME" (неверное имя файла): когда мой слиент обращается к серверу, ISAPI DLL говорит "INVALID FILENAME". Мои таблицы PARADOX/DBASE расположены на сервере NOVELL. В чем дело?

Вы пропустили процедуру отображения диска (drive mapping) для вашего бюджета IUSR_XXX. Ваши таблицы расположены на сервере Novell, поэтому вам необходимо иметь диск, отображенный на нужный том сервера (где расположены таблицы).

Сопутствующая информация: Ваш Web-сервер выполняется IIS как сервис. Никто не сможет войти в систему интерактивно. Клиентская страница является результатом работы ISAPI DLL. IIS регистрирует вас на сервере как IUSR_XXX. Для того, чтобы ISAPI DLL могло бы видеть ваши таблицы на сервере Novell, вам необходимо отобразить для пользователя соответствующий диск. [001965]



Как бы мне соорудить в SP исключение, чтобы его увидел Delphi-клиент?


Nomadic отвечает:

sqlstate='99999' не подходит, так как хочется на клиенте видеть код исключения.

Используй RAISERROR с кодом >20000. Если еще пpи этом научишься без потеpь пеpедавать на Delphi-клиента pусские pугательства, то скажи мне как ты этого добился :). [001395]



Как добиться верной работы фильтра на запросах и на неиндексированных таблицах?


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;

[001353]



Как поймать свой 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у написать свою процедуру. [001336]



Когда я применяю ApplyUpdates


Nomadic отвечает:

Никак. Эти обновления идут прямо через BDE, а не через компонент набора данных.

В Delphi 4.0 (C++Builder 4.0) ситуация радикально изменилась.

Во-первых, обычному провайдеру данных (TProvider) можно указать, каким образом обновлять данные.

Во-вторых, новый тип провайдера (TDataSetProvider) работает только через соответвующие методы TDataSet.

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

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



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


    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, там много чего есть полезного. [001291]



Обработка исключений EDBEngineError


Информация, описывающая условия возникновения ошибки BDE, может быть получена приложением с помощью исключения EDBEngineError. Перехват и обработка в приложениях исключений EDBEngineError осуществляется с помощью конструкции try..except. При наступлении исключения EDBEngineError должен быть создан объект EDBEngineError, различные поля в котором могут быть использованы программистом для определения источника ошибки и принятия решения по исправлению ситуации. Для данного типа исключения может генерироваться более чем одно сообщение об ошибке. Для получения нужной информации необходимо "проиграть" все сообщения.

Вот поля, наиболее соответствующие нашему контексту: ErrorCount: тип Integer; указывает количество ошибок в свойстве Errors; отсчет начинается с нуля. Errors: тип TDBError; набор записей типа структуры, содержащей информацию о каждой специфической сгенерированной ошибке; каждая запись доступна через номер индекса, имеющего тип Integer. Errors.ErrorCode: тип DBIResult; указывает код ошибки BDE для ошибки в текущей записи Errors. Errors.Category: тип Byte; категория ошибки, ссылается на поле ErrorCode. Errors.SubCode: тип Byte; субкод значения ErrorCode. Errors.NativeError: тип LongInt; код удаленной ошибки, возвращаемой сервером; если ноль, то ошибка не является ошибкой сервера; в этом поле возвращается код запроса SQL. Errors.Message: тип TMessageStr; если ошибка является ошибкой сервера, то сообщение сервера содержится в текущей записи Errors; если это не ошибка сервера, то это сообщение об ошибке BDE. В случае наличия конструкции try..except, объект EDBEngineError создается непосредственно в секции except. После создания объекта исключения все его области становятся доступными, ссылка на объект может передаваться в другую процедуру для детального исследования ошибок. Метод передачи объекта EDBEngineError в специализированную процедуру для приложения предпочтительнее, поскольку делает код приложения более модульным и уменьшает общий объем кода, необходимого для синтаксического анализа объекта и получения информации о возникшей ошибке. В качестве альтернативы можно предложить идею создания специализированного компонента, предусматривающего описанную функциональность; такое решение позволяет распространять созданный в основе компонента код среди нескольких приложений. Приведенный ниже пример демонстрирует создание объекта DBEngineError, передачу его процедуре и синтаксический разбор объекта для получения информации об ошибке.

В конструкции try..except для создания экземпляра DBEngineError необходим синтаксис, показаный ниже:

    procedure TForm1.Button1Click(Sender: TObject); var i: Integer; begin if Edit1.Text > ' ' then begin Table1.FieldByName('Number').AsInteger := StrToInt(Edit1.Text); try Table1.Post; except on E: EDBEngineError do ShowError(E); end; end; end;

В данной процедуре сделана попытка изменить значение поля таблицы и вызвать метод Post соответствующего компонента TTable. Ошибка при попытке отправить измененные данные перехватывается в секции try..except. В случае возникновения EDBEngineError, выполнение передается в секцию except, где происходит создание объекта EDBEngineError (E) и передача его процедуре ShowError. Обратите внимание на то, что в этой секции во внимание берутся только исключения EDBEngineError. В реальной программе код должен содержать проверку на другие типы исключений.

Процедура ShowError в качестве параметра получает ссылку на объект EDBEngineError и "опрашивает" его на предмет наличия информации об ошибках. В приведенном ниже примере информация об ошибках отображается в компоненте TMemo. В реальной жизни отображение ошибок может и не понадобится, но информация о них является логикой работы приложения, расширяющая его функциональность так, чтобы оно могло правильно реагировать на них. Первым шагом необходимо вычислить количество реально произошедших ошибок. Эта величина хранится в свойстве ErrorCounnt. Данное свойство имеет тип Integer и может использоваться для создания цикла, в теле которого можно по очереди получить информацию о каждой ошибке, содержащейся в объекте. В теле цикла поочередно ErrorCount-раз перебираются все содержащиеся в объекте ошибки (как вы помните, каждая ошибка представляет собой запись-элемент свойства Errors), "достается" о них вся информация и помещается в компонент TMemo.

    procedure TForm1.ShowError(AExc: EDBEngineError); var i: Integer; begin Memo1.Lines.Clear; Memo1.Lines.Add('Количество ошибок: ' + IntToStr(AExc.ErrorCount)); Memo1.Lines.Add(''); {Перебираем все записи Errors} for i := 0 to AExc.ErrorCount - 1 do begin Memo1.Lines.Add('Сообщение: ' + AExc.Errors[i].Message); Memo1.Lines.Add(' Категория: ' + IntToStr(AExc.Errors[i].Category)); Memo1.Lines.Add(' Код ошибки: ' + IntToStr(AExc.Errors[i].ErrorCode)); Memo1.Lines.Add(' Субкод: ' + IntTooStr(AExc.Errors[i].SubCode)); Memo1.Lines.Add(' Реальная ошибка: ' + IntToStr(AExc.Errors[i].NativeError)); Memo1.Lines.Add(''); end; end;

[000592]



Я использую среду Delphi. Ошибка,


Пример, приведенный для функции dbiGetDatabaseDesc в файле BDE32.HLP, неверен. Такой же пример содержится в файле TI3100.ASC. Я пробовал это на 3 разных компьютерах. Я использую среду Delphi. Ошибка, которую я получаю при попытке использования функции, выглядит следующим образом:

EDBEngineError с сообщением 'Возникла ошибка при попытке инициализации Borland Database Engine (ошибка $2104).'

При вызове любой из функций BDE, если вы не пользуетесь компонентами для работы с базами данных, вам необходимо инициализировать BDE вызовом dbiInit(nil).

- Pat Ritchey [001097]


Ошибка пcевдонимов


Ошибка ODBC "INVALID CONFIGURATION PARAMETER FOR ALIAS {ALIAS_NAME}" (Неверно сконфигурирован параметр для псевдонима {имя псевдонима}: эта ошибка вознимает при попытке получения доступа к базе данных через ODBC DSN на сервере ISAPI/NSAPI. Что я делаю не так?

Для того, чтобы ODBC использовался как сервис, и был доступен всем пользователям, (бюджет гостя IIS), вам необходимо создать нестандартный SYSTEM DSN, а не пользовательский USER DSN, предоставляемый по-умолчанию. [001964]



Ошибка создания дескриптора курсора


Вы должны использовать ExecSql вместо Open. К примеру, если имя вашего запроса UpdateStudent, то при необходимости обновления STUDENT.DB вы должны использовать следующий код:

    Begin
..... UpdateStudent.ExecSql; ..... End;

Ваш запрос является Passtrough-запросом, который не может возвратить установленный результат, так что это не может быть открыто, а должно быть 'ВЫПОЛНЕНО'. [001271]



Перехват исключений базы данных


    Try
Tabl.Post; Except
Begin On EDatabaseError do ShowMessage('Не могу отправить данные (выполнить Post)'); (Sender AS TDBEdit).SetFocus; End; {Begin} End, {Try}

Я осуществляю синтаксический разбор Error и вновь генерирую исключение (передаю по иерархии следующему обработчику объектов исключительных ситуаций), если я больше не хочу иметь с ним дела. Если использовать:

    On E : EDatabaseError do...

то можно получить значение E.Error. Реально, имя свойства с текстом ошибки должно быть похоже на что-то типа E.Message (уточните в электронной справке).

    On EDatabaseError do begin
ShowMessage('Не могу отправить данные'); Edit1.setFocus; end;

[001672]



Перехват ошибок DBEngine


Ошибки общего характера, типа Key Violation или конфликты блокировки лучше всего обрабатывать в обработчике события Application.OnException ...например:

    {Секция Interface}
procedure HandleException(Sender: TObject; E: Exception);

{Секция Implementation}
procedure TForm1.HandleException(Sender: TObject; E: Exception);
var err : DBIResult;
begin
if E is EDBEngineError then begin err := (E as EDBEngineError).errors[(E as EDBEngineError).errorcount-1].errorcode; if (err = DBIERR_KEYVIOL) then showMessage('Ошибка Key violation!') else if (err = DBIERR_LOCKED) then showmessage('Запись блокирована другим пользователем') else if (err = DBIERR_FILELOCKED) then showmessage('Таблица блокирована кем-то еще') else showmessage('Другая ошибка DB') end else showmessage('Упс!: '+E.Message); end;

...'инсталлировать' обработчик исключений можно так:

    procedure TForm1.FormCreate(Sender: TObject);
begin
Application.onException:=HandleException; end;

Для использования предопределенных констант ошибок ('DBIERR_etc.'), вам необходимо включить DBIERRS в список используемых модулей. Полный список кодов ошибок при работе с базами данных вы можете найти в файле DBIERRS.INT, расположенном в каталоге :\DELPHI\DOC.

Eryk [000567]



При обращении к memo-полю из BDE возникает ошибка 'Memo too large'. Как лечить?


Nomadic отвечает:

В BDE есть крутая ошибка, достаточно известная всем, кроме Borland'a. Поскольку они ее еще с 1й Delphi не исправили. Этот баг проявляется как Access Violation в программе при обращении к таблице IB, которая содержит более одного поля типа VARCHAR (или CHAR) размером > 255. Причем, первое поле меньшего, а второе большего размера. Если поменять местами поля или сделать их одного размера, то все нормально.

Эффект имеет место только с IB, вроде. [001290]



При разрушении обьектов, порожденных


Nomadic отвечает:

Недоработка в VCL.
Сейчас вышел из ситуации так: в TForm.OnClose, т.е. пока ещё все компоненты формы живы, делаю CloseDatabases(Self). [001284]



При выполнении некоторых живых


Nomadic отвечает:

Запросы вида SELECT c, b, a, q FROM T WHERE b = :b, где ключ c, но BDE посчитала ключом a. Интересный запрос, да? Такое впечатление, что, поскольку ключом в исходной таблице являлась третья колонка, то Дельфы посчитали ключом третью колонку.

Перестановкой SELECT a, b, c, q... все исправилось. Я решил теперь использовать в таких (live) запросах только SELECT *. [001328]



Проблема BDE при использовании "неживого" TQuery


У меня была та же проблема, и я нашел единственное решение как ее обойти. Я подозреваю, что причина кроется в том, что Query1.Refresh ничего не делает, если установлен режим readonly, т.е. не ожидается никаких изменений. Один способ у меня прошел успешно (в предположении, что мы имеем один вход): я использовал 3 TQuerie, две сетки и форму обновления. Это способ, когда я могу установить requestlive в истину. Вы не должны допускать, чтобы пользователь мог сам редактировать табличную сетку (если это то, что вы хотите). [001219]



Исключения в Delphi


100-149 - ошибки ввода/вывода (I/O), 200-255 - фатальные ошибки согласно файлам помощи Delphi.

В Windows.pas всем кодам ошибок внешних исключительных ситуаций присвоены имена. Поищите, например

    STATUS_BREAKPOINT

чтобы найти декларации констант ошибок.

Ошибки времени выполнения, расположенные в таблице с номерами ниже 100 (и несколько ошибок с номерами больше 100, но они незначительны) - ошибки DOS.

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

Код и описание ошибок, возникающий в среде DOS
Код (Hex) Код (Dec) Описание
00h0нет ошибки
01h1 неверный номер функции
02h2 файл не найден
03h3 путь не найден
04h4 cлишком много открытых файлов (нет свободных дескрипторов)
05h5 доступ запрещен
06h6 неверный дескриптор
07h7 управляющий блок памяти разрушен
08h8 недостаточно памяти
09h9 неверный адрес блока памяти
0Ah10 неверное окружение (обычно при длине > 32К)
0Bh11 неверный формат
0Ch12 неверный код доступа
0Dh13 неверные данные
0Eh14 зарезервировано
0Fh15 неверное устройство (drive)
10h16 попытка удаления текущей директории
11h17 не то же устройство
12h18 нет больше файлов
--- DOS 3.0+ ---
13h19 диск имеет защиту от записи
14h20 неизвестное устройство
15h21 устройство не готово
16h22 неизвестная команда
17h23 ошибка данных (CRC)
18h24 неправильный запрос длины структуры
19h25 ошибка поиска
1Ah26 неизвестный тип носителя (не-DOS диск)
1Bh27 сектор не найден
1Ch28 принтер без бумаги
1Dh29 ошибка записи
1Eh30 ошибка чтения
1Fh31 общая ошибка (general failure)
20h32 нарушение доступа (sharing violation)
21h33 нарушение доступа (lock violation)
22h34 ошибка смены диска (ES:DI -> media ID диска) (смотри #0981)
23h35 FCB недоступно
24h36 переполнение буфера общего доступа (sharing buffer)
25h37 (DOS 4.0+) несовпадение кодовой страницы
26h38 (DOS 4.0+) невозможно завершить действие с файлом (чтение или запись)
27h39 (DOS 4.0+) недостаточно места на диске
28h-31h  зарезервировано
32h50 сетевой запрос не поддерживается
33h51 удаленный компьютер не откликается
34h52 дублирование сетевого имени
35h53 сетевое имя не найдено
36h54 сеть занята
37h55 сетевое устройство больше не существует
38h56 превышен лимит команд сетевого BIOS
39h57 аппаратная ошибка сетевого адаптера
3Ah58 из сети получен неверный ответ
3Bh59 неожиданная сетевая ошибка
3Ch60 несовместимый сетевой адаптер
3Dh61 полная очередь печати
3Eh62 очередь не полная
3Fh63 нет свободного места для печати файла
40h64 сетевое имя было удалено
41h65 сеть: в доступе отказано
42h66 неверный тип сетевого устройства
43h67 сетевое имя не найдено
44h68 превышен лимит сетевого имени
45h69 превышен лимит сеансов сетевого BIOS
46h70 временная пауза
47h71 сетевой запрос не принят
48h72 сетевая печать/дисковая переадресация приостановлена
49h73 программная поддержка сети не установлена
(LANtastic) неверная сетевая версия
4Ah74 неожиданный отказ сетевого адаптера
(LANtastic) истек бюджет пользователя (account)
4Bh75 (LANtastic) истек пароль
4Сh76 (LANtastic) на этот раз неудачная попытка входа в сеть
4Dh77 (LANtastic v3+) не хватает дискового пространства на сетевом узле
4Eh78 (LANtastic v3+) нет регистрации на сетевом узле
4Fh79 зарезервировано
50h80 файл существует
51h81 зарезервировано
52h82 невозможно создать каталог
53h83 ошибка на INT 24h
54h84 (DOS 3.3+) слишком много переадресаций
55h85 (DOS 3.3+) двойная переадресация
56h86 (DOS 3.3+) неверный пароль
57h87 (DOS 3.3+) неверный параметр
58h88 (DOS 3.3+) ошибка сетевой записи
59h89 (DOS 4.0+) функция в сети не поддерживается
5Ah90 (DOS 4.0+) не установлен необходимый системный компонент
64h100 (MSCDEX) неизвестная ошибка
65h101 (MSCDEX) нет готовности
66h102 (MSCDEX) нехватка EMS памяти
67h103 (MSCDEX) не High Sierra или ISO-9660 формат
68h104 (MSCDEX) открыт лоток
B0h176 (MS-DOS 7.0) носитель не блокирован
B1h177 (MS-DOS 7.0) носитель блокирован
B2h178 (MS-DOS 7.0) не сменный носитель
B4h180 (MS-DOS 7.0) переполнение счетчика блокировок
B5h181 (MS-DOS 7.0) неудача запроса на извлечение носителя

[000084]



Как обработать ошибку предже, чем программа уведомит об этом пользователя?


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

Приблизительно так:

Объявите следующую процедуру в объекте вашей главной формы:

    procedure MyException(Sender:TObject; E:Exception);

Затем делайте так:

    procedure TMyForm.MyException(Sender:TObject; E:Exception);
begin
if (E.ClassType.ClassName='EConvertError') then begin {как-то общаемся с пользователем по-поводу ошибки} end else Application.ShowException(E); {позволяем Delphi показать ошибку} end;

Наконец, позвольте приложению воспользоваться вашим новым обработчиком исключений:

    procedure TMyForm.FormCreate(Sender: TObject);
begin
Application.OnException := MyException; end;

[001670]



Как передать код выхода (errorlevel) запустившей программе, либо *.bat-файлу?


Своим опытом делится Олег Кулабухов:

Просто выйдите командой Halt() с параметром кода выхода.

    begin
Halt(2)
end.

[001874]



Как получить текстовое описание ошибки, полученной GetLastError?


Своим опытом делится Олег Кулабухов:

Используйте SysErrorMessage.

    procedure TForm1.Button1Click(Sender: TObject);
begin
{Cause a Windows system error message to be logged}
ShowMessage(IntToStr(lStrLen(nil)));
ShowMessage(SysErrorMessage(GetLastError));
end;

[001857]



Номера ошибок


Номера ошибок
Ошибка Сообщение об ошибке
1Неверный номер функции (Invalid function number)
2Файл не найден (File not found)
3Путь не найден (Path not found)
4Слишком много открытых файлов (Too many open files)
5Доступ к файлу закрыт (File access denied)
6Неверный дескриптор файла (Invalid file handle)
12Неверный код доступа к файлу (Invalid file access code)
15Неверный номер устройства (Invalid drive number)
16Невозможно удалить текущий каталог (Cannot remove current directory)
17Невозможно переименовать устройство (Cannot rename across drives)
100Ошибка чтения диска (Disk read error)
101Ошибка записи на диск (Disk write error)
102Файл не назначен (File not assigned)
103Файл не открыт (File not open)
104Файл не открыт для ввода (File not open for input)
105Файл не открыт для вывода (File not open for output)
106Неверный числовой формат (Invalid numeric format)
200Деление на ноль (Division by zero)
201Превышение допустимого диапазона (Range check error)
202Переполнение стека (Stack overflow error)
203Переполнение кучи (Heap overflow error)
204Неверная операция с указателем (Invalid pointer operation)
205Переполнение плавающей точки (Floating point overflow)
206Потеря значимости плавающей точкой (Floating point underflow)
207Неверная операция с плавающей точкой (Invalid floating point operation)
210Объект не инициализирован (Object not initialized)
211Вызов абстрактного метода (Call to abstract method)
212Ошибка регистрации потока (Stream registration error)
213Индекс коллекции вышел за пределы допустимого диапазона (Collection index out of range)
214Ошибка переполнения коллекции (Collection overflow error)
215Ошибка арифметического переполнения (Arithmetic overflow error)
216Общая ошибка защиты (General protection fault)

[000131]



Обработка исключительных ситуаций


Попробуйте эту схему. У меня это работает.

    procedure part_of_starting_up(n:string....)
var f: typed file;
begin
try try assign/reset(f,n); while not eof(f) do read_and_process_each_record(f); finally {$i-}     { Нет необходимости жаловаться, если закрытие прошло неудачно. } close(f); {$i+} end; except on E:EInOutError do case e.ErrorCode of nn1: messagedlg('невозможно найти/открыть файл'); nn2: messagedlt('ошибка чтения файла'); end; end (и т.д.)

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

К сожалению (или к счастью), вы не можете вкладыть except & finally в блоки try. [001668]



Ошибки времени выполнения


    type str31  = string[31];
function ErrMeaning (ResultCode: Integer): str31; {----------------------------------------------------------}
{ Возвращает строковое значение по коду ошибки.            }
{----------------------------------------------------------}
const NumOfEntries = 108; type ErrorEntry = record Code: Integer; Meaning: str31; end; ErrorMeaningsArray = array [1..NumOfEntries] of ErrorEntry; const MeaningsArray: ErrorMeaningsArray = {Ошибки DOS}
((Code:   1;  Meaning: 'Неверный номер DOS-функции' {Invalid DOS function number}), (Code:   2;  Meaning: 'Файл не найден' {File not found}), (Code:   3;  Meaning: 'Путь не найден' {Path not found}), (Code:   4;  Meaning: 'Слишком много открытых файлов' {Too many open files}), (Code:   5;  Meaning: 'В доступе к файлу отказано' {File access denied}), (Code:   6;  Meaning: 'Неверный дескриптор файла' {Invalid file handle}), (Code:   7;  Meaning: 'Разрушены управляющие блоки памяти' {Memory control blocks destroyed}), (Code:   8;  Meaning: 'Недостаточно памяти DOS' {Insufficient DOS memory}), (Code:   9;  Meaning: 'Неверный адрес блока памяти' {Invalid memory block address}), (Code:  10;  Meaning: 'Неверное окружение DOS' {Invalid DOS environment}), (Code:  11;  Meaning: 'Неверный формат (DOS)' {Invalid format (DOS)}), (Code:  12;  Meaning: 'Неверный код доступа к файлу' {Invalid file access code}), (Code:  13;  Meaning: 'Неверные данные (DOS)' {Invalid data (DOS)}), (Code:  15;  Meaning: 'Неверный номер устройства' {Invalid drive number}), (Code:  16;  Meaning: 'Невозможно удалить текущую директорию' {Cannot remove current directory}), (Code:  17;  Meaning: 'Невозможно переименовать драйвер' {Cannot rename across drives}), (Code:  18;  Meaning: 'Файлов больше нет' {No more files}), (Code:  19;  Meaning: 'Диск защищен от записи' {Disk write-protected}), (Code:  20;  Meaning: 'Неизвестное устройство (DOS)' {Unknown unit (DOS)}), (Code:  21;  Meaning: 'Устройство не готово' {Drive not ready}), (Code:  22;  Meaning: 'Неизвестная команда DOS' {Unknown DOS command}), (Code:  23;  Meaning: 'CRC-ошибка' {CRC error}), (Code:  24;  Meaning: 'Плохой запрос длины структуры' {Bad request structure length}), (Code:  25;  Meaning: 'Ошибка поиска' {Seek error}), (Code:  26;  Meaning: 'Неизвестный тип носителя' {Unknown media type}), (Code:  27;  Meaning: 'Сектор диска не найден' {Disk sector not found}), (Code:  28;  Meaning: 'Недостаточно бумаги' {Out of paper}), (Code:  29;  Meaning: 'Ошибка записи' {Write fault}), (Code:  30;  Meaning: 'Ошибка чтения' {Read fault}), (Code:  31;  Meaning: 'Общий сбой' {General failure}), (Code:  32;  Meaning: 'Нарушение общего доступа к файлу' {File sharing violation}), (Code:  33;  Meaning: 'Нарушение блокировки файла' {File lock violation}), (Code:  34;  Meaning: 'Неверная смена диска' {Invalid disk change}), (Code:  35;  Meaning: 'Управляющий блок файла недоступен' {File control block unavailable}), (Code:  36;  Meaning: 'Переполнение разделяемого буфера' {Sharing buffer overflow}), (Code:  37;  Meaning: 'Несовпадение кодовой страницы' {Code page mismatch}), (Code:  38;  Meaning: 'Ошибка обработки EOF' {Error handling EOF}), (Code:  39;  Meaning: 'Дескриптор диска полон' {Handle disk full}), (Code:  50;  Meaning: 'Сетевой запрос не поддерживается' {Network request not supported}), (Code:  51;  Meaning: 'Удаленный компьютер недоступен' {Remote computer not listening}), (Code:  52;  Meaning: 'Дубликат имени в сети' {Duplicate name on network}), (Code:  53;  Meaning: 'Сетевое имя не найдено' {Network name not found}), (Code:  54;  Meaning: 'Сеть занята' {Network busy}), (Code:  55;  Meaning: 'Сетевое устройство больше не существует' {Network device no longer exists}), (Code:  56;  Meaning: 'Превышен лимит команды NetBIOS' {NetBIOS command limit exceeded}), (Code:  57;  Meaning: 'Ошибка сетевого адаптера' {Network adaptor error}), (Code:  58;  Meaning: 'Неверный сетевой ответ' {Incorrect network response}), (Code:  59;  Meaning: 'Неожиданная ошибка сети' {Unexpected network error}), (Code:  60;  Meaning: 'Несовместимый удаленный адаптер' {Incompatible remote adaptor}), (Code:  61;  Meaning: 'Очередь на печать переполнена' {Print queue full}), (Code:  62;  Meaning: 'Нет достаточного места для файла печати' {Not enough space for print file}), (Code:  63;  Meaning: 'Файл печати удален' {Print file deleted}), (Code:  64;  Meaning: 'Сетевое имя удалено' {Network name deleted}), (Code:  65;  Meaning: 'Доступ запрещен' {Access denied}), (Code:  66;  Meaning: 'Неверный тип сетевого устройства' {Network device type incorrect}), (Code:  67;  Meaning: 'Сетевое имя не найдено' {Network name not found}), (Code:  68;  Meaning: 'Превышен предел сетевого имени' {Network name limit exceeded}), (Code:  69;  Meaning: 'Превышен предел сеансов NetBIOS' {NetBIOS session limit exceeded}), (Code:  70;  Meaning: 'Временная пауза' {Temporarily paused}), (Code:  71;  Meaning: 'Сетевой запрос не принят' {Network request not accepted}), (Code:  72;  Meaning: 'Пауза переадресации печати/диска' {Print/disk redirection paused}), (Code:  80;  Meaning: 'Файл уже существует' {File already exists}), (Code:  82;  Meaning: 'Невозможно создать каталог' {Cannot make directory entry}), (Code:  83;  Meaning: 'Ошибка прерывания 24' {Fail on interrupt 24}), (Code:  84;  Meaning: 'Слишком много переадресаций' {Too many redirections}), (Code:  85;  Meaning: 'Дубликат переадресации' {Duplicate redirection}), (Code:  86;  Meaning: 'Неверный пароль' {Invalid password}), (Code:  87;  Meaning: 'Неверный параметр' {Invalid parameter}), (Code:  88;  Meaning: 'Ошибка данных сети' {Network data fault}), {Ошибки ввода/вывода (I/O errors)}
(Code: 100;  Meaning: 'Ошибка чтения диска' {Disk read error}), (Code: 101;  Meaning: 'Ошибка записи диска' {Disk write error}), (Code: 102;  Meaning: 'Файл не назначен' {File not assigned}), (Code: 103;  Meaning: 'Файл не открыт' {File not open}), (Code: 104;  Meaning: 'Не открыт файл для приема' {File not open for input}), (Code: 105;  Meaning: 'Не открыт файл для выдачи' {File not open for output}), (Code: 106;  Meaning: 'Неверный числовой формат' {Invalid numeric format}), {Критические ошибки (Только для реального или защищенного режима)}
(Code: 150;  Meaning: 'Диск защищен от записи' {Disk is write protected}), (Code: 151;  Meaning: 'Неизвестное устройство' {Unknown unit}), (Code: 152;  Meaning: 'Устройство не готово' {Drive not ready}), (Code: 153;  Meaning: 'Неизвестная команда DOS' {Unknown DOS command}), (Code: 154;  Meaning: 'Ошибка CRC в данных' {CRC error in data}), (Code: 155;  Meaning: 'Плохой запрос длины структуры устройства' {Bad drive request struct length}), (Code: 156;  Meaning: 'Ошибка позиционирования диска' {Disk seek error}), (Code: 157;  Meaning: 'Неизвестный тип носителя' {Unknown media type}), (Code: 158;  Meaning: 'Сектор не найден' {Sector not found}), (Code: 159;  Meaning: 'Недостаточно бумаги в принтере' {Printer out of paper}), (Code: 160;  Meaning: 'Ошибка записи устройства' {Device write fault}), (Code: 161;  Meaning: 'Ошибка чтения устройства' {Device read fault}), (Code: 162;  Meaning: 'Аппаратный сбой' {Hardware failure}), {Фатальные ошибки}
(Code: 200;  Meaning: 'Деление на ноль' {Division by zero}), (Code: 201;  Meaning: 'Ошибка проверки диапазона' {Range check error}), (Code: 202;  Meaning: 'Ошибка переполнения стека' {Stack overflow error}), (Code: 203;  Meaning: 'Ошибка переполнения кучи' {Heap overflow error}), (Code: 204;  Meaning: 'Неверная операция с указателем' {Invalid pointer operation}), (Code: 205;  Meaning: 'Переполнение числа с плавающей точкой' {Floating point overflow}), (Code: 206;  Meaning: 'Потеря значимости числа с плавающей точкой' {Floating point underflow}), (Code: 207;  Meaning: 'Неверная операция с числом с плавающей точкой' {Invalid floating pt. operation}), (Code: 208;  Meaning: 'Не установлен оверлей-менеджер' {Overlay manager not installed}), (Code: 209;  Meaning: 'Ошибка чтения оверлей-файла' {Overlay file read error}), (Code: 210;  Meaning: 'Объект не инициализирован' {Object not initialised}), (Code: 211;  Meaning: 'Вызов абстрактного метода' {Call to abstract method}), (Code: 212;  Meaning: 'Ошибка регистрации потока' {Stream registration error}), (Code: 213;  Meaning: 'Индекс TCollection вышел за границы диапазона' {TCollection index out of range}), (Code: 214;  Meaning: 'Ошибка переполнения TCollection' {TCollection overflow error}), (Code: 215;  Meaning: 'Ошибка арифметического переполнения' {Arithmetic overflow error}), (Code: 216;  Meaning: 'Общая ошибка защиты' {General Protection Fault}), (Code: 217;  Meaning: 'Необработанное исключение' {Unhandled exception}), (Code: 219;  Meaning: 'Неверное приведение типа' {Invalid typecast})); var Low, High, Mid, Diff: Integer; begin Low := 1; High := NumOfEntries; while Low <= High do begin Mid := (Low + High) div 2; Diff := MeaningsArray[Mid].Code - ResultCode; if Diff < 0 then Low  := Mid + 1 else if Diff > 0 then High := Mid - 1 else begin {нашли это} ErrMeaning := MeaningsArray[Mid].Meaning; Exit; {ErrMeaning} end; end; {while} ErrMeaning := 'Ошибка ' + IntToStr(ResultCode) + ' (неизвестное значение)'; end; {ErrMeaning}

...я привожу несколько. Они все взяты из 'Delphi Developers Guide' (руководство Delphi-разработчика) авторов Pacheco и Teixeira. > type > str31 = string[31]; > > function ErrMeaning (ResultCode: Integer): str31; > {----------------------------------------------------------------} > { Возвращает строковое значение по коду ошибки. } > {----------------------------------------------------------------} > const > NumOfEntries = 48; > type > ErrorEntry = record > Code: Integer; > Meaning: str31; > end; > ErrorMeaningsArray = array [1..NumOfEntries] of ErrorEntry; > const > MeaningsArray: ErrorMeaningsArray = > {DOS errors} > ((Code: 1; Meaning: 'Неправильный номер функции DOS' {Invalid DOS function number}), > (Code: 2; Meaning: 'Файл не найден' {File not found}), > (Code: 3; Meaning: 'Путь не найден' {Path not found}), > (Code: 4; Meaning: 'Слишком много открытых файлов' {Too many open files}), > (Code: 5; Meaning: 'Доступ к файлу запрещен' {File access denied}), > (Code: 6; Meaning: 'Неверный дескриптор файла' {Invalid file handle}), 7 Разрушены управляющие блоки памяти (Memory Control Blocks Destroyed) 8 Недостаточно памяти (Insufficient memory (NFI)) 9 Неверный адрес блока памяти (Invalid Memory Block Address) 10 Неверная среда (Invalid Environment) 11 Неверный формат (Invalid format) > (Code: 12; Meaning: 'Неверный код доступа к файлу' {Invalid file access code}), 13 Неверные данные {Invalid Data} 14 Зарезервировано {Reserved} > (Code: 15; Meaning: 'Неверный номер устройства' {Invalid drive number}), > (Code: 16; Meaning: 'Невозможно удалить текущую директорию' {Cannot remove current directory}), > (Code: 17; Meaning: 'Невозможно переименовать драйвер' {Cannot rename across drives}), > (Code: 18; Meaning: 'файлов больше нет' {No more files}), 19 Диск защищен от записи {Disk write protected} 20 Неизвестное устройство {Unknown unit} 21 Устройство не готово {Drive not ready} 22 Неизвестная команда {Unknown command} 23 Ошибка CRC {CRC error} 24 Плохой запрос длины структуры {Bad request Structure Length} 25 Ошибка поиска {Seek Error} 26 Неизвестный тип носителя {Unknown media type} 27 Сектор не найден {Sector not found} 28 Недостаточно бумаги {Out of paper} 29 Ошибка записи {Write fault} 30 Ошибка чтения {Read Fault} 31 Общий сбой {General Failure} 32 Нарушение общего доступа {Sharing violation} 33 Нарушение блокировки {Lock violation} 34 Неверная смена диска {Invalid Disk Change} 35 FCB недоступно {FCB unavailable} 36 Переполнение буфера общего доступа {Sharing buffer overflow} 37 Несовпадение кодовой страницы {Code page mismatch} 38 Ошибка обработки EOF (конца файла) {Error handling EOF} 39 Обработка переполнения диска ?? {Handle disk full ??} 40..49 Зарезервировано {Reserved} (Code :50 ; Meaning : 'Сетевой запрос не поддерживается' {Network request not supported}), (Code :51 ; Meaning : 'Удаленный компьютер недоступен' {Remote computer not listening}), (Code :52 ; Meaning : 'Дубликат имени в сети' {Duplicate name on network}), (Code :53 ; Meaning : 'Сетевое имя не найдено' {Network name not found}), (Code :54 ; Meaning : 'Сеть занята' {Network busy}), (Code :55 ; Meaning : 'Сетевое устройство больше не существует' {Network device no longer exists}), (Code :56 ; Meaning : 'Превышен лимит команды NetBIOS' {NETBIOS command limit exceeded}), (Code :57 ; Meaning : 'Ошибка сетевого адаптера' {Network adapter error}), (Code :58 ; Meaning : 'Неверный сетевой ответ' {Incorrect network response}), (Code :59 ; Meaning : 'Неожиданная ошибка сети' {Unexpected network error}), (Code :60 ; Meaning : 'Несовместимый сетевой адаптер' {Incompatible remote adapter}), (Code :61 ; Meaning : 'Очередь на печать переполнена' {Print queue full}), (Code :62 ; Meaning : 'Нет достаточного места для файла печати' {Not enough space for print file}), (Code :63 ; Meaning : 'Файл печати удален' {Print file deleted}), (Code :64 ; Meaning : 'Сетевое имя удалено' {Network name deleted}), (Code :65 ; Meaning : 'Доступ запрещен' {Access denied}), (Code :66 ; Meaning : 'Неверный тип сетевого устройства' {Network device type incorrect}), (Code :67 ; Meaning : 'Сетевое имя не найдено' {Network name not found}), (Code :68 ; Meaning : 'Превышен предел сетевого имени' {Network name limit exceeded}), (Code :69 ; Meaning : 'Превышен предел сеансов NETBIOS' {NETBIOS session limit exceeded}), (Code :70 ; Meaning : 'Временная пауза' {Temporarily paused}), (Code :71 ; Meaning : 'Сетевой запрос не принят' {Network request not accepted}), (Code :72 ; Meaning : 'Печать или дисковая переадресация приостановлена' {Print or disk redirection is paused}), (Code :73..79; Meaning : 'Зарезервировано' {Reserved}), (Code :80 ; Meaning : 'Файл уже существует' {File already exists}), (Code :81 ; Meaning : 'Зарезервировано' {Reserved}), (Code :82 ; Meaning : 'Невозможно создать каталог' {Cannot make directory entry}), (Code :83 ; Meaning : 'Ошибка прерывания 24' {Fail on Interrupt 24}), (Code :84 ; Meaning : 'Cлишком много переадресаций' {Too many redirections}), (Code :85 ; Meaning : 'Дубликат переадресации' {Duplicate redirection}), (Code :86 ; Meaning : 'Неверный пароль' {Invalid password}), (Code :87 ; Meaning : 'Неверный параметр {Invalid parameter}), (Code :88 ; Meaning : 'Ошибка данных сети' {Network data fault}), >{Ошибки ввода/вывода (I/O errors)} > (Code: 100; Meaning: 'Ошибка чтения диска' {Disk read error}), > (Code: 101; Meaning: 'Ошибка записи диска' {Disk write error}), > (Code: 102; Meaning: 'Файл не назначен' {File not assigned}), > (Code: 103; Meaning: 'Файл не открыт' {File not open}), > (Code: 104; Meaning: 'Не открыт файл для приема' {File not open for input}), > (Code: 105; Meaning: 'Не открыт файл для выдачи' {File not open for output}), > (Code: 106; Meaning: 'Неверный числовой формат' {Invalid numeric format}), >{Критические ошибки (Только для реального или защищенного режима)} ({Critical errors (Real or proteted mode only)}) > (Code: 150; Meaning: 'Диск защищен от записи' {Disk is write protected}), > (Code: 151; Meaning: 'Неизвестное устройство' {Unknown unit}), > (Code: 152; Meaning: 'Устройство не готово' {Drive not ready}), > (Code: 153; Meaning: 'Неизвестная команда DOS' {Unknown DOS command}), > (Code: 154; Meaning: 'Ошибка CRC в данных' {CRC error in data}), > (Code: 155; Meaning: 'Плохой запрос длины структуры устройства' {Bad drive request struct length}), > (Code: 156; Meaning: 'Ошибка позиционирования диска' {Disk seek error}), > (Code: 157; Meaning: 'Неизвестный тип носителя' {Unknown media type}), > (Code: 158; Meaning: 'Сектор не найден' {Sector not found}), > (Code: 159; Meaning: 'Недостаточно бумаги в принтере' {Printer out of paper}), > (Code: 160; Meaning: 'Ошибка записи устройства' {Device write fault}), > (Code: 161; Meaning: 'Ошибка чтения устройства' {Device read fault}), > (Code: 162; Meaning: 'Аппаратный сбой' {Hardware failure}), > {Фатальные ошибки (Fatal errors)} > (Code: 200; Meaning: 'Деление на ноль' {Division by zero}), > (Code: 201; Meaning: 'Ошибка проверки диапазона' {Range check error}), > (Code: 202; Meaning: 'Ошибка переполнения стека' {Stack overflow error}), > (Code: 203; Meaning: 'Ошибка переполнения кучи' {Heap overflow error}), > (Code: 204; Meaning: 'Неверная операция с указателем' {Invalid pointer operation}), > (Code: 205; Meaning: 'Переполнение числа с плавающей точкой' {Floating point overflow}), > (Code: 206; Meaning: 'Потеря значимости числа с плавающей точкой' {Floating point underflow}), > (Code: 207; Meaning: 'Неверная операция с числом с плавающей точкой' {Invalid floating pt. operation}), > (Code: 208; Meaning: 'Не установлен оверлей-менеджер' {Overlay manager not installed}), > (Code: 209; Meaning: 'Ошибка чтения оверлей-файла' {Overlay file read error}), > (Code: 210; Meaning: 'Объект не инициализирован' {Object not initialised}), > (Code: 211; Meaning: 'Вызов абстрактного метода' {Call to abstract method}), > (Code: 212; Meaning: 'Ошибка регистрации потока' {Stream registration error}), > (Code: 213; Meaning: 'Индекс TCollection вышел за границы диапазона' {TCollection index out of range}), > (Code: 214; Meaning: 'Ошибка переполнения TCollection' {TCollection overflow error}), > (Code: 215; Meaning: 'Ошибка арифметического переполнения' {Arithmetic overflow error}), > (Code: 216; Meaning: 'Общая ошибка защиты' {General Protection Fault})); 217 Необработанное исключение (Unhandled Exception) 219 Неверное приведение типа (Invalid typecast) > var > i: Integer; > begin > for i := 1 to NumOfEntries do > if MeaningsArray[i].Code < ResultCode then > Continue {до следующей итерации цикла FOR loop} > else > begin > if MeaningsArray[i].Code = ResultCode then > begin > ErrMeaning := MeaningsArray[i].Meaning; > Exit; {ErrMeaning} > end > else {Code in array > ResultCode} > Break; {выход из цикла FOR} > end; > ErrMeaning := 'Ошибка ' + IntToStr(ResultCode) + > ' (неизвестное значение)'; > end; {ErrMeaning} [001797]



Перехват ошибки


    procedure TForm1.FormCreate(Sender: TObject); begin Application.OnException := MyExcept; end;
Procedure TForm1.MyExcept(Sender:TObject; E:Exception); begin If E is EDatabaseError then MessageDlg('Перехвачено исключение', mtInformation, [mbOk], 0) else { если это не та ошибка, которую вы ищете, передайте на обработку дальше } end;

[000425]



FileListBox с двумя колонками


...как сказал Майкл, вы можете сделать количество колонок > 1. Но, как это имеет место в TDirectoryListBox, колонки перекрывают одна другую. Я действительно не рекомендую это из-за потенциально возможных конфликтов во время изменения шрифта, но вы могли бы сделать по-другому:

    with TDirectoryListBox(FileListBox1) do begin Columns := 2; SendMessage(Handle, LB_SETCOLUMNWIDTH, LoWord(GetTextExtent(Canvas.Handle, 'WWWWWWWW.WWW', 12)), 0); end;

Успехов.

Kurt [000653]