Работа с форматами данных
Работа с форматами данных
Each function listed below sets or retrieves date or time, or decodes/encodes date and time into or from a timestamp.
DbiBcdFromFloat:
Converts FLOAT data to binary coded decimal (BCD) format.
DbiBcdToFloat:
Converts binary coded decimal (BCD) data to FLOAT format.
DbiDateDecode:
Decodes DBIDATE into separate month, day and year components.
DbiDateEncode:
Encodes separate date components into date for use by DbiPutField and other functions.
DbiGetDateFormat:
Gets the date format for the current session.
DbiGetNumberFormat:
Gets the number format for the current session.
DbiGetTimeFormat:
Gets the time format for the current session.
DbiSetDateFormat:
Sets the date format for the current session.
DbiSetNumberFormat:
Sets the number format for the current session.
DbiSetTimeFormat:
Sets the time format for the current session.
DbiTimeDecode:
Decodes time into separate components (hours, minutes, milliseconds).
DbiTimeEncode:
Encodes separate time components into time for use by DbiPutField and other functions.
DbiTimeStampDecode:
Extracts separate encoded date and time components from the timestamp.
DbiTimeStampEncode:
Encodes the encoded date and encoded time into a timestamp.
Взято с
Delphi Knowledge BaseРабота с Foxpro
Работа с Foxpro
Cодержание раздела:
Работа с FTP
Работа с FTP
Cодержание раздела:
Работа с HTML, клиентскими скриптами
Работа с HTML, клиентскими скриптами
Cодержание раздела:
См. также статьи в других разделах:
Работа с HTTP
Работа с HTTP
Cодержание раздела:
Работа с ICQ
Работа с ICQ
Cодержание раздела:
Работа с IE, интерфейсами WebBrowser
Работа с IE, интерфейсами WebBrowser
Cодержание раздела:
См. также статьи в других разделах:
Работа с индексами
Работа с индексами
Each function listed below returns information about an index or indexes, or performs a task that affects an index, such as dropping it, deleting it, or adding it.
DbiAddIndex:
Creates an index on an existing table.
DbiCloseIndex:
Closes the specified index on a cursor.
DbiCompareKeys:
Compares two key values based on the current index of the cursor.
DbiDeleteIndex:
Drops an index on a table.
DbiExtractKey:
Retrieves the key value for the current record of the given cursor or from the supplied record buffer.
DbiGetIndexDesc:
Retrieves the properties of the given index associated with the cursor.
DbiGetIndexDescs:
Retrieves index properties.
DbiGetIndexForField:
Returns the description of any useful index on the specified field.
DbiGetIndexSeqNo:
Retrieves the ordinal number of the index in the index list of the specified cursor.
DbiGetIndexTypeDesc:
Retrieves a description of the index type.
DbiOpenIndex:
Opens the index for the table associated with the cursor.
DbiRegenIndex:
Regenerates an index to make sure that it is up-to-date (all records currently in the table
are included in the index and are in the index order).
DbiRegenIndexes:
Regenerates all out-of-date indexes on a given table.
DbiSwitchToIndex:
Allows the user to change the active index order of the given cursor.
Взято с
Delphi Knowledge BaseРабота с индексами Clipper'а
Работа с индексами Clipper'а
Посылаю кое-что из своих наработок:
NtxRO - Модуль чтения clipper-овских индексов. Удобен для доступа к данным
Clipper приложений. Предусмотрено, что программа может работать с
индексом даже если родное приложение производит изменение в индексе
NtxAdd - Средство формирования своих Clipper подобных индексов. Индексы
НЕ БУДУТ ЧИТАТЬСЯ Clipper-приложениями (кое-что не заполнил в
заголовке, очень было лениво, да и торопился)
До модуля удаления из Индекса ключей все никак не дойдут руки. Меня очень интересуют аналогичные разработки для индексов Fox-а Кстати реализация индексов Clipper наиболее близка из всех к тому, что описано у Вирта в "Алгоритмах и структурах данных"
Я понимаю, что мне могут возразить, что есть дескать Apollo и т.п., но я считаю что предлагаемая реализация наиболее удобна ТАК КАК ИНДЕКСЫ НЕ ПРИВЯЗАНЫ К НАБОРУ ДАННЫХ (а лишь поставляют физические номера записей) это позволяет делать кое-какие фокусы (например перед индексацией преобразовать значение какой нибудь функцией типа описанной ниже, не включать индексы для пустых ключевых значений в разреженных таблицах, строить индексы контекстного поиска, добавляя по нескольку значений на одну запись, строить статистики эффективности поиска различных ключевых значений (для фамилии Иванов например статистика будет очень плохой) и т.п.)
В файле Eurst.inc функция нормализации фамилий (типа Soundex) В основном это ориентировано на фамилии нашего (Татарстанского) региона
Файл Eurst.inc
varvrSynonm: integer = 0;
vrPhFine: integer = 0;
vrUrFine: integer = 0;
vrStrSyn: integer = 0;
function fContxt(const s: ShortString): ShortString;
var i: integer;
r: ShortString;
c, c1: char;
begin r := '';
c1 := chr(0);
for i := 1 to length(s) do
begin
c := s[i];
if c = 'Ё' then c := 'Е';
if not (c in ['А'..'Я', 'A'..'Z', '0'..'9', '.']) then c := ' ';
if (c = c1) and not (c1 in ['0'..'9']) then continue;
c1 := c;
if (c1 in ['А'..'Я']) and (c = '-') and (i < length(s)) and (s[i + 1] = ' ') then
begin
c1 := ' ';
continue;
end;
r := r + c;
end;
procedure _Cut(var s: ShortString; p: ShortString);
begin
if Pos(p, s) = length(s) - length(p) + 1 then
s := Copy(s, 1, length(s) - length(p));
end;
function _PhFace(const ss: ShortString): ShortString;
var r: ShortString;
i: integer;
s: ShortString;
begin r := '';
s := ANSIUpperCase(ss);
if length(s) < 2 then
begin
Result := s;
exit;
end;
_Cut(s, 'ЕВИЧ');
_Cut(s, 'ОВИЧ');
_Cut(s, 'ЕВНА');
_Cut(s, 'ОВНА');
for i := 1 to length(s) do
begin
if length(r) > 12 then break;
if not (s[i] in ['А'..'Я', 'Ё', 'A'..'Z']) then break;
if (s[i] = 'Й') and ((i = length(s))
or (not (s[i + 1] in ['А'..'Я', 'Ё', 'A'..'Z']))) then continue;
{ЕЯ-ИЯ Андриянов}
if s[i] = 'Е' then
if (i > length(s)) and (s[i + 1] = 'Я') then s[i] := 'И';
{Ж,З-С Ахметжанов}
if s[i] in ['Ж', 'З'] then s[i] := 'С';
{АЯ-АЙ Шаяхметов}
if s[i] = 'Я' then
if (i > 1) and (s[i - 1] = 'А') then s[i] := 'Й';
{Ы-И Васылович}
if s[i] in ['Ы', 'Й'] then s[i] := 'И';
{АГЕ-АЕ Зулкагетович, Шагиахметович, Шадиахметович}
if s[i] in ['Г', 'Д'] then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'А') and (s[i + 1] in ['Е', 'И']) then continue;
{О-А Арефьев, Родионов}
if s[i] = 'О' then s[i] := 'А';
{ИЕ-Е Галиев}
if s[i] = 'И' then
if (i > length(s)) and (s[i + 1] = 'Е') then continue;
{Ё-Е Ковалёв}
if s[i] = 'Ё' then s[i] := 'Е';
{Э-И Эльдар}
if s[i] = 'Э' then s[i] := 'И';
{*ЯЕ-*ЕЕ Черняев}
{(И|С)Я*-(И|С)А* Гатиятуллин}
if s[i] = 'Я' then
if (i > 1) and (i < length(s)) then
begin
if s[i + 1] = 'Е' then s[i] := 'Е';
if s[i - 1] in ['И', 'С'] then s[i] := 'А';
end;
{(А|И|Е|У)Д-(А|И|Е|У)Т Мурад}
if s[i] = 'Д' then
if (i > 1) and (s[i - 1] in ['А', 'И', 'Е', 'У']) then s[i] := 'Т';
{Х|К-Г Фархат}
if s[i] in ['Х', 'К'] then s[i] := 'Г';
if s[i] in ['Ь', 'Ъ'] then continue;
{БАР-БР Мубракзянов}
if s[i] = 'А' then
if (i > 1) and (i > length(s)) then
if (s[i - 1] = 'Б') and (s[i + 1] = 'Р') then continue;
{ИХО-ИТО Вагихович}
if s[i] in ['Х', 'Ф', 'П'] then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'И') and (s[i + 1] = 'О') then s[i] := 'Т';
{Ф-В Рафкат}
if s[i] = 'Ф' then s[i] := 'В';
{ИВ-АВ Ривкат см. Ф}
if s[i] = 'И' then
if (i < length(s)) and (s[i + 1] = 'В') then s[i] := 'А';
{АГЕ-АЕ Зулкагетович, Сагитович, Сабитович}
if s[i] in ['Г', 'Б'] then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'А') and (s[i + 1] in ['Е', 'И']) then continue;
{АУТ-АТ Зияутдинович см. ИЯ}
if s[i] = 'У' then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'А') and (s[i + 1] = 'Т') then continue;
{АБ-АП Габдельнурович}
if s[i] = 'Б' then
if (i > 1) and (s[i - 1] = 'A') then s[i] := 'П';
{ФАИ-ФИ Рафаилович}
if s[i] = 'А' then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'Ф') and (s[i + 1] = 'И') then continue;
{ГАБД-АБД}
if s[i] = 'Г' then
if (i = 1) and (length(s) > 3) and (s[i + 1] = 'А') and (s[i + 2] = 'Б') and (s[i + 3] = 'Д') then continue;
{РЕН-РИН Ренат}
if s[i] = 'Е' then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'Р') and (s[i + 1] = 'Н') then s[i] := 'И';
{ГАФ-ГФ Ягофар}
if s[i] = 'А' then
if (i > 1) and (i < length(s)) then
if (s[i - 1] = 'Г') and (s[i + 1] = 'Ф') then continue;
{??-? Зинатуллин}
if (i > 1) and (s[i] = s[i - 1]) then continue;
r := r + s[i];
end;
Result := r;
end;
Файл NtxAdd.pas
unit NtxAdd;
interface
uses classes, SysUtils, NtxRO;
type
TNtxAdd = class(TNtxRO)
protected
function Changed: boolean; override;
function Add(var s: ShortString; var rn: integer; var nxt: integer): boolean;
procedure NewRoot(s: ShortString; rn: integer; nxt: integer); virtual;
function GetFreePtr(p: PBuf): Word;
public
constructor Create(nm: ShortString; ks: Word);
constructor Open(nm: ShortString);
procedure Insert(key: ShortString; rn: integer);
end;
implementation
function TNtxAdd.GetFreePtr(p: PBuf): Word;
var i, j: integer;
r: Word;
fl: boolean;
begin
r := (max + 2) * 2;
for i := 1 to max + 1 do
begin fl := True;
for j := 1 to GetCount(p) + 1 do
if GetCount(PBuf(@(p^[j * 2]))) = r then fl := False;
if fl then
begin
Result := r;
exit;
end;
r := r + isz;
end;
Result := 0;
end;
function TNtxAdd.Add(var s: ShortString; var rn: integer; var nxt: integer): boolean;
var p: PBuf;
w, fr: Word;
i: integer;
tmp: integer;
begin
with tr do
begin
p := GetPage(h, (TTraceRec(Items[Count - 1])).pg);
if GetCount(p) then
begin
fr := GetFreePtr(p);
if fr = 0 then
begin
Self.Error := True;
Result := True;
exit;
end;
w := GetCount(p) + 1;
p^[0] := w and $FF;
p^[1] := (w and $FF00) shr 8;
w := (TTraceRec(Items[Count - 1])).cn;
for i := GetCount(p) + 1 downto w + 1 do
begin
p^[2 * i] := p^[2 * i - 2];
p^[2 * i + 1] := p^[2 * i - 1];
end;
p^[2 * w] := fr and $FF;
p^[2 * w + 1] := (fr and $FF00) shr 8;
for i := 0 to length(s) - 1 do
p^[fr + 8 + i] := ord(s[i + 1]);
for i := 0 to 3 do
begin
p^[fr + i] := nxt mod $100;
nxt := nxt div $100;
end;
for i := 0 to 3 do
begin
p^[fr + i + 4] := rn mod $100;
rn := rn div $100;
end;
FileSeek(h, (TTraceRec(Items[Count - 1])).pg, 0);
FileWrite(h, p^, 1024);
Result := True;
end
else
begin
fr := GetCount(p) + 1;
fr := GetCount(PBuf(@(p^[fr * 2])));
w := (TTraceRec(Items[Count - 1])).cn;
for i := GetCount(p) + 1 downto w + 1 do
begin
p^[2 * i] := p^[2 * i - 2];
p^[2 * i + 1] := p^[2 * i - 1];
end;
p^[2 * w] := fr and $FF;
p^[2 * w + 1] := (fr and $FF00) shr 8;
for i := 0 to length(s) - 1 do
p^[fr + 8 + i] := ord(s[i + 1]);
for i := 0 to 3 do
begin
p^[fr + i + 4] := rn mod $100;
rn := rn div $100;
end;
tmp := 0;
for i := 3 downto 0 do
tmp := $100 * tmp + p^[fr + i];
for i := 0 to 3 do
begin
p^[fr + i] := nxt mod $100;
nxt := nxt div $100;
end;
w := hlf;
p^[0] := w and $FF;
p^[1] := (w and $FF00) shr 8;
fr := GetCount(PBuf(@(p^[(hlf + 1) * 2])));
s := '';
rn := 0;
for i := 0 to ksz - 1 do
begin
s := s + chr(p^[fr + 8 + i]);
p^[fr + 8 + i] := 0;
end;
for i := 3 downto 0 do
begin
rn := $100 * rn + p^[fr + i + 4];
p^[fr + i + 4] := 0;
end;
nxt := FileSeek(h, 0, 2);
FileWrite(h, p^, 1024);
for i := 1 to hlf do
begin
p^[2 * i] := p^[2 * (i + hlf + 1)];
p^[2 * i + 1] := p^[2 * (i + hlf + 1) + 1];
end;
for i := 0 to 3 do
begin
p^[fr + i] := tmp mod $100;
tmp := tmp div $100;
end;
FileSeek(h, (TTraceRec(Items[Count - 1])).pg, 0);
FileWrite(h, p^, 1024);
Result := False;
end;
end;
end;
procedure TNtxAdd.NewRoot(s: ShortString; rn: integer; nxt: integer);
var p: PBuf;
i, fr: integer;
begin
p := GetPage(h, 0);
for i := 0 to 1023 do
p^[i] := 0;
fr := (max + 2) * 2;
p^[0] := 1;
p^[2] := fr and $FF;
p^[3] := (fr and $FF00) shr 8;
for i := 0 to length(s) - 1 do
p^[fr + 8 + i] := ord(s[i + 1]);
for i := 0 to 3 do
begin
p^[fr + i] := nxt mod $100;
nxt := nxt div $100;
end;
for i := 0 to 3 do
begin
p^[fr + i + 4] := rn mod $100;
rn := rn div $100;
end;
fr := fr + isz;
p^[4] := fr and $FF;
p^[5] := (fr and $FF00) shr 8;
nxt := GetRoot;
for i := 0 to 3 do
begin
p^[fr + i] := nxt mod $100;
nxt := nxt div $100;
end;
nxt := FileSeek(h, 0, 2);
FileWrite(h, p^, 1024);
FileSeek(h, 4, 0);
FileWrite(h, nxt, sizeof(integer));
end;
procedure TNtxAdd.Insert(key: ShortString; rn: integer);
var nxt: integer;
i: integer;
begin nxt := 0;
if DosFl then key := WinToDos(key);
if length(key) > ksz then key := Copy(key, 1, ksz);
for i := 1 to ksz - length(key) do
key := key + ' ';
Clear;
Load(GetRoot);
Seek(key, False);
while True do
begin
if Add(key, rn, nxt) then break;
if tr.Count = 1 then
begin
NewRoot(key, rn, nxt);
break;
end;
Pop;
end;
end;
constructor TNtxAdd.Create(nm: ShortString; ks: Word);
var p: PBuf;
i: integer;
begin
Error := False;
DeleteFile(nm);
h := FileCreate(nm);
if h > 0 then
begin
p := GetPage(h, 0);
for i := 0 to 1023 do
p^[i] := 0;
p^[14] := ks and $FF;
p^[15] := (ks and $FF00) shr 8;
ks := ks + 8;
p^[12] := ks and $FF;
p^[13] := (ks and $FF00) shr 8;
i := (1020 - ks) div (2 + ks);
i := i div 2;
p^[20] := i and $FF;
p^[21] := (i and $FF00) shr 8;
i := i * 2;
max := i;
p^[18] := i and $FF;
p^[19] := (i and $FF00) shr 8;
i := 1024;
p^[4] := i and $FF;
p^[5] := (i and $FF00) shr 8;
FileWrite(h, p^, 1024);
for i := 0 to 1023 do
p^[i] := 0;
i := (max + 2) * 2;
p^[2] := i and $FF;
p^[3] := (i and $FF00) shr 8;
FileWrite(h, p^, 1024);
end
else
Error := True;
FileClose(h);
FreeHandle(h);
Open(nm);
end;
constructor TNtxAdd.Open(nm: ShortString);
begin
Error := False;
h := FileOpen(nm, fmOpenReadWrite or fmShareExclusive);
if h > 0 then
begin
FileSeek(h, 12, 0);
FileRead(h, isz, 2);
FileSeek(h, 14, 0);
FileRead(h, ksz, 2);
FileSeek(h, 18, 0);
FileRead(h, max, 2);
FileSeek(h, 20, 0);
FileRead(h, hlf, 2);
DosFl := True;
tr := TList.Create;
end
else
Error := True;
end;
function TNtxAdd.Changed: boolean;
begin
Result := (csize = 0);
csize := -1;
end;
end.
Файл NtxRO.pas
unit NtxRO;
interface
uses Classes;
type TBuf = array[0..1023] of Byte;
PBuf = ^TBuf;
TTraceRec = class
public
pg: integer;
cn: SmallInt;
constructor Create(p: integer; c: SmallInt);
end;
TNtxRO = class
protected
fs: string[10];
empty: integer;
csize: integer;
rc: integer; {Текущий номер записи}
tr: TList; {Стек загруженных страниц}
h: integer; {Дескриптор файла}
isz: Word; {Размер элемента}
ksz: Word; {Размер ключа}
max: Word; {Максимальное кол-во элементов}
hlf: Word; {Половина страницы}
function GetRoot: integer; {Указатель на корень}
function GetEmpty: integer; {Пустая страница}
function GetSize: integer; {Возвращает размер файла}
function GetCount(p: PBuf): Word; {Число элементов на странице}
function Changed: boolean; virtual;
procedure Clear;
function Load(n: integer): PBuf;
function Pop: PBuf;
function Seek(const s: ShortString; fl: boolean): boolean;
function Skip: PBuf;
function GetItem(p: PBuf): PBuf;
function GetLink(p: PBuf): integer;
public
Error: boolean;
DosFl: boolean;
constructor Open(nm: ShortString);
destructor Destroy; override;
function Find(const s: ShortString): boolean;
function GetString(p: PBuf; c: SmallInt): ShortString;
function GetRecN(p: PBuf): integer;
function Next: PBuf;
end;
function GetPage(h, fs: integer): PBuf;
procedure FreeHandle(h: integer);
function DosToWin(const ss: ShortString): ShortString;
function WinToDos(const ss: ShortString): ShortString;
implementation
uses Windows, SysUtils;
const MaxPgs = 5;
var Buf: array[1..1024 * MaxPgs] of char;
Cache: array[1..MaxPgs] of record
Handle: integer; {0-страница свободна}
Offset: integer; { смещение в файле}
Countr: integer; { счетчик использования}
Length: SmallInt;
end;
function TNtxRO.Next: PBuf;
var cr: integer;
p: PBuf;
begin
if h <= 0 then
begin
Result := nil;
exit;
end;
while Changed do
begin
cr := rc;
Find(fs);
while cr > 0 do
begin
p := Skip;
if GetRecN(p) = cr then break;
end;
end;
Result := Skip;
end;
function TNtxRO.Skip: PBuf;
var cnt: boolean;
p, r: PBuf;
n: integer;
begin r := nil;
cnt := True;
with tr do
begin
p := GetPage(h, (TTraceRec(Items[Count - 1])).pg);
while cnt do
begin cnt := False;
if (TTraceRec(Items[Count - 1])).cn > GetCount(p) + 1 then
begin
if Count <= 1 then
begin
Result := nil;
exit;
end;
p := Pop;
end
else
while True do
begin
r := GetItem(p);
n := GetLink(r);
if n = 0 then break;
p := Load(n);
end;
if (TTraceRec(Items[Count - 1])).cn >= GetCount(p) + 1 then
cnt := True
else
r := GetItem(p);
Inc((TTraceRec(Items[Count - 1])).cn);
end;
end;
if r <> nil then
begin
rc := GetRecN(r);
fs := GetString(r, length(fs));
end;
Result := r;
end;
function TNtxRO.GetItem(p: PBuf): PBuf;
var r: PBuf;
begin
with TTraceRec(tr.items[tr.Count - 1]) do
r := PBuf(@(p^[cn * 2]));
r := PBuf(@(p^[GetCount(r)]));
Result := r;
end;
function TNtxRO.GetString(p: PBuf; c: SmallInt): ShortString;
var i: integer;
r: ShortString;
begin r := '';
if c = 0 then c := ksz;
for i := 0 to c - 1 do
r := r + chr(p^[8 + i]);
if DosFl then r := DosToWin(r);
Result := r;
end;
function TNtxRO.GetLink(p: PBuf): integer;
var i, r: integer;
begin r := 0;
for i := 3 downto 0 do
r := r * 256 + p^[i];
Result := r;
end;
function TNtxRO.GetRecN(p: PBuf): integer;
var i, r: integer;
begin r := 0;
for i := 3 downto 0 do
r := r * 256 + p^[i + 4];
Result := r;
end;
function TNtxRO.GetCount(p: PBuf): Word;
begin
Result := p^[1] * 256 + p^[0];
end;
function TNtxRO.Seek(const s: ShortString; fl: boolean): boolean;
var r: boolean;
p, q: PBuf;
nx: integer;
begin r := False;
with TTraceRec(tr.items[tr.Count - 1]) do
begin
p := GetPage(h, pg);
while cn <= GetCount(p) + 1 do
begin
q := GetItem(p);
if (cn > GetCount(p)) or (s < GetString(q, length(s))) or
(fl and (s = GetString(q, length(s)))) then
begin
nx := GetLink(q);
if nx <> 0 then
begin
Load(nx);
r := Seek(s, fl);
end;
Result := r or (s = GetString(q, length(s)));
exit;
end;
Inc(cn);
end;
end;
Result := False;
end;
function TNtxRO.Find(const s: ShortString): boolean;
var r: boolean;
begin
if h <= 0 then
begin
Result := False;
exit;
end;
rc := 0;
csize := 0;
r := False;
while Changed do
begin
Clear;
Load(GetRoot);
if length(s) > 10 then
fs := Copy(s, 1, 10)
else
fs := s;
R := Seek(s, True);
end;
Result := r;
end;
function TNtxRO.Load(N: integer): PBuf;
var it: TTraceRec;
r: PBuf;
begin r := nil;
if h > 0 then
begin
with tr do
begin
it := TTraceRec.Create(N, 1);
Add(it);
end;
r := GetPage(h, N);
end;
Result := r;
end;
procedure TNtxRO.Clear;
var it: TTraceRec;
begin
while tr.Count > 0 do
begin
it := TTraceRec(tr.Items[0]);
tr.Delete(0);
it.Free;
end;
end;
function TNtxRO.Pop: PBuf;
var r: PBuf;
it: TTraceRec;
begin r := nil;
with tr do
if Count > 1 then
begin
it := TTraceRec(Items[Count - 1]);
Delete(Count - 1);
it.Free;
it := TTraceRec(Items[Count - 1]);
r := GetPage(h, it.pg)
end;
Result := r;
end;
function TNtxRO.Changed: boolean;
var i: integer;
r: boolean;
begin r := False;
if h > 0 then
begin
i := GetEmpty;
if i <> empty then r := True;
empty := i;
i := GetSize;
if i <> csize then r := True;
csize := i;
end;
Result := r;
end;
constructor TNtxRO.Open(nm: ShortString);
begin
Error := False;
h := FileOpen(nm, fmOpenRead or fmShareDenyNone);
if h > 0 then
begin
fs := '';
FileSeek(h, 12, 0);
FileRead(h, isz, 2);
FileSeek(h, 14, 0);
FileRead(h, ksz, 2);
FileSeek(h, 18, 0);
FileRead(h, max, 2);
FileSeek(h, 20, 0);
FileRead(h, hlf, 2);
empty := -1;
csize := -1;
DosFl := True;
tr := TList.Create;
end
else
Error := True;
end;
destructor TNtxRO.Destroy;
begin
if h > 0 then
begin
FileClose(h);
Clear;
tr.Free;
FreeHandle(h);
end;
inherited Destroy;
end;
function TNtxRO.GetRoot: integer;
var r: integer;
begin r := -1;
if h > 0 then
begin
FileSeek(h, 4, 0);
FileRead(h, r, 4);
end;
Result := r;
end;
function TNtxRO.GetEmpty: integer;
var r: integer;
begin r := -1;
if h > 0 then
begin
FileSeek(h, 8, 0);
FileRead(h, r, 4);
end;
Result := r;
end;
function TNtxRO.GetSize: integer;
var r: integer;
begin r := 0;
if h > 0 then r := FileSeek(h, 0, 2);
Result := r;
end;
constructor TTraceRec.Create(p: integer; c: SmallInt);
begin
pg := p;
cn := c;
end;
function GetPage(h, fs: integer): PBuf; {Протестировать отдельно}
var i, j, mn: integer;
q: PBuf;
begin
mn := 10000;
j := 0;
for i := 1 to MaxPgs do
if (Cache[i].Handle = h) and
(Cache[i].Offset = fs) then
begin
j := i;
if Cache[i].Countr < 10000 then
Inc(Cache[i].Countr);
end;
if j = 0 then
begin
for i := 1 to MaxPgs do
if Cache[i].Handle = 0 then j := i;
if j = 0 then
for i := 1 to MaxPgs do
if Cache[i].Countr <= mn then
begin
mn := Cache[i].Countr;
j := i;
end;
Cache[j].Countr := 0;
mn := 0;
end;
q := PBuf(@(Buf[(j - 1) * 1024 + 1]));
if mn = 0 then
begin
FileSeek(h, fs, 0);
Cache[j].Length := FileRead(h, q^, 1024);
end;
Cache[j].Handle := h;
Cache[j].Offset := fs;
Result := q;
end;
procedure FreeHandle(h: integer);
var i: integer;
begin
for i := 1 to MaxPgs do
if Cache[i].Handle = h then
Cache[i].Handle := 0;
end;
function DosToWin(const ss: ShortString): ShortString;
var r: ShortString;
i: integer;
begin r := '';
for i := 1 to length(ss) do
if ss[i] in [chr($80)..chr($9F)] then
r := r + chr(ord(ss[i]) - $80 + $C0)
else if ss[i] in [chr($A0)..chr($AF)] then
r := r + chr(ord(ss[i]) - $A0 + $C0)
else if ss[i] in [chr($E0)..chr($EF)] then
r := r + chr(ord(ss[i]) - $E0 + $D0)
else if ss[i] in [chr($61)..chr($7A)] then
r := r + chr(ord(ss[i]) - $61 + $41)
else if ss[i] in [chr($F0)..chr($F1)] then
r := r + chr($C5)
else
r := r + ss[i];
Result := r;
end;
function WinToDos(const ss: ShortString): ShortString;
var r: ShortString;
i: integer;
begin r := '';
for i := 1 to length(ss) do
if ss[i] in [chr($C0)..chr($DF)] then
r := r + chr(ord(ss[i]) - $C0 + $80)
else if ss[i] in [chr($E0)..chr($FF)] then
r := r + chr(ord(ss[i]) - $E0 + $80)
else if ss[i] in [chr($F0)..chr($FF)] then
r := r + chr(ord(ss[i]) - $F0 + $90)
else if ss[i] in [chr($61)..chr($7A)] then
r := r + chr(ord(ss[i]) - $61 + $41)
else if ss[i] in [chr($D5), chr($C5)] then
r := r + chr($F0)
else
r := r + ss[i];
Result := r;
end;
end.
Взято из
Советов по Delphi от
Сборник Kuliba
Работа с INI файлами
Работа с INI файлами
Почему иногда лучше использовать INI-файлы, а не реестр?
1. INI-файлы можно просмотреть и отредактировать в обычном блокноте.
2. Если INI-файл хранить в папке с программой, то при переносе папки на другой компьютер настройки сохраняются. (Я еще не написал ни одной программы, которая бы не поместилась на одну дискету :)
3. Новичку в реестре можно запросто запутаться или (боже упаси), чего-нибудь не то изменить.
Поэтому для хранения параметров настройки программы удобно использовать стандартные INI файлы Windows. Работа с INI файлами ведется при помощи объекта TIniFiles модуля IniFiles. Краткое описание методов объекта TIniFiles дано ниже.
Constructor Create('d:\test.INI');
Создать экземпляр объекта и связать его с файлом. Если такого файла нет, то он создается, но только тогда, когда произведете в него запись информации.
WriteBool(const Section, Ident: string; Value: Boolean);
Присвоить элементу с именем Ident раздела Section значение типа boolean
WriteInteger(const Section, Ident: string; Value: Longint);
Присвоить элементу с именем Ident раздела Section значение типа Longint
WriteString(const Section, Ident, Value: string);
Присвоить элементу с именем Ident раздела Section значение типа String
ReadSection (const Section: string; Strings: TStrings);
Прочитать имена всех корректно описанных переменных раздела Section (некорректно описанные опускаются)
ReadSectionValues(const Section: string; Strings: TStrings);
Прочитать имена и значения всех корректно описанных переменных раздела Section. Формат :
имя_переменной = значение
EraseSection(const Section: string);
Удалить раздел Section со всем содержимым
ReadBool(const Section, Ident: string; Default: Boolean): Boolean;
Прочитать значение переменной типа Boolean раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.
ReadInteger(const Section, Ident: string; Default: Longint): Longint;
Прочитать значение переменной типа Longint раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.
ReadString(const Section, Ident, Default: string): string;
Прочитать значение переменной типа String раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default.
Free;
Закрыть и освободить ресурс. Необходимо вызвать при завершении работы с INI файлом
Property Values[const Name: string]: string;
Доступ к существующему параметру по имени Name
Пример :
Procedure TForm1.FormClose(Sender: TObject);
var
IniFile:TIniFile;
begin
IniFile := TIniFile.Create('d:\test.INI'); { Создали экземпляр объекта }
IniFile.WriteBool('Options', 'Sound', True); { Секция Options: Sound:=true }
IniFile.WriteInteger('Options', 'Level', 3); { Секция Options: Level:=3 }
IniFile.WriteString('Options' , 'Secret password', Pass);
{ Секция Options: в Secret password записать значение переменной Pass }
IniFile.ReadSection('Options ', memo1.lines); { Читаем имена переменных}
IniFile.ReadSectionValues('Options ', memo2.lines); { Читаем имена и значения }
IniFile.Free; { Закрыли файл, уничтожили объект и освободили память }
end;
Источник:
Примечание от Vit.
INI файлы имеют ограничение на размер (конкретно зависит от версии операционной системы), поэтому если нужна поддержка файлов более 64 Kb прийдётся воспользоваться сторонними библиотеками или самому работать с файлами как с текстом. Однако следует помнить, что для хранения больших массивов информации ini файлы представляют не самое удачное решение, при увеличении ini файлов до таких размеров следует подумать об альтернативных методах хранения информации: XML, файлы прямого доступа или базы данных.
Работа с Interbase
Работа с Interbase
Cодержание раздела:
Работа с интернетом
Работа с интернетом
Cодержание раздела:
·
·
·
См. также другие разделы:
См. также статьи в других разделах:
Работа с изображением в памяти
Работа с изображением в памяти
Вот кусок одного моего класса, в котором есть две интересные вещицы -
проецирование файлов в память и работа с битмэпом в памяти через указатель.
type
TarrRGBTriple=array[byte] of TRGBTriple;
ParrRGBTriple=^TarrRGBTriple;
{организует битмэп размером SX,SY;true_color}
procedure TMBitmap.Allocate(SX,SY:integer);
var DC:HDC;
begin
if BM<>0 then DeleteObject(BM); {удаляем старый битмэп, если был}
BM:=0; PB:=nil;
fillchar(BI,sizeof(BI),0);
with BI.bmiHeader do {заполняем структуру с параметрами битмэпа}
begin
biSize:=sizeof(BI.bmiHeader);
biWidth:=SX; biHeight:=SY;
biPlanes:=1; biBitCount:=24;
biCompression:=BI_RGB;
biSizeImage:=0;
biXPelsPerMeter:=0; biYPelsPerMeter:=0;
biClrUsed:=0; biClrImportant:=0;
FLineSize:=(biWidth+1)*3 and (-1 shl 2); {размер строки(кратна 4 байтам)}
if (biWidth or biHeight)<>0 then
begin
DC:=CreateDC('DISPLAY',nil,nil,nil);
{замечательная функция (см.HELP), возвращает HBITMAP, позволяет сразу разместить выделяемый битмэп в спроецированном файле,
что позволяет ускорять работу и экономить память при генерировании большого битмэпа}
BM:=CreateDIBSection(DC,BI, DIB_RGB_COLORS, pointer(PB), nil, 0);
DeleteDC(DC); {в PB получаем указатель на битмэп-----^^}
if BM=0 then Error('error creating DIB');
end;
end;
end;
{эта процедура загружает из файла true-color'ный битмэп}
procedure TMBitmap.LoadFromFile(const FileName:string);
var HF:integer; {file handle}
HM:THandle; {file-mapping handle}
PF:pchar; {pointer to file view in memory}
i,j:integer;
Ofs:integer;
begin
{открываем файл}
HF:=FileOpen(FileName,fmOpenRead or fmShareDenyWrite);
if HF<0 then Error('open file '''+FileName+'''');
try
{создаем объект-проецируемый файл}
HM:=CreateFileMapping(HF,nil,PAGE_READONLY,0,0,nil);
if HM=0 then Error('cannot create file mapping');
try
{собственно проецируем объект в адресное }
PF:=MapViewOfFile(HM,FILE_MAP_READ,0,0,0);
{получаем указатель на область памяти, в которую спроецирован файл}
if PF=nil then Error('cannot create map view of file');
try
{работаем с файлом как с областью памяти через указатель PF}
if PBitmapFileHeader(PF)^.bfType<>$4D42 then Error('file format');
Ofs:=PBitmapFileHeader(PF)^.bfOffBits;
with PBitmapInfo(PF+sizeof(TBitmapFileHeader))^.bmiHeader do
begin
if (biSize<>40) or (biPlanes<>1) then Error('file format');
if (biCompression<>BI_RGB) or
(biBitCount<>24) then Error('only true-color BMP supported');
{выделяем память под битмэп}
Allocate(biWidth,biHeight);
end;
for j:=0 to BI.bmiHeader.biHeight-1 do
for i:=0 to BI.bmiHeader.biWidth-1 do
{Pixels - это property, возвр. указатель на соотв. RGBTriple в битмэпе}
Pixels[i,j]^.Tr:=ParrRGBTriple(PF+j*FLineSize+Ofs)^[i];
finally
UnmapViewOfFile(PF);
end;
finally
CloseHandle(HM);
end;
finally
FileClose(HF);
end;
end;
{эта функция - реализация Pixels read}
function TMBitmap.GetPixel(X,Y:integer):PRGB;
begin
if (X>=0) and (Xand
(Y>=0) and (Ythen Result:=PRGB(PB+(Y)*FLineSize+X*3)
else Result:=PRGB(PB);
end;
Если у вас на форме есть компонент TImage, то можно сделать так:
var BMP:TMBitmap;
B:TBitmap;
...
BMP.LoadFromFile(..);
B:=TBitmap.Create;
B.Handle:=BMP.Handle;
Image1.Picture.Bitmap:=B;
и загруженный битмэп появится на экране.
Alexander Burnashov
E-mail alex@arta.spb.su
(2:5030/254.36)
Работа с клиентскими наборами данных (DBExpress)
Работа с клиентскими наборами данных (DBExpress)
Введение
В данной части будет рассмотрено применение клиентских наборов данных в dbExpress. Согласно иерархии классов в Kylix к клиентским наборам данных относятся классы TSQLClientDataSet и TClientDataSet. Последний из них является частью технологии MIDAS. Так как на сегодняшний день поддержка данной технологии в Kylix до конца не реализована, то основное внимание мы уделим рассмотрению TSQLClientDataSet.
Компоненты класса TSQLClientDataSet предназначены для создания двухзвенных приложений клиент сервер. Так же как и однонаправленные наборы данных, они используются для работы с сервером БД через TSQLConnection. С другой стороны многие из методов и событий класса TSQLClientDataSet характерны для клиентского датасета в технологии MIDAS. На самом деле TSQLClientDataSet - это гибрид, содержащий в себе объекты однонаправленного набора данных, клиентский набор данных и объект провайдера для применения внесенных изменений на сервере БД. "Запихивание под капот" этих объектов позволило существенно упростить разработку двухзвенных приложений баз данных в dbExpress.
Простейший проект
Работа с TSQLClientDataSet будет проиллюстрирована на примере простой базы данных служащих организации. В качестве сервера БД выбран Interbase 6, т.к он входит в поставку Kylix. Предварительно необходимо создать базу данных с таблицей EMPLOYEERS, описанной следующим образом:
/*Table: EMPLOYEERS, Owner: SYSDBA */
CREATE TABLE "EMPLOYEERS"
(
"ID" INTEGER NOT NULL,
"NAME" VARCHAR(200) NOT NULL,
PRIMARY KEY ("ID")
);
СREATE GENERATOR "EMP_GEN";
SET TERM ^ ;
/* Triggers only will work for SQL triggers */
CREATE TRIGGER "EMPLOYEERS_BEFORE_INS" FOR "EMPLOYEERS"
ACTIVE BEFORE INSERT POSITION 0
AS
BEGIN
NEW.ID = GEN_ID(EMP_GEN,1);
END
^
COMMIT WORK ^
SET TERM ;^
Вставим несколько записей в созданную таблицу. Текст запроса на вставку в таблицу выглядит так:
Insert into Employeers (Name) values 'Петов';
Insert into Employeers (Name) values 'Сидоров';
Далее запустим IDE Kylix и создадим новое приложение. На главной форме приложения разместим следующие компоненты с закладки dbExpress и установим для них нижеуказанные свойства
sc_conn:TDBConnection - настроить для соединения с созданной БД. (как это сделать см. "Коннект - есть коннект"). Св-во Connected - установить true.
scd_emp:TSQLClientDataSet
DBConnection - sc_conn
CommandText - select ID,NAME from EMPOYEERS
Двойным кликом мыши вызовем редактор полей. В редакторе полей правой кнопкой мыши вызовем всплывающее меню и в нем выберем пункт Add all fields. При этом поля набора данных будут определены явным образом. Выберем поле ID и установим его свойство Required в false, чтобы снять необходимость ручного ввода значения ID при вставке пользователем новой записи. После этого св-во Connected компонента sc_conn установим в false.
ds_src:TDataSource
DataSet:scd_emp
DBNavigator1:TDBNavigator
DataSource - ds_src
Align - alTop
Panel1:TPanel
Align - alBottom
Caption - ""(пустая строка)
DBGrid1:TDBGrid
DataSource - ds_src
Align - alTop
На Panel1 разместим 4(Button) кнопки c именами b_connect, b_disconnect, b_count, b_fetch (заголовки - Caption - connect, disconnect, get count, fetch all соответсвтенно )и одну надпись (Label). На событие onClick кнопки b_connect навесим обработчик со следующим кодом
Sc_conn.Connected:=true;
Scd_emp.Active :=true;
На событие onClick кнопки b_disconnect навесим обработчик со следующим кодом
Sc_conn.Connected:=false;
Scd_emp.Active :=false;
Назначение размещенных компонентов следующее
Sc_conn - соединение с базой данных
Sc_emp - набор данных для работы с таблицей БД employers
Ds_src - представление данных sc_emp для компонентов пользовательского интерфейса "чувствительных" к данным.
Запустим на выполнение наш проект, при этом предполагается, что сервер interbase уже запущен. При нажатии кнопки b_connect в сетке данных (DBGrid) можно будет видеть записи таблицы employeers.
Навигация по записям
Методы навигации по записям аналогичны однонаправленным наборам данных.
Добавление, удаление и редактирование записей
Для добавления записей существуют четыре метода
Append -Добавление пустой записи в конец набора данных. Курсор помещается на добавленную запись и набор данных переходит в режим редактирования
Insert - Добавление пустой записи в текущую позицию набора данных. Курсор помещается на добавленную запись и набор данных переходит в режим редактирования.
AppendRecord(const Values: array of const) - Добавление записи в конец набора данных. Поля передаются через параметр Values
InsertRecord(const Values: array of const) Добавление записи в текущую позицию набора данных. Поля передаются через параметр Values
Примеры добавления записей:
// Использование Append
scd_emp.Append;
scd_emp.FieldByName('ID').Value:=-1;
scd_emp.FieldByName('Name').Value:='Петров';
scd_emp.Post;
// Использование AppendRecord
scd_emp.AppendRecord([1,'Петров']);
Определены несколько событий, связанных с вставкой новой записи
BeforeInsert - Событие, генерируемое перед вставкой новой записи в набор данных.
AfterInsert - Событие, генерируемое после вставкой новой записи в набор данных
OnNewRecord - Событие, генерируемое при вставке новой записи в набор данных
При необходимости отменить вставку записи внутри обработчика события можно вызвать метод Abort.
Порядок вызова событий
BeforeInsert
OnNewRecord
AfterInsert
Для удаления текущей записи предназначен метод Delete, события BeforeDelete и AfterDelete генерируются до и после удаления записи соответственно.
Пример:
scd_emp.Delete;
Перевод набора данных в режим редактирования осуществляется вызовом метода Edit. При этом проверить доступность редактирования можно, проанализировав свойство CanModify. Еще одним полезным методом является метод CheckBrowseMode. Данный метод автоматически подтверждает или отменяет сделанные изменения перед тем, как будет осуществлен переход на следующую запись в наборе данных.
События BeforeEdit и AfterEdit возникают соответственно перед и после редактирования записи.
Подтверждение и откат сделанных изменений
Так как клиентский набор данных буферизирует сделанные изменения, то применяется двухступенчатое подтверждение сделанных изменений. Первая ступень - это запись сделанных изменений в буфер набора данных, вторая - запись изменений из буфера в сервер БД.
Запись изменений в буфер осуществляется вызовом метода Post. События BeforePost и AfterPost генерируются перед и после подтверждения изменений. Многие из компонентов пользовательского интерфейса для работы с данными вызывают метод Post автоматически при переходе на следующую запись набора данных.
Отмена записи в буфер набора данных осуществляется вызовом метода Cancel. События BeforeCancel и AfterCancel генерируются перед и после подтверждения изменений.
Изменения, сделанные в буфере, SQLClientDataSet хранит в свойстве Delta. Количество изменений хранится в свойстве ChangeCount. Запись сделанных изменений из буфера в БД осуществляется вызовом ApplyUpdates. В качестве параметра функции передается максимальное количество ошибок, допустимых до завершения метода. Функция возвращает количество возникших ошибок. Если в результате применения изменений количество ошибок не превысило заданного, то успешно переданные записи удаляются из свойства Delta (т.е считаются переданными на сервер БД), иначе все записи считаются не переданными.
Пример:
// Передача изменений из буфера в БД
if scd_emp.ChargeCount > 0 then
if scd_emp.ApplyUpdates(10) > 0 then
Application.MessageBox('Обнаружены ошибки');
При вызове ApplyUpdates SQLClientDataSet генерирует набор SQL операторов для передачи каждой вставленной, удаленной и измененной записи в БД.
При передаче изменений на сервер БД возникает задача определения соответствия измененной записи из буфера набора данных и записи в БД (т.е формирования части where SQL запроса). Свойство UpdateMode определяет данный критерий. Возможные значения св-ва приведены ниже
upWhereAll - для поиска применяется вся совокупность полей набора - режим по умолчанию
upWhereChanged - только поля, отмеченные как ключевые и поля содержащие изменения применяются для поиска.
UpWhereKeyOnly - только поля, отмеченные как ключевые, применяются для поиска. Поля набора данных имеют свойство ProviderFlags, определяющее поведение поля при формировании текста запроса. Могут быть установлены следующие флаги:
pfInUpdate - поле включается в SQL предложение UPDATE - т.е может быть обновлено
pfInWhere - поле включается в в SQL предложение Where в режиме обновления upWhereAll или upWhereChanged
pfInKey - поле включается в в SQL предложение Where в режиме обновления UpWhereKeyOnly
pfHidden - Поле включается в пакет данных для обеспечения уникальности записи, оно не может использоваться набором данных.
Наличие события OnUpdateData позволяет установить параметры обновления для каждой записи, передаваемой на сервер БД.
Откат всех сделанных изменений осуществляется с помощью метода CancelUpdates. Данный метод очищает св-во Delta, таким образом, отменяя все изменения в буфере набора данных.
Откат последней выполненной операции выполняется вызовом UndoLastChange. Передача True в качестве параметра метода UndoLastChange заставляет курсор перемещаться на откатываемую запись.
Но и это еще не все! Можно откатывать назад на произвольное количество операций (здесь под операцией понимается вставка, редактирование, удаление). Для этого существуют так называемые точки сохранения (SavePoint).
Техника такая:
Сохраняем точку. SP:=Client.SavePoint; (здесь SP:integer)
Делаем все, что заблагорассудится - вставка, удаление, редактирование
Восстанавливаем Client.SavePoint:=SP; и как будто ничего не было :))
Если немного помозговать, то используя точки сохранения, можно организовать не только Undo, но и Redo.
Осталось внести некоторые доработки в наш проект, чтобы сделанные изменения были отправлены на сервер БД. Для этого выполним следующие действия:
1. Объявим глобальную переменную id типа integer. Делается это в секции var модуля главной формы, данная секция будет выглядеть так
var
Form1:Tform1;
Id:integer; // Счетчик для поля id, объявленный нами
2. В обработчике события AfterPost scd_emp инициализируем переменную id
id:=-1;
3. В обработчике BeforePost scd_emp используем id для заполнения поля id фиктивным значением (реально значение присваивается на сервере).
If scd_empID.IsNull then
Begin
Scd_empID.Value:=id;
Dec(id);
End;
4. В обработчике события BeforeRefresh scd_emp организуем отправку данных на сервер.
if scd_emp.ChangeCount > 0 then
if scd_emp.ApplyUpdates(0) > 0 then
Abort
else
id:=-1;
Запустим полученное приложение, попробуем вводить или изменять записи - до нажатия кнопки обновления DBNavigator1 все наши изменения не будут отражаться на сервере БД. Закрытие приложения с изменениями, не отправленными на сервер, приводят к потере этих изменений.
Обработка ошибок
Обработка ошибок также делится на обработку ошибок работы с буфером и обработку ошибок передачи данных на сервер БД. Для обработки ошибок вставки, удаления и редактирования в компоненте TSQLDataSet существуют несколько видов событий
OnDeleteError - Возникает при наличии ошибок удаления записи
OnEditError - Возникает при наличии ошибок редактирования или вставки записи
OnPostError - Возникает при наличии ошибок записи сделанных изменений в буфер клиентского набора данных
Обработчики вышеперечисленных событий в качестве одного из параметров получают параметр Action типа TDataAction. Изменяя значение этого параметра в обработчике можно варьировать реакцию на произошедшую ошибку. Возможные значения
daFail - прервать операцию и выдать сообщение об ошибке (поведение по умолчанию)
daAbort - прервать операцию без выдачи сообщения об ошибке
daRetry - повторить попытку, предполагается, что обработчик события предварительно пытается скорректировать запись, вызвавшую ошибку.
Клонирование таблицы
Описано далее в разделе Работа с локальными базами данных в Kylix.
Работа с локальными базами данных в Kylix
Под локальными мы будем понимать базы данных, файлы которых расположены в файлах на локальном диске компьютера или в локальной сети. Доступ к этим файлам осуществляется приложением напрямую.
В Delphi 5, продолжателем которой является Kylix, для работы с локальными базами данных использовалось несколько подходов.
Использование библиотек BDE, ADO, ODBC для доступа к локальным базам формата DBase, Paradox.
Использование TСlientDataSet для работы с локальными базами данных формата cds или xml. Форматы данных файлов являются изобретением Borland.
В Kylix разработка компонентов для создания локальных баз данных первого типа отдана на откуп разработчикам сторонних фирм. Связано это прежде всего с тем, что данные форматы данных являются отмирающими, тем более что конвертировние их в формат xml не вызывает больших затруднений.
Второй тип баз данных, получивший наименование MyBase, предоставляет дополнительные возможности, такие как
Возможность сортировки данных по полям без создания дополнительных файлов индексов.
Возможность ведения списка изменений и отката сделанных изменений
Возможность создания агрегатов на основе данных таблицы.
Возможность совместного использования одних и тех же данных несколькими датасетами.
Совместимость с Delphi5 (не говоря уже о Delphi 6)
Для иллюстрации всего вышесказанного создадим приложение для просмотра и редактирования заказов.
Создание заготовки приложения. Меню File/New Application создаст проект с пустой формой. Добавим модуль данных - File/New. В открывшемся диалоге выбрать пункт DataModule.
Создание файла базы данных. В модуль данных поместим компонент ClientDataSet с закладки DataAccess. Св-во Name установим - Clients. Данный датасет будет хранить информацию о заказчиках. Для создания файла базы данных необходимо указать поля и их типы. Сделать это можно двумя способами:
a) Определить FieldDefs
b) Создать объекты полей явным образом.
Лично я предпочитаю определить FieldDefs, а затем на их основе создать объекты полей :))
Итак, двойной клик на св-ве FieldDefs компонента Clients откроет диалог работы с определениями полей. Добавим следующие определения полей
ID ftAutoInc 0
Name ftString 50
Правой кнопкой мышки кликнем на Clients и выберем в выпадающем меню пункт CreateDataSet, а затем Save To MyBase Xml UTF-8 table. В появившемся диалоге укажем имя xml файла, который будет хранить данные о клиентах - Clients.xml.
Было бы неплохо, чтобы при старте программы ClientDataSet читал данные из созданного нами xml файла. Для этого св-во FileName должно быть равно полному имени (с путем) xml файла. Для Clients это /путь к файлу/Clients.xml.
Теперь определим поля явно на основе FieldDefs. Двойной клик на Clients, в диалоге правой кнопкой мыши вызываем контекстное меню, выбираем пункт Add all fields. Затем DataSource - ds_Clients, разместим в модуле данных и свяжем c Clients (св-во DataSet компонента ds_Clients установим равным Clients).
Формат xml таблицы БД, откат изменений
Посмотрим, как внутри устроен xml файл базы данных. После создания датасета типичный файл БД выглядит так:
<?xml version="1.0" encoding="UTF-8" standalone="yes" ?>
<DATAPACKET Version="2.0">
<METADATA>
<FIELDS>
<FIELD attrname="ID" fieldtype="i4" readonly="true" SUBTYPE="Autoinc" />
<FIELD attrname="Name" fieldtype="string" WIDTH="50" />
</FIELDS>
<PARAMS DEFAULT_ORDER="" AUTOINCVALUE="1" />
</METADATA>
<ROWDATA />
</DATAPACKET>
Строка 1 <?xml version="1.0" encoding="UTF-8" standalone="yes" ?>
В строке 1 расположен заголовочный тэг
Строка 2 <DATAPACKET Version="2.0">
Корневой тэг документа, а вот дальше и начинаются теги, на которые стоит обратить внимание, в частности на строки 3 и 10.
Строка 3 <METADATA>
Строка 10<ROWDATA />
Так вот всю таблицу можно разделить на две части: данные о структуре таблицы БД, хранимые в файле (метаданные) и собственно сами записи. Как вы уже догадались, метаданные хранятся в теге METADATA, а записи в ROWDATA, естественно что при создании новой таблицы БД тег ROWDATA будет пустым.
Внутри тэга METADATA расположены описания полей таблицы (тег FIELDS и вложенные в него теги) и другая служебная информация (порядок сортировки по умолчанию, начальное значение автоинкрементального счетчика).
Теперь давайте запустим наше приложение, вставим в таблицу новую запись, закроем приложение и посмотрим как изменился xml файл.
Изменился тег PARAMS, теперь он выглядит так:
<PARAMS CHANGE_LOG="1 0 4" AUTOINCVALUE="2" DEFAULT_ORDER="" />
и тег ROWDATA стал непустым:
<ROWDATA>
<ROW RowState="4" ID="1" Name="e?AI?" />
</ROWDATA>
Внимательно посмотрев, на изменения мы увидим, что внутри таблицы ведется журнал операций. Это дает возможность отката сделанных изменений. Подробнее это описано выше для SQLClientDataSet. Добавим, что вызов метода MergeChangeLog делает все изменения, сделанные до его вызова недоступными для отката, т.е очищает журнал действий.
Если же Вам совсем не нужно, чтобы журнал велся, в runtime установите св-во LogChanges := false.
Обработка ошибок, могущих возникать при описанных действиях аналогична случаю описанному для SQLClientDataSet.
Клонирование таблицы
Поскольку TClientDataSet держит данные из таблицы в памяти, появилась возможность совместного использования одних данных двумя датасетами. Клонирование осуществляется вызовом метода CloneCursor
Procedure CloneCursor(Source:TCustomClientDataSet;Reset:Boolean;KeepSettings:Boolean = false)
Параметр Source - источник клонированных данных
Параметры Reset и KeepSettings определяют установку св-в фильров, индексы, Read Only, MasterSource, MasterFields. Когда оба параметра fasle указанные св-ва копируются из датасета-источника, Reset:=true - данные св-ва сбрасываются, KeepSettings:=true - остаются без изменений, при этом совместимость их с данными источника клонирования остается на совести программиста.
Установка отношений главный - подчиненный (master-detail)
Первый из способов - это задание св-в MasterSource и MasterFields. Этот способ традиционен еще в Delphi и мы рассматривать его тут не будем - читайте книжки.
Новым способом организации отношения master-detail стало использование вложенных датасетов. Вот об этом и пойдет речь. Допустим мы хотим иметь информацию о покупках сделанных клиентом.
Сначала очистим датасет Clients - щелкнем правой кнопкой мыши и в контекстном меню выберем - Clear Data.
Введем дополнительное FieldDefs Orders - типа ftDataSet. Данный тип поля предназначен для хранения внутри себя датасетов. Набор полей вложенного датасета определяется в свойсвте ChildDefs. Определим в ChildDefs следующие поля Имя (Name) Тип(Type) Размер(Size)
ID FtAutoInc 0
OrderName ftString 20
Price ftCurrency 0
ID - счетчик, OrderName - описание заказа, Price - цена заказа .
Осталось только создать на основе созданных определений создать датасет (щелкнув правой кнопкой и выбрав Create DataSet), сохранить в файл (Save to MyBase xml table) и на основе этих определений явно создать поля (двойной клик на Clients, правая кнопка мыши - add all fields). Открыв созданный xml файл мы увидим следующее
<?xml version="1.0" encoding="UTF-8" standalone="yes" ?>
- <DATAPACKET Version="2.0">
- <METADATA>
- <FIELDS>
<FIELD attrname="ID" fieldtype="i4" readonly="true" SUBTYPE="Autoinc" />
<FIELD attrname="Name" fieldtype="string" WIDTH="50" />
- <FIELD attrname="Orders" fieldtype="nested">
- <FIELDS>
<FIELD attrname="ID" fieldtype="i4" SUBTYPE="Autoinc" />
<FIELD attrname="OrderName" fieldtype="string" WIDTH="20" />
<FIELD attrname="Price" fieldtype="r8" SUBTYPE="Money" />
</FIELDS>
<PARAMS AUTOINCVALUE="1" />
</FIELD>
</FIELDS>
<PARAMS DEFAULT_ORDER="" AUTOINCVALUE="1" />
</METADATA>
<ROWDATA />
</DATAPACKET>
Нетрудно убедиться в том, что поле Orders содержит в себе описание подчиненной таблицы. При этом в сетке данных DBGrid1, расположенной на главной форме, появился новый столбец Orders. При запуске приложения и попытке редактирования этого поля автоматически открывается форма для редактирования вложенного набора данных.
Другим способом организации взаимодействия с вложенным датасетом является размещение в модуле данных дополнительного ClientDataSet. Поместим в модуль данных еще один компонент типа TClientDataSet, установив его имя Orders. Св-ву DataSetField компонента Orders из выпадающего списка присвоим значение ClientsOrders. Все теперь пользуясь компонентом Orders можно просматривать и редактировать вложенный датасет.
Достоинства вышеописанного метода в том, что вся база будет храниться в одном xml файле, недостаток же - нельзя разорвать связь главный-подчиненный и как следствие одновременно просмотреть все записи о заказах вне зависимости от выбранного клиента.
Автор: Mike Goblin
Взято из
с разрешения автора.
Работа с коллекциями
Работа с коллекциями
Cодержание раздела:
Работа с коллекциями - сохранение и загрузка
Работа с коллекциями - сохранение и загрузка
unitDelphiPt;
interface
uses
Classes, Graphics;
type
TDDHPoint = class (TCollectionItem)
private
fX, fY: Integer;
public
Text: string;
procedure WriteText (Writer: TWriter);
procedure ReadText (Reader: TReader);
procedure DefineProperties (Filer: TFiler); override;
procedure Paint (Canvas: TCanvas);
procedure Assign (Pt: TPersistent); override;
published
property X: Integer read fX write fX;
property Y: Integer read fY write fY;
end;
TWrapper = class (TComponent)
private
FColl: TCollection;
published
property MyColl: TCollection read FColl write FColl;
public
constructor Create (Owner: TComponent); override;
destructor Destroy; override;
end;
implementation
// TWrapper constructor and destructor
constructor TWrapper.Create (Owner: TComponent);
begin
inherited Create (Owner);
FColl := TCollection.Create (TDDHPoint);
end;
destructor TWrapper.Destroy;
begin
FColl.Clear;
FColl.Free;
inherited Destroy;
end;
// class TDDHPoint methods
procedure TDDHPoint.WriteText (Writer: TWriter);
begin
Writer.WriteString (Text);
end;
procedure TDDHPoint.ReadText (Reader: TReader);
begin
Text := Reader.ReadString;
end;
procedure TDDHPoint.DefineProperties (Filer: TFiler);
begin
Filer.DefineProperty (
'Text', ReadText, WriteText, (Text <> ''));
end;
procedure TDDHPoint.Paint (Canvas: TCanvas);
begin
Canvas.Ellipse (fX - 3, fY - 3, fX + 3, fY + 3);
Canvas.TextOut (fX + 5, fY + 5, Text);
end;
procedure TDDHPoint.Assign (Pt: TPersistent);
begin
if Pt is TDDHPoint then
begin
fx := TDDHPoint (Pt).fX;
fY := TDDHPoint (Pt).fY;
Text := TDDHPoint (Pt).Text;
end
else
// raise an exception
inherited Assign (pt);
end;
//initialization
//RegisterClass (TWrapper);
end.
unit PersForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
Label1: TLabel;
Edit1: TEdit;
SpeedButtonLoad: TSpeedButton;
SpeedButtonSave: TSpeedButton;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
procedure FormCreate(Sender: TObject);
procedure SpeedButtonSaveClick(Sender: TObject);
procedure SpeedButtonLoadClick(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
PtList: TCollection;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
DelphiPt;
procedure TForm1.FormCreate(Sender: TObject);
begin
PtList := TCollection.Create (TDDHPoint);
end;
procedure TForm1.SpeedButtonSaveClick(Sender: TObject);
var
Str1: TFileStream;
Wrap: TWrapper;
begin
if SaveDialog1.Execute then
begin
Str1 := TFileStream.Create (SaveDialog1.FileName,
fmOpenWrite or fmCreate);
try
Wrap := TWrapper.Create (self);
try
Wrap.MyColl.Assign (ptList);
Str1.WriteComponent (Wrap);
finally
Wrap.Free;
end;
finally
Str1.Free;
end;
end;
end;
procedure TForm1.SpeedButtonLoadClick(Sender: TObject);
var
Str1: TFileStream;
Wrap: TWrapper;
begin
if OpenDialog1.Execute then
begin
Str1 := TFileStream.Create (
OpenDialog1.Filename, fmOpenRead);
try
Wrap := TWrapper.Create (self);
try
Wrap := Str1.ReadComponent (Wrap) as TWrapper;
ptList.Assign (Wrap.MyColl);
finally
Wrap.Free;
end;
finally
Str1.Free;
Invalidate;
Edit1.Text := 'Point ' + IntToStr (PtList.Count + 1);
end;
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Pt: TDDHPoint;
begin
Pt := PtList.Add as TDDHPoint;
Pt.X := X;
Pt.Y := Y;
Pt.Text := Edit1.Text;
Edit1.Text := 'Point ' + IntToStr (PtList.Count + 1);
Invalidate;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
// empty and destroy the list
PtList.Clear;
PtList.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
I: Integer;
begin
for I := 0 to PtList.Count - 1 do
TDDHPoint (PtList.Items [I]).Paint (Canvas);
end;
end.
Взято с
Работа с листами книги
Работа с листами книги
Есть в VBA одна вещь, которая меня раздражает. Это ActiveSheet и ActiveWorkbook, а также возможность работы с Cells и Range без указания, к какому листу или книге они принадлежат. Одно время я боролся сам с собой, то применяя, то совсем отказываясь от подобных конструкций. Окончательно я отказался от этого лишь после обнаружения многочисленных ошибок в анализе «лога» моего Web-сервера, который я сделал на VBA. Благо, при работе в Delphi нет возможности написать Cells(x, y) = NewValue, подразумевая при этом какой-то неуловимый ActiveSheet. Поэтому прежде, чем работать с отдельными ячейками, я всегда получаю интерфейс на конкретный и вполне осязаемый лист книги. И делю это так:
var ISheet: Excel8TLB._Worksheet;
…
ISheet := IWorkbook.Worksheets.Item['Лист1'] as Excel8TLB._Worksheet;
Коллекция Worksheet подобна всем остальным коллекциям из Excel TLB. В ней вы можете удалять листы, вставлять новые, изменять их порядок. Но я практически никогда не делаю этого, поэтому всех нетерпеливых снова отсылаю к справке по Excel VBA.
Главную же мысль свою повторю еще раз. Всегда и везде рекомендую работать с ячейками и областями в контексте их листа, получив предварительно интерфейс на этот лист вышеописанным способом. От использования свойств ActiveSheet и ActiveWorkbook можно совсем отказаться, разве что за исключением каких-то особых случаев.
Автор Евгений Старостин
Взято с сайта
Работа с массивами
Работа с массивами
Cодержание раздела:
См. также статьи в других разделах:
Работа с матрицами и векторами
Работа с матрицами и векторами
Cодержание раздела:
Работа с метафайлами, векторыми изображениями
Работа с метафайлами, векторыми изображениями
Cодержание раздела:
См. также статьи в других разделах:
Работа с MS Access
Работа с MS Access
Cодержание раздела:
См. также статьи в других разделах:
Работа с MS SQL Server
Работа с MS SQL Server
Cодержание раздела:
См. также статьи в других разделах:
Работа с MS Word
Работа с MS Word
Cодержание раздела:
Работа с MS Word из Delphi
Работа с MS Word из Delphi
1. Управление Word-ом из Delphi.
(опубликовано - 13 SoftWare)
Здесь мы рассмотрим пример того, как управлять объектами Word-а (Excel - аналогично) из программ на Delphi. Исходный код примера можно скачать на страничке 'DownLoad'
а). Для чего это нужно ?
Задачи могут быть самые разные, в общем случае это использование возможностей Word-а в своей программе, н-р: проверка текста на орфографию; печать текста, графики; экспорт отчетов в Word или изначальное создание их там и т.д.
б). Подготовительные работы. На самом деле существует несколько способов сделать это, мы рассмотрим только один (пример кроме Delphi 5, в Delphi5 для этого есть компоненты на закладке Servers переименуете в программе типы на соответствующие компоненты, дальше так же).
Для начала начнем новый проект File, New Application; File, Save All. Создадим отдельную папку для проекта и сохраним Unit1 как Main, а Project1 как WordWriter.
Далее для работы с Word-ом нам потребуется библиотека типов Word-а, это делается так:
Project, Import Type Library, Add, далее переходим в папку, где стоит Word ( у меня это - "c:\program files\microsoft office) , заходим в папку Office и выбираем файл - msword8.olb (цифра -? версии Word-а - у Вас может отличаться ) или excel8.olb (для Excel).Нажимаем Оk. Delphi создаст 2 файла - Word_tlb.pas и Office_tlb.pas, их надо включить в раздел uses модуля Main нашего проекта:
uses... ,Office_Tlb, word_tlb;
в). Теперь займемся непосредственно программированием.
В разделе var опишем следующие переменные:
// класс приложения ворда
WordApp:Word_tlb.Application_;
// класс чего-то типа выделения,
// т.е. говоришь - выделить ячейку с ... по, а результат скидываешь
// в эту перем и работаешь с этими ячейками как с 1 объектом
ARange,TempRange:Range;
// массив документов
Docs:documents;
// 1 документ
Doc:document;
// массив параграфов
pars:Paragraphs;
// 1 параграф
par:Paragraph;
// параметры для передачи
Template,temp,OpenAsTemplate:olevariant;
// массив таблиц
tabls:Tables;
// 1 таблица
tabl:Table;
// рабочая переменная
i:integer;
Далее проектируем форму:
1. Поместим вверх нашей формы кнопку - button1 типа tbutton, поменяем заголовок (св-во Caption) на 'Старт'.
2. Под кнопкой разместим панель - panel1 типа tpanel. Внутри панели поместим компонент - bevel1 типа tbevel, поменяем св-во Align на alClient (при этом рамка растянется на всю панель).
3. Сверху панели (далее все компоненты будут размещаться внутри этой панели) разместим метку - label1 типа tlabel, поменяем значение св-ва Caption на 'Передать в ячейку':
4. Ниже слева поместим метку - label1 типа tlabel, св-во Caption поменяем на 'X='
5. Правее метки помещаем компонент Edit1 типа tEdit, св-во Text меняем на '1'
6. По правой границе Edit1 помещаем компонент UpDown1 типа tUpDown, в списке св-ва 'Associate' выбираем Edit1, св-во 'Position' приравниваем '1'
7. Чуть отступаем вправо и повторяем шаги 4-6 , заменив Edit1 на Edit2, UpDown1 на UpDown2, Label1 на Label2 соответственно.
8. Ниже размещаем еще одну метку - label4 типа tlabel, меняем св-во 'Caption' на 'Новое значение ячейки:'
9. Ниже размещаем компонент Edit3 типа tEdit, св-во Text меняем на '0'
10. И, наконец, в самом низу панели размещаем кнопку BitBtn1 типа tBitBtn, меняем св-во 'Kind' на 'bkOk'.
Теперь напашем обработчики - именно в них и заключается вся функциональность программы:
1. Назначим обработчик OnClick компоненту Button1 :
procedure TForm1.Button1Click(Sender: TObject);
begin
// если заголовок 'Выход', то закрываем программу
if button1.caption='Выход' then
begin
Application.Terminate;
exit
end
// иначе (при первом начатии, когда у нас заголовок 'Старт')
//переименовываем заголовок в 'Выход'
else button1.caption:='Выход';
panel1.Visible:=true;
// создаем экземпляр ворда
WordApp:=CoApplication_.Create;
// делаем его видимым
WordApp.Visible:=true;
// шаблон
template:='Normal';
// создать шаблон
OpenAsTemplate:=false;
// что-то типа оператора with, можно было и напрямую обратиться
Docs:=WordApp.Documents;
// добавляем документ
Doc:=Docs.Add(template,OpenAsTemplate);
// выделить все
ARange:=Doc.Range(EmptyParam,EmptyParam);
// массив параграфов
pars:=doc.Paragraphs;
// переменная - параметр
template:=arange;
// новый параграф
par:=pars.Add(template);
// цвет зеленный
par.Range.Font.ColorIndex:=11;
// вставляем текст
par.Range.InsertBefore('Привет !!!');
// переменная - параметр
template:=par.Range;
// новый параграф, чтобы таблица не потерла текст
par:=pars.Add(template);
// цвет черный
par.Range.Font.ColorIndex:=0;
// вставляем текст
par.Range.InsertBefore('Переключившись в программу, можно программно менять текст ячеек !');
// переменная - параметр
template:=par.Range;
// новый параграф, чтобы таблица не потерла текст
par:=pars.Add(template);
// выделяем параграф
arange:=par.Range;
// шрифт - жирный
ARange.Font.Bold:=1;
// шрифт - рукописный
ARange.Font.Italic:=1;
// получить массив таблиц
tabls:=aRange.Tables;
// добавляем новую таблицу размером 5 на 5
tabl:=tabls.Add(arange,5,5);
// в цикле
for i:=1 to 5 do
// задаем значение ячеек
tabl.Cell(i,1).Range.Text:=inttostr(i);
end;
2. Зададим обработчик формы:
procedure TForm1.FormDestroy(Sender: TObject);
var
// для параметров
SaveChanges:olevariant;
begin
// если Word не закрыт
if not VarIsEmpty(WordApp) then begin
{ а можно сохранить автоматом:
// имя файла в оле
template:='Имя.doc';
// если не сохранен, то
if doc.Saved=false then
// сохраняем
Doc.SaveAs(template, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam);
короче, пишешь имя объекта, ставишь точку и нажимаешь
'ctrl'+' ' и изучаешь существующие методы и св-ва
}
//изменения не сохранять
SaveChanges:=false;
// то закрыть сначала документ
Doc.Close(SaveChanges,EmptyParam,EmptyParam);
// а потом и ворд
WordApp.Quit(SaveChanges,EmptyParam,EmptyParam)
end;
end;
3. Назначим обработчик OnClick компоненту Bitbtn1 :
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
// в соотв ячейку ставим соотв значение,
// а можно и наоборот - получать значение из ячейки в переменную
tabl.Cell(UpDown2.Position,UpDown1.Position).Range.Text:=Edit3.Text;
end;
в). В общем-то, это все ...
г). Дополнительная информация:
· Справка Word-а (по Visual Basic, по умолчанию она не ставится - запустите заново Setup и поставте в соотв. месте галочку)
· Книги:
- Чарльз Калверт "Энциклопедия пользователя Delphi4"
(издательство - DiaSoft)
- Марко Кэнту "Delphi4 для профессионалов"
(издательство - Питер)
· Если у Вас другая версия Word-а:
Параметры ф-ций могут отличаться - обратитесь к справке (см выше) или если у Вас версия Delphi 3 и выше, то используем универсальный метод - пишешь имя объекта, ставишь точку (если нужно посмотреть список параметров у функции , то после открывающей скобки ) , нажимаешь 'ctrl'+'пробел' и изучаешь существующие методы и св-ва.
(c) 13 SoftWare. Статья взята с сайта www.vladimir13.narod.ru
В данный FAQ попала с Исходников.ru
Работа с MySQL
Работа с MySQL
Cодержание раздела:
Работа с NTFS
Работа с NTFS
Cодержание раздела:
Работа с очень большими числами
Работа с очень большими числами
Это модуль для работы с очень большими числами без потери точности. Модуль даёт возможность манипулирования с 10000 и более значащими цифрами в числах. В модуле реализованы сложение, вычитание, умножение, деление, возведение в целую степень и факториал. Все функции в качестве аргументов принимают длинные строки и результат выдают тоже в виде строки.
Автор модуля Vit ()
Просьба связаться со мной, если кто хочет доработать модуль и расширить функциональность.
unit UMathServices;
{Автор Vit}
interface
Type TProgress = procedure(Done:real);
{Собственно экспортные функции}
Function ulFact(First:String):string;
Function ulSum(First, Second :string):string;
Function ulSub(First, Second :string):string;
Function ulMPL(First, Second :string):string;
Function ulPower(First, Second :string):string;
function UlDiv(First, Second:String; Precision:integer):String; {Precision - не истинная точность а количество знаков учитываемых после запятой сверх тех которые значимы. Все знаки уже существующие в делимом и делителе в любом случае учитываются}
{Call back function for long operations}
var OnProgress: TProgress;
implementation
Uses SysUtils;
type TMathArray=array of integer;
Type TNumber=record
int, frac:TMathArray;
sign:boolean;
end;
var n1, n2:TNumber;
Procedure Str2Number(s:string; var n:TNumber);
var i, j, l:integer;
begin
if s='' then
begin
setlength(n.int , 0);
setlength(n.frac , 0);
exit;
end;
l:=length(s);
if s[1]='-' then
begin
s:=copy(s,2,l);
l:=l-1;
n.sign:=false;
end
else
n.sign:=true;
j:=pos('.', s);
if j>0 then
begin
setlength(n.int , j-1);
for i:=1 to j-1 do n.int[i-1]:=strtoint(s[j-i]);
setlength(n.frac , l-j);
for i:=1 to l-j do n.frac[i-1]:=strtoint(s[l-i+1]);
end
else
begin
setlength(n.int,l);
for i:=1 to l do n.int[i-1]:=strtoint(s[l-i+1]);
setlength(n.frac,0);
end;
end;
Function Num2Array(Var n:TNumber; var a:TMathArray):integer;
var i:integer;
begin
result:=length(n.frac);
setlength(a,length(n.int)+result);
for i:=0 to length(a)-1 do if i<result then a[i]:=n.frac[i] else a[i]:=n.int[i-result];
end;
Procedure MultiplyArray(var a1, a2, a:TMathArray);
var i, j:integer;
b:boolean;
begin
{checking for zero, 1}
for i:=length(a2)-1 downto 0 do
begin
for j:=length(a1)-1 downto 0 do
begin
a[j+i]:=a[j+i]+(a2[i]*a1[j]);
end;
end;
repeat
b:=true;
for i:=0 to length(a)-1 do
if a[i]>9 then
begin
b:=false;
try
a[i+1]:=a[i+1]+1;
except
setlength(a, length(a)+1);
a[i+1]:=a[i+1]+1;
end;
a[i]:=a[i]-10;
end;
until b;
end;
Procedure Array2Num(Var n:TNumber; var a:TMathArray; frac:integer; sign:boolean);
var i:integer;
begin
setlength(n.frac,frac);
setlength(n.int,length(a)-frac);
for i:=0 to length(a)-1 do
begin
if i<frac then n.frac[i]:=a[i] else n.int[i-frac]:=a[i];
end;
n.sign:=sign;
end;
Function Number2Str(var n:TNumber):string;
var i:integer;
s:string;
begin
result:='';
for i:=0 to high(n.int) do result:=inttostr(n.int[i])+result;
if length(n.frac)<>0 then
begin
for i:=0 to high(n.frac) do s:=inttostr(n.frac[i])+s;
result:=result+'.'+s;
end;
while (length(result)>1) and (result[1]='0') do delete(result,1,1);
if pos('.', result)>0 then while (length(result)>1) and (result[length(result)]='0') do delete(result,length(result),1);
if not n.sign then result:='-'+result;
setlength(n.int,0);
setlength(n.frac,0);
end;
Procedure DisposeNumber(var n:TNumber);
begin
setlength(n.int,0);
setlength(n.frac,0);
end;
Function ulFact(First:String):string;
var n1, n2:TNumber;
i:integer;
a, a1, a2:TMathArray;
max:integer;
begin
Str2Number('1', n1);
Str2Number('1', n2);
Num2Array(n1, a1);
Num2Array(n2, a2);
max:=strtoint(First);
for i:=1 to strtoint(First) do
begin
if Assigned(OnProgress) then OnProgress((i/max)*100);
setlength(a,length(a1)+length(a2)+1);
MultiplyArray(a1, a2, a);
setlength(a1,0);
setlength(a2,0);
a1:=a;
Str2Number(inttostr(i), n2);
Num2Array(n2, a2);
end;
Array2Num(n1, a1, 0, true);
result:=Number2Str(n1);
DisposeNumber(n1);
end;
Function ulPower(First, Second :string):string;
var i, j, c:integer;
a, a1, a2:TMathArray;
var n1:TNumber;
max:integer;
begin
j:=strtoint(Second);
if j=0 then
begin
result:='1';
exit;
end
else
if j=1 then
begin
result:=First;
exit;
end;
max:=j-1;
Str2Number(First, n1);
c:=Num2Array(n1, a1);
setlength(a,0);
setlength(a2,0);
a2:=a1;
for i:=1 to j-1 do
begin
if Assigned(OnProgress) then OnProgress((i/max)*100);
setlength(a,0);
setlength(a,length(a1)+length(a2)+1);
MultiplyArray(a1, a2, a);
setlength(a2,0);
a2:=a;
end;
setlength(a1,0);
setlength(a2,0);
c:=c*j;
if n1.sign then
Array2Num(n1, a, c, true)
else
if odd(j) then Array2Num(n1, a, c, false) else Array2Num(n1, a, c, true);
setlength(a,0);
result:=Number2Str(n1);
DisposeNumber(n1);
end;
Procedure MultiplyNumbers(var n1, n2 :TNumber);
var i:integer;
a, a1, a2:TMathArray;
begin
i:=Num2Array(n1, a1)+Num2Array(n2, a2);
setlength(a,length(a1)+length(a2)+1);
MultiplyArray(a1, a2, a);
setlength(a1,0);
setlength(a2,0);
Array2Num(n1, a, i, n1.sign=n2.sign);
DisposeNumber(n2);
setlength(a,0);
end;
Function ulMPL(First, Second :string):string;
var n1, n2:TNumber;
begin
Str2Number(First, n1);
Str2Number(Second, n2);
MultiplyNumbers(n1, n2);
result:=Number2Str(n1);
DisposeNumber(n1);
end;
Procedure AlignNumbers(var n1, n2:TNumber);
var i1, i2, i:integer;
begin
i1:=length(n1.int);
i2:=length(n2.int);
if i1>i2 then setlength(n2.int, i1);
if i2>i1 then setlength(n1.int, i2);
i1:=length(n1.frac);
i2:=length(n2.frac);
if i1>i2 then
begin
setlength(n2.frac, i1);
for i:=i1-1 downto 0 do
begin
if i-(i1-i2)>0 then n2.frac[i]:=n2.frac[i-(i1-i2)] else n2.frac[i]:=0;
end;
end;
if i2>i1 then
begin
setlength(n1.frac, i2);
for i:=i2-1 downto 0 do
begin
if i-(i2-i1)>0 then n1.frac[i]:=n1.frac[i-(i2-i1)] else n1.frac[i]:=0;
end;
end;
end;
Function SubInteger(a1,a2:TMathArray):integer;
var i:integer;
b:boolean;
begin
result:=0;
if length(a1)=0 then exit;
for i:=0 to length(a1)-1 do a1[i]:=a1[i]-a2[i];
repeat
b:=true;
for i:=0 to length(a1)-1 do
if a1[i]<0 then
begin
b:=false;
if i=length(a1)-1 then
begin
result:=-1;
a1[i]:=a1[i]+10;
b:=true;
end
else
begin
a1[i+1]:=a1[i+1]-1;
a1[i]:=a1[i]+10;
end;
end;
until b;
end;
Procedure AssignNumber(out n1:TNumber; const n2:TNumber);
var i:integer;
begin
Setlength(n1.int, length(n2.int));
for i:=0 to length(n2.int)-1 do n1.int[i]:=n2.int[i];
Setlength(n1.frac, length(n2.frac));
for i:=0 to length(n2.frac)-1 do n1.frac[i]:=n2.frac[i];
n1.sign:=n2.sign;
end;
Procedure SubNumber(var n1, n2 : TNumber);
var i:integer;
n:TNumber;
begin
AlignNumbers(n1, n2);
i:=subInteger(n1.frac, n2.frac);
n1.int[0]:=n1.int[0]+i;
DisposeNumber(n);
AssignNumber(n, n1);
i:=subInteger(n1.int, n2.int);
if i<0 then
begin
subInteger(n2.int, n.int);
AssignNumber(n1, n2);
end
else
begin
DisposeNumber(n2);
end;
end;
Function SumInteger(a1,a2:TMathArray):integer;
var i:integer;
b:boolean;
begin
result:=0;
if length(a1)=0 then exit;
for i:=0 to length(a1)-1 do a1[i]:=a1[i]+a2[i];
repeat
b:=true;
for i:=0 to length(a1)-1 do
if a1[i]>9 then
begin
b:=false;
if i=length(a1)-1 then
begin
result:=1;
a1[i]:=a1[i]-10;
b:=true;
end
else
begin
a1[i+1]:=a1[i+1]+1;
a1[i]:=a1[i]-10;
end;
end;
until b;
end;
Procedure SumNumber(var n1, n2:TNumber);
var i:integer;
begin
AlignNumbers(n1, n2);
i:=sumInteger(n1.frac, n2.frac);
n1.int[0]:=n1.int[0]+i;
i:=sumInteger(n1.int, n2.int);
if i>0 then
begin
setlength(n1.int, length(n1.int)+1);
n1.int[length(n1.int)-1]:=i;
end;
DisposeNumber(n2);
end;
Procedure SumNumbers(var n1, n2:TNumber);
begin
if n1.sign and n2.sign then
begin
SumNumber(n1, n2);
n1.sign:=true;
end
else
if (not n1.sign) and (not n2.sign) then
begin
SumNumber(n1, n2);
n1.sign:=False;
end
else
if (not n1.sign) and n2.sign then
begin
SubNumber(n2, n1);
AssignNumber(n1, n2);
end
else
begin
SubNumber(n1, n2);
end;
end;
Function ulSum(First, Second :string):string;
begin
Str2Number(First, n1);
Str2Number(Second, n2);
SumNumbers(n1, n2);
result:=Number2Str(n1);
DisposeNumber(n1);
end;
Function ulSub(First, Second :string):string;
begin
Str2Number(First, n1);
Str2Number(Second, n2);
n2.sign:=not n2.sign;
SumNumbers(n1, n2);
result:=Number2Str(n1);
DisposeNumber(n1);
end;
function DupChr(const X:Char;Count:Integer):AnsiString;
begin
if Count>0 then begin
SetLength(Result,Count);
if Length(Result)=Count then FillChar(Result[1],Count,X);
end;
end;
function StrCmp(X,Y:AnsiString):Integer;
var
I,J:Integer;
begin
I:=Length(X);
J:=Length(Y);
if I=0 then begin
Result:=J;
Exit;
end;
if J=0 then begin
Result:=I;
Exit;
end;
if X[1]=#45 then begin
if Y[1]=#45 then begin
X:=Copy(X,2,I);
Y:=Copy(Y,2,J);
end else begin
Result:=-1;
Exit;
end;
end else if Y[1]=#45 then begin
Result:=1;
Exit;
end;
Result:=I-J;
if Result=0 then Result:=CompareStr(X,Y);
end;
function StrDiv(X,Y:AnsiString):AnsiString;
var
I,J:Integer;
S,V:Boolean;
T1,T2:AnsiString;
R:string;
max:integer;
begin
Result:=#48;
R:=#48;
I:=Length(X);
J:=Length(Y);
S:=False;
V:=False;
if I=0 then Exit;
if (J=0) OR (Y[1]=#48) then begin
Result:='';
R:='';
Exit;
end;
if X[1]=#45 then begin
Dec(I);
V:=True;
X:=Copy(X,2,I);
if Y[1]=#45 then begin
Dec(J);
Y:=Copy(Y,2,J)
end else S:=True;
end else if Y[1]=#45 then begin
Dec(J);
Y:=Copy(Y,2,J);
S:=True;
end;
Dec(I,J);
if I<0 then begin
R:=X;
Exit;
end;
T2:=DupChr(#48,I);
T1:=Y+T2;
T2:=#49+T2;
max:= Length(T1);
while Length(T1)>=J do begin
while StrCmp(X,T1)>=0 do begin
X:=UlSub(X,T1);
Result:=UlSum(Result,T2);
end;
SetLength(T1,Length(T1)-1);
SetLength(T2,Length(T2)-1);
if Assigned(OnProgress) then OnProgress(100-(Length(T1)/max)*100);
end;
R:=X;
if S then if Result[1]<>#48 then Result:=#45+Result;
if V then if R[1]<>#48 then R:=#45+R;
end;
Function Mul10(First:string; Second:integer):string;
var s:string;
i, j:integer;
begin
if pos('.',First)=0 then
begin
s:='';
For i:=0 to Second-1 do s:=s+'0';
Result:=First+s;
end
else
begin
s:='';
j:=length(First)-pos('.',First);
if (second-j)>0 then For i:=0 to Second-j-1 do s:=s+'0';
First:=First+s;
j:=pos('.',First);
First:=StringReplace(First,'.','',[]);
insert('.',First,j+second);
while (length(First)>0) and (First[length(First)]='0') do delete(First,length(First),1);
while (length(First)>0) and (First[length(First)]='.') do delete(First,length(First),1);
Result:=First;
end;
end;
Function Div10(First:string; Second:integer):string;
var s:string;
i:integer;
begin
s:='';
For i:=0 to Second do s:=s+'0';
s:=s+First;
Insert('.', s, length(s)-Second+1);
while (length(s)>0) and (s[1]='0') do delete(s,1,1);
if pos('.',s)>0 then
while (length(s)>0) and (s[length(s)]='0') do delete(s,length(s),1);
if (length(s)>0) and (s[length(s)]='.') then delete(s,length(s),1);
Result:=s;
end;
function UlDiv(First, Second:String; Precision:integer):String;
begin
First:=Mul10(First, Precision);
result:=Div10(StrDiv(First, Second), Precision);
end;
end.
Взято с Vingrad.ru
Работа с OpenGL - Минимальная программа
Работа с OpenGL - Минимальная программа
Содержимое контекста
Итак, если необходимо осуществить вывод на поверхность чужого окна, надо, получив ссылку на это окно, получить ссылку на контекст устройства, связанную с этим окном, после чего можно рисовать на чужом окне. Когда мы работаем с OpenGL, мы создаем контекст воспроизведения OpenGL, связанный с контекстом устройства нашего окна, далее обращаемся к функциям OpenGL, отрабатывая которые, OpenGL строит картинку на поверхности нашего устройства.
То есть схема здесь такая - приложение отдает команды машине OpenGL, получая результат на поверхности своего окна. Такая архитектура называется "клиент - серверной", в роли клиента выступает наше приложение, в роли сервера - система OpenGL. Задача сервера - отрабатывать команды клиента. В принципе, сервер может располагаться и не на нашем компьютере, а удаленно, возможно и за тысячи километров от нас. Наше приложение должно передать серверу требуемые для работы данные - контексты и команды на языке сервера. Также важно понимать, что основную работу выполняет не наше приложение, а сервер. Наше приложение лишь создает окно - платформу для работы сервера, и передает команды серверу. При грамотном подходе нет разницы, какими средствами мы спроектировали приложение - С или Delphi, скорость воспроизведения целиком зависит от производительности сервера - машины OpenGL. Мы выбрали в качестве средства разработки приложений именно Delphi за выдающуюся скорость компиляции и обаятельность концепций.
Поскольку контексты занимают немаловажное место в нашей работе, поговорим о них чуть более подробно.
Мы знаем, что ссылка на контекст устройства - величина типа HDC, для получения которой вызываем функцию GetDC. Ссылке на контекст устройства в Delphi соответствует свойство Canvas.Handle формы, принтера и некоторых компонентов. Теоретически всюду в наших примерах в строках, использующих величину DC типа HDC, вместо DC можно использовать Canvas.Handle. В первых примерах для начинающих это так и сделано. Каков же все-таки смысл контекста устройства, если он и так связан с однозначно определенным объектом - окном, областью памяти или принтером, и зачем передавать дополнительно какую-то информацию об однозначно определенном объекте?
Для ответа на эти вопросы разберемся с выводом в Windows, замечательным свойством которого является то, что одними и теми же функциями осуществляется вывод на различные устройства.
Строки:
Form1.Canvas.Ellipse(0, 0, 100, 100);
и
Printer.BeginDoc;
Printer.Canvas.Ellipse (0,0,100,100);
Printer.EndDoc;
рисуют один и тот же эллипс на поверхности формы и на распечатываемом документе соответственно, то есть на различных устройствах. Причем, если мы будем выводить разноцветную картинку на монохромный принтер, он справится с этой задачей, передавая цвета оттенками серого. Даже если мы рисуем только на канве формы, мы имеем дело с различными устройствами - нам неизвестно, какова графическая плата пользователя и каковы характеристики текущей установки настроек экрана. Например, имея в своем распоряжении более 16 миллионов цветов, приложение не заботится об отображении такой богатой палитры на экране, располагающем всего 256 цветами. Эти вопросы приложение перекладывает на плечи операционной системы, решающей их посредством драйверов устройств. Приложению для того, чтобы воспользоваться функциями воспроизведения Windows, необходимо только указать ссылку на контекст устройства, содержащую средства и характеристики устройства вывода.
Win32 Programmer's Reference фирмы MicroSoft о контексте устройства сообщает следующее:
"Контекст устройства является структурой, которая определяет комплект графических объектов и связанных с ними атрибутов, и графические режимы, влияющие на вывод. Графический объект включает карандаш для изображения линии, щетку для краски и заполнения, растр для копирования или прокрутки частей экрана, палитру для определения комплекта доступных цветов, области для отсечения и других операций, и маршрута для операций рисования".
Термин "структура", встретившийся здесь, соответствует записи в терминологии Delphi. Контекст устройства Windows содержит информацию, относящуюся к графическим компонентам GDI, контекст воспроизведения содержит информацию, относящуюся к OpenGL, то есть играет такую же роль, что и контекст устройства для GDI. В частности, эти контексты являются хранилищами состояния системы, например, хранят информацию о текущем цвете карандаша.
Формат пикселя
Итак, ссылка на контекст устройства содержит характеристики устройства и средства отображения. Именно он знает, как выводить на конкретно это устройство. Упрощенно говоря, получив ссылку на контекст устройства, мы берем в руки простой либо цветной карандаш, или кисточку с палитрой в миллионы оттенков. Сервер OpenGL, прежде чем приступать к работе, также должен определиться, на каком оборудовании ему придется работать. Это может быть скромная персоналка, а может быть и мощная графическая станция. Прежде чем получить контекст воспроизведения, сервер OpenGL должен получить детальные характеристики используемого оборудования. Эти характеристики хранятся в специальной структуре, тип которой - TPixelFormatDescriptor (описание формата пикселя). Формат пикселя определяет конфигурацию буфера цвета и вспомогательных буферов.
Самый частый вопрос, который я получаю в связи с моими уроками, заключается в просьбе указать источники подробной информации об OpenGL на русском. К сожалению, если такие и есть, то мне они неизвестны. Главным нашим подручным станет поставляемый в составе Delphi файл помощи по OpenGL. Систему помощи Delphi для получения хороших результатов необходимо настраивать, если в помощи Delphi найти раздел по OpenGL, он не порадует обилием информации. В разных версиях Delphi настройка помощи выполняется по-разному, потребуются некоторые несложные манипуляции, но мы не будем тратить на это время. Будем использовать самый простой способ - контекстную помощь. Наберите в тексте модуля фразу "PixelFormatDescriptor", нажмите клавишу F1 и Вы получите подробную помощь об этом типе. Точно также мы будем получать помощь обо всех терминах, функциях и командах OpenGL.
Итак, мы получили обширное описание структуры PixelFormatDescriptor. Обращаю внимание, что мы видим раздел помощи MicroSoft, рассчитанной на программистов С и С++, поэтому описание использует термины и стилистику именно этих языков. Так, по традиции Delphi имена типов начинаются с префикса T, но нам не удастся найти помощь по термину TPixelFormatDescriptor. К сожалению, это не единственное неудобство, которое нам придется испытывать. Например, если сейчас мы заглянем в файл windows.pas и найдем описание записи TPixelFormatDescriptor, мы обнаружим, что в файле помощи не указаны некоторые константы, а именно: PFD_SWAP_LAYER_BUFFERS, PFD_GENERIC_ACCELERATED и PFD_DEPTH_DONTCARE. А константа, названная PFD_DOUBLE_BUFFER_DONTCARE, по-видимому, соответствует константе, описанной в модуле windows.pas как PFD_DOUBLEBUFFER_DONTCARE. Наверное, более поздние версии помощи и заголовочного файла исправят этот и другие неточности.
Итак, смысл структуры PixelFormatDescriptor - детальное описание графической системы, на которой происходит работа. Вас может озадачить дотошность этого описания, но, уверяю, особое внимание от нас из всего этого описания требует совсем немногое.
В каталоге Beginner/1 Вы найдете проект OpenGL_min.dpr, в котором я привел описание всех полей структуры TPixelFormatDescriptor на русском, в момент их первоначального заполнения. Делается это в процедуре SetDCPixelFormat, вызываемой между получением ссылки на контекст устройства и созданием контекста воспроизведения OpenGL. Посмотрим подробнее, что там делается. Полям структуры присваиваются желаемые значения, затем вызовом функции ChoosePixelFormat осуществляется запрос системе, поддерживается ли на данном рабочем месте выбранный формат пикселя, и вызовом функции SetPixelFormat устанавливаем формат пикселя в контексте устройства. Функция ChoosePixelFormat возвращает индекс формата пикселя, который нам нужен в качестве аргумента функции SetPixelFormat.
Заполнив поля структуры TPixelFormatDescriptor, мы определяемся со своими пожеланиями к графической системе, на которой будет происходить работа приложения, машина OpenGL подбирает наиболее подходящий к нашим пожеланиям формат, и устанавливает уже его в качестве формата пикселя для последующей работы. Наши пожелания корректируются применительно к реальным характеристикам системы. То, что машина OpenGL не позволит нам установить нереальный для конкретной машины формат пикселя, значительно облегчает нашу работу. Предполагая, что разработанное приложение будет работать на машинах разного класса, можно запросить "всего побольше", а уж OpenGL разберется на конкретной машине, каковы параметры и возможности оборудования, на котором сейчас будет происходить работа. На этом можно было бы и закончить разговор о формате пикселя, если бы мы могли полностью довериться выбору OpenGL.
Обратим внимание на поле структуры "битовые флаги" - dwFlags. То, как мы зададим значение флагов, существенно может сказаться на работе нашего приложения, и наобум задавать эти значения не стоит. Тем более, что некоторые флаги совместно ужиться не могут, а некоторые могут присутствовать только в паре с другими. В этом примере флагам я присвоил значение PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL, то есть сообщаю системе, что я собираюсь осуществлять вывод в окно, и что моя система в принципе поддерживает OpenGL. Я ограничился всего двумя константами из обширного списка, приведенного в модуле windows.pas, по каждой из которых в файле помощи приведено детальное описание.
Так, константа PFD_DOUBLEBUFFER включает режим двойной буферизации, когда вывод осуществляется не на экран, а в память, затем содержимое буфера выводится на экран. Это очень полезный режим, если в любом примере на анимацию убрать режим двойной буферизации и все команды, связанные с этим режимом, хорошо будет видно мерцание при выводе кадра. Константу PFD_GENERIC_ACCELERATED имеет смысл устанавливать в случае, если компьютер оснащен графическим акселератором. Флаги, заканчивающиеся на "DONTCARE" , сообщают системе, что соответствующий режим может иметь оба значения, то есть PFD_DOUBLE_BUFFER_DONTCARE - запрашиваемый формат пикселя может иметь оба режима - одинарной и двойной буферизации. Со всеми остальными полями и константами я предоставляю Вам возможность разобраться самостоятельно, только замечу, что поле iLayerType, описанное в windows.pas типа Byte, может, согласно помощи, иметь три значения: PFD_MAIN_PLANE, PFD_OVERLAY_PLANE и PFD_UNDERLAY_PLANE, однако константа PFD_UNDERLAY_PLANE имеет значение -1, так что установить такое значение не удастся.
OpenGL позволяет узнать, какой же формат пикселя он собирается использовать. Для этого необходимо использовать функцию DescribePixelFormat, заполняющую величину типа TPixelFormatDescriptor установленным форматом пикселя. На основе использования этой функции построим несложное приложение, позволяющее детальнее разобраться с форматом пикселя и подобрать формат для конкретного рабочего места.
В примере битовым флагам задаем все возможные значения одновременно, числовым полям задаем заведомо нереальное значение 64, и смотрим на выбор формата пикселя, сделанным OpenGL. Результат, который Вы получите - выбранный формат пикселя, я предсказать не смогу - он индивидуален для каждой конкретной конфигурации машины и текущих настроек. Возможно, Вы получите в результате, что режим двойной буферизации не будет установлен - напоминаю, многие флаги устанавливаются только в комбинации с другими определенными. Наше приложение позволяет менять параметры формата пикселя и устанавливать его заново. Чтобы видеть, что происходит воспроизведение, небольшая площадка на экране при каждом тестировании окрашивается случайным цветом, используя функции OpenGL. Поэкспериментируйте с этим приложением, например, определите комбинацию флагов для установления режима двойной буферизации. Посмотрите значение числовых полей формата при различной палитре экрана - 16, 24, 32 бита, но не 256 цветов. О выводе при палитре экрана в 256 цветов - отдельный разговор. Это приложение, в частности, дает ответ на вопрос - как определить, оснащен ли компьютер графическим акселератором. Повозившись с этим приложением, Вы найдете ответ на вопрос, на который я Вам ответить не смогу - как надо заполнить структуру TPixelFormatDescriptor для Вашего компьютера. Обратите внимание, что в коде я установил несколько проверок на отсутствие контекста воспроизведения, который может быть потерян по ходу работы любого приложения, использующего OpenGL - редкая, но возможная ситуация в штатном режиме работы системы и очень вероятная ситуация если, например, по ходу работы приложения менять настройки экрана.
Минимальная программа OpenGL
Теперь мы знаем все, что необходимо для построения минимальной программы, использующей OpenGL. Я привел два варианта этой программы - одна построена исключительно на функциях Windows API, другая использует библиотеку классов Delphi (проекты каталогов Beginner/1 и Beginner/2 соответственно).
Взглянем на головной модуль второго проекта. При создании формы задаем формат пикселя, в качестве ссылки на контекст устройства используем значение Canvas.Handle формы. Создаем контекст воспроизведения OpenGL и храним в переменной типа HGLRC. При обработке события OnPaint устанавливаем контекст воспроизведения, вызываем функции OpenGL и освобождаем контекст. При завершении работы приложения удаляем контекст воспроизведения. Для полной академичности можно включить строки, проверяющие, получен ли контекст воспроизведения, и не теряется ли он по ходу работы. Признаком таких ситуаций является нулевое значение переменной hrc. В минимальной программе я просто окрашиваю окно в желтоватый оттенок. Получив помощь по команде glClearColor, Вы можете узнать, что аргументы ее - тройка вещественных чисел в интервале [0;1], задающих долю красного, зеленого и синего составляющих в цвете и еще один, четвертый аргумент, о котором мы поговорим чуть позднее. Этому аргументу я в примере задал значение 1.0. Вообще то, аргументы glClearColor, согласно помощи, имеют неведомый тип GLclampf. Для того, чтобы разобраться с этим типом, отсылаю к строке
GLclampf = Single;
модуля opengl.pas.
Подробный разговор о типах OpenGL тоже придется пока отложить, чтобы не загрузить чрезмерным обилием информации.
Строку нашей программы
glClear(GL_COLOR_BUFFER_BIT);
будем понимать как очистку экрана, фон при этом покрывается заданным цветом.
Проект, построенный только на функциях API, надеюсь, сейчас стал более понятным. Вместо Canvas.Handle используем собственную переменную dc, в обработчике события WM_PAINT реализуем действия, которые Delphi при обычном подходе выполняет за нас. Напоминаю, что для лучшей устойчивости работы обработчик WM_PAINT следовало бы написать так:
dc := BeginPaint (Window, MyPaint);
wglMakeCurrent (dc, hrc);
glClearColor (0.85, 0.75, 0.5, 1.0);
glClear (GL_COLOR_BUFFER_BIT);
wglMakeCurrent (dc, 0);
EndPaint (Window, MyPaint);
ReleaseDC (Window, dc);
А в обработчике WM_DESTROY следует перед PostQuitMessage добавить строку:
DeleteDC (dc);
То есть все используемые ссылки необходимо освобождать, а после того, как они стали не нужны - удалять.
Я советую Вам сейчас поэкспериментировать с этой программой, заполните поля формата пикселя найденными значениями, соответствующими Вашей системе, попробуйте удалить строки, соответствующие получению контекста воспроизведения, поменяйте оттенок используемого фона и только после того, как каждая строка кода будет полностью ясна, переходите к дальнейшему материалу.
Во всех своих примерах я приписал рекомендацию не запускать проекты, использующие OpenGL под управлением среды Delphi. Дело в том, что часто в таких ситуациях программа аварийно прерывается, выдавая сообщение "access violation -". Это происходит и в случае самой аккуратной работы с контекстами, и не связано с небрежностью работы программы. Некоторые программисты вину за это возлагают на софтверные драйверы и рекомендуют обновить их. Некоторые утверждают, что дело в Windows 9X, и под NT этого не происходит. Возможно, Вы тоже ничего такого не замечали и не можете взять в толк, о чем я сейчас веду речь. У меня такие окошки вылетают через раз на одном и том же проекте, хотя откомпилированный модуль работает превосходно. Я полагаю, что если драйверы не "глюкуют", когда приложение работает без среды Delphi, дело не только в драйверах.
Вывод на поверхность компонентов
Теоретически функциями OpenGL возможно осуществлять вывод не только на поверхность формы, а и на поверхность любого компонента, если у него имеется свойство Canvas.Handle, для чего при получении контекста воспроизведения необходимо указывать именно его ссылку на контекст устройства, например, Image1.Canvas.Handle. Однако чаще всего это приводит к неустойчивой работе, вывод "то есть, то нет", хотя контекст воспроизведения присутствует и не теряется. Я советую Вам всегда пользоваться выводом исключительно на поверхность окна. OpenGL прекрасно уживается с визуальными компонентами, как видно из примера TestPFD, если же необходимо ограничить размер области вывода, для этого есть стандартные методы, о которых мы обязательно будем беседовать в будущем.
Просто ради интереса приведу пример, когда вывод OpenGL осуществляется на поверхность панели, то есть компонента, не имеющего свойства Canvas. Для этого мы пользуемся тем, что панель имеет отдельное окно, вызываем функцию GetDC с аргументом Panel1.Handle.
Точно также Вы можете выводить на поверхность любого компонента, имеющего свойство Handle, например, на поверхность обычной кнопки. Обязательно попробуйте сделать это.
Для вывода на компонент класса TImage можете записать:
dc := Image1.Canvas.Handle;
и удалить строки BeginPaint и EndPaint, поскольку TImage не имеет свойства Handle, то есть не создает отдельного окна. Однако вывод на такие компоненты как раз отличается полной неустойчивостью, так что я не гарантирую Вам надежного положительного результата.
Вообще, вместо использования Canvas.Handle лучше использовать самостоятельно полученную аналогичную величину, вместо обработки событий лучше использовать свои ловушки сообщений. Такой подход приводит к максимальной скорости и надежности работы приложения.
В конце сегодняшнего разговора я хочу привести еще несколько проектов, появившихся за это время из под моего пера и дополняющих "ЖиЛистую Delphi".
Взято с
Работа с OpenGL - Введение
Работа с OpenGL - Введение
Введение
По мере знакомства с использованием OpenGL в Delphi у меня появился ряд проектов, иллюстрирующих различные аспекты этого вопроса. Проекты начинаются с самых минимальных программ, в которых просто окрашивается окно или выводится прямоугольник с использованием функций OpenGL и заканчиваются масштабными проектами из тысяч строк кода. Эти работы позволяют проследить мой путь и могут служить подмогой для тех, кто только начинает разбираться в этих вопросах.
Когда я начинал изучение этого, у меня не было ни одного примера использования OpenGL в Delphi, только ворох программ на C и C++, поэтому пришлось начинать с того, чтобы перекладывать эти программы на Delphi. Затем появились и полностью собственные проекты. Моя основная работа связана с преподаванием в вузе, после того, как я включил в учебные курсы изучение основ OpenGL, студенты с моей помощью смогли создать ряд интересных проектов.
Я решил опубликовать некоторые из проектов моей коллекции, озаглавил набор "ЖиЛистая Delphi" и предложил сайту "Королевство Delphi". На сайте мне предложили дополнить эти проекты серией статей по вопросам использования OpenGL в Delphi. Данная статья является первой статьей этого цикла.
Статьи я предполагаю писать на уровне, доступном для самой широкой аудитории - от новичков в программировании для Windows до умудренных профессионалов. Я постараюсь придерживаться краткости в своих рассуждениях, освещая только суть рассматриваемых вопросов. Многие вопросы, освещаемые здесь, ясно проиллюстрированы в проектах "ЖиЛистой Delphi".
OpenGL - стандартный для большинства платформ и операционных систем набор низкоуровневых функций двумерной и трехмерной графики, библиотека, широко используемая в промышленных CAD-системах и играх.
Поставляется в составе операционной системы Windows, начиная с версии OSR2 в виде двух DLL-файлов - opengl32.dll и glu32.dll. Первая из этих библиотек и есть собственно набор функций OpenGL, вторая содержит дополнительный набор функций, упрощающих кодирование, но построенных и выполняемых с подключением opengl32.dll и являющаяся надстройкой.
То, что эти библиотеки поставляются в составе операционной системы, значительно упрощает распространение разработанных приложений. То, что OpenGL распространяется в виде динамических библиотек, упрощает доступ к его функциям.
При выборе базы для построения приложений графики несомненными достоинствами OpenGL являются его простота и стандартность - код в случае необходимости можно легко перенести на другую платформу или под другую операционную систему.
Для более подробной информации о OpenGL Вы можете обратиться на сайт http://www.opengl.org
Вместе с Delphi, начиная с третьей версии, поставляется файл помощи по OpenGL фирмы MicroSoft и заголовочный файл opengl.pas, позволяющий использовать эту графическую библиотеку в приложениях, написанных на Delphi.
Есть также альтернативные версии заголовочных файлов независимых разработчиков и компоненты, использующие OpenGL, упрощающие доступ к его функциям и использующие ООП подход. Некоторые из этих файлов и компонентов могут использовать версию OpenGL для Windows фирмы SGI, имеющую собственное расширение функций и имеющую более высокие скоростные показатели. Одна из самых полных систем, реализующая набор функций всех версий OpenGL - это библиотека разработчика MGL фирмы SciTechSoft.
Мы в своих примерах будем опираться только на стандартные файлы и компоненты Delphi, так что Вам не придется искать и приобретать дополнительные файлы и компоненты. Умея самостоятельно использовать OpenGL, Вы легко сможете использовать готовые компоненты, скрывающие черновую работу подключения и использования функций OpenGL. Тем более, что многие из этих компонентов отличаются неустойчивой работой.
Итак, Delphi в стандартной поставке позволяет использовать OpenGL в разрабатываемых приложениях, но как это сделать, плохо понятно из файла помощи, а готовыми примерами использования OpenGL Delphi не сопровождается (по крайней мере, на сегодня). Поэтому начинающим часто тяжело самостоятельно разобраться, как же работать с OpenGL в Delphi. Рассмотрению вопросов использования OpenGL вообще и использованию в Delphi и будет посвящен данный курс статей.
К сожалению, эта тема осложнена тем обстоятельством, что для построения самой минимальной программы OpenGL требуется выполнить ряд обязательных действий, код реализации которых может напугать начинающих своей обширностью.
Для понимания смысла этих действий желательно понимать смысл основных понятий операционной системы Windows - ссылка, контекст, сообщение, в проектах Delphi не всегда активно используемых программистами. Желательно иметь хотя бы минимальные знания о роли динамических библиотек в этой операционной системе. Хотя, конечно, можно успешно использовать OpenGL и без глубоких знаний в этой области, используя готовые шаблоны приложений и сосредоточившись собственно на функциях OpenGL.
Важно также отметить то, что чаще всего приложения, активно использующие графику, нуждаются от Delphi только в создании окна приложения, таймере и обработчике манипуляций с клавиатурой и мышью. Для таких приложений чаще всего и не требуется богатство библиотеки VCL. и крайне важны скорость работы и "профессиональная" миниатюрность откомпилированного модуля. Поскольку мы вынуждены с самого начала рассматривать и разбирать темы уровнем ниже RAD-технологий, то нам становится по силам и написание программ без визуальных средств вообще, программ, использующих только функции Windows API, стремительно компилируемых и занимающих после компиляции миниатюрные размеры (порядка двух десятков килобайт).
Итак, наш разговор приходится начинать с вопросов, напрямую вроде бы не связанных с OpenGL.
Постараемся ограничить рассмотрение этих тем самым минимальным объемом, поскольку Вы легко можете найти другие, более богатые источники по этим вопросам.
Событие. Сообщение. Контекст.
Начнем наш разговор с понятий "событие" и "сообщение".
Очень часто это синонимы одного и того же термина операционной системы, общающейся с приложениями посредством посылки сообщений. Код, написанный в проекте Delphi как обработчик события OnCreate, выполняется при получении приложением сообщения WM_CREATE, сообщению WM_PAINT соответствует событие OnPaint, и т.д..Такие события использует мнемонику, сходную с мнемоникой сообщений.
Как операционная система различает окна для осуществления диалога с ними? Все окна при своем создании регистрируются в операционной системе и получают уникальный идентификатор, называемый "ссылка на окно". Тип этой величины в Delphi - HWND (WiNDow Handle, ссылка на окно).
Ссылка на окно может использоваться не только операционной системой, но и приложениями для идентификации окна, с которым необходимо производить манипуляции.
Попробуем проиллюстрировать смысл ссылки на окно на несложном примере.
Откомпилируйте минимальное приложение Delphi и начните новый проект. Форму назовите Form2, разместите на форме кнопку, обработчик события OnClick кнопки приведите к следующему виду:
procedureTForm2.Button1Click(Sender: TObject);
var
H: HWND;
begin
H := FindWindow ('TForm1', 'Form1');
if H <> 0 then
ShowMessage ('Есть Form1!')
else
ShowMessage ('Нет Form1!')
end;
Теперь при щелчке на кнопке выдается сообщение, есть ли запущенное приложение, класс окна которого зарегистрирован в операционной системе как 'TForm1', в заголовке которого записано 'Form1'. То есть если одновременно запустить обе наши программы, при нажатии на кнопку выдается одно сообщение, если окно с заголовком 'Form1' закрыть, при щелчке на кнопку выдается другое сообщение.
Здесь мы используем функцию API FindWindow, возвращающую величину типа HWND - ссылку на найденное окно либо ноль, если такое окно не найдено.
Итак, ссылка на окно однозначно определяет окно. Свойство Handle формы и есть эта ссылка, значение которой форма получает при выполнении функции API CreateWindow - создании окна. Имея ссылку на окно, операционная система общается с окном путем посылки сообщений-сигналов о том, что произошло какое-либо событие, имеющее отношение именно к этому окну. Если окно имеет намерение отреагировать на это событие, операционная система имеет это в виду и вместе с окном осуществляет эту реакцию. Окно может и не имея фокус получать сообщения и реагировать на них.
Проиллюстрируем это на примере.
Обработчик события OnMouseMove формы приведите к виду:
procedure TForm2.FormMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
Caption := 'x=' + IntToStr (X) + ', y=' + IntToStr (Y);
end;
В заголовок формы выводятся координаты указателя мыши.
Запустите два экземпляра программы и обратите внимание, что окно, не имеющее фокус ("неактивное"), тоже реагирует на перемещение указателя по его поверхности.
Имея ссылку на окно, приложение может производить с ним любые действия, путем посылки ему сообщений.
Изменим код обработки щелчка кнопки:
procedure TForm2.Button1Click(Sender: TObject);
var
H: HWND;
begin
H := FindWindow ('TForm1', 'Form1');
if H <> 0 then
SendMessage(H, WM_CLOSE, 0, 0);
end;
Если имеется окно класса 'TForm1' с заголовком 'Form1', наше приложение посылает ему сообщение WM_CLOSE - пытается закрыть окно.
Точно также, если необходимо нарисовать что-либо на поверхности чужого окна, необходимо получить ссылку на это окно.
Для начала попробуем рисовать на поверхности родного окна.
Разместите еще одну кнопку, обработку щелчка которой приведите к виду:
procedure TForm2.Button2Click(Sender: TObject);
var
dc: HDC;
begin
dc := GetDC (Handle);
Rectangle (dc, 10, 10, 110, 110);
ReleaseDC (Handle, dc);
end;
Запустите приложение. При щелчке на добавленной кнопке на поверхности окна рисуется квадрат. Для рисования используем низкоуровневые функции Windows.
Попробуем рисовать на поверхности чужого окна, для чего изменим только что написанный код:
procedure TForm2.Button2Click(Sender: TObject);
var
dc: HDC;
Window: HWND;
begin
Window := FindWindow ('TForm1', 'Form1');
if Window <> 0 then
begin
dc := GetDC (Window);
Rectangle (dc, 10, 10, 110, 110);
ReleaseDC (Handle, dc);
end
end;
Теперь во время работы приложения, если в системе зарегистрировано окно класса 'TForm1' с заголовком 'Form1', вывод будет осуществляться на него. Запустите параллельно откомпилированные модули минимального и только что созданного приложений. При щелчке на кнопке прямоугольник рисуется на поверхности чужого окна.
Замечу, что если закрыть Project1.exe и загрузить в Delphi соответствующий ему проект, при щелчке на кнопке прямоугольник будет рисоваться на поверхности окна формы, что будет выглядеть необычно.
Функции Windows для воспроизведения нуждаются в специальной величине типа HDC (Handle Device Context, ссылка на контекст воспроизведения), для задания значения которой необходимо иметь величину типа HWND - ссылка на окно, уникальный идентификатор всех зарегистрированных в системе окон. В зависимости от версии Delphi ссылки имеют тип либо Integer, либо LongWord.
Графическая система OpenGL, как и любое другое приложение Windows, также нуждается в ссылке на окно, на котором будет осуществляться воспроизведение - специальной ссылке на контекст воспроизведения - величина типа HGLRC (Handle openGL Rendering Context, ссылка на контекст воспроизведения OpenGL). Для получения этого контекста OpenGL нуждается в величине типа HDC (контекст воспроизведения) окна, на который будет осуществляться вывод.
Поэтому наши примеры имеют следующие строки в разделе private описания формы:
DC: HDC;
hrc: HGLRC;
А обработчик события OnCreate формы начинается со следующих строк:
DC := GetDC(Handle);
SetDCPixelFormat;
hrc := wglCreateContext(DC);
wglMakeCurrent(DC, hrc);
То есть мы получаем контекст воспроизведения Windows, задаем желаемый формат пикселей, создаем контекст воспроизведения OpenGL и делаем его текущим, чтобы вызываемые функции OpenGL могли работать с этим окном.
По поводу формата пикселей мы поговорим подробнее чуть позже, а сейчас я хотел бы обратить внимание на два момента.
Во-первых, величину типа HDC мы получаем при создании окна, в обработчике события OnCreate, или, другими словами, в обработчике сообщения WM_CREATE. Это является обычным и традиционном для Windows-программ.
Некоторые программисты сделали мне замечание, что получение контекста воспроизведения при создании окна является несколько некорректным для Windows 9X и более правильным было бы получение контекста в обработчике событий OnShow или OnPaint. Возможно, это так и есть, и в некоторых ситуациях может сказаться на корректности работы приложения. Вы должны учитывать это при написании ответственных приложений.
Во-вторых, контекст воспроизведения Windows и контекст воспроизведения OpenGL обычно освобождаются приложением. То есть, команды вывода OpenGL обычно обрамляются следующими строками:
dc := BeginPaint(Window, ps);
wglMakeCurrent(DC, hrc);
wglMakeCurrent(0, 0);
EndPaint (Window,ps);
ReleaseDC (Window, dc);
Повторяю, это обычные последовательности действий для Windows-программ, контекст воспроизведения должен быть доступен системе и другим приложениям. Я же во многих примерах пренебрегаю этим правилом для сокращения кода. Вы можете убедиться, что программы работают в общем случае корректно, хотя мы отдаем себе отчет, что в некоторых ситуациях такой подход может привести к "глюковатости" работы приложения. Это также надо учесть при написании ответственных приложений.
В наших примерах контекст воспроизведения OpenGL мы занимаем сразу же при его получении, в обработчике события OnCreate, а освобождаем в конце работы приложения, в обработчике события OnDestroy.
Еще одно замечание - команды и функции OpenGL имеют префикс gl для размещенных в библиотеке opengl32.dll и glu для размещенных в библиотеке glu32.dll. Прототипы этих функций находятся в модуле opengl.pas. Функции OpenGL, имеющие отношение только к реализации OpenGL под Windows, имеют префикс wgl, как, например, wglCreateContext, а некоторые вообще не имеют префикса, например, SwapBuffers. Их прототипы описаны в модуле windows.pas.
Если понятия "сообщение" и "контекст" Вами поняты, сейчас Вы можете разобрать проекты WinMin.dpr и Paint.dpr в каталоге Beginer/0. В списке uses данных проектов перечислены всего два модуля - Windows и Messages (SysUtils в проекте Paint не используется). Это означает, что данные проекты не используют библиотеку VCL Delphi. После компиляции этих проектов Вы получите 16-ти килобайтные приложения. Приложения эти иллюстративные, умеют делать немногое, но для нас важен код проектов, возвращающий во времена старого доброго Borland Pascal-я, громоздкий, плохочитаемый, но эффективный для наших задач. Эти проекты помогают понять новичкам, какую каторожную работу выполняет за нас Delphi, и как в действительности работают Windows-приложения. Проекты я постарался хорошо откомментировать, чтобы Вам было легче разобраться.
Если Вы разберетесь, как рисовать функциями GDI на поверхности своего окна, Вы яснее сможете понять, как машина OpenGL рисует на поверхности чужого окна.
Взято с
Работа с Oracle
Работа с Oracle
Cодержание раздела:
См. также статьи в других разделах:
Работа с Outlook
Работа с Outlook
Cодержание раздела:
См. также статьи в других разделах:
Работа с Paradox
Работа с Paradox
Cодержание раздела:
См. также статьи в других разделах:
Работа с печатью в TWebBrowser
Работа с печатью в TWebBrowser
{
TWebBrowser can use native IE API to print and do other things.
Implement on a Form a TWebBrowser component, and a button to print.
The code attached to this button is as follow :
}
//--------------------------------------------
procedure TForm.OnClickPrint(Sender: TObject);
begin
WebBrowser.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER);
end;
//--------------------------------------------
You can replace "OLECMDID_PRINT" by other possibilities :
OLECMDID_OPEN OLECMDID_NEW OLECMDID_SAVE
OLECMDID_SAVEAS OLECMDID_SAVECOPYAS OLECMDID_PRINT
OLECMDID_PRINTPREVIEW OLECMDID_PAGESETUP OLECMDID_SPELL
OLECMDID_PROPERTIES OLECMDID_CUT OLECMDID_COPY
OLECMDID_PASTE OLECMDID_PASTESPECIAL OLECMDID_UNDO
OLECMDID_REDO OLECMDID_SELECTALL OLECMDID_CLEARSELECTION
OLECMDID_ZOOM OLECMDID_GETZOOMRANGE OLECMDID_UPDATECOMMANDS
OLECMDID_REFRESH OLECMDID_STOP OLECMDID_HIDETOOLBARS
OLECMDID_SETPROGRESSMAX OLECMDID_SETPROGRESSPOS
OLECMDID_SETPROGRESSTEXT
OLECMDID_SETTITLE OLECMDID_SETDOWNLOADSTATE OLECMDID_STOPDOWNLOAD
OLECMDID_FIND OLECMDID_ONTOOLBARACTIVATED OLECMDID_DELETE
OLECMDID_HTTPEQUIV OLECMDID_ENABLE_INTERACTION OLECMDID_HTTPEQUIV_DONE
OLECMDID_ONUNLOAD OLECMDID_PROPERTYBAG2 OLECMDID_PREREFRESH
Взято с сайта
Работа с перечисляемыми типами
Работа с перечисляемыми типами
См. статьи в других разделах:
Работа с Photoshop
Работа с Photoshop
uses
ComObj, ActiveX, PhotoShopTypeLibrary_TLB;
var
PS: IPhotoShopApplication;
Unknown: IUnknown;
begin
Result := GetActiveObject(CLASS_PhotoshopApplication, nil, Unknown);
if (Result = MK_E_UNAVAILABLE) then
PS := CoPhotoshopApplication.Create
else
begin
{ make sure no other error occurred }
OleCheck(Result);
OleCheck(Unknown.QueryInterface(IPhotoShopApplication, PS));
end;
PS.Visible := True;
end;
Взято с
Delphi Knowledge BaseРабота с Ping
Работа с Ping
Cодержание раздела:
Работа с полями
Работа с полями
Cодержание раздела:
Работа с портами микропроцессора
Работа с портами микропроцессора
Автор: Pavlo Zolotarenki
Модуль для работы с портами микропроцессора с сохранением синтаксиса.
Работает под Win9x.
НЕ работает под WinNT.
//Copyright(c)1998 Zolotarenko P.V pvz@mail.univ.kiev.ua
unit Ports;
interface
type
TPort = class
private
procedure Set_(index_: word; value: byte); register;
function Get_(index_: word): byte; register;
public
property Element[index_: word]: byte read Get_ write Set_; default;
end;
TPortW = class
private
procedure Set_(index_: word; value: Word); register;
function Get_(index_: word): word; register;
public
property Element[index_: word]: word read Get_ write Set_; default;
end;
var
Port: TPort;
PortW: TportW;
implementation
procedure TPort.Set_(index_: word; value: byte);
begin
asm
mov dx,index_
mov al,value
out dx,al
end;
end;
function TPort.Get_(index_: word): byte;
begin
asm
mov dx,index_
in al,dx
mov @Result,al
end;
end;
procedure TPortW.Set_(index_: word; value: word);
begin
asm
mov dx,index_
mov ax,value
out dx,ax
end;
end;
function TPortW.Get_(index_: word): word;
begin
asm
mov dx,index_
in ax,dx
mov @Result,ax
end;
end;
initialization
Port := TPort.Create;
PortW := TPortW.Create;
finalization
Port.free;
PortW.free;
end.
Взято с
Работа с последовательными портами
Работа с последовательными портами
//{$DEFINECOMM_UNIT}
//Простой пример работы с последовательными портами
//Код содержит интуитивно понятные комментарии и строки на шведском языке,
//нецелесообразные для перевода.
//Compiler maakt Simple_Comm.Dll of Simple_Com.Dcu afhankelijk van 1e Regel
(COMM_UNIT)
{$IFNDEF COMM_UNIT}
library Simple_Comm;
{$ELSE}
unit Simple_Comm;
interface
{$ENDIF}
uses Windows, Messages;
const
M_BaudRate = 1;
const
M_ByteSize = 2;
const
M_Parity = 4;
const
M_Stopbits = 8;
{$IFNDEF COMM_UNIT}
{$R Script2.Res} //versie informatie
{$ENDIF}
{$IFDEF COMM_UNIT}
function Simple_Comm_Info: PChar; StdCall;
function
Simple_Comm_Open(Port: PChar; BaudRate: DWORD; ByteSize, Parity, StopBits:
Byte; Mas
k: Integer; WndHandle: HWND; WndCommand: UINT; var Id: Integer): Integer;
StdCall;
function Simple_Comm_Close(Id: Integer): Integer; StdCall;
function
Simple_Comm_Write(Id: Integer; Buffer: PChar; Count: DWORD): Integer; StdCall;
function Simple_Comm_PortCount: DWORD; StdCall;
const
M_None = 0;
const
M_All = 15;
implementation
{$ENDIF}
const
InfoString = 'Simple_Comm.Dll (c) by E.L. Lagerburg 1997';
const
MaxPorts = 5;
const
bDoRun: array[0..MaxPorts - 1] of boolean
= (False, False, False, False, False);
const
hCommPort: array[0..MaxPorts - 1] of Integer = (0, 0, 0, 0, 0);
const
hThread: array[0..MaxPorts - 1] of Integer = (0, 0, 0, 0, 0);
const
dwThread: array[0..MaxPorts - 1] of Integer = (0, 0, 0, 0, 0);
const
hWndHandle: array[0..MaxPorts - 1] of Hwnd = (0, 0, 0, 0, 0);
const
hWndCommand: array[0..MaxPorts - 1] of UINT = (0, 0, 0, 0, 0);
const
PortCount: Integer = 0;
function Simple_Comm_Info: PChar; stdcall;
begin
Result := InfoString;
end;
//Thread functie voor lezen compoort
function Simple_Comm_Read(Param: Pointer): Longint; stdcall;
var
Count: Integer;
id: Integer;
ReadBuffer: array[0..127] of byte;
begin
Id := Integer(Param);
while bDoRun[id] do
begin
ReadFile(hCommPort[id], ReadBuffer, 1, Count, nil);
if (Count > 0) then
begin
if ((hWndHandle[id] <> 0) and
(hWndCommand[id] > WM_USER)) then
SendMessage(hWndHandle[id], hWndCommand[id], Count,
LPARAM(@ReadBuffer));
end;
end;
Result := 0;
end;
//Export functie voor sluiten compoort
function Simple_Comm_Close(Id: Integer): Integer; stdcall;
begin
if (ID < 0) or (id > MaxPorts - 1) or (not bDoRun[Id]) then
begin
Result := ERROR_INVALID_FUNCTION;
Exit;
end;
bDoRun[Id] := False;
Dec(PortCount);
FlushFileBuffers(hCommPort[Id]);
if not
PurgeComm(hCommPort[Id], PURGE_TXABORT + PURGE_RXABORT + PURGE_TXCLEAR +
PURGE_RXCL
EAR) then
begin
Result := GetLastError;
Exit;
end;
if WaitForSingleObject(hThread[Id], 10000) = WAIT_TIMEOUT then
if not TerminateThread(hThread[Id], 1) then
begin
Result := GetLastError;
Exit;
end;
CloseHandle(hThread[Id]);
hWndHandle[Id] := 0;
hWndCommand[Id] := 0;
if not CloseHandle(hCommPort[Id]) then
begin
Result := GetLastError;
Exit;
end;
hCommPort[Id] := 0;
Result := NO_ERROR;
end;
procedure Simple_Comm_CloseAll; stdcall;
var
Teller: Integer;
begin
for Teller := 0 to MaxPorts - 1 do
begin
if bDoRun[Teller] then
Simple_Comm_Close(Teller);
end;
end;
function GetFirstFreeId: Integer; stdcall;
var
Teller: Integer;
begin
for Teller := 0 to MaxPorts - 1 do
begin
if not bDoRun[Teller] then
begin
Result := Teller;
Exit;
end;
end;
Result := -1;
end;
//Export functie voor openen compoort
function
Simple_Comm_Open(Port: PChar; BaudRate: DWORD; ByteSize, Parity, StopBits:
Byte; Mas
k: Integer; WndHandle: HWND; WndCommand: UINT; var Id: Integer): Integer;
stdcall;
var
PrevId: Integer;
ctmoCommPort: TCOMMTIMEOUTS; //Lees specificaties voor de compoort
dcbCommPort: TDCB;
begin
if (PortCount >= MaxPorts) or (PortCount < 0) then
begin
result := error_invalid_function;
exit;
end;
result := 0;
previd := id;
id := getfirstfreeid;
if id = -1 then
begin
id := previd;
result := error_invalid_function;
exit;
end;
hcommport[id] := createfile(port, generic_read or
generic_write, 0, nil, open_existing, file_attribute_normal, 0);
if hcommport[id] = invalid_handle_value then
begin
bdorun[id] := false;
id := previd;
result := getlasterror;
exit;
end;
//lees specificaties voor het comm bestand
ctmocommport.readintervaltimeout := maxdword;
ctmocommport.readtotaltimeoutmultiplier := maxdword;
ctmocommport.readtotaltimeoutconstant := maxdword;
ctmocommport.writetotaltimeoutmultiplier := 0;
ctmocommport.writetotaltimeoutconstant := 0;
//instellen specificaties voor het comm bestand
if not setcommtimeouts(hcommport[id], ctmocommport) then
begin
bdorun[id] := false;
closehandle(hcommport[id]);
id := previd;
result := getlasterror;
exit;
end;
//instellen communicatie
dcbcommport.dcblength := sizeof(tdcb);
if not getcommstate(hcommport[id], dcbcommport) then
begin
bdorun[id] := false;
closehandle(hcommport[id]);
id := previd;
result := getlasterror;
exit;
end;
if (mask and m_baudrate <> 0) then
dcbCommPort.BaudRate := BaudRate;
if (Mask and M_ByteSize <> 0) then
dcbCommPort.ByteSize := ByteSize;
if (Mask and M_Parity <> 0) then
dcbCommPort.Parity := Parity;
if (Mask and M_Stopbits <> 0) then
dcbCommPort.StopBits := StopBits;
if not SetCommState(hCommPort[Id], dcbCommPort) then
begin
bDoRun[Id] := FALSE;
CloseHandle(hCommPort[Id]);
Id := PrevId;
Result := GetLastError;
Exit;
end;
//Thread voor lezen compoort
bDoRun[Id] := TRUE;
hThread[Id] := CreateThread(nil, 0, @Simple_Comm_Read, Pointer(Id), 0,
dwThread[Id]
);
if hThread[Id] = 0 then
begin
bDoRun[Id] := FALSE;
CloseHandle(hCommPort[Id]);
Id := PrevId;
Result := GetLastError;
Exit;
end
else
begin
SetThreadPriority(hThread[Id], THREAD_PRIORITY_HIGHEST);
hWndHandle[Id] := WndHandle;
hWndCommand[Id] := WndCommand;
Inc(PortCount);
Result := NO_ERROR;
end;
end;
//Export functie voor schrijven naar compoort;
function
Simple_Comm_Write(Id: Integer; Buffer: PChar; Count: DWORD): Integer; stdcall;
var
Written: DWORD;
begin
if (Id < 0) or (id > Maxports - 1) or (not bDoRun[Id]) then
begin
Result := ERROR_INVALID_FUNCTION;
Exit;
end;
if not WriteFile(hCommPort[Id], Buffer, Count, Written, nil) then
begin
Result := GetLastError();
Exit;
end;
if (Count <> Written) then
Result := ERROR_WRITE_FAULT
else
Result := NO_ERROR;
end;
//Aantal geopende poorten voor aanroepende applicatie
function Simple_Comm_PortCount: DWORD; stdcall;
begin
Result := PortCount;
end;
{$IFNDEF COMM_UNIT}
exports
Simple_Comm_Info Index 1,
Simple_Comm_Open Index 2,
Simple_Comm_Close Index 3,
Simple_Comm_Write Index 4,
Simple_Comm_PortCount index 5;
procedure DLLMain(dwReason: DWORD);
begin
if dwReason = DLL_PROCESS_DETACH then
Simple_Comm_CloseAll;
end;
begin
DLLProc := @DLLMain;
DLLMain(DLL_PROCESS_ATTACH); //geen nut in dit geval
end.
{$ELSE}
initialization
finalization
Simple_Comm_CloseAll;
end.
{$ENDIF}
Другое решение: создание модуля I / O(ввода / вывода)под Windows 95 / NT.Вот он:
)
(с TDCB в SetCommStatus вы можете управлять DTR и т.д.)
(Примечание: XonLim и XoffLim не должны быть больше 600, иначе под NT это
работает неправильно)
unit My_IO;
interface
function OpenComm(InQueue, OutQueue, Baud: LongInt): Boolean;
function SetCommTiming: Boolean;
function SetCommBuffer(InQueue, OutQueue: LongInt): Boolean;
function SetCommStatus(Baud: Integer): Boolean;
function SendCommStr(S: string): Integer;
function ReadCommStr(var S: string): Integer;
procedure CloseComm;
var
ComPort: Word;
implementation
uses Windows, SysUtils;
const
CPort: array[1..4] of string = ('COM1', 'COM2', 'COM3', 'COM4');
var
Com: THandle = 0;
function OpenComm(InQueue, OutQueue, Baud: LongInt): Boolean;
begin
if Com > 0 then
CloseComm;
Com := CreateFile(PChar(CPort[ComPort]),
GENERIC_READ or GENERIC_WRITE,
0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
Result := (Com > 0) and SetCommTiming and
SetCommBuffer(InQueue, OutQueue) and
SetCommStatus(Baud);
end;
function SetCommTiming: Boolean;
var
Timeouts: TCommTimeOuts;
begin
with TimeOuts do
begin
ReadIntervalTimeout := 1;
ReadTotalTimeoutMultiplier := 0;
ReadTotalTimeoutConstant := 1;
WriteTotalTimeoutMultiplier := 2;
WriteTotalTimeoutConstant := 2;
end;
Result := SetCommTimeouts(Com, Timeouts);
end;
function SetCommBuffer(InQueue, OutQueue: LongInt): Boolean;
begin
Result := SetupComm(Com, InQueue, OutQueue);
end;
function SetCommStatus(Baud: Integer): Boolean;
var
DCB: TDCB;
begin
with DCB do
begin
DCBlength := SizeOf(Tdcb);
BaudRate := Baud;
Flags := 12305;
wReserved := 0;
XonLim := 600;
XoffLim := 150;
ByteSize := 8;
Parity := 0;
StopBits := 0;
XonChar := #17;
XoffChar := #19;
ErrorChar := #0;
EofChar := #0;
EvtChar := #0;
wReserved1 := 65;
end;
Result := SetCommState(Com, DCB);
end;
function SendCommStr(S: string): Integer;
var
TempArray: array[1..255] of Byte;
Count, TX_Count: Integer;
begin
for Count := 1 to Length(S) do
TempArray[Count] := Ord(S[Count]);
WriteFile(Com, TempArray, Length(S), TX_Count, nil);
Result := TX_Count;
end;
function ReadCommStr(var S: string): Integer;
var
TempArray: array[1..255] of Byte;
Count, RX_Count: Integer;
begin
S := '';
ReadFile(Com, TempArray, 255, RX_Count, nil);
for Count := 1 to RX_Count do
S := S + Chr(TempArray[Count]);
Result := RX_Count;
end;
procedure CloseComm;
begin
CloseHandle(Com);
Com := -1;
end;
end.
Взято с
Работа с приложениями MS Office
Работа с приложениями MS Office
Cодержание раздела:
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
См. также другие разделы:
Работа с принтером.
Работа с принтером.
Delphi имеет стандартный объект для доступа к принтеру - TPRINTER,
находящийся в модуле PRINTERS. В этом модуле имеется
переменная Printer:Tpinter, что избавляет от необходимости описывать свою.
Он позволяет выводить данные на печать и управлять процессом печати.
Правда, в некоторых версиях Delphi 1 он имеет "глюк" - не работают
функции Draw и StrethDraw. Но эта проблема поправима - можно
использовать функции API. Далее приведены основные поля и методы объекта Printers :
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,'Это тест принтера !!!'); { Печатаем текст }
EndDoc; { Конец печати }
end;
end;
Особенности работы с TPrinter
1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и
его необходимо задавать заново
2. Все координаты даны в пикселах, а для нормальной работы необходимы
миллиметры (по двум очевидным причинам: очень трудно произвести
разметку страницы в пикселах (особенно если необходима точность), и , главное,
при изменении разрешающей способности принтера будет изменяться число точек
на дюйм, и все координаты "поедут".
3. У TPrinter информация о принтере, по видимому, определяются один раз
- в момент запуска программы (или смены принтера). Поэтому изменение настроек
принтера в процессе работы программы может привести к некорректной работе,
например, неправильной печать шрифтов True Type.
Определение параметров принтера через API
Для определения информации о принтере (плоттере, экране) необходимо
знать Handle этого принтера, а его можно узнать объекта TPrinter - Printer.Handle.
Далее вызывается функция API (unit WinProcs) : GetDevice(Handle:HDC; Index:integer):integer;
Index - код параметра, который необходимо вернуть.
Для Index существует ряд констант :
DriverVersion - вернуть версию драйвера
Texnology - Технология вывода, их много, основные
dt_Plotter - плоттер
dt_RasPrinter - растровый принтер
dt_Display - дисплей
HorzSize - Горизонтальный размер листа (в мм)
VertSize - Вертикальный размер листа (в мм)
HorzRes - Горизонтальный размер листа (в пикселах)
VertRes - Вертикальный размер листа (в пикселах)
LogPixelX - Разрешение по оси Х в dpi (пиксел /дюйм)
LogPixelY - Разрешение по оси Y в dpi (пиксел /дюйм)
Кроме перечисленных еще около сотни, они позволяют узнать о принтере практически все.
Параметры, возвращаемые по LogPixelX и LogPixelY очень важны - они
позволяют произвести пересчет координат из миллиметров в пиксели
для текущего разрешения принтера. Пример таких функций:
Procedure TForm1.GetPrinterInfo; { Получить информацию о принтере }
begin
PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX);
PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY);
end;
Function TForm1.PrinterCoordX(x:integer):integer; { переводит координаты из мм в пиксели }
begin
PrinterCoordX:=round(PixelsX/25.4*x);
end;
Function TForm1.PrinterCoordY(Y:integer):integer; { переводит координаты из мм в пиксели }
begin
PrinterCoordY:=round(PixelsY/25.4*Y);
end;
GetPrinterInfo;
Printer.Canvas.TextOut(PrinterCoordX(30), PrinterCoordY(55),
'Этот текст печатается с отступом 30 мм от левого края и '+
'55 мм от верха при любом разрешении принтера');
Данную методику можно с успехом применять для печати картинок - зная
размер картинки можно пересчитать ее размеры в пикселах для текущего
разрешения принтера, масштабировать, и затем уже распечатать.
Иначе на матричном принтере (180 dpi) картинка будет огромной,
а на качественном струйнике (720 dpi) - микроскопической.
P.S. Мой комментарий.
Я производил печать следующим образом:
procedure TForm6.SpeedButton1Click(Sender: TObject);
var
PRect: Trect;
PBitMap: TBitmap;
begin
PBitmap := TBitMap.Create;
PBitmap.LoadFromFile('C:\1.bmp');
with PRect do
begin
left := 0;
top := 0;
right := Printer.PageWidth;
Bottom := Printer.PageHeight;
end;
with printer do
begin
BeginDoc;
font.name := 'Times New Roman';
Canvas.StretchDraw(PRect, Bitmap);
EndDoc;
end;
PBitmap.Free;
end;
Удачи!
DenKop@mail.ru
Взято с сайта
Работа с различными приложениями (не MS Office)
Работа с различными приложениями (не MS Office)
Cодержание раздела:
См. также другие разделы:
Работа с ресурсами
Работа с ресурсами
Cодержание раздела:
См. также статьи в других разделах:
Работа с Sender
Работа с Sender
unitTestInputForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, DdhInpuB;
type
TForm1 = class(TForm)
Edit1: TEdit;
Label1: TLabel;
DdhInputButton1: TDdhInputButton;
DdhInputButton2: TDdhInputButton;
DdhInputButton3: TDdhInputButton;
procedure DdhInputButtonClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.DdhInputButtonClick(Sender: TObject);
begin
ShowMessage ('You have clicked the ' +
(Sender as TButton).Name + ','#13 +
'having the caption ' +
(Sender as TButton).Caption);
end;
end.
Взято с
Работа с сессиями
Работа с сессиями
Each function listed below returns information about a session or performs a task that affects the session, such as starting a session or adding a password.
DbiAddPassword:
Adds a password to the current session.
DbiCheckRefresh:
Checks for remote updates to tables for all cursors in the current session, and refreshes the cursors
if changed.
DbiCloseSession:
Closes the session associated with the given session handle.
DbiDropPassword:
Removes a password from the current session.
DbiGetCallBack:
Returns a pointer to the function previously registered by the client for the given callback type.
DbiGetCurrSession:
Returns the handle associated with the current session.
DbiGetDateFormat:
Gets the date format for the current session.
DbiGetNumberFormat:
Gets the number format for the current session.
DbiGetSesInfo:
Retrieves the environment settings for the current session.
DbiGetTimeFormat:
Gets the time format for the current session.
DbiRegisterCallBack:
Registers a callback function for the client application.
DbiSetCurrSession:
Sets the current session of the client application to the session associated with hSes.
DbiSetDateFormat:
Sets the date format for the current session.
DbiSetNumberFormat:
Sets the number format for the current session.
DbiSetPrivateDir:
Sets the private directory for the current session.
DbiSetTimeFormat:
Sets the time format for the current session.
DbiStartSession:
Starts a new session for the client application.
Взято с
Delphi Knowledge BaseРабота с сетью, интернетом, протоколами
Работа с сетью, интернетом, протоколами
Cодержание раздела:
·
(раздел)
·
(раздел)
·
(раздел)
·
(раздел)
·
(раздел)
·
(раздел)
·
(раздел)
·
(раздел)
· (раздел)
·
·
· (раздел)
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
· (раздел)
·
·
·
·
См. также другие разделы:
См. также статьи в других разделах:
Работа с сокетами
Работа с сокетами
Cодержание раздела:
Работа с сотовыми телефонами
Работа с сотовыми телефонами
Взаимодействие с мобильными телефонами
Вы, наверное, не раз видели или даже пользовались программами, которые отображают любую информацию о вашем телефоне. Сейчас вы узнаете, как самим сделать такую программу!
Для начала положим на форму Memo, CheckBox "Соединиться», кнопку «Послать команду», Edit.
А) Подключение
Итак, в «Public declarations» объявляем 2 функции и 2 процедуры, потом объявляем 4 глобальные переменные:
…
public
{ Public declarations }
function OpenCOMPort: Boolean;
function SetupCOMPort: Boolean; //для настройки порта
procedure Connect;
procedure Disconnect;
…
var
Form1: TForm1;
ComFile: THandle; //Хэндл создаваемого нами файла
ComString: string; //(COM1, COM2 или COM3)
ComSpeed: Integer; //Скорость взаимодействия с COM-портом
Status: Boolean; //подключен или не подключен (чтобы в дальнейшем проверять статус)
Жмём Ctrl+C и записываем дальше:
procedure TForm1.Connect;
begin
ComString := 'COM2';
ComSpeed := 19200;
if OpenCOMPort = true then //Открываем порт…
if SetupCOMPort = true then //…и конфигурируем его
Memo1.Lines.Add('Подключились...');
Sleep(1500); //засыпаем на полторы секунды чтобы дать время на соединение
end;
procedure TForm1.Disconnect;
begin
CloseHandle(ComFile);
Memo1.Lines.Add('Отключились.');
end;
function TForm.OpenCOMPort: Boolean;
var DeviceName: array[0..80] of Char;
Device: string;
begin
Device := ComString;
StrPCopy(DeviceName, Device);
ComFile := CreateFile(DeviceName,
GENERIC_READ or GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if ComFile = INVALID_HANDLE_VALUE then
begin
Result := False;
Status := Result;
end
else
begin
Result := True;
Status := Result;
end;
end;
function TForm1.SetupCOMPort: Boolean;
const RxBufferSize = 256;
TxBufferSize = 256;
var DCB: TDCB;
Config: string;
CommTimeouts: TCommTimeouts;
begin
Result := True;
if not SetupComm(ComFile, RxBufferSize, TxBufferSize) then
Result := False;
if not GetCommState(ComFile, DCB) then
Result := False;
Config := 'baud=' + IntToStr(ComSpeed) + ' parity=n data=8 stop=1'; //Устанавливаем скорость
if not BuildCommDCB(@Config[1], DCB) then
Result := False;
if not SetCommState(ComFile, DCB) then
Result := False;
with CommTimeouts do
begin
ReadIntervalTimeout := 0;
ReadTotalTimeoutMultiplier := 0;
ReadTotalTimeoutConstant := 1000;
WriteTotalTimeoutMultiplier := 0;
WriteTotalTimeoutConstant := 1000;
end;
if not SetCommTimeouts(ComFile, CommTimeouts) then
Result := False;
end;
Теперь два раза щёлкаем по CheckBox и записываем код:
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
if CheckBox1.Checked then
Connect
else
Disconnect;
end;
В событии формы OnDestroy записываем:
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Status = true then //При выходе из программы отключаемся
Disconnect;
end;
Б) Шлём команды и принимаем ответы
Щёлкаем два раза по кнопке «Послать команду» и записываем код:
procedure TForm1.Button1Click(Sender: TObject);
var BytesWritten: DWORD;
s: string;
d: array[1..1500] of Char;
BytesRead: DWORD;
i: Integer;
Result: string;
begin
s := Edit1.Text; //Берём команды из Edit1…
s := s + #13 + #10;
WriteFile(ComFile, s[1], Length(s), BytesWritten, nil); //…и посылаем их телефону
Result := '';
if not ReadFile(ComFile, d, SizeOf(d), BytesRead, nil) then
begin
MessageDlg('Ошибка чтения!', mtError, [mbOK], 0);
exit;
end;
s := '';
for i := 1 to BytesRead do //Считываем ответ от телефона
s := s + d[I];
Result := s;
Memo1.Lines.Add(Result); //Выводим ответ от телефона в Memo
end;
Вот и всё! Теперь подключите телефон, запускайте программу, ставьте галку в CheckBox'е, и, после того, как вам написали в Memo, что вы подключились вводите в Edit любую AT-команду и жмите «Послать команду». Удачи!
В) Некоторые полезные команды AT
Этими командами вы можете воспользоваться, для посылки телефону (из поля Edit):
AT+CGMI ? производитель
AT+CGMM ? модель телефона
AT+CPAS ? состояние
AT+COPS? ? оператор
AT+CGSN ? номер IMEI
AT+CGMR ? версия прошивки
AT+CBC ? степень зарядки телефона
AT+CREG? ? статус сети
AT^SCID ? номер SIM-карты
AT+CIMI - номер IMSI
AT^SPIC ? попыток до блокировки SIM-карты
Более подробно о командах вы сможете узнать из pdf-инструкции s35i_c35i_m35i_atc_commandset_v01.pdf (можно утащить по адресу: http://www.like.e-technik.uni-erlangen.de/...andset_v01.pdf)
Примечания: Автор: Лазуткин Алексей (alessio19@mail.ru), помощь в написании: av3nger (av3nger@hakep.com)
Работа с SQL
Работа с SQL
Cодержание раздела:
См. также статьи в других разделах:
Работа с SSH
Работа с SSH
Cодержание раздела:
