Programming: Delphi


Советы программистов (Часть 1)





  1. Часть 2
  2. Часть 3
  3. Часть 4
  1. Преобразование арабских чисел в римские
  2. Преобразование в EBCDIC
  3. Добавление лидирующих символов
  4. Получение элемента даты
  5. Использование DateTime в DBGrid
  6. Управление битами
  7. Вращение изображения
  8. Защита программ перекрытием кода
  9. Пример защиты типа SHAREWARE
  10. Перекодировка текста из DOS в Windows и наоборот
  11. Сумма прописью
  12. Правильное округление дробных чисел
  13. Паскалевский эквивалент StrTok
  14. Как получить указатели всех процессов, запущенных в системе
  15. Список запущенных приложений
  16. Как запустить другую программу
  17. Как предотвратить запуск копии приложения
  18. Контроль завершения приложения
  19. Управление завершением работы Windows
  20. Директивы компилятора, способные увеличить скорость
  21. Создание редактора свойства
  22. Вызов процедуры, имя которой содержится в переменной
  23. Передача функции как параметра
  24. Переменная в качестве имени процедуры
  25. Массивы размером более 64К




Преобразование арабских чисел в римские

 Как преобразовать арабские числа в римские?

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

function TForm1.DecToRoman(Decimal: Integer): String; const Romans: array[1..13] of String = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M'); Arabics: array[1..13] of Integer = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000); var i: Integer; begin result := ''; for i := 13 downto 1 do while (Decimal >= Arabics[i]) do begin Decimal := Decimal - Arabics[i]; result := result + Romans[i]; end; end;



Преобразование в EBCDIC

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

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

const a2e: array [0..255] of byte = (000, 001, 002, 003, 055, 045, 046, 047, 022, 005, 037, 011, 012, 013, 014, 159, 016, 017, 018, 019, 182, 181, 050, 038, 024, 025, 063, 039, 028, 029, 030, 031, 064, 090, 127, 123, 091, 108, 080, 125, 077, 093, 092, 078, 107, 096, 075, 097, 240, 241, 242, 243, 244, 245, 246, 247, 248, 249, 122, 094, 076, 126, 110, 111, 124, 193, 194, 195, 196, 197, 198, 199, 200, 201, 209, 210, 211, 212, 213, 214, 215, 216, 217, 226, 227, 228, 229, 230, 231, 232, 233, 173, 224, 189, 095, 109, 121, 129, 130, 131, 132, 133, 134, 135, 136, 137, 145, 146, 147, 148, 149, 150, 151, 152, 153, 162, 163, 164, 165, 166, 167, 168, 169, 192, 106, 208, 161, 007, 104, 220, 081, 066, 067, 068, 071, 072, 082, 083, 084, 087, 086, 088, 099, 103, 113, 156, 158, 203, 204, 205, 219, 221, 224, 236, 252, 176, 177, 178, 062, 180, 069, 085, 206, 222, 073, 105, 154, 155, 171, 015, 186, 184, 183, 170, 138, 139, 060, 061, 098, 079, 100, 101, 102, 032, 033, 034, 112, 035, 114, 115, 116, 190, 118, 119, 120, 128, 036, 021, 140, 141, 142, 065, 006, 023, 040, 041, 157, 042, 043, 044, 009, 010, 172, 074, 174, 175, 027, 048, 049, 250, 026, 051, 052, 053, 054, 089, 008, 056, 188, 057, 160, 191, 202, 058, 254, 059, 004, 207, 218, 020, 225, 143, 070, 117, 253, 235, 238, 237, 144, 239, 179, 251, 185, 234, 187, 255); procedure StringA2E(var StringToConvert: String); var Loop: integer; begin for Loop := 1 to Length(StringToConvert) do StringToConvert[Loop] := Char(a2e[Ord(StringToConvert[Loop])]); end;



Добавление лидирующих символов

 Как в начало строки вставить символ? Количество вставляемых символов может быть различным.

Если необходимо в начало строки вставить определенный символ, например, преобразовать «1010» в «0001010», воспользуйтесь следующей функцией:

function PadL(s_InStr: string; i_Wide: integer; c_Chr: char): string; begin while Length(s_InStr) < i_Wide do s_InStr := c_Chr + s_InStr; Result := s_InStr; end;



