Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 2 сентября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Кто-нибудь знает быстрый способ поиска строки в текстовом файле?

unit BMSearch;

{Поиск строки методом Boyer-Moore.
Это - один из самых быстрых алгоритмов поиска строки.}

interface

type
{$ifdef WINDOWS}

size_t = Word;
{$else}

size_t = LongInt;
{$endif}

type

TTranslationTable = array[char] of char; { таблица перевода }


TSearchBM = class(TObject)
private
FTranslate : TTranslationTable; { таблица перевода }
FJumpTable : array[char] of Byte; { таблица переходов }
FShift_1 : integer;
FPattern : pchar;
FPatternLen : size_t;


public
procedure Prepare( Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean );
procedure PrepareStr( const Pattern: string; IgnoreCase: Boolean );


function Search( Text: pchar; TextLen: size_t ): pchar;
function Pos( const S: string ): integer;
end;


implementation

uses SysUtils;

{Игнорируем регистр таблицы перевода}
procedure CreateTranslationTable( var T: TTranslationTable; IgnoreCase: Boolean );
var
c: char;
begin
for c := #0 to #255 do
T[c] := c;

if not IgnoreCase then
exit;

for c := 'a' to 'z' do
T[c] := UpCase(c);

{ Связываем все нижние символы с их эквивалентом верхнего регистра }
T['Б'] := 'A';
T['А'] := 'A';
T['Д'] := 'A';
T['В'] := 'A';


T['б'] := 'A';
T['а'] := 'A';
T['д'] := 'A';
T['в'] := 'A';


T['Й'] := 'E';
T['И'] := 'E';
T['Л'] := 'E';
T['К'] := 'E';


T['й'] := 'E';
T['и'] := 'E';
T['л'] := 'E';
T['к'] := 'E';


T['Н'] := 'I';
T['М'] := 'I';
T['П'] := 'I';
T['О'] := 'I';


T['н'] := 'I';
T['м'] := 'I';
T['п'] := 'I';
T['о'] := 'I';


T['У'] := 'O';
T['Т'] := 'O';
T['Ц'] := 'O';
T['Ф'] := 'O';


T['у'] := 'O';
T['т'] := 'O';
T['ц'] := 'O';
T['ф'] := 'O';


T['Ъ'] := 'U';
T['Щ'] := 'U';
T['Ь'] := 'U';
T['Ы'] := 'U';


T['ъ'] := 'U';
T['щ'] := 'U';
T['ь'] := 'U';
T['ы'] := 'U';


T['с'] := 'С';
end;

{Подготовка таблицы переходов}
procedure TSearchBM.Prepare( Pattern: pchar; PatternLen: size_t;

IgnoreCase: Boolean );
var

i: integer;
c, lastc: char;
begin

FPattern := Pattern;
FPatternLen := PatternLen;


if FPatternLen < 1 then
FPatternLen := strlen(FPattern);


{Данный алгоритм базируется на наборе из 256 символов}
if FPatternLen > 256 then
exit;

{1. Подготовка таблицы перевода}
CreateTranslationTable( FTranslate, IgnoreCase);

{2. Подготовка таблицы переходов}
for c := #0 to #255 do
FJumpTable[c] := FPatternLen;

for i := FPatternLen - 1 downto 0 do begin
c := FTranslate[FPattern[i]];
if FJumpTable[c] >= FPatternLen - 1 then
FJumpTable[c] := FPatternLen - 1 - i;
end;

FShift_1 := FPatternLen - 1;
lastc := FTranslate[Pattern[FPatternLen - 1]];

for i := FPatternLen - 2 downto 0 do
if FTranslate[FPattern[i]] = lastc then begin
FShift_1 := FPatternLen - 1 - i;
break;
end;

if FShift_1 = 0 then
FShift_1 := 1;
end;

procedure TSearchBM.PrepareStr( const Pattern: string; IgnoreCase: Boolean );
var
str: pchar;
begin
if Pattern <> '' then begin
{$ifdef Windows}

str := @Pattern[1];
{$else}

str := pchar(Pattern);
{$endif}

Prepare( str, Length(Pattern), IgnoreCase);
end;
end;

{Поиск последнего символа & просмотр справа налево}
function TSearchBM.Search( Text: pchar; TextLen: size_t ): pchar;
var
shift, m1, j: integer;
jumps: size_t;
begin
result := nil;
if FPatternLen > 256 then
exit;

if TextLen < 1 then
TextLen := strlen(Text);

m1 := FPatternLen - 1;
shift := 0;
jumps := 0;

{Поиск последнего символа}

while jumps <= TextLen do begin
Inc( Text, shift);
shift := FJumpTable[FTranslate[Text^]];
while shift <> 0 do begin
Inc( jumps, shift);
if jumps > TextLen then
exit;

Inc( Text, shift);
shift := FJumpTable[FTranslate[Text^]];
end;

{Сравниваем справа налево FPatternLen - 1 символов}
if jumps >= m1 then begin
j := 0;
while FTranslate[FPattern[m1 - j]] = FTranslate[(Text - j)^] do begin
Inc(j);
if j = FPatternLen then begin
result := Text - m1;
exit;
end;
end;
end;

shift := FShift_1;
Inc( jumps, shift);
end;
end;

function TSearchBM.Pos( const S: string ): integer;
var
str, p: pchar;
begin
result := 0;
if S <> '' then begin
{$ifdef Windows}

str := @S[1];
{$else}

str := pchar(S);
{$endif}

p := Search( str, Length(S));
if p <> nil then
result := 1 + p - str;
end;
end;

end.



Есть какая-либо функция или вызов API для поиска загрузочного диска?

Я нашел это в регистрах:
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Setup
Значение "BootDir" и есть искомая величина.



Нужен компонент производящий поиск каких-либо EXE файлов на винчестере

unit Audit1;
interface
uses windos;

var
dest:string;

procedure dorecurse(dir:string);

implementation
{$R *.DFM}
Procedure Process (dir:string; Searchrec:tsearchrec);
begin
showmessage (Searchrec.name);
case Searchrec.attr of
$10:
if (searchrec.name<>'.') and (searchrec.name<>'..') then
begin
dorecurse (dir+'\'+searchrec.name);
writeln (dir);
end;
end;
end;

Procedure Dorecurse(dir:string);
var
Searchrec:Tsearchrec;
pc: array[0..79] of Char;
begin
StrPCopy(pc, dir+'\*.*');
FindFirst(pc, FaAnyfile, SearchRec);
Process (dir,SearchRec);
while FindNext(SearchRec)<>-18 do
begin
Process (dir,SearchRec);
end;
end;

Procedure startsearch;
begin
dorecurse (paramstr(1));
end;

begin
startsearch;
end.



Как вывести свединея о диске?

По нажатию на кнопку в поле ввода класса TMemo будут выводиться сведения об указанном вами диске:

procedure TForm1.Button2Click(Sender: TObject);
var
VolumeName,
FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord;
MaxComponentLength,FileSystemFlags: Cardinal;
begin
GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo,
MaxComponentLength,FileSystemFlags,
FileSystemName,MAX_PATH);
Memo1.Lines.Add('VolumeName = '+VolumeName);
Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));
Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));
Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));
Memo1.Lines.Add('FSName = '+FileSystemName);
end;




Как подмутить вылет окна?

Если Вы хотите ввести в изумление пользователя с первых минут его использования Вашего приложения, тогда самый верный способ - заставить окно “вылететь”, а не появиться обычным способом! Сделать это довольно легко, надо только описать два события: OnShow (на появление формы) и OnClose (на закрытие формы)
Выглядеть это будет так:
procedure TForm1.FormShow(Sender: TObject);
var
RectSmall,RectNormal:TRect;
begin
RectSmall:=Rect(0,0,0,0);
RectNormal:=Form1.BoundsRect; DrawAnimatedRects(GetDesktopWindow,IDANI_CAPTION,RectSmall,RectNormal);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
RectSmall,RectNormal:TRect;
begin
RectSmall:=Rect(0,0,0,0);
RectNormal:=Form1.BoundsRect; DrawAnimatedRects(GetDesktopWindow,IDANI_CAPTION,RectNormal,RectSmall);
end;
Как это сделано?
Мы объявляем две переменные класса TRect (От англ. Rectangle - прямоугольник ). Называем их, например RectSmall и RectNormal. Для RectSmall мы задаём нули: (0,0,0,0), тем самым указав начало координат, т.е. левый верхний угол экрана. В RectNormal помещаем рамку формы с помощью функции BoundsRect. Функция DrawAnimatedRects создаёт перетекание начальной рамки в конечную. В событии OnShow мы из маленькой рамки делаем большую – окно вылетает, а в событии OnClose большая рамка перетекает в маленькую – окно улетает!



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

Перед появлением главного окна во всех серьёзных приложениях сначала появляется заставка. Теперь и у Вас есть возможность повыёживаться! Для создания заставки выполняем следующую последовательность действий:
Начинаем создание нового приложение командой “New Application” (“Новое приложение”) из меню “File” (“Файл”)
Добавьте ещё одну форму: “New Form”(“Новая форма”) из меню “File” (“Файл”). Это окно и будет заставкой. У него нужно убрать рамку с полосой заголовка, установив свойство “BorderStyle” в “bsNone”. Теперь можно смело разработать дизайн окна заставки.
Из меню “Project” (“Проект”) выбрать команду “Options”(“Опции”). Зайти на закладку “Forms”(“Формы”) и Form2 из списка автоматически создаваемых форм (Auto-Create forms) перенести в список доступных форм (Available forms)
На форму-заставку с закладки System вынести компонент Timer. В его свойстве Interval установить значение 5000, а в событии OnTimer написать: Timer1.Enabled:=false;
(это сделано для того, чтобы заставка была видна в период указанного времени – 5000 миллисекунд, т.е. 5 секунд)
Перейти в файл проекта, нажав Ctrl+F12 и выбрав Project1. Исходный код должен выглядеть так: program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Теперь мы внесём сюда немного изменений и код должен стать таким:
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
{$R *.RES}
begin
Application.Initialize;
Form2:=TForm2.Create(Application);
Form2.Show;
Form2.Update;
while Form2.Timer1.Enabled do Application.ProcessMessages;
Application.CreateForm(TForm1, Form1);
Form2.Hide;
Form2.Free;
Application.Run;
end.

