|
|
|
Как не допустить запуск второй копии программы?
Как извлечь иконку из EXE- и DLL-файлов?
Как завершить все работающие приложения?
Как программно включить NUM LOCK?
Как открыть-закрыть привод CD-ROM?
Как перетащить форму не за заголовок?
Как сделать главную форму полностью невидимой?
Как добиться реального STAY-ON-TOP?
Как сделать прозрачную форму?
Как градиентно "залить" экран?
Как заполнить фон формы повторяющимся изображением?
Как скрыть кнопку "Пуск"?
Как добавить событие OnMouseLeave?
Как добавить кнопку не главной формы на Панель задач?
Как ограничить TEdit на ввод нецифровой информации?
Как добавить иконку в меню?
Как использовать анимированный курсор?
Как узнать серийный номер винчестера?
Как из программы изменить системные время и дату?
Как запустить другую программу?
Как не допустить
запуск второй копии программы?
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.
Как извлечь иконку из
EXE- и DLL-файлов?
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;
Как завершить все
работающие приложения?
Пример показывает,
как закрыть все приложения без сохранения
данных.
procedure TForm1.Button1Click(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;
Как программно включить
NUM LOCK?
procedure
TForm1.Button1Click(Sender: TObject);
var
KeyState : TKeyboardState;
begin
GetKeyboardState(KeyState);
if
(KeyState[VK_NUMLOCK] = 0)
then
KeyState[VK_NUMLOCK] :=
1
else
KeyState[VK_NUMLOCK] :=
0;
SetKeyboardState(KeyState);
end;
{Для CAPS LOCK - VK_CAPITAL}
{Для SCROOL
LOCK - VK_SCROLL}
Как открыть-закрыть
привод
CD-ROM?
Открываем:
mciSendString('Set
cdaudio door open wait', nil, 0, handle);
Закрываем:
mciSendString('Set cdaudio door closed wait', nil, 0,
handle);
//Не забудьте
подключить модуль MMSystem
Как перетащить форму не
за заголовок?
public
procedure WMNCHitTest(var M: TWMNCHitTest); message
wm_NCHitTest;
......
procedure TForm1.WMNCHitTest(var
M: TWMNCHitTest);
begin
inherited;
if M.Result = htClient then
M.Result := htCaption;
end;
Как сделать главную форму
полностью невидимой?
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;
Как добиться реального
STAY-ON-TOP?
with Form1 do
SetWindowPos(Handle,
HWND_TOPMOST,
Left,
Top,
Width,
Height,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
Поместите
вызов данной функции в обработчиках события OnShow(),
OnDeactivate(), и OnActivate().
Как сделать прозрачную
форму?
procedure TForm1.FormCreate(Sender:
TObject);
begin
Form1.Brush.Style :=
bsClear;
Form1.BorderStyle := bsNone;
end;
Как градиентно "залить"
экран?
procedure TForm1.FormPaint(Sender:
TObject);
var
Row, Ht: Word;
begin
Ht := (ClientHeight + 255) div 256;
for Row :=
0 to 255 do
with Canvas
do
begin
Brush.Color :=
RGB(0, 0, Row);
FillRect(Rect(0, Row * Ht, ClientWidth, (Row + 1) *
Ht));
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.
Как скрыть кнопку
"Пуск"?
procedure
HideStartButton(visi:boolean);
var
Tray, Child :
hWnd;
C : Array[0..127] of Char;
S :
String;
begin
Tray := FindWindow('Shell_TrayWnd',
nil);
Child := GetWindow(Tray,
GW_CHILD);
while Child <> 0 do
begin
If
GetClassName(Child, C, SizeOf(C)) > 0
then
begin
S :=
StrPAS(C);
If
UpperCase(S) = 'BUTTON'
then
begin
IsWindowVisible(Child);
If Visi then
ShowWindow(Child,
1)
else
ShowWindow(Child,
0);
end;
end;
Child := GetWindow(Child, GW_HWNDNEXT);
end;
end;
procedure TForm1.Button1Click(Sender:
TObject);
begin
HideStartButton(True);
end;
Как добавить событие
OnMouseLeave?
procedure CMMouseEnter(var
msg:TMessage); message CM_MOUSEENTER;
procedure
CMMouseLeave(var msg: TMessage); message
CM_MOUSELEAVE;
.....
procedure
MyComponent.CMMouseEnter(var msg:TMessage);
begin
inherited;
{действия на вход мыши в
область компонента}
end;
procedure
MyComponent.CMMouseLeave(var msg:
TMessage);
begin
inherited;
{действия на покидание мыши
области компонента}
end;
Как добавить
кнопку не главной формы на Панель
задач?
type
TForm2 =
class(TForm)
protected
procedure CreateParams(VAR Params: TCreateParams);
override;
....
procedure TForm2.CreateParams(VAR Params:
TCreateParams);
begin
Inherited
CreateParams(Params);
with Params do ExStyle
:= ExStyle OR WS_EX_APPWINDOW;
end;
Как ограничить TEdit на
ввод нецифровой информации?
procedure
TForm1.Edit1KeyPress(Sender: TObject; var Key:
Char);
begin
if not (Key in [#8,'0'..'9']) then
Key := #0;
end;
Как добавить иконку в
меню?
var
Bmp1 :
TPicture;
.....
Bmp1 :=
TPicture.Create;
Bmp1.LoadFromFile('c:\where\b1.BMP');
SetMenuItemBitmaps(MenuItemTest.Handle,
0,
MF_BYPOSITION,
Bmp1.Bitmap.Handle,
Bmp1.Bitmap.Handle);
Как использовать
анимированный
курсор?
const
crMyCursor = 1;
.....
procedure
TForm1.FormCreate(Sender: TObject);
begin
// Загружаем курсор. Единственный способ для
этого
Screen.Cursors[crMyCursor] :=
LoadCursorFromFile('c:\mystuff\mycursor.ani');
// Используем курсор на
форме
Cursor := crMyCursor;
end;
Как узнать серийный
номер винчестера?
procedure
TForm1.Button1Click(Sender: TObject);
var
SerialNum : dword;
a, b : dword;
Buffer :
array [0..255] of char;
begin
if
GetVolumeInformation('c:\', Buffer, SizeOf(Buffer),
@SerialNum, a, b, nil, 0) then
Label1.Caption := IntToStr(SerialNum);
end;
Как из
программы изменить системные время и
дату?
function SetPCSystemTime(tDati:
TDateTime): boolean;
var
tSetDati:
TDateTime;
vDatiBias: Variant;
tTZI: TTimeZoneInformation;
tST:
TSystemTime;
begin
GetTimeZoneInformation(tTZI);
vDatiBias
:= tTZI.Bias / 1440;
tSetDati :=
tDati + vDatiBias;
with tST do
begin
wYear :=
StrToInt(FormatDateTime('yyyy',
tSetDati));
wMonth :=
StrToInt(FormatDateTime('mm',
tSetDati));
wDay :=
StrToInt(FormatDateTime('dd',
tSetDati));
wHour :=
StrToInt(FormatDateTime('hh',
tSetDati));
wMinute :=
StrToInt(FormatDateTime('nn',
tSetDati));
wSecond :=
StrToInt(FormatDateTime('ss',
tSetDati));
wMilliseconds := 0;
end;
SetPCSystemTime := SetSystemTime(tST);
end;
Как запустить другую
программу?
function ExecuteFile(const
FileName, Params, DefaultDir: string; ShowCmd: Integer):
THandle;
var
zFileName, zParams, zDir:
array[0..79] of Char;
begin
Result :=
ShellExecute(Application.MainForm.Handle,
nil,
StrPCopy(zFileName,
FileName), StrPCopy(zParams,
Params),
StrPCopy(zDir, DefaultDir), ShowCmd);
end;
.....
procedure TForm1.Button1Click(Sender:
TObject);
begin
ExecuteFile('maker.exe','text_file','c:\maker',
SW_SHOWNORMAL);
end;
|
главная
Смотрите также