Получение элемента даты

 Как из даты выделить нужный элемент?

Используйте универсальную функцию возврата значения элемента даты (год, месяц, день, квартал):

function RetDate(inDate: TDateTime; inTip: integer): integer; var xYear, xMonth, xDay: word; begin Result := 0; DecodeDate(inDate, xYear, xMonth, xDay); case inTip of 1: Result := xYear; // год 2: Result := xMonth; // месяц 3: Result := xDay; // день 4: if xMonth < 4 then Result := 1 // квартал else if xMonth < 7 then Result := 2 else if xMonth < 10 then Result := 3 else Result := 4; end; end; [Галимарзанов Фанис]



Использование DateTime в DBGrid

 При отображении TDateTimeField в DBGrid с форматированием hh:mm (для показа только времени), любая попытка изменения времени приводит (при передаче данных) к ошибке примерно такого содержания: «'07:00' is not a valid DateTime». Как переслать данные в виде: «Trunc(oldDateTimevalue) + StrToTime(displaytext)»?

Следующий обработчик событий – TDateTimeField.OnSetText – не слишком элегантен, но он работает.

Предположим, что имеется маска редактирования, допускающая формат hh:mm или hh:mm:ss. Тогда процедура будет иметь следующий вид:

procedure TForm1.Table1Date1SetText(Sender: TField; const Text: String); var d: TDateTime; t: string; begin t := Text; with Sender as TDateTimeField do begin if IsNull then d := SysUtils.Date else d := AsDateTime; AsDateTime := StrToDateTime(Copy(DateToStr(d), 1, 10) + ' ' + t); end; end; Примечание
Функция Copy как раз и формирует постоянную дату (в формате dd/mm/yyyy), которая автоматически вводится в поле, t – вводимое время.

[News Group]



Управление битами

 Как получить доступ к битам переменной и управлять их значением?

Решение 1
unit Bitwise; interface function IsBitSet(const val: longint; const TheBit: byte): boolean; function BitOn(const val: longint; const TheBit: byte): LongInt; function BitOff(const val: longint; const TheBit: byte): LongInt; function BitToggle(const val: longint; const TheBit: byte): LongInt; implementation function IsBitSet(const val: longint; const TheBit: byte): boolean; begin result := (val and (1 shl TheBit)) <> 0; end; function BitOn(const val: longint; const TheBit: byte): LongInt; begin result := val or (1 shl TheBit); end; function BitOff(const val: longint; const TheBit: byte): LongInt; begin result := val and ((1 shl TheBit) xor $FFFFFFFF); end; function BitToggle(const val: longint; const TheBit: byte): LongInt; begin result := val xor (1 shl TheBit); end; end.
Решение 2
SetWord – слово, которое необходимо установить. BitNum – номер бита, который необходимо выставить согласно определениям в секции const (Bit0, Bit1 и др.). GetBitStat возвращает значение True, если бит установлен и False – в противном случае.

const Bit0 = 1; Bit1 = 2; Bit2 = 4; Bit3 = 8; Bit4 = 16; Bit5 = 32; Bit6 = 64; Bit7 = 128; Bit8 = 256; Bit9 = 512; Bit10 = 1024; Bit11 = 2048; Bit12 = 4096; Bit13 = 8192; Bit14 = 16384; Bit15 = 32768; procedure SetBit(SetWord, BitNum: Word); begin SetWord := SetWord Or BitNum; { Устанавливаем бит } end; procedure ClearBit(SetWord, BitNum: Word); begin SetWord := SetWord Or BitNum; { Устанавливаем бит } SetWord := SetWord Xor BitNum; { Переключаем бит } end; procedure ToggleBit(SetWord, BitNum: Word); begin SetWord := SetWord Xor BitNum; { Переключаем бит } end; function GetBitStat(SetWord, BitNum: Word): Boolean; begin GetBitStat := SetWord and BitNum = BitNum; { Если бит установлен } end;



Вращение изображения

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