Как это сделано?
Сначала мы создаём экземпляр формы-заставки, т.к. она автоматически не создаётся
Form2:=TForm2.Create(Application);
Потом мы показываем созданное окно
Form2.Show;
Для большей верности, что окно будет выведено, мы его обновляем
Form2.Update;
Так как период задержки формы на экране очень мал, мы не скрываем окно, пока активен таймер, который был вынесен на форму-заставку
while Form2.Timer1.Enabled do Application.ProcessMessages;
Перед запуском приложения – Application.Run – скрываем заставку и уничтожаем её
Form2.Hide;
Form2.Free;




Пароль на доступ в файл

Если Вы создали крутую вещицу и хотите сшибать за неё бабки, то самое время позаботиться об авторском праве. Вы можете и не давать общий доступ к вашей проге, выводя вначале запуска окно с милым и невинным предложением ввести пароль...
Начинаем создание нового приложение командой “New Application” (“Новое приложение”) из меню “File” (“Файл”)
Добавьте ещё одну форму: “New Form”(“Новая форма”) из меню “File” (“Файл”). Это окно будет диалогом с вводом пароля. Чтобы сделать ‘это окно диалоговым, нужно его свойство “BorderStyle” установить в “bsDialog”. Заголовок окна будет, например, таким: “Идентификация пользователя”. Выносим на него поле ввода – Edit. Свойство Text его очищаем, а в свойстве “PasswordChar” ставим “*” – звёздочку. Теперь всё, что будет вводить пользователь, будет отображаться таким символом!
Выносим в форму метку – компонент Label. Устанавливаем её над Edit’ом. В заголовке метки пишем что-нибудь типа: “Введите пароль”.
Кнопки возьмём с закладки Additional - компоненты класса TBitBtn. С помощью их свойства Kind одну кнопку сделаем “Ok”, а другую – “Cancel”. Ну вот, круто!
Теперь попытайтесь запустить приложение на выполнение (из меню “Run“(“Пуск”) команда “Run”(“Пуск”))... но, вот, незадача... вместо созданного окна для ввода пароля вначале появилась Form1. Почему? Потому, что это окно главное! Чтобы сделать главной вторую форму, нужно в меню “Project” (“Проект”) выбрать команду “Options”(“Опции”). Зайти на закладку “Forms”(“Формы”) и в выпадающем списке “Main form”(“Основная”) указать "Form2". Если запустить теперь всё будет работать правильно.
Теперь нужно написать код по нажатию на кнопку “Cancel”: Application.Terminate;
В событии по нажатию на кнопке “Ok” нужно сначала сопоставить текст, находящийся в поле ввода с тем ключевым словом, которое Вы хотите использовать в качестве пароля. У нас паролем будет число "1522" Если совпадение будет полное, тогда мы выведем первую форму, что так тщательно скрываем от всеобъемлющего взора пользователя, иначе будет осуществлён выход. Но главное это то, что нам сначала нужно установить взаимосвязь между модулями, потому, что если даже пользователь введёт правильный пароль, мы не сможем вывести Form1, находящуюся в Unit1, из Unit2. Связываем модули так: в главном модуле (в Unit2) объявляем используемый модуль (Unit1) в области uses. Выглядеть это должно примерно так: uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, Unit1;
А в используемом модуле объявляем - главный, но после ключевого слова implementation. Так как слова uses здесь нет, поэтому пишем так:
uses Unit2;
Теперь можно смело писать код по нажатию на кнопке “Ok” (У меня она названа по умолчанию - BitBtn1):
procedure TForm2.BitBtn1Click(Sender: TObject);
begin
if Edit1.Text='1522' then begin
Form1.Show;
end
else begin
MessageDlg('Введён неправильный пароль!',mtWarning,[mbOk],0);
Application.Terminate;
end;
end;
Теперь если мы запустим, то убедимся, что кнопки работают безотказно, но по появлению Form1 вторая форма не исчезает. Избавиться от этого можно описав следующим образом событие “OnShow” – на появление – для окна Form1: Form2.Hide;
И, наконец, самый главный недостаток – это то, что мы теперь, выходя из Form1, не можем осуществить полный выход из приложения. Но отчаиваться не стоит, так как нет безвыходных ситуаций! Нужно по выходу из Form1 (событие OnClose) осуществить полный выход из программы с помощью следующего кода: Application.Terminate;
Теперь всё готово! Можно поглумиться над неопытным пользователем, тщетно пытающимся взломать нашу защиту!




перемещение окна вне заголовка

СПОСОБ 1
Нужно объявить три глобальные переменные в публичных объявлениям (после ключевого слова Public): public
{ Public declarations }
Draging:Boolean;
X0,Y0:integer;
end;
Draging - для обозначение того периода времени когда пользователь перемещает мышь с зажатой кнопкой мыши,
X0 и Y0 - координаты точки, над которой была зажата кнопка мыши
Далее описываем события формы 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 [Предложил Alexandr Drugov]
Хочу показать еще один способ перемещения окна за его тело
Обрабатываем OnMouseDown:
ReleaseCapture;
Perform(WM_SYSCOMMAND, $F012, 0);




изменить фон рабочего стола

Если Вы хотите позаботиться о дизайне той машины, на которой запускаете свою прогу, то наиболее эффектно будет изменение фона рабочего стола. Я показываю как это сделать по нажатию кнопки - Button1:
uses ...Registry; //подключаем модуль
...
procedure TForm1.Button1Click(Sender: TObject);
var
Reg:TRegIniFile;
begin
Reg:=TRegIniFile.Create('Control Panel');
Reg.WriteString('desktop','Wallpaper','c:\windows\Установка.bmp');
Reg.WriteString('desktop','TileWallpaper','0');
Reg.Free;
SystemParametersInfo(SPI_SETDESKWALLPAPER,0,nil,SPIF_SENDWININICHANGE);
end;
ВНИМАНИЕ:
Вместо 'c:\windows\Установка.bmp' нужно указать имя файла, который Вы хотите вынести на рабочий стол.




вывести сообщение во время загрузки windows

Очень часто мы видим, что во время загрузки Windows на чётном экране выводится какой-то текст. Но как дописать туда что-нибудь своё? Хороший вопрос. Это можно сделать с помощью файла Autoexec.bat, находящегося в корневом каталоге.
Давайте откроем его, вписав в командную строку("Пуск">"Выполнить") следующее:
SysEdit
- эта команда позволяет вызвать редактор системных файлов. Самый верхний и будет Autoexec.bat
Добавим следующее и перезагрузим машину:
@echo off
@echo Attention
@echo System error. File kernel.dll is fail. Press any key for format C
pause
директива @echo off позволяет отключить вывод echo
директива @echo позволяет вывести сообщение
директива pause позволяет задержать загрузку Windows - нужно, чтобы пользователь обязательно
заметил наше сообщение!..
И что же мы видим, ещё до того как загрузится Windows, появится строка, гласящая, что произошла системная ошибка.
Итак, неопытный пользователь, увидев такое сообщение, не поймёт откуда оно взялось и будет всерьёз ошеломлён. Нажать какую-нибудь клавишу осмелится не каждый... но, в последствии, когда, несколько раз перезагрузив компьютер... он обнаружит то же сообщение, ему уже ничего не останется сделать, как рискнуть...
Да, выставить кого-нибудь чайником - занятие чрезмерно приятное...
И наша очередная задача - сделать всё это из Delphi
Объявляем файловую переменную класса TextFile и массив строк в публичных объявлениях (после ключевого слова Public): public
{ Public declarations }
f:TextFile;
t:array[1..4]of string;
По нажатию простого "батона" пишем код: procedure TForm1.Button1Click(Sender: TObject);
var
i:integer;
begin
assignfile(f,'c:\autoexec.bat');
Append(f);
t[1]:='@echo off';
t[2]:='@echo Attention';
t[3]:='@echo System error. File kernel.dll is fail. Press any key for format C';
t[4]:='pause';
for i:=1 to 4 do begin
writeln(f,t[i]);
end;
closefile(f);
end;
Как это сделано?
Сначала мы присваиваем файловой переменой файл Autoexec.bat:
assignfile(f,'c:\autoexec.bat');
Затем, используя функцию Append, добавляем текстовые строки массива f в файл. Строками массива является уже известный нам код, который мы вписывали в Autoexec.bat.
Функция writeln(f,t[i]); вписывает в цикле поочерёдно элементы массива в файл f. После того как мы внесли изменения, остаётся только закрыть файл с помощью следующей строки кода:
closefile(f);




мраморное окно

Если вам надоели обычные монотонные формы, то эта статья - спасенье для вас!!! Всё, что вам нужно сделать для того, чтобы ваше окно выглядело так же эффектно, как и показанное на рисунке , это только написать несколько строк кода на событие OnPaint (на прорисовку) для вашего подопытного окна:
procedure TForm1.FormPaint(Sender: TObject);
var
i,j:Integer;
begin
with Form1.Canvas do begin
for j:=0 to Form1.Height do begin
for i:=0 to Form1.Width do begin
Pixels[i,j]:=Trunc(Random($00000095));
end;
end;
end;
end;
Как это сделано?
С помощью двух циклов мы обошли поверхность окна (канву) и каждому пикселю задали случайный оттенок нужного цвета. (Для тех, кто не знает, ПИКСЕЛЬ - это мельчайшая точка). Цвет задаём 16-ричным кодом, например я указал:
$00000095
Получилось весьма неплохо :-))
Вы можете изменить цвет.
Удачи.




изменить свойства системы

Когда вы вызываете контекстное меню на иконке "Моего компьютера" и щёлкаете на команде "Свойства" - вы видите свойства системы. Эта статья позволит вам внести туда любой свой собственный текст и даже поместить рисунок!
Что же для этого надо?Для начала давайте заглянем в папку System, находящуюся в директории Windows и найдём там файл инициализации с именем Oeminfo.ini, нужно его отредактировать так, чтобы он выглядел следующим образом:
[General]
Manufacturer="производитель типа Я"
Model="модель беспонтовая!!! :-))"
[Support Information]
Line1="А здесь крутая инфа о поддержки"
Line2="тоже написанная мною,"
Line3="а Бил ГЕЙ, тс..."
Здесь, как видно, должно быть всего два раздела:
[General] - указанные здесь данные будут отображаться в окне "Свойства: Система" на закладке "Общие".
[Support Information] - информация о поддержки, которая будет видна в диалоговом окне появляющимся по нажатию на кнопке "Поддержка..." на той же закладке.
В разделе [General] есть два параметра (Manufacturer и Model), которым можно задавать любые значения.
В разделе же информации о поддержки можно создать сколько угодно параметров.
Чтобы было ещё эффектнее можно поместить в окно свойств системы даже графический файл, для этого файл нужно сначала создать, используя любой графический редактор, учитывая главное условие - размер файла должен быть 127х127. Назвать файл нужно так: Oemlogo.bmp, а затем поместить в папку System, находящуюся в директории Windows.
Ну, а как же собственно занести информацию в ini-файл программно?
Всё довольно-таки просто :-)
Для взаимодействия с ini-файлами нужно сделать следующее:
Сначала в области uses нужно объявить модуль inifiles
Затем объявить переменную класса TIniFile
Выделить память под этот объект, т.е. создать его с помощью метода Create
А после уже можно заносить или считывать данные из этого ini-файла
Вид модуля должен быть примерно таким:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, inifiles; {Объявляем модуль для взаимодействия с ini-файлами}
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject); {по созданию окна пишем следующий код}
var
APChar: array [0..254] of char; {сначала нужно узнать где у пользователя папка Windows - объявляем под это дело массив символов}
sFile:String; {объявляем текстовую переменную под имя ini-файла}
Ini:TIniFile; {...и экземпляр класса TIniFile для взаимодействия с файлами инициализации}
begin
GetWindowsDirectory(APChar,255); {узнаём, где у чудилки находится каталог Windows}
sFile:=String(APChar)+'\System\Oeminfo.ini'; {в текстовую переменную помещаем имя нужного нам файла}
if FileExists(sFile) then begin {и если файл существует...}
Ini:=TIniFile.Create(sFile); {связываем объявленную переменную с этим файлом}
{далее заносим данные, используя процедуру WriteString, т.к. данные текстового типа. Параметры у процедуры такие:
Имя раздела
Имя ключа
Вносимое значение}
Ini.WriteString('General','Manufacturer','"производитель типа Я"');
Ini.WriteString('General','Model','"модель беспонтовая!!! :-))"');
Ini.WriteString('Support Information','Line1','"А здесь крутая инфа о поддержки"');
Ini.WriteString('Support Information','Line2','"тоже написанная мною,"');
Ini.WriteString('Support Information','Line3','"а Бил ГЕЙ, тс..."');
Ini.Free; {ну, а под конец, сделав своё грязное дело, мы как порядочные... программисты - освобождаем занимаемую память}
end;
end;
end.



собственные курсоры в программе

В этой статье вы найдёте несколько способов использования собственных курсоров, в том числе и анимированных.[это файлы с расширением .ani]
Например, у вас есть какой-то файл с расширением .ani и вы хотите его задействовать. Всё, что вам для этого потребуется сделать, это - поместить файл в тот же каталог, где будет ваш exe, а затем написать следующий код, ну, скажем, по нажатию на кнопку:
Screen.Cursors[5] := LoadCursorFromFile('File.ani');
Screen.Cursor := 5;
Здесь используется свойство Cursors глобального объекта Screen. В нём содержится список курсоров, доступных приложению. По индексу в нужную позицию мы загружаем курсор из файла. А затем с помощью свойства Cursor задействуем его.
Если же вы имеете файл ресурсов, тогда дела будут обстоять иначе:
Помещаете этот файл в тот же каталог, что и exe. Затем в модуле объявляем глобальную константу, например после
var
Form1: TForm1;
Выглядеть это будет примерно так:
var
Form1: TForm1;
const
MyConst = 100;
С помощью этой константы мы зарезервируем новую позицию в свойстве Cursors глобального объекта Screen.
После чего подключаем файл ресурсов, т.е. если он у нас называется Cursors.res, тогда после
{$R *.DFM}
напишем
{$R Cursors.res}
Затем, допустим, по нажатию на кнопку пишем код:
Screen.Cursors[MyConst] := LoadCursor(hInstance,'MYCURSOR');
Screen.Cursor := MyConst;
Здесь 'MYCURSOR' - это имя курсора, который нам необходимо загрузить. Обратите внимание, если вы создаёте файл ресурсов самостоятельно, а сделать это можно с помощью утилиты "ImageEditor", вам необходимо в именах курсоров использовать только прописные буквы.



как поместить иконку в traybar

Для добавления иконки нужно сперва подключить модуль ShellAPI в раздел uses, а затем написать следующий код по нажатию на кнопку:
procedure TForm1.Button1Click(Sender: TObject);
var no:TNotifyIconData;
Hicon1:HIcon;
begin
//Помещение иконки в Tray Bar
HIcon1:=ExtractIcon(Handle,'i:\arw01lt.ico',0);
with no do begin
cbSize:=Sizeof(TNotifyIconData);
Wnd:=Handle;
uID:=0;
UFlags:=NIF_MESSAGE+NIF_ICON+NIF_TIP;
SzTip:='Traybar Tip';
HIcon:=HIcon1;
uCallBackMessage:=WM_USER+0;//Определяемое пользователем сообщение
end;
Shell_NotifyIcon(NIM_ADD,@no);
end;
Для того, чтобы удалить иконку обработайте нажатие второй кнопки:
procedure TForm1.Button2Click(Sender: TObject);
var no:TNotifyIconData;
begin
//Удаление иконки
with no do begin
cbSize:=Sizeof(TNotifyIconData);
Wnd:=Handle;
uID:=0;
end;
Shell_NotifyIcon(NIM_Delete,@no);
end;
Как это сделано?
Для добавления, удаления или редактирования иконок на TrayBar'e используем специальную API функцию - Shell_NotifyIcon. Как вы уже прочитали для того, чтобы ею воспользоваться, нужно сначала подключить модуль ShellAPI в разделе uses. В качестве параметров функции нужно указать две вещи. Сначала сообщение, которое мы посылаем, определяющее необходимое действие над иконкой. Этот параметр может принимать одно из следующих значений:
NIM_ADD - добавляет иконку в область TrayBar'a
NIM_DELETE - соответственно, удаляет
NIM_MODIFY - если задать это значение, можно будет модифицировать иконку
В качестве второго параметра передаётся структура NOTIFYICONDATA, которая содержит сведения об иконке. Эта структура обладает следующими полями:
cbSize - это размер структуры в байтах
hWnd - дескриптор окна, которое будет получать сообщения ассоциированные с иконкой на TrayBar'e
uID - идентификатор иконки на TrayBar'e
uFlags - массив флагов, значение этого поля может комбинироваться из следующих констант:
NIF_ICON - элемент структуры hIcon будет задействован
NIF_MESSAGE - элемент структуры uCallbackMessage будет задействован
NIF_TIP - - элемент структуры szTip будет задействован
uCallbackMessage - идентификатор сообщения. Система использует этот идентификатор, когда сообщение посылается окну, обозначенному в поле hWnd. Это сообщение посылается, когда происходит событие мыши над областью иконки.
hIcon - дескриптор задаваемой иконки
szTip - всплывающая подсказка, появляющаяся над областью иконки



запустить текущий screen saver

Для этого можно использовать следующую функцию:
function RunScreenSaver : bool;
var
b : boolean;
begin
result := false;
if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE,0,@b,0) <> true then exit;
if not b then exit;
PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
result := true;
end;
Сначала мы проверяем, установлен ли Screen Saver, если нет - возвращаемся с отрицательным ответом, в противном случае - запускаем его и возвращаем true.




анимированная кнопка пуск

Если вы используете приведённый здесь код, ваша кнопка ПУСК будет извиваться как в экстазе. На форму предварительно нужно вынести Image, Timer и две кнопки: CopyPuskBtn и AnimateBtn. Последняя должна быть неактивна изначально. Timer - отключен, его свойство Interval должно быть установлено в оптимальное значение - испытывайте.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI,
ExtCtrls, StdCtrls;
const
MAX_BUFFER = 6;
type
TForm1 = class(TForm)
CopyPuskBtn: TButton;
Timer1: TTimer;
AnimateBtn: TButton;
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure CopyPuskBtnClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure AnimateBtnClick(Sender: TObject);
procedure Edit1KeyPress(Sender: TObject; var Key: Char);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
HW : HWND;
DC : HDC;
R : TRect;
FNumber : integer;
Buffer : array[1..MAX_BUFFER] of TBitmap;
TrayIcon : TNotifyIconData;
procedure CreateFrames;
procedure DestroyFrames;
procedure BuildFrames;
procedure NotifyIcon(var Msg : TMessage);message WM_USER + 100;
procedure OnMinimizeEvt(Sender : TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Math;
{$R *.DFM}
// Создаём буфер для спрайтов
procedure TForm1.CreateFrames;
var
i : integer;
begin
for i:=1 to MAX_BUFFER do
begin
Buffer[i] := TBitmap.Create;
Buffer[i].Height := R.Bottom-R.Top;
Buffer[i].Width := R.Right-R.Left;
Buffer[i].Canvas.Brush.Color := clBtnFace;
Buffer[i].Canvas.Pen.Color := clBtnFace;
Buffer[i].Canvas.Rectangle(0,0,Buffer[i].Width,Buffer[i].Height);
end;
end;
procedure TForm1.DestroyFrames;
var
i : integer;
begin
for i:=1 to MAX_BUFFER do
begin
Buffer[i].Destroy;
end;
end;
// Подготавливает сегменты/спрайты для анимации
procedure TForm1.BuildFrames;
var
i,j,k,H,W : integer;
Y : double;
begin
H := R.Bottom-R.Top;
W := R.Right-R.Left;
Image1.Width := W;
Image1.Height:= H;
for i := 1 to MAX_BUFFER-1 do //Буфер[MAX_BUFFER] используется для хранения оригинального битмапа
for j:= 1 to W do
for k:=1 to H do
begin
Y := 2*Sin((j*360/W)*(pi/180)-20*i);
Buffer[i].Canvas.Pixels[j,k-Round(Y)]:= Buffer[6].Canvas.Pixels[j,k];
end;
end;
procedure TForm1.OnMinimizeEvt(Sender : TObject);
begin
ShowWindow(Application.Handle,SW_HIDE);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
HW := FindWindowEx(FindWindow('Shell_TrayWnd',nil),0,'Button',nil);
GetWindowRect(HW,R);
DC := GetWindowDC(HW);
CreateFrames;
FNumber :=1;
TrayIcon.cbSize := SizeOf(TrayIcon);
TrayIcon.Wnd := Form1.Handle;
TrayIcon.uID := 100;
TrayIcon.uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
TrayIcon.uCallbackMessage := WM_USER + 100;
TrayIcon.hIcon := Application.Icon.Handle;
Shell_NotifyIcon(NIM_ADD,@TrayIcon);
Application.OnMinimize := OnMinimizeEvt;
end;
procedure TForm1.NotifyIcon(var Msg : TMessage);
begin
case Msg.LParam of
WM_LBUTTONDBLCLK :
begin
ShowWindow(Application.Handle,SW_SHOW);
Application.Restore;
end;
end;
end;
procedure TForm1.CopyPuskBtnClick(Sender: TObject);
begin
//Получаем изображение оригинальной кнопки, чтобы потом использовать его
//когда анимация завершится
BitBlt(Buffer[MAX_BUFFER].Canvas.Handle,0,0,R.Right-R.Left,R.Bottom-R.Top,
DC,0,0,SRCCOPY);
BuildFrames;
Image1.Canvas.Draw(0,0,Buffer[MAX_BUFFER]);
AnimateBtn.Enabled := true;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Timer1.Enabled := false;
BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top,
Buffer[MAX_BUFFER].Canvas.Handle,0,0,SRCCOPY);
ReleaseDC(HW,DC);
DestroyFrames; // не забудьте сделать это !!!
Shell_NotifyIcon(NIM_DELETE,@TrayIcon);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top,
Buffer[FNumber].Canvas.Handle,0,0,SRCCOPY);
Inc(FNumber);
if (FNumber > MAX_BUFFER-1) then FNumber := 1;
end;
procedure TForm1.AnimateBtnClick(Sender: TObject);
begin
Timer1.Enabled := not Timer1.Enabled;
if not Timer1.Enabled then
begin
BitBlt(DC,0,0,R.Right-R.Left,R.Bottom-R.Top,
Buffer[MAX_BUFFER].Canvas.Handle,0,0,SRCCOPY);
AnimateBtn.Caption := '&Animate';
CopyPuskBtn.Enabled := true;
end
else
begin
AnimateBtn.Caption := '&Stop';
CopyPuskBtn.Enabled := false;
end;
end;
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
if not (Key in ['0'..'9']) and (Key <> Chr(VK_BACK)) then Key := #0;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caNone;
PostMessage(Form1.Handle,WM_DESTROY,0,0);
Application.Terminate;
end;
end.