procedure RotateRight(BitMap: TImage); var FirstC, LastC, c, r: integer; procedure FixPixels(c, r: integer); var SavePix, SavePix2: tColor; i, NewC, NewR: integer; begin SavePix := Bitmap.Canvas.Pixels[c, r]; for i := 1 to 4 do begin Newc := BitMap.Height - r + 1; Newr := c; SavePix2 := BitMap.Canvas.Pixels[Newc, Newr]; Bitmap.Canvas.Pixels[Newc, Newr] := SavePix; SavePix := SavePix2; c := NewC; r := NewR; end; end; begin if BitMap.Width <> BitMap.Height then exit; BitMap.Visible := False; with Bitmap.Canvas do begin FirstС := 0; LastС := BitMap.Width; for r := 0 to BitMap.Height div 2 do begin for c := FirstС to LastС do FixPixels(c, r); Inc(FirstC); Dec(LastC); end; end; BitMap.Visible := True; end; [News Group]

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



Защита программ перекрытием кода

 Не секрет, что совершенной защиты не существует. Тем не менее, хорошая защита должна обеспечить такой уровень, чтобы на ее вскрытие нужно было затратить усилия сравнимые, с самостоятельным написанием программы. Разумеется, она должна быть многоуровневой и перекрывающейся (уровни должны работать независимо). Не забывайте, что хорошие взломщики неплохо знают Ассемблер, и высокоуровневые ухищрения от них не спасают. Следовательно, для построения высококлассной защиты с использованием Ассемблера, необходимо владеть последним в совершенстве. Не думайте, что вам это не подходит, т. к. слишком сложно или уже не модно. Хороший программист не пренебрегает ассемблером и высшей математикой.

Один из методов – это перекрывающийся код. Он может показаться немного сложным для большинства из нас, но, зная несколько HEX значений инструкций процессора, вы тоже сможете создать небольшой по размеру перекрывающийся код. Перекрывающийся код можно сделать сколь угодно многоуровневым, а здесь я покажу лишь, в каком направлении надо «копать».

temp_string := 'Den is Com'; asm mov ax, $05EB @as: jmp @as-2 end; ShowMessage('Сообщение'); На первый взгляд, это может озадачить, но на самом деле все очень просто. Первая инструкция заносит значение в AX. Вторая выполняет переход на значение операнда команды MOV. Код '05EB' переводится как 'JMP $+5' (помните, что слова хранятся в обратном порядке). Этот переход минует JMP и передает выполнение дальше. Вероятно, этого не будет достаточно для защиты, но технику ее создания демонстрирует.

Присваивание temp_string := 'Den is Com' существенной роли не играет, но может применяться при отладке программы, т. к. хорошо просматривается при использовании дизассемблера и отладчика. Возможно, ваши первые попытки будут приводить к частому зависанию компьютера, но не отчаивайтесь – защита того стоит. Попробуйте разработать свой способ сравнения строк (чаше всего ловятся именно эти инструкции), замаскируйте инструкции зависания компьютера и т.д.

[Den is Com]



Пример защиты типа SHAREWARE

 В качестве примера приведен небольшой участок программного кода, позволяющий быстро создать защиту для программ SHAREWARE, которая, не влияет на функциональность самой программы, но настоятельно «просит» ее зарегистрировать и закрывает при каждом повторном запуске.

Технология данного метода заключается в том, что пользователь может запустить программу только один раз за текущий сеанс Windows.

Используйте обработчик события FormShow:

procedure TForm1.FormShow(Sender : TObject); var atom: integer; CRLF: string; begin if GlobalFindAtom('THIS_IS_SOME_OBSCUREE_TEXT') = 0 then atom := GlobalAddAtom('THIS_IS_SOME_OBSCUREE_TEXT') else begin CRLF := #10 + #13; ShowMessage('Данная версия предусматривает только один запуск' + 'в текущем сеансе Windows.' + CRLF + 'Для повторного запуска необходимо перезапустить Windows, или,' + CRLF + 'что лучше, - ' + CRLF + 'ЗАРЕГИСТРИРУЙТЕСЬ !'); Close; end; end; Преимущество данного метода в том, что пользователю доступны все возможности программы, но только до момента ее закрытия, или перезапуска системы. Вся хитрость заключается в сохранении некоторой строки в системных глобальных переменных («атомах») и последующей проверке ее в таблице «атомов» системы.



Перекодировка текста из DOS в Windows и наоборот

 Как с помощью Delphi перекодировать текстовый файл из DOS в Windows и наоборот?

Решение 1
Src – строка для перекодировки, Str – перекодированная строка

procedure TForm1.WinToDos; var Src, Str: PChar; begin GetMem(Str, Length(Memo1.Lines.Text)); // Выделяем место под строку-приемник Src := Memo1.Lines.GetText; // Берем текст из TMemo как PChar CharToOem(Src, Str); // Перекодировка текста Memo2.Lines.SetText(Str); // Передаем перекодированный текст FreeMem(Str); // Освобождаем память end; procedure TForm1.DosToWin; // С точностью до вызова функции API var // повторяем код Src, Str: PChar; begin GetMem(Str, Length(Memo1.Lines.Text)); Src := Memo1.Lines.GetText; OemToChar(Src, Str); Memo2.Lines.SetText(Str); FreeMem(Str); end;
Решение 2
Используйте CharToOEM, OEMToChar, CharToOEMBuff, OEMToCharBuff.

[Nomadic]



Сумма прописью

 Очень часто в финансовых приложениях сумму нужно писать прописью. Как сумму, представленную цифрой, преобразовать в строку прописью?

function TextSum(S: double): string; function Conv999(M: longint; fm: integer): string; const c1to9m: array [1..9] of string[6] = ('один', 'два', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь','девять'); c1to9f: array [1..9] of string[6] = ('одна', 'две', 'три', 'четыре', 'пять', 'шесть', 'семь', 'восемь', 'девять'); c11to19: array [1..9] of string[12] = ('одиннадцать', 'двенадцать', 'тринадцать', 'четырнадцать', 'пятнадцать', 'шестнадцать', 'семнадцать', 'восемнадцать', 'девятнадцать'); c10to90: array [1..9] of string[11] = ('десять', 'двадцать', 'тридцать', 'сорок', 'пятьдесят', 'шестьдесят', 'семьдесят', 'восемьдесят', 'девяносто'); c100to900: array [1..9] of string[9] = ('сто', 'двести', 'триста', 'четыреста', 'пятьсот', 'шестьсот', 'семьсот', 'восемьсот', 'девятьсот'); var s: String; i: Longint; begin s := ''; i := M div 100; if I <> 0 then s := c100to900[i] + ' '; M := M mod 100; i := M div 10; if (M > 10) and (M < 20) then s := s + c11to19[M - 10] + ' ' else begin if I <> 0 then s := s + c10to90[i] + ' '; M := M mod 10; if M <> 0 then if fm = 0 then s := s + c1to9f[M] + ' ' else s := s + c1to9m[M] + ' '; end; Conv999 := s; end; var i: Longint; j: Longint; r: Real; t: String; begin t := ''; j := Trunc(S / 1000000000.0); r := j; r := S - r*1000000000.0; i := Trunc(r); if j <> 0 then begin t := t + Conv999(j, 1) + 'миллиард'; j := j mod 100; if (j > 10) and (j < 20) then t := t + 'ов ' else case j mod 10 of 0: t := t + 'ов '; 1: t := t + ' '; 2..4: t := t + 'а '; 5..9: t := t + 'ов '; end; end; j := i div 1000000; if j <> 0 then begin t := t + Conv999(j, 1) + 'миллион'; j := j mod 100; if (j > 10) and (j < 20) then t := t + 'ов ' else case j mod 10 of 0: t := t + 'ов '; 1: t := t + ' '; 2..4: t := t + 'а '; 5..9: t := t + 'ов '; end; end; i := i mod 1000000; j := i div 1000; if j <> 0 then begin t := t + Conv999(j, 0) + 'тысяч'; j := j mod 100; if (j > 10) and (j < 20) then t := t + ' ' else case j mod 10 of 0: t := t + ' '; 1: t := t + 'а '; 2..4: t := t + 'и '; 5..9: t := t + ' '; end; end; i := i mod 1000; j := i; if j <> 0 then t := t + Conv999(j, 1); t := t + 'руб. '; i := Round(Frac(S)*100.0); t := t + IntToStr(i) + ' коп.'; TextSum := t; end; [Александр]



Правильное округление дробных чисел

 Как научить Delphi правильно округлять дробные числа?

function RoundEx(X: Double; Precision: Integer): Double; { Precision : 1 - до целых, 10 - до десятых, 100 - до сотых... } var ScaledFractPart, Temp: Double; begin ScaledFractPart := Frac(X) * Precision; Temp := Frac(ScaledFractPart); ScaledFractPart := Int(ScaledFractPart); if Temp >= 0.5 then ScaledFractPart := ScaledFractPart + 1; if Temp <= -0.5 then ScaledFractPart := ScaledFractPart - 1; RoundEx := Int(X) + ScaledFractPart / Precision; end; [Nomadic]



Паскалевский эквивалент StrTok
Решение 1
function NextToken(P: PChar; Divider: PChar): PChar; const next: PChar = nil ; begin if P = nil then P := next; if P <> nil then begin next := StrPos(P, Divider); if next <> nil then begin next^ := #0; next := @next[StrLen(Divider)]; end; end; NextToken := P; end; [News Group]

Решение 2
function StrTok(Phrase: PChar; Delimeter: PChar): PChar; const tokenPtr: PChar = nil; workPtr: PChar = nil; var delimPtr: PChar; begin if (Phrase <> nil) then workPtr := Phrase else workPtr := tokenPtr; if workPtr = nil then begin Result := nil; Exit; end; delimPtr := StrPos(workPtr, Delimeter); if (delimPtr <> nil) then begin delimPtr^ := Chr(0); tokenPtr := delimPtr + 1 end else tokenPtr := nil; Result := workPtr; end; [News Group]



Как получить указатели всех процессов, запущенных в системе

 Под Windows (Win32) это возможно с использованием вспомогательных информационных функций:
  • Вызывается функция: hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  • Process32First() – получение информации о первом процессе в списке;
  • Далее в цикле Process32Next() – получение информации о следующем процессе в списке. unit KernlUtl; interface uses TlHelp32, Windows, Classes, SysUtils; procedure GetProcessList(List: TStrings); procedure GetModuleList(List: TStrings); function GetProcessHandle(ProcessID: DWORD): THandle; procedure GetParentProcessInfo(var ID: DWORD; var Path: String); const PROCESS_TERMINATE = $0001; PROCESS_CREATE_THREAD = $0002; PROCESS_VM_OPERATION = $0008; PROCESS_VM_READ = $0010; PROCESS_VM_WRITE = $0020; PROCESS_DUP_HANDLE = $0040; PROCESS_CREATE_PROCESS = $0080; PROCESS_SET_QUOTA = $0100; PROCESS_SET_INFORMATION = $0200; PROCESS_QUERY_INFORMATION = $0400; PROCESS_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0FFF; implementation procedure GetProcessList(List: TStrings); var I: Integer; hSnapshoot: THandle; pe32: TProcessEntry32; begin List.Clear; hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if (hSnapshoot = -1) then Exit; pe32.dwSize := SizeOf(TProcessEntry32); if (Process32First(hSnapshoot, pe32)) then repeat I := List.Add(Format('%x, %x: %s', [pe32.th32ProcessID, pe32.th32ParentProcessID, pe32.szExeFile])); List.Objects[I] := Pointer(pe32.th32ProcessID); until not Process32Next(hSnapshoot, pe32); CloseHandle (hSnapshoot); end; procedure GetModuleList(List: TStrings); var I: Integer; hSnapshoot: THandle; me32: TModuleEntry32; begin List.Clear; hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0); if (hSnapshoot = -1) then Exit; me32.dwSize := SizeOf(TModuleEntry32); if (Module32First(hSnapshoot, me32)) then repeat I := List.Add(me32.szModule); List.Objects[I] := Pointer(me32.th32ModuleID); until not Module32Next(hSnapshoot, me32); CloseHandle (hSnapshoot); end; procedure GetParentProcessInfo(var ID: DWORD; var Path: String); var ProcessID: DWORD; hSnapshoot: THandle; pe32: TProcessEntry32; begin ProcessID := GetCurrentProcessId; ID := 0; Path := ''; hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if (hSnapshoot = -1) then Exit; pe32.dwSize := SizeOf(TProcessEntry32); if (Process32First(hSnapshoot, pe32)) then repeat if pe32.th32ProcessID = ProcessID then begin ID := pe32.th32ParentProcessID; Break; end; until not Process32Next(hSnapshoot, pe32); if ID <> -1 then if (Process32First(hSnapshoot, pe32)) then repeat if pe32.th32ProcessID = ID then begin Path := pe32.szExeFile; Break; end; until not Process32Next(hSnapshoot, pe32); CloseHandle (hSnapshoot); end; function GetProcessHandle(ProcessID: DWORD): THandle; begin Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID); end; end. [Nomadic]



    Список запущенных приложений

     Решение

    procedure TForm1.Button1Click(Sender: TObject); var Wnd: hWnd; buff: array [0..127] of char; begin ListBox1.Clear; Wnd := GetWindow(Handle, gw_HWndFirst); while Wnd <> 0 do begin // Не показываем: if (Wnd <> Application.Handle) // Собственное окно and IsWindowVisible(Wnd) // Невидимые окна and (GetWindow(Wnd, gw_Owner) = 0) // Дочерние окна and (GetWindowText(Wnd, buff, sizeof(buff)) <> 0) then begin GetWindowText(Wnd, buff, sizeof(buff)); ListBox1.Items.Add(StrPas(buff)); end; Wnd := GetWindow(Wnd, gw_hWndNext); end; ListBox1.ItemIndex := 0; end; [Nikolaev Igor]



    Как запустить другую программу

     Для примера посмотрите в Delphi модуль FMXUTILS.PAS:

    function ExecuteFile(const FileName, Params, DefaultDir: string; ShowCmd: Integer): THandle; var zFileName, zParams, zDir: array[0..79] of Char; begin Result := ShellExecute(Application.MainForm.Handle, nil, StrPCopy(zFileName, FileName), StrPCopy(zParams, Params), StrPCopy(zDir, DefaultDir), ShowCmd); end; Пример вызова:

    ExecuteFile('Notepad.exe', '', 'c:\windows', SW_SHOWNORMAL); Примечание
    Чтобы этот код заработал, необходимо добавить в uses модуль ShellAPI.



    Как предотвратить запуск копии приложения

     Можно использовать переменную Atom, полная информация о которой содержится в справочном руководстве по Delphi.

    program Project1; uses Windows, Forms, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} const AtStr = 'MyProgram'; function CheckThis: boolean; var Atom: THandle; begin Atom := GlobalFindAtom(AtStr); Result := Atom <> 0; if not Result then GlobalAddAtom(AtStr); end; begin if not CheckThis then begin // Запуск программмы Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; GlobalDeleteAtom(GlobalFindAtom(AtStr)); end else MessageBox(0, 'Нельзя запустить две копии программы', 'Error', 0); end. [Чумак Михаил]



    Контроль завершения приложения

     Решение

    function WinExecAndWait32(FileName: String; Visibility: integer): DWORD; var zAppName: array[0..512] of char; zCurDir: array[0..255] of char; WorkDir: String; StartupInfo: TStartupInfo; ProcessInfo: TProcessInformation; Pd: pointer; begin StrPCopy(zAppName, FileName); GetDir(0, WorkDir); StrPCopy(zCurDir, WorkDir); FillChar(StartupInfo, Sizeof(StartupInfo), #0); StartupInfo.cb := Sizeof(StartupInfo); StartupInfo.dwFlags := STARTF_USESHOWWINDOW; StartupInfo.wShowWindow := Visibility; if not CreateProcess(nil, zAppName, nil, nil, false, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then Result := 0 else begin WaitforSingleObject(ProcessInfo.hProcess, INFINITE); GetExitCodeProcess(ProcessInfo.hProcess, Result); end; end; В качестве дополнения внесем резонное исправление – вместо:WaitforSingleObject(ProcessInfo.hProcess, INFINITE); лучше написать:

    while WaitforSingleObject(ProcessInfo.hProcess, 200) = WAIT_TIMEOUT do TForm1.Repaint; Смысл замены: в первом варианте главное окно ждёт завершения вызванного сообщения, не обрабатывая при этом никаких событий. Вследствие этого, главное окно не перерисовывается, что выглядит далеко не лучшим образом. Последний вариант исправляет этот недостаток.

    [Trubachev Pavel]



    Управление завершением работы Windows

     Как в одном компоненте реализовать выключение компьютера, его перезагрузку, завершение сеанса работы пользователя, функцию Eject CD, выключение питания монитора и т. д.?

    Предлагаем рассмотреть следующий пример:

    procedure TForm1.Button1Click(Sender: TObject); begin PowerControl1.Action := actCDEject; // Или... actLogOFF, actShutDown... PowerControl1.Execute; end; unit PowerControl; interface uses Windows, Messages, SysUtils, Classes, Controls, Forms, Graphics, MMSystem; type TAction = (actLogOFF, actShutDown, actReBoot, actForce, actPowerOFF, actForceIfHung, actMonitorOFF, actMonitorON, actCDEject, actCDUnEject); TPowerControl = class(TComponent) private FAction: TAction; Procedure SetAction(Value: TAction); public function Execute: Boolean; published property Action: TAction read FAction write SetAction; end; procedure Register; implementation procedure Register; begin RegisterComponents('K2', [TPowerControl]); end; procedure TPowerControl.SetAction(Value: TAction); begin FAction := Value; end; function TPowerControl.Execute: Boolean; begin with (Owner as TForm) do case FAction of actLogOff: ExitWindowsEx(EWX_LOGOFF,1); actShutDown: ExitWindowsEx(EWX_SHUTDOWN,1); actReBoot: ExitWindowsEx(EWX_REBOOT,1); actForce: ExitWindowsEx(EWX_FORCE,1); actPowerOff: ExitWindowsEx(EWX_POWEROFF,1); actForceIfHung: ExitWindowsEx(EWX_FORCEIFHUNG,1); actMonitorOFF: SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0); actMonitorON: SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1); actCDEject: mciSendstring('SET CDAUDIO DOOR OPEN WAIT', nil, 0, Handle); actCDUnEject: mciSendstring('SET CDAUDIO DOOR CLOSED WAIT', nil, 0, Handle); end; {Case} Result := True; end; end. [Nikolaev Igor]



    Директивы компилятора, способные увеличить скорость

     Скорость исполнения прилоежния может упасть из-за применения динамических массивов. Поэтому целесообразно обратить внимание на ключи компилятора. После отладки кода установите эти три наиболее важных ключа:

    {$R-} {Range checking off - проверка диапазона} {$S-} {Stack checking off – проверка стека} {$A+} {Word align data – 'выравнивание слов'}



    Создание редактора свойства

     Если вы присвоили свойству имя TableName, то полный цикл создания редактора свойств включает следующие шаги:

    Опишите класс редактора свойства:

    type TTableNameProperty = class(TStringProperty) function GetAttributes: TPropertyAttributes; override; procedure GetValues(Proc: TGetStrProc); override; end; implementation { TTableNameProperty } function TTableNameProperty.GetAttributes: TPropertyAttributes; begin Result := [paValueList]; end; procedure TTableNameProperty.GetValues(Proc: TGetStrProc); var TableName: String; I: Integer; begin { здесь вы должны добавить свой код, чтобы с помощью цикла обойти имена всех таблиц, включенных в список } for I := 0 to ???? do begin TableName := ????[I]; Proc(TableName); end; end; Затем зарегистрируйте данный редактор свойства следующим образом:

    RegisterPropertyEditor(TypeInfo(string), TcsNotebook, 'TableName', TTableNameProperty); [News Group]



    Вызов процедуры, имя которой содержится в переменной

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

    Можно создать переменную типа StringList, как показано ниже:

    StringList.Create; StringList.AddObject('Proc1', @Proc1); StringList.AddObject('Proc2', @Proc2); Затем реализовать это в программе: var myFunc: procedure; begin if Stringlist.IndexOf(S) = -1 then MessageDlg('Не понял процедуру ' + S, mtError, [mbOk], 0) else begin @myFunc := Stringlist.Objects[Stringlist.IndexOf(S)]; myFunc; end; end; [News Group]



    Передача функции как параметра

     В этом случае лучшим решением будет использование процедурного типа. Допустим, что DllFunction() на входе хочет получить определенную функцию. Поясним это на примере:

    type TMyFuncType = function: integer; var MyFunc: TMyFuncType; function foo: integer; begin result := 1; end; begin MyFunc := foo; DllFunction(longint(MyFunc)); Можно это сделать и так:

    DllFunction(longint(@foo)); Тем не менее, нельзя гарантировать, что память при вызовах DLL (как в этом примере) распределяется оптимальным образом.. Для корректной работы необходимо объявить foo с директивой far, т. е. экспортировать ее в модуле.

    Также, в зависимости от того, как написана DllFunction(), можно в вызове подразумевать приведение типа:

    function DllFunction(p: TMyFuncType): Integer; far; external 'mydll'; В этом случае не нужна переменная MyFunc или оператор «@».

    В Delphi/Pascal можно передавать функции как параметры. Но для того чтобы этим воспользоваться, необходимо установить для компилятора тип.

    Проверьте следующий код:

    unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls; type TForm1 = class(TForm) Button1: TButton; Button2: TButton; procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); end; var Form1: TForm1; implementation {$R *.DFM} type IntFunc = function: integer; function DllFunction(iFunc: IntFunc): integer; far; begin DllFunction := iFunc; // Обратите внимание, что это вызов функции end; function iFoo: integer; far; begin iFoo := 1; end; procedure TestIFunc; var i: integer; begin i := DllFunction(iFoo); end; procedure TForm1.Button1Click(Sender: TObject); begin TestIFunc; end; procedure TForm1.Button2Click(Sender: TObject); begin Close; end; end. Возможны два способа. Первый заключается в использовании следующего кода:

    i := longint(@foo); Такой способ подойдет, если вы хотите применить для передачи longint. Другой вариант, которым можно воспользоваться – исключить работу с longint и вызывать функцию DLL следующим образом:

    DLLfunction(@foo); Имейте в виду, что если собираетесь вызывать foo из DLL, то необходимо предусмотреть вопросы совместимости. Для получения дополнительной информации почитайте описание функции MakeProcInstance.



    Переменная в качестве имени процедуры

     Каким образом можно использовать переменную типа String в качестве имени процедуры?

    Если все процедуры, которые вы собираетесь вызывать, имеют список с одними и теми же параметрами (или все без параметров), то это не трудно. Для этого необходимы:

    процедурный тип, соответствующий вашей процедуре, например:

    type TMacroProc = procedure(param: Integer); массив, сопоставляющий имена процедур их адресам во время выполнения приложения:

    type TMacroName = string[32]; TMacroLink = record name: TMacroName; proc: TMacroProc; end; TMacroList = array [1..MaxMacroIndex] of TMacroLink; const Macros: TMacroList = ( (name: 'Proc1'; proc: Proc1), (name: 'Proc2'; proc: Proc2), ... ); интерпретатор функций, типа:

    procedure CallMacro(name: String; param: Integer); var i: Integer; begin for i := 1 to MaxMacroIndex do if CompareText(name, Macros[i].name) = 0 then begin Macros[i].proc(param); break; end; end; Макропроцедуры необходимо объявить в секции Interface модуля или с ключевым словом Far, например:

    procedure Proc1(n: Integer); far; begin ... end; procedure Proc2(n: Integer); far; begin ... end; [News Group]



    Массивы размером более 64К

     Не существует способа непосредственного доступа к массиву размером свыше 65520 элементов. Или вы пользуетесь для распределения памяти GlobalAlloc или TMemoryStream и создаете специализированный класс для доступа к элементам массива, или вы делаете это непосредственно вручную. Добраться до следующих сегментов GlobalAlloc объекта можно, строя указатели с помощью SelectorInc. Самый простой способ заключается в применении TMemoryStream.

    type Tmyarr = class buffer: TMemoryStream; elsize: LongInt; constructor Create(esize, number: Word); destructor Free; procedure SetElement(index: Word; p: Pointer); procedure GetElement(index: Word; p: Pointer); end; implementation constructor Tmyarr.Create(esize, number: Word); var size: LongInt; begin Inherited Create; buffer := TMemoryStream.Create; elsize := esize; size := esize * number; buffer.SetSize(size); end; destructor Tmyarr.Free; begin if Self <> Nil then begin buffer.Free; Destroy; end; end; procedure Tmyarr.GetElement(index: Word; p: Pointer); begin buffer.Seek(elsize * index, 0); buffer.Read(p^, elsize); end; procedure Tmyarr.SetElement(index: Word; p: Pointer); begin buffer.Seek(elsize * index, 0); buffer.Write(p^, elsize); end; [News Goup]


    Часть 2


    При перепечатке любого материала с сайта, видимая ссылка на источник www.warayg.narod.ru и все имена, ссылки авторов обязательны.

    © 2005
     

    • Hosted by uCoz