интеграция flash в delphi-приложение

Flash позволяет создавать анимацию для растровой графики и включать её в web-страницы. Многие хорошо знают этот продукт фирмы Macromedia. Если у вас когда-нибудь возникало желание воспроизводить flash'овские movie-клипы [swf-файлы] на своей форме, то теперь вашему желанию суждено сбыться! Для этого нужно сделать следующее:

Скачайте файл SWFLASH.OCX [не забудьте распаковать архив :-]
Импортируйте этот элемент управления ActiveX в среду программирования Delphi. Для этого из меню Component возьмите команду Import ActiveX Control. В появившемся окне щелкните на кнопке Add и укажите на скаченный файл [SWFLASH.OCX]. В том случае, если у вас уже установлен Flash - вам не надо скачивать этот файл - вы его сможете найти по следующему пути: C:/Windows/System/Macromed/Flash/



как добавить в исполняемый файл 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;



как подключить и отключить сетевые диски?

Для работы с сетевыми дисководами (и ресурсами типа LPT порта)
в WIN API 16 и WIN API 32 следующие функции:
1.Подключить сетевой ресурс
WNetAddConnection(NetResourse,Password,LocalName:PChar):longint;
где
NetResourse - имя сетевого ресурса (например '\\P166\c')
Password - пароль на доступ к ресурсу (если нет пароля, то пустая строка)
LocalName - имя, под которым сетевой ресурс будет отображен на данном компьютере (например 'F:')
Пример подключения сетевого диска: WNetAddConnection('\\P166\C','','F:');
Функция возвращает код ошибки. Для всех кодов предописаны константы, наиболее часто используемые:
NO_ERROR - Нет ошибок - успешное завершение
ERROR_ACCESS_DENIED - Ошибка доступа
ERROR_ALREADY_ASSIGNED - Уже подключен. Наиболее часто возникает
при повторном вызове данной функции с
теми-же параметрами.
ERROR_BAD_DEV_TYPE - Неверный тип устройства.
ERROR_BAD_DEVICE - Неверное устройство указано в LocalName
ERROR_BAD_NET_NAME - Неверный сетевой путь или сетевое имя
ERROR_EXTENDED_ERROR - Некоторая ошибка сети (см. функцию
WNetGetLastError для подробностей)
ERROR_INVALID_PASSWORD - Неверный пароль
ERROR_NO_NETWORK - Нет сети
2.Отключить сетевой ресурс
WNetCancelConnection(LocalName:PChar;ForseMode:Boolean):Longint;
где
LocalName - имя, под которым сетевой ресурс был подключен к данному
компьютеру (например 'F:')
ForseMode - режим отключения : False - корректное отключение. Если
отключаемый ресурс еще используется, то отключения не
произойдет (например, на сетевом диске открыт файл)
True - скоростное некорректное отключение. Если ресурс
используется, отключение все равно произойдет и может
привести к любым последствиям (от отсутствия ошибок до
глухого повисания)
Функция возвращает код ошибки. Для всех кодов предописаны константы, наиболее часто используемые:
NO_ERROR - Нет ошибок - успешное завершение
ERROR_DEVICE_IN_USE - Ресурс используется
ERROR_EXTENDED_ERROR - Некоторая ошибка сети (см. функцию
WNetGetLastError для подробностей)
ERROR_NOT_CONNECTED - Указанное ус-во не является сетевым
ERROR_OPEN_FILES - На отключаемом сетевом диске имеются
открытые файлы и параметр ForseMode=false
Рекомендация: при отключении следует сначала попробовать отключить ус-во с параметром ForseMode=false и при ошибке типа ERROR_OPEN_FILES выдать запрос с сообщением о том, что ус-во еще используется и предложением отключить принудительно, и при согласии пользователя повторить вызов с ForseMode=true.
(Взято с http://delphinium.narod.ru/tips/tips/tips.html)



как запустить апплет "панели управления"?

Запустить аплет Панели управления можно вызвав функцию WinExec, для выполнения файла control.exe, которому передано имя аплета. Обычно аплеты панели управления расположены в каталоге System Windows и имеют расширение .cpl.
procedure TForm1.Button1Click(Sender: TObject);
begin
WinExec('C:\WINDOWS\CONTROL.EXE TIMEDATE.CPL',
sw_ShowNormal);
end;
Запускать можете следующие апплеты:
Desk.cpl - свойства экрана
Inetcpl.cpl - свойства Internet
Intl.cpl - свойства "Язык и Стандарты"
Joy.cpl - игровые устройства
Mmsys.cpl - свойства мультимедиа
Modem.cpl - свойства модемы
Netcpl.cpl - сеть
Odbccp32.cpl - ODBC Data Source Administrator
Password.cpl - свойства пароли
Powercfg.cpl - свойства "Управление электропитанием"
Access.cpl - свойства "Специальные возможности"
Sticpl.cpl - свойства "Сканеры м камеры"
Sysdm.cpl - свойства системы
Telephon.cpl - параметры набора номера
Appwiz.cpl - установка и удаление программ
Main.cpl - мышь
Timedate.cpl - свойства "Дата и время"
dtccfg.cpl - настройка клиента MS DTC
Mlcfg32.cpl - свойства Microsoft Outlook
Findfast.cpl - Microsoft FrontPage
bdeadmin.cpl - BDE Administrator
ibmgr.cpl - Interbase manager



как преобразовать rgb-цвет в оттенки серого?

function RgbToGray(RGBColor : TColor) : TColor;
var
Gray : byte;
begin
Gray := Round((0.30 * GetRValue(RGBColor)) +
(0.59 * GetGValue(RGBColor)) +
(0.11 * GetBValue(RGBColor )));
Result := RGB(Gray, Gray, Gray);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
h,w:integer;
begin
for w:=0 to Image1.Width-1 do begin
for h:=0 to Image1.Height-1 do begin
Image2.Canvas.Pixels[w,h]:=RgbToGray(Image2.Canvas.Pixels[w,h]);
end;
end;
end;



обмен данными с excel

В Delphi 5, для обмена данными между Вашим приложением и Excel можно использовать компонент TExcelApplication, доступный на Servers Page в Component Palette.На форме находится TStringGrid, заполненный некоторыми данными и две кнопки, с названиями To Excel и From Excel. Так же на форме находится компонент TExcelApplication со свойством Name, содержащим XLApp и свойством ConnectKind, содержащим ckNewInstance.Когда нам необходимо работать с Excel, то обычно мы открываем ExcelApplication, затем открываем WorkBook и в конце используем WorkSheet.Итак, несомненный интерес представляет для нас листы (WorkSheets) в книге (WorkBook). Давайте посмотрим как всё это работает.
Посылка данных в ExcelЭто можно сделать с помощью следующей процедуры :
procedure TForm1.BitBtnToExcelOnClick(Sender: TObject);
var
WorkBk : _WorkBook; // определяем WorkBook
WorkSheet : _WorkSheet; // определяем WorkSheet
I, J, K, R, C : Integer;
IIndex : OleVariant;
TabGrid : Variant;
begin
if GenericStringGrid.Cells[0,1] <> '' then
begin
IIndex := 1;
R := GenericStringGrid.RowCount;
C := GenericStringGrid.ColCount;
// Создаём массив-матрицу
TabGrid := VarArrayCreate([0,(R - 1),0,(C - 1)],VarOleStr);
I := 0;
// Определяем цикл для заполнения массива-матрицы
repeat
for J := 0 to (C - 1) do
TabGrid[I,J] := GenericStringGrid.Cells[J,I];
Inc(I,1);
until
I > (R - 1);
// Соединяемся с сервером TExcelApplication
XLApp.Connect;
// Добавляем WorkBooks в ExcelApplication
XLApp.WorkBooks.Add(xlWBatWorkSheet,0);
// Выбираем первую WorkBook
WorkBk := XLApp.WorkBooks.Item[IIndex];
// Определяем первый WorkSheet
WorkSheet := WorkBk.WorkSheets.Get_Item(1) as _WorkSheet;
// Сопоставляем Delphi массив-матрицу с матрицей в WorkSheet
Worksheet.Range['A1',Worksheet.Cells.Item[R,C]].Value := TabGrid;
// Заполняем свойства WorkSheet
WorkSheet.Name := 'Customers';
Worksheet.Columns.Font.Bold := True;
Worksheet.Columns.HorizontalAlignment := xlRight;
WorkSheet.Columns.ColumnWidth := 14;
// Заполняем всю первую колонку
WorkSheet.Range['A' + IntToStr(1),'A' + IntToStr(R)].Font.Color := clBlue;
WorkSheet.Range['A' + IntToStr(1),'A' + IntToStr(R)].HorizontalAlignment := xlHAlignLeft;
WorkSheet.Range['A' + IntToStr(1),'A' + IntToStr(R)].ColumnWidth := 31;
// Показываем Excel
XLApp.Visible[0] := True;
// Разрываем связь с сервером
XLApp.Disconnect;
// Unassign the Delphi Variant Matrix
TabGrid := Unassigned;
end;
end;
Получение данных из Excel
Это можно сделать с помощью следующей процедуры procedure TForm1.BitBtnFromExcelOnClick(Sender: TObject);
var
WorkBk : _WorkBook;
WorkSheet : _WorkSheet;
K, R, X, Y : Integer;
IIndex : OleVariant;
RangeMatrix : Variant;
NomFich : WideString;
begin
NomFich := ‘C:\MyDirectory\NameOfFile.xls’;
IIndex := 1;
XLApp.Connect;
// Открываем файл Excel
XLApp.WorkBooks.Open(NomFich,EmptyParam,EmptyParam,EmptyParam,EmptyParam, EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,0);
WorkBk := XLApp.WorkBooks.Item[IIndex];
WorkSheet := WorkBk.WorkSheets.Get_Item(1) as _WorkSheet;
// Чтобы знать размер листа (WorkSheet), т.е. количество строк и количество
// столбцов, мы активируем его последнюю непустую ячейку
WorkSheet.Cells.SpecialCells(xlCellTypeLastCell,EmptyParam).Activate;
// Получаем значение последней строки
X := XLApp.ActiveCell.Row;
// Получаем значение последней колонки
Y := XLApp.ActiveCell.Column;
// Определяем количество колонок в TStringGrid
GenericStringGrid.ColCount := Y;
// Сопоставляем матрицу WorkSheet с нашей Delphi матрицей
RangeMatrix := XLApp.Range['A1',XLApp.Cells.Item[X,Y]].Value;
// Выходим из Excel и отсоединяемся от сервера
XLApp.Quit;
XLApp.Disconnect;
// Определяем цикл для заполнения TStringGrid
K := 1;
repeat
for R := 1 to Y do
GenericStringGrid.Cells[(R - 1),(K - 1)] := RangeMatrix[K,R];
Inc(K,1);
GenericStringGrid.RowCount := K + 1;
until
K > X;
// Unassign the Delphi Variant Matrix
RangeMatrix := Unassigned;
end;



сумма прописью №1

Создавайте отдельный модуль, где будут расположена эта функция, и подключайте его в нужные проекты.
Здесь опубликовывается конечный вид модуля:
unit FullSum;
interface
uses SysUtils;
{ Функция перевода суммы, записанной цифрами в сумму прописью :
например, 23.12 -> двадцать три рубля 12 копеек.
переводит до 999999999 руб. 99 коп.
Функция не отслеживает, правильное ли значение получено в параметре Number
(т.е. положительное и округленное с точностью до сотых) - эту проверку
необходимо провести до вызова функции.}
//----------------- Copyright (c) 1999 by Константин Егоров
//----------------- mailto: egor@vladi.elektra.ru
function SumNumToFull(Number:real):string;
implementation
function SumNumToFull(Number:real):string;
var
PartNum, TruncNum, NumTMP, D: integer;
NumStr : string;
i, R : byte;
Flag11 : boolean;
begin
D:=1000000;
R:=4;
TruncNum:=Trunc(Number); //выделяем рубли
if TruncNum<>0
then
repeat
PartNum:=TruncNum div D;
Dec(R);
D:=D div 1000;
until PartNum<>0
else
R:=0;
// перевод рублей
FOR i:=R DOWNTO 1 DO
BEGIN
Flag11:=False;
NumTMP:=PartNum div 100; {выделение цифры сотен}
case NumTMP of
1: NumStr:=NumStr+'сто ';
2: NumStr:=NumStr+'двести ';
3: NumStr:=NumStr+'триста ';
4: NumStr:=NumStr+'четыреста ';
5: NumStr:=NumStr+'пятьсот ';
6: NumStr:=NumStr+'шестьсот ';
7: NumStr:=NumStr+'семьсот ';
8: NumStr:=NumStr+'восемьсот ';
9: NumStr:=NumStr+'девятьсот ';
end;
NumTMP:=(PartNum mod 100) div 10; {выделение цифры десятков }
case NumTMP of
1: begin
NumTMP:=PartNum mod 100;
case NumTMP of
10: NumStr:=NumStr+'десять ';
11: NumStr:=NumStr+'одиннадцать ';
12: NumStr:=NumStr+'двенадцать ';
13: NumStr:=NumStr+'тринадцать ';
14: NumStr:=NumStr+'четырнадцать ';
15: NumStr:=NumStr+'пятнадцать ';
16: NumStr:=NumStr+'шестнадцать ';
17: NumStr:=NumStr+'семнадцать ';
18: NumStr:=NumStr+'восемнадцать ';
19: NumStr:=NumStr+'девятнадцать ';
end;
case i of
3: NumStr:=NumStr+'миллионов ';
2: NumStr:=NumStr+'тысяч ';
1: NumStr:=NumStr+'рублей ';
end;
Flag11:=True;
end;
2: NumStr:=NumStr+'двадцать ';
3: NumStr:=NumStr+'тридцать ';
4: NumStr:=NumStr+'сорок ';
5: NumStr:=NumStr+'пятьдесят ';
6: NumStr:=NumStr+'шестьдесят ';
7: NumStr:=NumStr+'семьдесят ';
8: NumStr:=NumStr+'восемьдесят ';
9: NumStr:=NumStr+'девяносто ';
end;
NumTMP:=PartNum mod 10; {выделение цифры единиц}
if not Flag11 then
begin
case NumTMP of
1: if i=2 then NumStr:=NumStr+'одна ' else NumStr:=NumStr+'один ';
2: if i=2 then NumStr:=NumStr+'две ' else NumStr:=NumStr+'два ';
3: NumStr:=NumStr+'три ';
4: NumStr:=NumStr+'четыре ';
5: NumStr:=NumStr+'пять ';
6: NumStr:=NumStr+'шесть ';
7: NumStr:=NumStr+'семь ';
8: NumStr:=NumStr+'восемь ';
9: NumStr:=NumStr+'девять ';
end;
case i of
3: case NumTMP of
1 : NumStr:=NumStr+'миллион ';
2,3,4: NumStr:=NumStr+'миллиона ';
else NumStr:=NumStr+'миллионов ';
end;
2: case NumTMP of
1 : NumStr:=NumStr+'тысяча ';
2,3,4: NumStr:=NumStr+'тысячи ';
else if PartNum<>0 then NumStr:=NumStr+'тысяч ';
end;
1: case NumTMP of
1 : NumStr:=NumStr+'рубль ';
2,3,4: NumStr:=NumStr+'рубля ';
else NumStr:=NumStr+'рублей ';
end;
end;
end;
if i>1 then begin
PartNum:=(TruncNum mod (D*1000)) div D;
D:=D div 1000;
end;
END;
//перевод копеек
PartNum:=Round(Frac(Number)*100);
if PartNum=0 then
begin
SumNumToFull:=NumStr+'00 копеек';
Exit;
end;
NumTMP:=PartNum div 10; {выделение цифры десятков }
if NumTMP=0 then NumStr:=NumStr+'0'+IntToStr(PartNum)+' '
else NumStr:=NumStr+IntToStr(PartNum)+' ';
NumTMP:=PartNum mod 10; {выделение цифры единиц}
case NumTMP of
1: if PartNum<>11 then NumStr:=NumStr+'копейка'
else NumStr:=NumStr+'копеек';
2,3,4: if (PartNum<5) or (PartNum>14)
then NumStr:=NumStr+'копейки'
else NumStr:=NumStr+'копеек';
else NumStr:=NumStr+'копеек';
end;
SumNumToFull:=NumStr;
end; //---SumNumToFull
end.



сумма прописью №2

{ Преобразует трехзначное число в строку }
function ConvertToWord(N : word) : string;
Const
Sot : array[1..9] of string[13] =
('сто','двести','триста','четыреста','пятьсот',
'шестьсот','семьсот','восемьсот','девятьсот');
Des : array[2..9] of string[13] =
('двадцать','тридцать','сорок','пятьдесят',
'шестьдесят','семьдесят','восемьдесят','девяносто');
Edin : array[0..19] of string[13] =
('','один','два','три','четыре','пять','шесть','семь',
'восемь','девять','десять','одиннадцать','двенадцать',
'тринадцать','четырнадцать','пятнадцать',
'шестнадцать','семнадцать','восемнадцать','девятнадцать');
Var S : string;
begin
S:=''; N:=N mod 1000;
if N>99 then begin
S:=Sot[N div 100]+' '; N:=N mod 100;
end;
if N>19 then begin
S:=S+Des[N div 10]+' '; N:=N mod 10;
end;
Result:=S+Edin[N];
end;
{ Возвращает сумму прописью }
function CenaToStr(r : Currency) : string;
Var
N,k : longint;
S : string;
begin
N:=trunc(R); S:='';
if N<>0 then begin
if N>999999 then begin
k:=N div 1000000;
S:=ConvertToWord(k);
if ((k-(k div 100)*100)>10) and ((k-(k div 100)*100)<20) then S:=S+' миллионов' else
if (k mod 10)=1 then S:=S+' миллион' else
if ((k mod 10)>=2)and((k mod 10)<=4) then S:=S+' миллиона' else
S:=S+' миллионов';
N:=N mod 1000000;
end;
if N>999 then begin
k:=N div 1000;
S:=S+' '+ConvertToWord(k);
if ((k-(k div 100)*100)>10)and((k-(k div 100)*100)<20) then S:=S+' тысяч' else
if (k mod 10)=1 then begin SetLength(S, Length(S)-2); S:=S+'на тысяча'; end else
if (k mod 10)=2 then begin SetLength(S, length(S)-1); S:=S+'е тысячи'; end else
if ((k mod 10)>=3)and((k mod 10)<=4) then S:=S+' тысячи' else
S:=S+' тысяч';
N:=N mod 1000;
end; k:=N;
S:=S+' '+ConvertToWord(k);
if ((k-(k div 100)*100)>10)and((k-(k div 100)*100)<20) then S:=S+' рублей' else
if (k mod 10)=1 then S:=S+' рубль' else
if (k mod 10)=2 then S:=S+' рубля' else
if ((k mod 10)>=3)and((k mod 10)<=4) then S:=S+' рубля' else
S:=S+' рублей';
end;
if trunc(R)<>R then begin
k:=round(frac(R)*100);
S:=S+' '+IntToStr(K);
if ((k-(k div 100)*100)>10)and((k-(k div 100)*100)<20) then S:=S+' копеек' else
if (k mod 10)=1 then begin S:=S+' копейка'; end else
if (k mod 10)=2 then begin S:=S+' копейки'; end else
if ((k mod 10)>=3)and((k mod 10)<=4) then S:=S+' копейки' else
S:=S+' копеек';
end else S:=S+' 00 копеек';
S:=Trim(S);
if S<>'' then S[1]:=AnsiUpperCase(S[1])[1];
result:=S;
end;



сумма прописью №3

unit sumstr;
interface
uses
SysUtils, StrUtils;
function SumToString(Value : String) : string;
implementation
const a:array[0..8,0..9] of string=(
('','один ','два ','три ','четыре ','пять ','шесть ','семь ','восемь ','девять '),
('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),
('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '),
('тысяч ','тысяча ','две тысячи ','три тысячи ','четыре тысячи ','пять тысячь ','шесть тысячь ','семь тысячь ',
'восемь тысячь ','девять тысячь '),
('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),
('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '),
('миллионов ','один миллион ','два миллиона ','три миллиона ','четыре миллиона ','пять миллионов ',
'шесть миллионов ','семь миллионов ','восемь миллионов ','девять миллионов '),
('','','двадцать ','тридцать ','сорок ','пятьдесят ','шестьдесят ','семьдесят ','восемьдесят ','девяносто '),
('','сто ','двести ','триста ','четыреста ','пятьсот ','шестьсот ','семьсот ','восемьсот ','девятьсот '));
b:array[0..9] of string=
('десять ','одинадцать ','двенадцать ','тринадцать ','четырнадцать ','пятьнадцать ','шестьнадцать ',
'семьнадцать ','восемьнадцать ','девятьнадцать ');
function SumToStrin(Value : String) : string;
var s,t:string;
p,pp,i,k:integer;
begin
s:=value;
if s='0' then t:='Ноль ' else begin
p:=length(s);
pp:=p;
if p>1 then
if (s[p-1]='1') and (s[p]>'0') then begin
t:=b[strtoint(s[p])];pp:=pp-2;end;
i:=pp;
while i>0 do begin
if (i=p-3) and (p>4) then
if s[p-4]='1' then begin
t:=b[strtoint(s[p-3])]+'тысяч '+t;i:=i-2;end;
if (i=p-6) and (p>7) then
if s[p-7]='1' then begin
t:=b[strtoint(s[p-6])]+'миллионов '+t;
i:=i-2;end;
if i>0 then begin k:=strtoint(s[i]);
t:=a[p-i,k]+t;
i:=i-1;end;
end;end;
result:=t;
end;
procedure get2str(value:string;var hi,lo:string);
var p:integer;
begin
p:=pos(',',value);
lo:='';hi:='';
if p=0 then p:=pos('.',value);
if p<>0 then delete(value,p,1);
if p=0 then begin hi:=value;lo:='00';end;
if p>length(value) then begin hi:=value;lo:='00';end;
if p=1 then begin hi:='0';lo:=value;end;
if (p>1) and (pthen
begin
hi:=copy(value,1,p-1);
lo:=copy(value,p,length(value));
end;
end;
function sumtostring(value:string):string;
var hi,lo:string;
pr,er:integer;
begin
get2str(value,hi,lo);
if (hi='') or (lo='') then begin result:='';exit;end;
val(hi,pr,er);if er<>0 then begin result:='';exit;end;
hi:=sumtostrin(inttostr(pr))+'руб. ';
if lo<>'00' then begin
val(lo,pr,er);if er<>0 then begin result:='';exit;end;
lo:=inttostr(pr);
end;
lo:=lo+' коп. ';
hi[1]:=AnsiUpperCase(hi[1])[1];
result:=hi+lo;
end;
end.



как скопировать все файлы вместе с подкаталогами

Опишите нажатие кнопки следующим образом, а вместо выделенного полужирным шрифтом кода подставьте свой:
procedure TForm1.Button1Click(Sender: TObject);
var
OpStruc: TSHFileOpStruct;
frombuf, tobuf: Array [0..128] of Char;
Begin
FillChar( frombuf, Sizeof(frombuf), 0 );
FillChar( tobuf, Sizeof(tobuf), 0 );
StrPCopy( frombuf, 'c:\1\*.*' );
StrPCopy( tobuf, 'c:\2' );
With OpStruc DO Begin
Wnd:= Handle;
wFunc:= FO_COPY;
pFrom:= @frombuf;
pTo:=@tobuf;
fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
fAnyOperationsAborted:= False;
hNameMappings:= Nil;
lpszProgressTitle:= Nil;
end;
ShFileOperation( OpStruc );
end;




получение информации о taskbar

Для вывода информации мы будет использовать компонент TStringGrid с закладки Additional.
Сначала вам нужно будет после
var
Form1: TForm1;
добавить следующий код:
AppBarData : TAppBarData;
bAlwaysOnTop,
bAutoHide : boolean;
Clrect,rect : TRect;
Edge:UInt;
затем после слова Implementation пишем
procedure DetectTaskBar;
begin
AppBarData.hWnd := FindWindow('Shell_TrayWnd', nil);
AppBarData.cbSize := sizeof(AppBarData);
bAlwaysOnTop := (SHAppBarMessage(ABM_GETSTATE, AppBardata) and ABS_ALWAYSONTOP) <> 0;
bAutoHide := (SHAppBarMessage(ABM_GETSTATE, AppBardata) and ABS_AUTOHIDE) <>0;
GetClientRect(AppBarData.hWnd, Clrect);
GetWindowRect(AppBarData.hwnd, rect);
if (rect.top > 0) then Edge := ABE_BOTTOM
else if (rect.bottom < screen.height) then Edge:=ABE_TOP
else if rect.right < screen.width then Edge:=ABE_LEFT
else Edge:=ABE_RIGHT;
end;
и осталось описать самое главное - обработчик нажатия кнопки:
procedure TForm1.Button1Click(Sender: TObject);
begin
DetectTaskBar;
StringGrid1.Cells[0,0]:='Выше других окон';
StringGrid1.Cells[0,1]:='Автоматически убирать с экрана';
StringGrid1.Cells[0,2]:='Клиентская область';
StringGrid1.Cells[0,3]:='Оконная область';
StringGrid1.Cells[0,4]:='Края';
if bAlwaysOnTop=true then StringGrid1.Cells[1,0]:='true' else StringGrid1.Cells[1,0]:='false';
if bAutoHide=true then StringGrid1.Cells[1,1]:='true' else StringGrid1.Cells[1,1]:='false';
StringGrid1.Cells[1,2]:=IntToStr(Clrect.Left)+':'+IntToStr(Clrect.Top)+':'+IntToStr(Clrect.Right)+':'+IntToStr(Clrect.Bottom);
StringGrid1.Cells[1,3]:=IntToStr(rect.Left)+':'+IntToStr(rect.Top)+':'+IntToStr(rect.Right)+':'+IntToStr(rect.Bottom);
StringGrid1.Cells[1,4]:=IntToStr(Edge);
end;



как программно переключить раскладку клавиатуры

Выносим на форму две кнопки и описываем следующим образом их нажатия:
procedure TForm1.Button1Click(Sender: TObject);//На русский
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE);
end;
procedure TForm1.Button2Click(Sender: TObject);//На английский
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE);
end;



как изменить принтер по умолчанию

Легко ?:-)
uses IniFiles;
procedure TForm1.Button1Click(Sender: TObject);
var WinIni : TIniFile;
WinIniFileName : array[0..MAX_PATH] of char;
s : array[0..64] of char;
begin
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini');
WinIni := TIniFile.Create(WinIniFileName);
try
WinIni.WriteString('windows','device', 'HP LaserJet Series II,HPPCL,LPT1:');
finally
WinIni.Free;
end;
StrCopy(S, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;



создание компонентов во время выполнения программы и обработка их событий

В данном примере по созданию окна создаются кнопки, по нажатию каждой выводится сообщение, в котором значится заголовок кнопки, вызвавшей событие. Сначала вынесите на форму компонент TButton и по его нажатию напишите такой код:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage((Sender as TButton).Caption);
end;
А основное действие свершится по созданию окна: procedure TForm1.FormCreate(Sender: TObject);
var
Button1:TButton;
i:integer;
begin
for i:=0 to 4 do begin
Button1:=TButton.Create(Form1);
Button1.Parent:=Form1;
Button1.Caption:='Кнопка '+IntToStr(i+1);
Button1.Height:=25;
Button1.Width:=75;
Button1.Top:=i*25+25;
Button1.Left:=50;
Button1.OnClick:=Button1Click;
end;
end;




как определить когда мышь над компонентом, а когда она ушла с него

Для того, чтобы определить когда мышь над компонентом, в данном примере это будет панель, мы создадим новый класс, который будет являться потомком класса TPanel, и будет обрабатывать некоторые необходимые нам для данной задачи сообщения Windows.
Для этого определим следующим образом новый тип:
type TMyPanel=class(TPanel)
public
procedure CMMouseEnter (var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave (var Message: TMessage); message CM_MOUSELEAVE;
end;
Называться наш новый класс будет TMyPanel. Определить его можете до определение класса формы, т.е. сразу после директивы uses. После объявления экземпляра формы нужно объявить экземпляр нашего нового класса:
var
Form1: TForm1;
MyPanel1:TMyPanel;
В разделе implemetation обрабатываем несколько сообщения, именно этими обработчиками наш класс и будет отличаться от класса стандартной панели.
procedure TMyPanel.CMMouseEnter (var Message: TMessage);
begin
Form1.Label1.Caption:='Мышь на панели';
end;
procedure TMyPanel.CMMouseLEAVE (var Message: TMessage);
begin
Form1.Label1.Caption:='Мышь вне панели';
end;
По созданию окна создаём экземпляр нашего класса:
procedure TForm1.FormCreate(Sender: TObject);
begin
MyPanel1:=TMyPanel.Create(self);
MyPanel1.Parent:=Form1;
MyPanel1.Visible:=True;
MyPanel1.Left:=100;
MyPanel1.Top:=100;
end;
По уничтожению окна, соответственно, - уничтожаем:
procedure TForm1.FormDestroy(Sender: TObject);
begin
MyPanel1.Destroy;
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;




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

Объявляем сначала две глобальные переменные: var
si:Tstartupinfo;
p:Tprocessinformation;
Затем по нужному событию, например, по нажатию на кнопке пишет такой код:
FillChar( Si, SizeOf( Si ) , 0 );
with Si do
begin
cb := SizeOf( Si);
dwFlags := startf_UseShowWindow;
wShowWindow := 4;
end;
Form1.WindowState:=wsminimized;
Createprocess(nil,'c:\windows\sndrec32.exe e:\temp.wav',nil,nil,false,Create_default_error_mode,nil,nil,si,p);
Waitforsingleobject(p.hProcess,infinite);
Form1.WindowState:=wsNormal;



если приложение долго выполняет какой-то цикл, как сделать так, чтобы другие приложения не подвисали?

Нужно вставить в тело цикла: 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;



как программно создать ярлык?

Для начала подключите следующие модули: uses ShlObj, ComObj, ActiveX;
А затем используёте процедуру создания ярлыка: procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
var
IObject: IUnknown;
SLink: IShellLink;
PFile: IPersistFile;
begin
IObject := CreateComObject(CLSID_ShellLink);
SLink := IObject as IShellLink;
PFile := IObject as IPersistFile;
with SLink do begin
SetArguments(PChar(Param));
SetDescription(PChar(Desc));
SetPath(PChar(PathObj));
end;
PFile.Save(PWChar(WideString(PathLink)), FALSE);
end;




как установить драйвер принтера

Приведенный пример устанавливает драйвер принтера. Вам необходимо скопировать файлы с драйвером принтера в каталог Windows\System и внести необходимые изменения в файл Win.Ini.
Примечание:
DriverName = Имя драйвера;
DRVFILE - имя файла с драйвером без расширения
(".drv" - по умолчанию).
Пример: procedure TForm1.Button1Click(Sender: TObject);
var
s : array[0..64] of char;
begin
WriteProfileString('PrinterPorts',
'DriverName',
'DRVFILE,FILE:,15,45');
WriteProfileString('Devices',
'DriverName',
'DRVFILE,FILE:');
StrCopy(S, 'PrinterPorts');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
StrCopy(S, 'Devices');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;



как набрать номер по модему. голосовой звонок.

До слова implementation напишите такой код:
{tapi Errors}
const TAPIERR_CONNECTED = 0;
const TAPIERR_DROPPED = -1;
const TAPIERR_NOREQUESTRECIPIENT = -2;
const TAPIERR_REQUESTQUEUEFULL = -3;
const TAPIERR_INVALDESTADDRESS = -4;
const TAPIERR_INVALWINDOWHANDLE = -5;
const TAPIERR_INVALDEVICECLASS = -6;
const TAPIERR_INVALDEVICEID = -7;
const TAPIERR_DEVICECLASSUNAVAIL = -8;
const TAPIERR_DEVICEIDUNAVAIL = -9;
const TAPIERR_DEVICEINUSE = -10;
const TAPIERR_DESTBUSY = -11;
const TAPIERR_DESTNOANSWER = -12;
const TAPIERR_DESTUNAVAIL = -13;
const TAPIERR_UNKNOWNWINHANDLE = -14;
const TAPIERR_UNKNOWNREQUESTID = -15;
const TAPIERR_REQUESTFAILED = -16;
const TAPIERR_REQUESTCANCELLED = -17;
const TAPIERR_INVALPOINTER = -18;
{tapi size constants}
const TAPIMAXDESTADDRESSSIZE = 80;
const TAPIMAXAPPNAMESIZE = 40;
const TAPIMAXCALLEDPARTYSIZE = 40;
const TAPIMAXCOMMENTSIZE = 80;
const TAPIMAXDEVICECLASSSIZE = 40;
const TAPIMAXDEVICEIDSIZE = 40;
function tapiRequestMakeCallA(DestAddress : PAnsiChar;
AppName : PAnsiChar;
CalledParty : PAnsiChar;
Comment : PAnsiChar) : LongInt;
stdcall; external 'TAPI32.DLL';
function tapiRequestMakeCallW(DestAddress : PWideChar;
AppName : PWideChar;
CalledParty : PWideChar;
Comment : PWideChar) : LongInt;
stdcall; external 'TAPI32.DLL';
function tapiRequestMakeCall(DestAddress : PChar;
AppName : PChar;
CalledParty : PChar;
Comment : PChar) : LongInt;
stdcall; external 'TAPI32.DLL';
Нажатие кнопки обработайте следующим образом:
procedure TForm1.Button1Click(Sender: TObject);
var
DestAddress : string;
CalledParty : string;
Comment : string;
begin
DestAddress :={phone number}'11-11-11';
CalledParty := 'HYPER-X';
Comment := 'Calling to Hyper-x';
tapiRequestMakeCall(pChar(DestAddress),
PChar(Application.Title),
pChar(CalledParty),
PChar(Comment));
end;



как вызвать диалог "найти файлы и папки" проводника?

Нужно сначала объявить модуль ddeman
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Registry, DdeMan;
И затем обработать нажатие кнопки следующим образом: procedure TForm1.Button1Click(Sender: TObject);
begin
with TDDEClientConv.Create(Self) do begin
ConnectMode := ddeManual;
ServiceApplication := 'explorer.exe';
SetLink( 'Folders', 'AppProperties');
OpenLink;
ExecuteMacro('[FindFolder(, C:\Мои документы)]', False);
CloseLink;
Free;
end;
end;
После этого у пользователя появится диалог поиска, с заданной папкой "Мои документы" в качестве пути.



как увеличить процессорное время, выделяемое программе

Следующий пример изменяет приоритет приложения. Изменение приоритета следует использовать с осторожностью - т.к. присвоение слишком высокого приоритета может привести к медленной работе остальных программ и системы в целом ;-)
procedure TForm1.Button1Click(Sender: TObject);
var
ProcessID : DWORD;
ProcessHandle : THandle;
ThreadHandle : THandle;
begin
ProcessID := GetCurrentProcessID;
ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION,
false,
ProcessID);
SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
ThreadHandle := GetCurrentThread;
SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;




вывод диалога для выбора каталога

Подключаем модули: uses ShellAPI, ShlObj;
procedure TForm1.Button1Click(Sender: TObject);
var
TitleName : string;
lpItemID : PItemIDList;
BrowseInfo : TBrowseInfo;
DisplayName : array[0..MAX_PATH] of char;
TempPath : array[0..MAX_PATH] of char;
begin
FillChar(BrowseInfo, sizeof(TBrowseInfo), #0);
BrowseInfo.hwndOwner := Form1.Handle;
BrowseInfo.pszDisplayName := @DisplayName;
TitleName := 'Please specify a directory';
BrowseInfo.lpszTitle := PChar(TitleName);
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
lpItemID := SHBrowseForFolder(BrowseInfo);
if lpItemId <> nil then begin
SHGetPathFromIDList(lpItemID, TempPath);
ShowMessage(TempPath);
GlobalFreePtr(lpItemID);
end;
end;



как определить состояние модема под win32

procedure TForm1.Button2Click(Sender: TObject);
var
CommPort : string;
hCommFile : THandle;
ModemStat : DWord;
begin
CommPort := 'COM2';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_READ,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;
{Get the Modem Status}
if GetCommModemStatus(hCommFile, ModemStat) <> false then begin
if ModemStat and MS_CTS_ON <> 0 then
ShowMessage('The CTS (clear-to-send) is on.');
if ModemStat and MS_DSR_ON <> 0 then
ShowMessage('The DSR (data-set-ready) is on.');
if ModemStat and MS_RING_ON <> 0then
ShowMessage('The ring indicator is on.');
if ModemStat and MS_RLSD_ON <> 0 then
ShowMessage('The RLSD (receive-line-signal-detect) is on.');
end;
{Close the comm port}
CloseHandle(hCommFile);
end;



как добавить пункт к системному меню приложения

Системное меню вызывается по нажатию на иконку окна. Оно содержит такие команды как "Развернуть", "Восстановить", "Переместить" и т.д. Так вот, теперь у вас появилась возможность добавлять новые пункты к системному меню приложения и обрабатывать их нажатие! Для этого воспользуемся функцией AppendMenu(). В качестве параметров этой функции нужно указать:
Дескриптор того меню, которое мы хотим изменять
Флаг, контролирующий появление и поведение пункта меню. может принимать следующие значения:
MF_BITMAP Для использование изображение в качестве пункта меню. Тогда послежний параметр должен содержать дескриптор изображения.
MF_CHECKED Устанавливает контрольную метку возле пункта меню.
MF_DISABLED Показывает, что пункт меню будет неактивным. Его нельзя будет выделить и он приобретёт серое состояние.
MF_ENABLED Делает пункт меню активным.
MF_GRAYED Делает пункт меню недоступным.
MF_MENUBARBREAK Функция похожа на MF_MENUBREAK. Позволяет последующие пункты меню размещать в новой колонке, отделяемой от текущей вертикальной чертой.
MF_MENUBREAK Позволяет последующие пункты меню размещать в новой колонке, но не отделяет их вертикальной линией.
MF_OWNERDRAW Указывает, что пункт меню должен будет прорисовываться самостоятельно. До отображения меню в первый раз окно посылает сообщение WM_MEASUREITEM для того, чтобы узнать какой должна быть ширина меню. Так же посылает сообщение WM_DRAWITEM в тот момент, когда пункт меню должен обновляться.
MF_POPUP Характеризует меню, которое будет открывать подменю или контекстное меню. Тогда последний параметр должен содержать дескриптор этого пункта меню.
MF_SEPARATOR Отделительная горизонтальная линия. Линия не может становиться неактивной или активной. В данном случае последний параметр будет игнорироваться.
MF_STRING Показывает, что пункт меню будет содержать строку, которая должна быть указана в последнем параметре.
MF_UNCHECKED Снимает контрольную метку около пункта меню.
Идентификатор нового пункта меню. Если значение флага MF_POPUP, тогда этот параметр должен содержать дескриптор контекстного меню.
Содержание нового пункта меню. Так же зависит от значения флага. Если он содержит такие константа как MF_BITMAP, MF_OWNERDRAW или MF_STRING, тогда здесь нужно указывать: дескриптор изображения, собственную прорисовку пункта меню или строку.
Если функция выполняется успешно - она возвращает значение отличное от нуля, в противном случае - 0.
Давайте разберём пример:
Создайте новой приложение и по созданию окна [Событие OnCreate()] напишите такой код:
procedure TForm1.FormCreate(Sender: TObject);
begin
AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, '');
AppendMenu(GetSystemMenu(Handle, FALSE),MF_STRING,SC_MyMenuItem,'КРУТО, да!!!');
end;
Здесь мы добавляем два новых пункта в системное меню приложения. Сначала разделительную горизонтальную линию, о чём свидетельствует значение флага MF_SEPARATOR, а затем, пункт меню, который будет содержать строку. Это видно по значению флага MF_STRING. Сама строка, как вы видите указывается в последнем пункте меню. Но это ещё не всё, так же нужно предусмотреть вариант, когда пользователь нажмёт на наш новый пункт меню. Нужно генерировать новое сообщение Windows и обрабатывать его. Для этого в частных объявлениях, т.е. в директиве private напишем такой код:
private
{ Private declarations }
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
В разделе implementation напишем следующее:
const
SC_MyMenuItem = WM_USER + 1;
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if Msg.CmdType = SC_MyMenuItem then
ShowMessage('Был нажат наш пункт меню!!!') else
inherited;
end;
Ну вот, вообщем-то и всё! Теперь компилируйте и тестируйте приложение.



можно ли скопировать группу файлов, используя стандартный диалог с анимацией?

Сначала в разделе uses объявляем модуль ShellAPI
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI;
Затем следующим образом обрабатываем нажатие кнопки:
procedure TForm1.Button1Click(Sender: TObject);
var
Fo : TSHFileOpStruct;
buffer : array[0..4096] of char;
p : pchar;
begin
FillChar(Buffer, sizeof(Buffer), #0);
p := @buffer;
p := StrECopy(p, 'C:\first.rar') + 1; //Начали подключение файлов, предназначенных для копирования
p := StrECopy(p, 'C:\second.rar') + 1;
p := StrECopy(p, 'C:\third.rar') + 1;
p := StrECopy(p, 'C:\5.rar') + 1;
p := StrECopy(p, 'C:\6.rar') + 1;
p := StrECopy(p, 'C:\7.rar') + 1;
FillChar(Fo, sizeof(Fo), #0);
Fo.Wnd := Handle;
Fo.wFunc := FO_COPY; //Действие
Fo.pFrom := @Buffer; //Источник
Fo.pTo := 'c:\1\'; //Назначение - показываем куда копируем
Fo.fFlags := 0;
if ((SHFileOperation(Fo) <> 0) or
(Fo.fAnyOperationsAborted <> false)) then
ShowMessage('Cancelled')
end;
Заметим, что в качестве действия мы указали константу FO_COPY - это значит, что решено копировать файлы, помимо этого значения можно также указывать:FO_COPY
FO_DELETE
FO_MOVE
FO_RENAME



как определить тип дискового накопителя

Нужно воспользоваться API функцией GetDriveType().
procedure TForm1.Button1Click(Sender: TObject);
begin
case GetDriveType('C:\') of
0 : ShowMessage('The drive type cannot be determined');
1 : ShowMessage('The root directory does not exist');
DRIVE_REMOVABLE:ShowMessage('The disk can be removed');
DRIVE_FIXED : ShowMessage('The disk cannot be removed');
DRIVE_REMOTE : ShowMessage('The drive is remote (network) drive');
DRIVE_CDROM : ShowMessage('The drive is a CD-ROM drive');
DRIVE_RAMDISK : ShowMessage('The drive is a RAM disk');
end;
end;




как проверить готовность диска без появления окна ошибки windows?

Вы можете использовать функцию Windows API SetErrorMode() для отключения диалога Window's critical Error.
Сначала определяем нужную функцию:
function IsDriveReady(DriveLetter : char) : bool;
var
OldErrorMode : Word;
OldDirectory : string;
begin
OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
GetDir(0, OldDirectory);
{$I-}
ChDir(DriveLetter + ':\');
{$I+}
if IoResult <> 0 then
Result := False
else
Result := True;
ChDir(OldDirectory);
SetErrorMode(OldErrorMode);
end;
...затем используем её:
if not IsDriveReady('A') then
ShowMessage('Drive Not Ready') else
ShowMessage('Drive is Ready');




как вызвать диалог "найти файлы и папки" проводника?

Нужно сначала объявить модуль ddeman
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Registry, DdeMan;
И затем обработать нажатие кнопки следующим образом: procedure TForm1.Button1Click(Sender: TObject);
begin
with TDDEClientConv.Create(Self) do begin
ConnectMode := ddeManual;
ServiceApplication := 'explorer.exe';
SetLink( 'Folders', 'AppProperties');
OpenLink;
ExecuteMacro('[FindFolder(, C:\Мои документы)]', False);
CloseLink;
Free;
end;
end;
После этого у пользователя появится диалог поиска, с заданной папкой "Мои документы" в качестве пути.




как переслать файл в корзину?

Сначала нужно в директиве uses подключить модуль ShellAPI, чтобы мы смогли воспользоваться API-функцией SHFileOperation(). А затем уже можно использовать такой вот процедурой:
procedure SendToPomoyka(FileName: string);
var
SHF: TSHFileOpStruct;
begin
with SHF do begin
Wnd := Application.Handle;
wFunc := FO_DELETE;
pFrom := PChar(FileName);
fFlags := FOF_SILENT or FOF_ALLOWUNDO;
end;
SHFileOperation(SHF);
end;





как узнать переменные окружения

Опишем обработчик события по нажатию на кнопку следующим образом:
procedure TForm1.Button5Click(Sender: TObject);
var
p : pChar;
begin
Memo1.Lines.Clear;
Memo1.WordWrap := false;
{$IFDEF WIN32}
p := GetEnvironmentStrings;
{$ELSE}
p := GetDOSEnvironment;
{$ENDIF}
while p^ <> #0 do begin
Memo1.Lines.Add(StrPas(p));
inc(p, lStrLen(p) + 1);
end;
{$IFDEF WIN32}
FreeEnvironmentStrings(p);
{$ENDIF}
end;




как программно изменить текущий порт принтера

Используем метод SetPrinter класса TPrinter.
Пример: uses Printers;
{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}
procedure TForm1.Button1Click(Sender: TObject);
var
pDevice : pChar;
pDriver : pChar;
pPort : pChar;
hDMode : THandle;
PDMode : PDEVMODE;
begin
if PrintDialog1.Execute then begin
GetMem(pDevice, cchDeviceName);
GetMem(pDriver, MAX_PATH);
GetMem(pPort, MAX_PATH);
Printer.GetPrinter(pDevice, pDriver, pPort, hDMode);
Printer.SetPrinter(pDevice, PDriver, 'FILE:', hDMode);
FreeMem(pDevice, cchDeviceName);
FreeMem(pDriver, MAX_PATH);
FreeMem(pPort, MAX_PATH);
Printer.BeginDoc;
Printer.Canvas.TextOut(100, 100, 'Delphi Is RAD!');
Printer.EndDoc;
end;
end;



копирование файлов [4 способа]

Копирование методом TurboPascal Type
TCallBack=procedure (Position,Size:Longint); {Для индикации
процесса копирования}
procedure FastFileCopy(Const InfileName, OutFileName: String;
CallBack: TCallBack);
Const BufSize = 3*4*4096; { 48Kbytes дает прекрасный результат }
Type
PBuffer = ^TBuffer;
TBuffer = array [1..BufSize] of Byte;
var
Size : integer;
Buffer : PBuffer;
infile, outfile : File;
SizeDone,SizeFile: Longint;
begin
if (InFileName <> OutFileName) then
begin
buffer := Nil;
AssignFile(infile, InFileName);
System.Reset(infile, 1);
try
SizeFile := FileSize(infile);
AssignFile(outfile, OutFileName);
System.Rewrite(outfile, 1);
try
SizeDone := 0; New(Buffer);
repeat
BlockRead(infile, Buffer^, BufSize, Size);
Inc(SizeDone, Size);
CallBack(SizeDone, SizeFile);
BlockWrite(outfile,Buffer^, Size)
until Size < BufSize;
FileSetDate(TFileRec(outfile).Handle,
FileGetDate(TFileRec(infile).Handle));
finally
if Buffer <> Nil then Dispose(Buffer);
System.close(outfile)
end;
finally
System.close(infile);
end;
end else
Raise EInOutError.Create('File cannot be copied into itself');
end;
Копирование методом потока
Procedure FileCopy(Const SourceFileName, TargetFileName: String);
Var
S,T : TFileStream;
Begin
S := TFileStream.Create(sourcefilename, fmOpenRead );
try
T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);
try
T.CopyFrom(S, S.Size ) ;
FileSetDate(T.Handle, FileGetDate(S.Handle));
finally
T.Free;
end;
finally
S.Free;
end;
end;
Копирование методом LZExpand
uses LZExpand;
procedure CopyFile(FromFileName, ToFileName : string);
var
FromFile, ToFile: File;
begin
AssignFile(FromFile, FromFileName);
AssignFile(ToFile, ToFileName);
Reset(FromFile);
try
Rewrite(ToFile);
try
if LZCopy(TFileRec(FromFile).Handle,
FileRec(ToFile).Handle)<0 then
raise Exception.Create('Error using LZCopy')
finally
CloseFile(ToFile);
end;
finally
CloseFile(FromFile);
end;
end;
Копирование методами Windows
uses ShellApi; // !!! важно
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 TForm1.Button1Click(Sender: TObject);
begin
if not WindowsCopyFile('C:\UTIL\ARJ.EXE', GetCurrentDir) then
ShowMessage('Copy Failed');
end;



<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS