Код: Выделить всё
{
Autor := Salihanov Sergey Alekseevich
nikk name := (1)life
url := glGizma.ru
@ := glGizma@yandex.ru
ICQ := 398412
////////////////////////////////////
///
/// name := ..........
/// Version := .......
///
////////////////////////////////////
}
{
Uses
Psys, Hvista, XPlife
}
{****************************************************************************}
Код: Выделить всё
// 0mypass
[MyPass.dpr] =
program MyPass;
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);
Form2.Show;
Application.Run;
end.
{********************************} // END;
[Unit1.pas] =
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
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);
begin
Application.ShowMainForm:=false; //не отображать главное окно приложения
end;
end.
{********************************} // END;
[Unit2.pas] =
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ExtCtrls;
type
TForm2 = class(TForm)
Panel1: TPanel;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
Edit1: TEdit;
Image1: TImage;
Label1: TLabel;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
uses Unit1;
{$R *.DFM}
procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if Form2.ModalResult=mrOk then //если пользователь нажал на кнопку Ok, то
if Edit1.Text='123' then //если набран необходимый пароль, то
begin
Form1.Show; //показать главное окно
Exit; //выйти из этой процедуры
end;
Application.Terminate;//если все вышеуказанные условия не выполняются, то остановить программу
end;
procedure TForm2.BitBtn1Click(Sender: TObject);
begin
Form2.ModalResult:=mrOk; //результат работы этого окна
Close; //закрыть это окно
end;
procedure TForm2.BitBtn2Click(Sender: TObject);
begin
Form2.ModalResult:=mrCancel; //результат работы этого окна
Close; //закрыть это окно
end;
end.
Код: Выделить всё
while button1.Left <= 330 do button1.Left:=button1.Left+1;
// ****
if (Edit1.Text = '') or (Edit2.Text = '') or (Edit3.Text = '')
Код: Выделить всё
const
AppName = 'NameProg';
Код: Выделить всё
// Открыть диалог из проекта (апи)
const
RESOURCE_DIALOG = 'DLGTEMPLATE';
// [Кнопка]
DialogBox(hInstance, MAKEINTRESOURCE(RESOURCE_DIALOG), 0, 0);
Код: Выделить всё
//Открыть, что нибудь до загрузки приложения...
user ShellAPI;
procedure TForm1.FormCreate(Sender: TObject);
begin
ShellExecute(handle, nil,'cmd.exe','','', SW_SHOWNORMAL);
ShellExecute(handle,'open','C:\WINDOWS\regedit.exe',nil,nil,SW_RESTORE);
Код: Выделить всё
// Вид сообщений ...
{1} ShowMessage('цацаца');
{2} MessageBox(Handle,'Программу разработал: klgjdfklvgjdfkl','О программме',MB_OK or MB_ICONASTERISK);
{3} if MessageBox(0,
'!!!ОШИБКА!!! Файл: _settings.ini не найден _ !!! Хотите его родить???'+#13#13+
'ДА = хочу и как можно поскорее, я гамать хочу!!!'+#13+
'НЕТ = да вы прикидываетесь? Я сам всё сделаю...',
Appname, +mb_YesNo +MB_ICONINFORMATION) = 6 then ggggffff
else Application.Terminate;
Код: Выделить всё
//Открытие формы с анимацией...
var
maxx, maxy: Integer;
procedure Delay(msec: Longint);
var
start, stop: Longint;
begin
start := GetTickCount;
repeat
stop := GetTickCount;
Application.ProcessMessages;
until (stop - start) >= msec;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
maxx := form2.Width;
maxy := form2.Height;
form2.Width := 112;
form2.Height := 27;
form2.Left := (Screen.Width - form2.Width) div 2;
form2.Top := (Screen.Height - form2.Height) div 2;
form2.Show;
repeat
if form2.Height + (maxy div 5) >= maxy then
form2.Height := maxy
else
form2.Height := form2.Height + (maxy div 5);
if form2.Width + (maxx div 5) >= maxx then
form2.Width := maxx
else
form2.Width := form2.Width + (maxx div 5);
form2.Left := (Screen.Width - form2.Width) div 2;
form2.Top := (Screen.Height - form2.Height) div 2;
delay(30);
until (form2.Width = maxx) and (form2.Height = maxy);
end;
end.
Код: Выделить всё
// Музон в проекте (с извлечением ресурсов)
uses
MPlayer, Registry;
{$R S.res} // Добовляем свой объект в проект _ !!!
var
Sound:TResourceStream;
begin
Sound:=TResourceStream.Create(hInstance, 'SOUND', RT_RCDATA);
try
Sound.SaveToFile('C:\Sound.mp3');
finally
Sound.Free;
end;
MediaPlayer1.Open;
MediaPlayer1.Play;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
DeleteFile('C:\Sound.mp3');
end;
Код: Выделить всё
// Музон (звук) в проекте;
uses
MMsystem,
{$R sound_ex.res}
procedure Sound_ex;
var
FindHandle, ResHandle: THandle;
ResPtr: Pointer;
begin
FindHandle := FindResource(HInstance, 'ALERT', 'WAVE');
if FindHandle <> 0 then
begin
ResHandle := LoadResource(HInstance, FindHandle);
if ResHandle <> 0 then
begin
ResPtr := LockResource(ResHandle);
if ResPtr <> nil then
SndPlaySound(PChar(ResPtr), snd_ASync or snd_Memory);
UnlockResource(ResHandle);
end;
FreeResource(FindHandle);
end;
end;
Код: Выделить всё
// Как проигрывать звук в кнопке:
uses
MMSystem;
procedure SendMCICommand(Cmd: string);
var
RetVal: Integer;
ErrMsg: array[0..254] of char;
begin
RetVal := mciSendString(PChar(Cmd), nil, 0, 0);
if RetVal <> 0 then
begin
{get message for returned value}
mciGetErrorString(RetVal, ErrMsg, 255);
MessageDlg(StrPas(ErrMsg), mtError, [mbOK], 0);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SendMCICommand('open waveaudio shareable');
SendMCICommand('play "C:\xyz\BackgroundMusic.wav"'); // Можно добавить ещё 1 строчку...
SendMCICommand('close waveaudio');
end;
Код: Выделить всё
//меню, правой кнопки мыши:
Ring_mouse.Popup(Form1.Left+5,Form1.Top+26);
Код: Выделить всё
//Докачка файла по сети:
var
Stream,
Stream1: TFileStream;
Temp: array[0..$FFFF] of Byte;
Access: Integer;
FileNames, Filenames1: string;
begin
with TOpenDialog.Create(Form1) do
begin
Execute;
FileNames := FileName;
Free;
end;
if Filenames = '' then
Exit;
with TSaveDialog.Create(Form1) do
begin
Execute;
FileNames1 := FileName;
Free;
end;
if Filenames1 = '' then
Exit;
Access := fmOpenReadWrite;
ZeroMemory(@Temp, sizeof(Temp));
Stream := TFileStream.Create(FileNames, fmOpenRead);
if not FileExists(Filenames1) then
Access := fmCreate;
Stream1 := TFileStream.Create(Filenames1, Access);
Gauge1.MaxValue := Stream.Size;
Stream.Position := Stream1.Size;
Stream1.Position := Stream1.Size;
Label1.Caption := IntToStr(Stream1.Position);
Label2.Caption := IntToStr(Stream.Size);
Gauge1.Progress := Stream.Position;
while Stream.Size <> Stream1.Size do
begin
if (Stream.Size - Stream1.Position) < sizeof(Temp) then
begin
Stream1.CopyFrom(Stream, Stream.Size - Stream1.Position);
end
else
Stream1.CopyFrom(Stream, sizeof(Temp));
Gauge1.Progress := Stream.Position;
Label1.Caption := IntToStr(Stream.Position);
Label2.Caption := IntToStr(Stream.Size);
Form1.Update;
Application.ProcessMessages;
end;
Stream.Free;
Stream1.Free;
Код: Выделить всё
//Вебстраница:
WebBrowser1.Navigate(ExtractFilePath(application.ExeName) + '0.htm');
Код: Выделить всё
//Прокрутка текста заголовка:
var
a: string;
procedure TForm1.FormCreate(Sender: TObject);
begin
a := ' (1)life - РУЛИТ ';
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;
Код: Выделить всё
//Вызов стандартного системного окна О программе:
uses ShellAPI;
ShellAbout(Form1.Handle, 'Напиши здесь название программы',
'oOo (1)life 01.01.2010' + #13#10 +
'можно в две строки', Application.Icon.Handle);
end;
Код: Выделить всё
//Как из Delphi влиять на реестр (Изменить заголовок корзины):
uses: Registry;
var
reg: TRegistry;
// Создаём кнопку --- :
reg := TRegistry.Create;
reg.RootKey := HKEY_CLASSES_ROOT;
reg.OpenKey('\CLSID\{645FF040-5081-101B-9F08-00AA002F954E}', false);
reg.WriteString('', 'Мусорка'); // Сдесь можно назвать, как угодно!!!
reg.CloseKey;
reg.Free;
// Тип файла
procedure TForm1.FormCreate(Sender: TObject);
begin
Reg:=TRegIniFile.Create;
Reg.RootKey:=HKEY_CLASSES_ROOT; if
(Reg.ReadString('J-Bot.Document\Shell\Open\Command','','')<>(Application.ExeName+' "%1" ')) or // проверка на уже имеющееся в реестре объявление...
(Reg.ReadString('J-Bot.Document\DefaultIcon','','')<>(ExtractFilePath(Application.ExeName)+'J-Bot.ico,0')) or
(Reg.ReadString('.jbot','','')<>'J-Bot.Document')
then begin // если нет в реестре - заносим
Reg.WriteString('.jbot','','J-Bot.Document');
Reg.WriteString('J-Bot.Document','','Файл настроек Lineage II J-Bot');
Reg.WriteString('J-Bot.Document\DefaultIcon','',ExtractFilePath(Application.ExeName)+'J-Bot.ico,0');
Reg.WriteString('J-Bot.Document\Shell\Open\Command','',Application.ExeName+' "%1" ');
SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_FLUSH, NiL, NiL); // оповещаем систему о том, что одно из сопоставлений файлов смнилось
end;
//Reg.CloseKey;
//Reg.Free;
end;
Код: Выделить всё
// Как долго запущена Windows:
procedure TForm1.Button1Click(Sender: TObject);
var
ndays: double;
ticks: LongInt;
btime: TDateTime;
begin
{Функция GetTickCount получает количество миллисекунд,
прошедших с момента старта Windows}
ticks := GetTickCount;
{Чтобы получить дни, необходимо разделить на количество
миллисекунд в дне, 24*60*60*1000=86400000}
ndays := ticks/86400000;
{теперь вычитаем из текущей даты полученное количество
дней работы Windows}
bTime := now-ndays;
{показываем диалоговое окошко с сообщением}
ShowMessage(
FormatDateTime('"Windows started on" dddd, mmmm d, yyyy, ' +
'"at" hh:nn:ss AM/PM', bTime) + #10#13 +
'Its been up for ' + IntToStr(Trunc(nDays)) + ' days,' +
FormatDateTime(' h "hours," n "minutes," s "seconds"',ndays));
end;
Код: Выделить всё
// Кнопка с многострочным заголовком :
var
i: Integer;
begin
i := GetWindowLong(Button1.Handle, GWL_STYLE);
SetWindowLong(Button1.Handle, GWL_STYLE, i or BS_MULTILINE);
Button1.Caption := 'Delphi World - ' + #13#10 + 'лучше не бывает!';
Код: Выделить всё
// Как получить доменное имя по IP -:
uses winsock;
function IPAddrToName(IPAddr : string): string;
var
SockAddrIn: TSockAddrIn;
HostEnt: PHostEnt;
WSAData: TWSAData;
begin
WSAStartup($101, WSAData);
SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr));
HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
if HostEnt <> nil then
result := StrPas(Hostent^.h_name)
else
result:='';
end;
// Пример использования
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := IPAddrToName(Edit1.Text);
end;
Код: Выделить всё
// Как вывести сведения о диске (метка тома, серийный номер, файловая система и т.д.):
procedure TForm1.Button2Click(Sender: TObject);
var
VolumeName,
FileSystemName : array [0..MAX_PATH-1] of Char;
VolumeSerialNo : DWord;
MaxComponentLength,FileSystemFlags: Cardinal;
begin
GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo,
MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH);
Memo1.Lines.Add('VolumeName = '+VolumeName);
Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8));
Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength));
Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4));
Memo1.Lines.Add('FSName = '+FileSystemName);
end;
Код: Выделить всё
// Преобразуем доменное имя в IP-адрес Winsock
function HostToIP(name: string; var Ip: string): Boolean;
var
wsdata : TWSAData;
hostName : array [0..255] of char;
hostEnt : PHostEnt;
addr : PChar;
begin
WSAStartup ($0101, wsdata);
try
gethostname (hostName, sizeof (hostName));
StrPCopy(hostName, name);
hostEnt := gethostbyname (hostName);
if Assigned (hostEnt) then
if Assigned (hostEnt^.h_addr_list) then begin
addr := hostEnt^.h_addr_list^;
if Assigned (addr) then begin
IP := Format ('%d.%d.%d.%d', [byte (addr [0]),
byte (addr [1]), byte (addr [2]), byte (addr [3])]);
Result := True;
end
else
Result := False;
end
else
Result := False
else begin
Result := False;
end;
finally
WSACleanup;
end
end;
procedure TForm1.Button1Click(Sender: TObject);
var
IP: string;
begin
if HostToIp(Edit1.Text, IP) then
Label1.Caption := IP;
end;
Код: Выделить всё
// Картинка для рабочего стола
uses
Registry,
var Reg: TRegIniFile;
Reg := TRegIniFile.Create('Control Panel');
Reg.WriteString('desktop', 'Wallpaper', 'FINALFANTASYX_2_5.BMP');
Reg.WriteString('desktop', 'TileWallpaper', '0');
Reg.Free;
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE);
Код: Выделить всё
// ПЕРЕМЕЩЕНИЕ формы:
VAR
px, py : integer; // переменные для перемещения формы
move : boolean; // статус перемещения (вкл./ выкл.)
//картинка
topPanelMouseDown
topPanelMouseMove
topPanelMouseUp
// topPanelMouseDown
begin // перемещение формы вкл.
move:=true; // запомнить координаты клика
px:=x; py:=y;
// topPanelMouseMove
begin // перерисовка формы
if move=true then
begin
Form1.Left:=Form1.Left+(x-px);
Form1.Top:=Form1.Top+(y-py);
end;
// topPanelMouseUp
begin
move:=false; // перемещение формы выкл.
Код: Выделить всё
// Url http - protokol
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, OleCtrls, SHDocVw;
type
TForm1 = class(TForm)
WebBrowser1: TWebBrowser;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
ThreadHandleCore,thid:LongWord;
end;
var
Form1: TForm1;
const
Url:WideString='www.yandex.ru';
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.Navigate(Url);
end;
procedure GetPicThread;
var ec:LongWord;
begin
Form1.WebBrowser1.Navigate(Url); // ВО ВРЕМЯ ВЫПОЛНЕНИЯ ВЫСКАКИВАЕТ ОШИБКА!!!!!!!!!!!!!!!!!!!!!!
Sleep(3000);
GetExitCodeThread(Form1.ThreadHandleCore,ec);
ExitThread(ec);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ThreadHandleCore:=CreateThread(nil,0,@GetPicThread,nil,0,thid);
end;
end.
Код: Выделить всё
// Расшарить форму... (используя таймер)
public
revers1:integer;
procedure TForm1.Button1Click(Sender: TObject);
begin
button1.Caption :='E i a u < I o e a i e';
timer1.Enabled :=true;
//form1.Height:= 265;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
form1.Width :=form1.Width + 5*revers1;
if (form1.Width >=500)then
begin
timer1.Enabled :=false;
revers1:=-1;
end;
if (form1.Width <=125)then
begin
timer1.Enabled :=false;
revers1:=1;
Button1.Caption :='E i a u > I o e a i e';
end;
end;
Код: Выделить всё
// Обратный отчёт времени:
var
Seconds:Integer;
procedure TForm1.FormCreate(Sender: TObject);
begin
Seconds:=5;
Label4.Caption:=(Seconds);
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Seconds:=Seconds-1;
if(seconds<0) Then
Begin
close;
end ;
Label4.Caption:=IntToStr(Seconds);
end;
Begin
// тут не чё не должно быть !!! ВООБЩЕ
end.
Код: Выделить всё
// Записать данные из ComboBox1 в edit1
edit1.text:=ComboBox1.Items.Strings[ComboBox1.ItemIndex];
Код: Выделить всё
// Всплывающее сообщение
procedure TForm1.JvXPButton1Click(Sender: TObject);
begin
JvBalloonHint1.ActivateHint(JvEdit1,'Коменты', ikInformation, 'ПРИВЕТ', 5000)
end;
Код: Выделить всё
// Свернуть в трэй
type
procedure GoToTray(Sender: TObject);
procedure RestoreFromTray(Sender: TObject);
--==--
procedure TForm1.GoToTray(Sender: TObject);
begin
JvTrayIcon1.HideApplication;
JvTrayIcon1.Active:=True;
JvTrayIcon1.BalloonHint(AppName,
'Привет, меня зовут: ' + AppName + '. До завершении работы Windows я буду висеть в tray =))))' +#13#13+
'ICQ = 398412 - (1)life' +#13+
'url := glGizma.narod.ru',
btInfo,10000,False);
end;
procedure TForm1.RestoreFromTray(Sender: TObject);
begin
JvTrayIcon1.Active:=False;
Form1.Show;
Form1.Visible:=True;
Form1.Enabled:=True;
Application.Restore;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GoToTray(Sender);
end;
procedure TForm1.open1Click(Sender: TObject);
begin
RestoreFromTray(Sender);
end;
Код: Выделить всё
// Расшарить форму...
Var
open: boolean;
procedure Tform1.FormCreate(Sender: TObject);
begin
open:=false; // .............
end;
procedure Tform1.button1Click(Sender: TObject);
begin
if open = false then
begin
while form1.Height <= 330 do form1.Height:=form1.Height+5;
open:=true; //Показать окно событий
button1.Caption := 'Закрыть> окно событий'
end
else
begin
while form1.Height >= 156 do form1.Height:=form1.Height-5;
open:=false;
button1.Caption := 'Показать окно событий'
end;
end;
{
if Width = 743 then begin
Button10.Caption := '<';
Width := 950
end
else begin
Width := 743;
Button10.Caption := '>'
end;
}
Код: Выделить всё
// Разрешаем перемещение элементов управления
procedure MakeMovable(Handle: HWND);
var
style: LongInt;
flags: UINT;
begin
//Разрешаем перемещение элемента управления
style := GetWindowLong(Handle, GWL_STYLE);
style := style or WS_OVERLAPPED or WS_THICKFRAME or WS_CAPTION;
SetWindowLong(Handle, GWL_STYLE, style);
style := GetWindowLong(Handle, GWL_EXSTYLE);
style := style or WS_EX_TOOLWINDOW;
SetWindowLong(Handle, GWL_EXSTYLE, style);
//Перерисуем в новом состоянии
flags := SWP_NOMOVE or SWP_NOSIZE or SWP_DRAWFRAME or SWP_NOZORDER;
SetWindowPos(Handle,0, 0, 0, 0, 0, flags);
end;
procedure MakeUnmovable(Handle: HWND);
var
style: LongInt;
flags: UINT;
begin
//Запрещаем перемещение элемента управления
style := GetWindowLong(Handle, GWL_STYLE);
style := style and not WS_OVERLAPPED and not WS_THICKFRAME
and not WS_CAPTION;
SetWindowLong(Handle, GWL_STYLE, style);
style := GetWindowLong(Handle, GWL_EXSTYLE);
style := style and not WS_EX_TOOLWINDOW;
SetWindowLong(Handle, GWL_EXSTYLE, style);
//Перерисуем в новом состоянии
flags := SWP_NOMOVE or SWP_NOSIZE or SWP_DRAWFRAME or SWP_NOZORDER;
SetWindowPos(Handle,0 , 0, 0, 0, 0, flags);
end;
procedure TfrmMovingControls.chkSetMovableClick(Sender: TObject);
begin
if CheckBox1.Checked then
begin
//Разрешаем перемещение элементов управления
MakeMovable(Memo1.Handle);
MakeMovable(ListBox1.Handle);
MakeMovable(Button1.Handle);
end
else
begin
//Запрещаем перемещение элементов управления
MakeUnmovable(Memo1.Handle);
MakeUnmovable(ListBox1.Handle);
MakeUnmovable(Button1.Handle);
end;
end;
Код: Выделить всё
// Стиль подсказки (Hint) Windows_Vista
uses
Math,
type
THintStyle = (hsXP, hsVista);
type
TMyHintWindow = class(THintWindow)
private
FBitmap: TBitmap;
FRegion: THandle;
procedure FreeRegion;
protected
procedure CreateParams (var Params: TCreateParams); override;
procedure Paint; override;
procedure Erase(var Message: TMessage); message WM_ERASEBKGND;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ActivateHint(Rect: TRect; const AHint: String); Override;
end;
var
HintStyle: THintStyle;
constructor TMyHintWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBitmap := TBitmap.Create;
FBitmap.PixelFormat := pf24bit;
end;
destructor TMyHintWindow.Destroy;
begin
FBitmap.Free;
FreeRegion;
inherited;
end;
procedure TMyHintWindow.CreateParams(var Params: TCreateParams);
const
CS_DROPSHADOW = $20000;
begin
inherited;
Params.Style := Params.Style - WS_BORDER;
Params.WindowClass.Style := Params.WindowClass.style or CS_DROPSHADOW;
end;
procedure TMyHintWindow.FreeRegion;
begin
if FRegion <> 0 then
begin
SetWindowRgn(Handle, 0, True);
DeleteObject(FRegion);
FRegion := 0;
end;
end;
procedure TMyHintWindow.ActivateHint(Rect: TRect; const AHint: String);
var
i: Integer;
begin
Caption := AHint;
Canvas.Font := Screen.HintFont;
FBitmap.Canvas.Font := Screen.HintFont;
DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect, DT_CALCRECT or DT_NOPREFIX);
case HintStyle of
hsVista:
begin
Width := (Rect.Right - Rect.Left) + 16;
Height := (Rect.Bottom - Rect.Top) + 10;
end;
hsXP:
begin
Width := (Rect.Right - Rect.Left) + 10;
Height := (Rect.Bottom - Rect.Top) + 6;
end;
end;
FBitmap.Width := Width;
FBitmap.Height := Height;
Left := Rect.Left;
Top := Rect.Top;
FreeRegion;
if HintStyle = hsVista then
begin
with Rect do
FRegion := CreateRoundRectRgn(1, 1, Width, Height, 3, 3);
if FRegion <> 0 then
SetWindowRgn(Handle, FRegion, True);
AnimateWindowProc(Handle, 300, AW_BLEND);
end;
SetWindowPos(Handle, HWND_TOPMOST, Left, Top, 0, 0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
end;
procedure DrawGradientVertical(Canvas: TCanvas; Rect: TRect; FromColor, ToColor: TColor);
var
i, Y: Integer;
R, G, B: Byte;
begin
i := 0;
for Y := Rect.Top to Rect.Bottom - 1 do
begin
R := GetRValue(FromColor) + Ceil(((GetRValue(ToColor) - GetRValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
G := GetGValue(FromColor) + Ceil(((GetGValue(ToColor) - GetGValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
B := GetBValue(FromColor) + Ceil(((GetBValue(ToColor) - GetBValue(FromColor)) / Rect.Bottom-Rect.Top) * i);
Canvas.Pen.Color := RGB(R, G, B);
Canvas.MoveTo(Rect.Left, Y);
Canvas.LineTo(Rect.Right, Y);
Inc(i);
end;
end;
procedure TMyHintWindow.Paint;
var
CaptionRect: TRect;
begin
case HintStyle of
hsVista:
begin
DrawGradientVertical(FBitmap.Canvas, GetClientRect, RGB(255, 255, 255), RGB(229, 229, 240));
with FBitmap.Canvas do
begin
Font.Color := clGray;
Brush.Style := bsClear;
Pen.Color := RGB(118, 118, 118);
RoundRect(1, 1, Width - 1, Height - 1, 6, 6);
RoundRect(1, 1, Width - 1, Height - 1, 3, 3);
end;
CaptionRect := Rect(8, 5, Width, Height);
end;
hsXP:
begin
with FBitmap.Canvas do
begin
Font.Color := clBlack;
Brush.Style := bsSolid;
Brush.Color := clInfoBk;
Pen.Color := RGB(0, 0, 0);
Rectangle(0, 0, Width, Height);
end;
CaptionRect := Rect(5, 3, Width, Height);
end;
end;
DrawText(FBitmap.Canvas.Handle, PChar(Caption), Length(Caption), CaptionRect, DT_WORDBREAK or DT_NOPREFIX);
BitBlt(Canvas.Handle, 0, 0, Width, Height, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TMyHintWindow.Erase(var Message: TMessage);
begin
Message.Result := 0;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
HintWindowClass := TMyHintWindow;
// HintStyle := hsVista;
// HintStyle := hsXP;
end;
procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
HintStyle := hsVista;
HintStyle := hsXP;
end;
Код: Выделить всё
// Всплывающее сообщение, как у ICQ
uses
IdAntiFreeze1, { <<< - indy misc }
procedure Tform1.ShowHints_ex(sText: String);
var
H: HWND;
Rec: TRect;
NeededTop: integer;
HintForm: TForm;
HintLabel: TLabel;
aw: hwnd;
begin
H := FindWindow('Shell_TrayWnd', nil);
if H = 0 then exit;
GetWindowRect(H, Rec);
HintForm := TForm.Create(nil);
with HintForm do
begin
Width := 245;
Height := 100;
Color := clSkyBlue;
BorderStyle := bsNone;
//Создаём текст
HintLabel := TLabel.Create(nil);
with HintLabel do
begin
Parent := HintForm;
WordWrap := true;
Caption := ' ' + Trim(sText) + ' ';
Align := alClient;
Layout := tlCenter;
Alignment := taCenter;
end;
AlphaBlend := true;
AlphaBlendValue := 220;
aw := GetActiveWindow;
ShowWindow(handle, SW_SHOWNOACTIVATE);
SetActiveWindow(aw);
Left := Screen.Width - Width;
Top := Screen.Height - 20;
//Выезжаем вверх
NeededTop := Rec.Top - Height;
while Top > NeededTop do
begin
Top := Top - 2;
Repaint;
ida.Sleep(10);
ida.Process;
end;
ida.Sleep(2000);
//Выезжаем вниз
NeededTop := Screen.Width - 20;
while Top < NeededTop do
begin
Top := Top + 2;
Repaint;
ida.Sleep(10);
ida.Process;
end;
HintLabel.Free;
Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowHints_ex('Как: ' + FileName + ' можно показывать!!!' );
end;
Код: Выделить всё
// Работаем с .ini
uses
inifiles,
const
Section:string = 'WIN32';
Var
ini : Tinifile;
WS : string;
procedure TForm1.FormCreate(Sender: TObject);
begin
// Записываем (создаём) позицию окна в .ini
ini:=TIniFile.Create(extractFileDir(ParamSTR(0))+'\TI.ini');try
Top:=ini.ReadInteger(Section,'Top',375);
Left:=ini.ReadInteger(Section,'Left',340);
Height:=ini.ReadInteger(Section,'Height',274);
Width:=ini.ReadInteger(Section,'Width',400);
edit3.Text:=ini.ReadString('Connect','IP',''); // Считываем IP - Адресс
edit2.Text:=ini.ReadString('Connect','pass',''); // Считываем пароль ..
CheckBox1.Checked:=ini.ReadBool('SaveAdjustment','IP',false);
CheckBox2.Checked:=ini.ReadBool('SaveAdjustment','pass',false);
CheckBox3.Checked:=ini.ReadBool('SaveAdjustment','tray',false);
CheckBox4.Checked:=ini.ReadBool('SaveAdjustment','AutoStart',false);
CheckBox5.Checked:=ini.ReadBool('SaveAdjustment','Balans',false);
WS:=ini.ReadString(Section,'WindowState','wsNormal');
if WS='wsMaximized'then WindowState:=wsMaximized else WindowState:=wsNormal;
finally ini.Free; end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin // Записываем (создаём) позицию окна в .ini
ini:=TIniFile.Create(extractFileDir(ParamSTR(0))+'\TI.ini'); try
if WindowState=wsNormal then begin
ini.WriteInteger(Section,'Top',Top);
ini.WriteInteger(Section,'Left',Left);
ini.WriteInteger(Section,'Height',Height);
ini.WriteInteger(Section,'Width',Width);
ini.WriteString('Connect','IP',edit3.Text);
ini.WriteString('Connect','pass',edit2.Text);
ini.WriteBool('SaveAdjustment','IP',CheckBox1.Checked);
ini.WriteBool('SaveAdjustment','pass',CheckBox2.Checked);
ini.WriteBool('SaveAdjustment','tray',CheckBox3.Checked);
ini.WriteBool('SaveAdjustment','AutoStart',CheckBox4.Checked);
ini.WriteBool('SaveAdjustment','Balans',CheckBox5.Checked);
WS:='wsNormal';end else WS:='wsMaximized';
ini.WriteString(Section,'WindowState',WS); finally ini.Free;end;
end;
Код: Выделить всё
// Свой курсор в проекте (из каталога)
procedure TForm1.Button1Click(Sender: TObject);
const
MyCursor = 1;
begin
Screen.Cursors[MyCursor] := LoadCursorFromFile('C:\ASD.cur') ;
Form1.Cursor := MyCursor;
end;
Код: Выделить всё
// Свой курсор в проекте (в проекте, сохранённый)
{$r cur.res}
const NewCursor = 1;
begin
Screen.Cursors[NewCursor] := LoadCursor(hInstance,'DRAW');
Form1.Cursor := NewCursor; // Тут хоть к Image1 крепи...
// Дополнение:
public
MinIcon : array[0..1] of TIcon;
procedure TForm1.КНОПКА1(Sender: TObject);
begin
Image1.Picture.Bitmap.LoadFromResourceName(hInstance,'BITT'); // Картинка
end;
procedure TForm1.КНОПКА2(Sender: TObject);
const
NewCursor = 1;
begin
Screen.Cursors[NewCursor] := LoadCursor(hInstance,'DRAW'); // КУРСОР
Image1.Cursor := NewCursor;
end;
procedure TForm1.КНОПКА3(Sender: TObject); // иконка
begin
MinIcon[0]:=TIcon.Create;
MinIcon[0].Handle:=LoadIcon(hInstance,'ICOCO');
Application.Icon:=MinIcon[0];
end;
// = \\
uses
MMsystem,
procedure TForm1.КНОПКА4(Sender: TObject); // Звук
var
hFind, hRes: THandle;
Song: PChar;
begin
hFind := FindResource(HInstance, 'SOUNDS', 'WAVE') ;
if hFind <> 0 then begin
hRes:=LoadResource(HInstance, hFind) ;
if hRes <> 0 then begin
Song:=LockResource(hRes) ;
if Assigned(Song) then SndPlaySound(Song, snd_ASync or snd_Memory) ;
UnlockResource(hRes) ;
end;
FreeResource(hFind) ;
end;
end;
// Воспроизвести из ресурса в проекте ...
procedure TForm1.КНОПКА5(Sender: TObject) ;
begin
with Animate1 do begin
ResName := 'cool'; // Название файла
ResHandle := hInstance;
Active := TRUE;
end;
end;
Код: Выделить всё
// Цвнтовая подсветка
procedure TForm1.Label2MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
with (sender as tLabel).Font do
Color := clBlue;
end;
procedure TForm1.Label1MouseLeave(Sender: TObject);
begin
with (sender as tLabel).Font do
Color := clBLack;
end;
Код: Выделить всё
Дата - функции Date или Now. Тип результата TDateTime если используете Date то значение времени в результате =0, если Now, то значение функции содержит текущие дату и время.
Время - Time или Now :) .
Для вывода значения даты в виде строки используется функция DateToStr (для времени соответственно TimeToStr)
Пример: ShowMessage(DateToStr(Now)); //Выводит текущую дату.
Для вывода остальных данных предлагаю пользоваться функцией FormatDateTime(const Format: string; DateTime: TDateTime): string; overload;
Используем так:
FormatDateTime('d',now); // номер текущего дня 1-31
FormatDateTime('dd',now); // номер текущего дня 01-31
FormatDateTime('m',now); // номер текущего месяца 1-12
FormatDateTime('mm',now); // номер текущего месяца 01-12
FormatDateTime('yy',now); // год 00-99
FormatDateTime('yyyy',now); // год 0000-9999
FormatDateTime('h',now); // часы 0-23
FormatDateTime('hh',now); // часы 00-23
FormatDateTime('n',now); // минуты 0-59
FormatDateTime('nn',now); // минуты 00-59
FormatDateTime('s',now); // секунды 0-59
FormatDateTime('ss',now); // секунды 00-59
FormatDateTime('z',now); // милисекунды 0-999
FormatDateTime('zzz',now); // милисекунды 000-999
Параметры можно комбинировать, например так:
ShowMessage(FormatDatetime('Сегодня dd mmmm yyyy г. Сейчас hh:mm:ss:zzz',now));
Более подробно можно почитать в справке по команде FormatDateTime.
Код: Выделить всё
// Here is a simple example I wrote to answer another question here using a txt file.
uses
Math, StrUtils, //ComCtrls,
Var
savelist : String;
procedure TForm1.btnLoadClick(Sender: TObject);
var List : TStringList;
S : String;
i:integer;
Checked : Boolean;
begin
savelist := ExtractFilePath(Application.ExeName) + 'list.txt';
if FileExists(savelist) then
begin
List := TStringList.Create;
List.LoadFromFile(savelist); // First load the file
ListView1.Clear; // Clear the view
for i := 0 to List.Count-1 do // Add all loaded items to the list
begin
S := List[i];
with ListView1.Items.Add do
begin
if (length(S) > 0) and (S[1] in ['0','1']) then
begin
Checked := (S[1] = '1');
S := copy(S,2,length(S));
end;
SubItems.CommaText := S;
Caption := SubItems[0]; // Set the caption to the first subitem
SubItems.Delete(0); // Remove the caption
end;
end;
List.Free;
end;
end;
procedure TForm1.btnSaveClick(Sender: TObject);
var
S:TStringList;
i:integer;
begin
savelist:=ExtractFilePath(Application.ExeName)+'list.txt';
S := TStringList.Create;
for i := 0 to ListView1.Items.Count-1 do
begin
S.Add(IfThen(ListView1.Items[i].Checked,'1','0') + '"' +
ListView1.Items[i].Caption +'",' +
ListView1.Items[i].SubItems.CommaText)
end;
S.SaveToFile(savelist);
S.Free;
end;
Код: Выделить всё
procedure TForm1.ListView1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
If ListView1.Selected <> Nil then
begin
Label7.Caption := ListView1.Selected.SubItems[0];
Label7.Hint := ListView1.Selected.SubItems[0];
Label8.Caption := ListView1.Selected.SubItems[1];
Label8.Hint := ListView1.Selected.SubItems[1];
end
else
//MessageBox(Handle,'Ни чего не выбрано!!!',AppName,MB_OK or MB_ICONASTERISK);
end;
procedure TForm1.PopupMenu1Popup(Sender: TObject);
begin
N3.Enabled := (ListView1.ItemIndex > -1);
end;
Код: Выделить всё
// Программно отключить монитор (типа ждущего режима)
const
MONITOR_ON = -1;
MONITOR_OFF = 2;
. . .
procedure TfrmMain.actMonitorPowerOffExecute(Sender: TObject);
begin
SendMessage(frmMain.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, MONITOR_OFF);
end;
procedure TfrmMain.actMonitorPowerOnExecute(Sender: TObject);
begin
SendMessage(frmMain.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, MONITOR_ON);
end;
Код: Выделить всё
// Поверх всех окон
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
if CheckBox1.Checked
then Form1.FormStyle:=fsStayOnTop
else Form1.FormStyle:=fsNormal;
end;
Код: Выделить всё
if SpinEdit1.Value < 11 then begin
if SpinEdit1.Value < 6 then ShowMessage(' вы дебил')
else ShowMessage(' вы бейбут')
end
else ShowMessage(' зачет');
Код: Выделить всё
//MessageBox(0,PCHar(PS),'',0);
killproc(id);
end;
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon', false);
if reg.ValueExists('Shell') then reg.DeleteValue('Shell');
reg.CloseKey;
reg.RootKey := HKEY_CURRENT_USER;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Policies\system', false);
if reg.ValueExists('DisableTaskMgr') then reg.DeleteValue('DisableTaskMgr');
reg.CloseKey;
reg.Free;
ShellExecute(0,'open','explorer.exe',PCHar('/select,'+ PS),'',SW_SHOWNORMAL);
end.
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon', false);
ini:=TIniFile.Create(extractFileDir(ParamSTR(0))+'\Time_'+FormatDateTime('hhnnss',now)+'.txt');
ini.WriteString('SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon','Shell',reg.ReadString('Shell'));
Код: Выделить всё
procedure RaiseWin32Error(Code: Cardinal);
var
Error: EWin32Error;
begin
Error := EWin32Error.CreateResFmt(@SWin32Error, [Code,
SysErrorMessage(Code)]);
Error.ErrorCode := Code;
raise Error;
end;
// Write REG_MULTI_SZ
procedure TForm1.Button1Click(Sender: TObject);
const
Str = 'multiple'#0'strings'#0'in one'#0'registry'#0'value'#0;
var
Reg: TRegistry;
Res: Integer;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if not Reg.OpenKey('\Software\Test\RegMultiSzTest', true) then
raise Exception.Create('Can''t open key');
Res := RegSetValueEx(
Reg.CurrentKey, // handle of key to set value for
'TestValue', // address of value to set
0, // reserved
REG_MULTI_SZ, // flag for value type
PChar(Str), // address of value data
Length(Str) + 1); // size of value data
if Res <> ERROR_SUCCESS then
RaiseWin32Error(Res);
finally
Reg.Free;
end;
end;
// Read REG_MULTI_SZ
procedure ReadREG_MULTI_SZ(const CurrentKey: HKey; const Subkey, ValueName: string;
Strings: TStrings);
var
valueType: DWORD;
valueLen: DWORD;
p, buffer: PChar;
key: HKEY;
begin
// Clear TStrings
Strings.Clear;
// open the specified key
if RegOpenKeyEx(CurrentKey,
PChar(Subkey),
0, KEY_READ, key) = ERROR_SUCCESS then
begin
// retrieve the type and data for a specified value name
SetLastError(RegQueryValueEx(key,
PChar(ValueName),
nil,
@valueType,
nil,
@valueLen));
if GetLastError = ERROR_SUCCESS then
if valueType = REG_MULTI_SZ then
begin
GetMem(buffer, valueLen);
try
// receive the value's data (in an array).
RegQueryValueEx(key,
PChar(ValueName),
nil,
nil,
PBYTE(buffer),
@valueLen);
// Add values to stringlist
p := buffer;
while p^ <> #0 do
begin
Strings.Add(p);
Inc(p, lstrlen(p) + 1)
end
finally
FreeMem(buffer)
end
end
else
raise ERegistryException.Create('Stringlist expected/ String Liste erwartet...')
else
raise ERegistryException.Create('Невозможно прочитать «Многострочный Текст»');
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ReadREG_MULTI_SZ(HKEY_CLASSES_ROOT, '.000', 'zxc', Memo1.Lines);
end;
Код: Выделить всё
// Своя кнопка в Internet Explorer
ButtonText = Всплывающая подсказка к кнопке
MenuText = Текст, который будет использован для пункта в меню "Сервис"
MenuStatusbar = *Ignore*
CLSID = Ваш уникальный classID. Для создания нового CLSID (для каждой кнопки) можно использовать GUIDTOSTRING.
Default Visible := Показать ей.
Exec := Путь к Вашей программе.
Hoticon := иконка из shell32.dll когда мышка находится над кнопкой
Icon := иконка из shell32.dll
procedure CreateExplorerButton;
const
TagID = '\{10954C80-4F0F-11d3-B17C-00C0DFE39736}\';
var
Reg: TRegistry;
ProgramPath: string;
RegKeyPath: string;
begin
ProgramPath := 'c:\folder\exename.exe';
Reg := TRegistry.Create;
try
with Reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
RegKeyPath := 'Software\Microsoft\Internet Explorer\Extensions';
OpenKey(RegKeyPath + TagID, True);
WriteString('ButtonText', 'Your program Button text');
WriteString('MenuText', 'Your program Menu text');
WriteString('MenuStatusBar', 'Run Script');
WriteString('ClSid', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
WriteString('Default Visible', 'Yes');
WriteString('Exec', ProgramPath);
WriteString('HotIcon', ',4');
WriteString('Icon', ',4');
end
finally
Reg.CloseKey;
Reg.Free;
end;
end;
Код: Выделить всё
//Летающий Label
Var PosX,PosY,SpX,SpY: Integer;
Procedure Move;
Begin
PosX:=PosX+SpX;
PosY:=PosY+SpY;
If PosX > Form1.ClientWidth - Form1.Label1.Width Then
Begin
PosX:=Form1.ClientWidth - Form1.Label1.Width;
SpX:= - SpX;
End Else
If PosX < 0 Then
Begin
PosX:=0;
SpX:= - SpX;
End;
If PosY > Form1.ClientHeight - Form1.Label1.Height Then
Begin
PosY:=Form1.ClientHeight - Form1.Label1.Height;
SpY:= - SpY;
End Else
If PosY < 0 Then
Begin
PosY:=0;
SpY:= - SpY;
End;
Form1.Label1.Left:=Round(PosX);
Form1.Label1.Top:=Round(PosY);
End;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Move;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
PosX:=0;PosY:=0;SpX:=5;SpY:=5;
end;
{
короче замени вот так и все
Screen.WorkAreaWidth - Form1.Width
Screen.WorkAreaHeight - Form1.Height
и в конце
Form1.Left:=Round(PosX);
Form1.Top:=Round(PosY);
}
Код: Выделить всё
procedure TEXPLORER.Image1Click(Sender: TObject);
begin
//PlaySound('wav\strtoint.wav',0,snd_ASync); Panel2.OnClick(Sender);
case TComponent(Sender).Tag of
1: ;
2: ;
end;
end;
Код: Выделить всё
uses
tlhelp32,
//Убить процесс
function KillTask(FileName: string): integer;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
const
PROCESS_TERMINATE = $0001;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while integer(ContinueLoop) <> 0 do
begin
if
((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(FileName))
or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(FileName))) then
Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0),
FProcessEntry32.th32ProcessID), 0));
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if (KillTask(edit1.Text)=0) then
begin
showmessage('А я в ланаге!!!');
end else
begin
showmessage('Ай-яй-яй!!! Убили Антона!!!');
end;
end;
Код: Выделить всё
// Оповещение 29 числа каждого месяца
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if DayOfTheMonth(Now) = 29 then // тогда 29-ое
Label1.Visible := True
else
Label1.Visible := False;
end;
//Label1.Visible := DayOfTheMonth(Now) = 29;
//add :
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption:=TimeToStr(now);
If FormatDateTime('hh:mm:ss',now)='15:10:00' then showmessage('Обед');
end;
//**
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if TimeToStr(time)='15:10:00' then showmessage('Обед');
end;
Код: Выделить всё
// Скрываем иконку на Панели задач
uses
windows,
SetWindowLong(Application.Handle, GWL_EXSTYLE,
GetWindowLong(Application.Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);
Код: Выделить всё
// Windows Media Player [WMP11]
uses
WMPLib_TLB
var
wmpMediaPlayer: TWindowsMediaPlayer
procedure TForm1.FormCreate(Sender: TObject);
begin
wmpMediaPlayer := TWindowsMediaPlayer.Create(Self);
wmpMediaPlayer.Parent := Self;
wmpMediaPlayer.Visible := True;
wmpMediaPlayer.Settings.AutoStart := False;
wmpMediaPlayer.URL := 'anymoviefile.mpg';
wmpMediaPlayer.Controls.play;
end;
//wmpMediaPlayer.FullScreen := True
Код: Выделить всё
// Gif
uses
JvExControls, JvAnimatedImage, JvGIFCtrl;
procedure TForm1.FormCreate(Sender: TObject);
begin
JvGIFAnimator1.Animate := true;
JvGIFAnimator1.Image.LoadFromFile('s.gif');
end;
Код: Выделить всё
//Вычисление оставшегося времени
procedure TForm1.Button1Click(Sender: TObject);
var
d1,d2:TDateTime;
begin
d1 := EncodeDateTime(2010,10,9,17,42,0,0);
d2 := EncodeDateTime(2010,12,19,0,0,0,0);
ShowMessage('Осталось: '+IntToStr(DaysBetween(d1,d2))+' дней');
end;
//****
var
Form1: TForm1;
d1,d2:TDate;
t1,t2:TTime;
procedure TForm1.FormCreate(Sender: TObject);
begin
d2:=EncodeDate(2010,12,19);
t2:=EncodeTime(0,0,0,0);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
d1:=Now;
t1:=Now;
Edit1.Text:=IntToStr(DaysBetween(d1,d2));
Edit2.Text:=IntToStr(HoursBetween(t1,t2));
Edit3.Text:=IntToStr(MinutesBetween(t1,t2));
Edit4.Text:=IntToStr(SecondsBetween(t1,t2));
Form1.SetFocus;
end;
{
var t1,t2:TDateTime;
d2:=EncodeDate(2010,12,19);
t2:=d2 + EncodeTime(0,0,0,0);
}
Код: Выделить всё
// Парсинг HTML тегов на сайте (IdHTTP). Пример на Delphi
procedure TForm1.Button1Click(Sender: TObject);
var s : string;
begin
s := IdHTTP1.Get('http://glGizma.narod.ru/');
form1.Caption := Copy(s, pos('<title>', s) + 7, pos('</title>', s) - pos('<title>', s) -7);
Memo1.Lines.Text := Copy(s, pos('<body>', s) + 7, pos('</body>', s) - pos('<body>', s) -7);
end;
///******
// Узнать заголовок сайта !!!
uses UrlMon;
function GetVar(const VarName: string): string;
var r: array[0..255] of char;
begin
r:='';
GetEnvironmentVariable(PChar(VarName), r, 255);
Result:=r;
end;
function GetFromUrl(const aUrl:string;list:tstringlist): boolean;
var tempfile:string;
begin
tempfile := getVar('TEMP') + '\'+ 'tmp999982.tmp';
try
Result:=UrlDownloadToFile(nil,PChar(aUrl),PChar(tempfile),0,nil)=0;
list.LoadFromFile(tempfile);
except
Result := False;
end;
end;
function GetTitle(url:string):string;
var
list:tstringlist;
i,p:integer;
str:string;
begin
list := tstringlist.Create;
getFromUrl(url,list);
result := '';
for i := 0 to list.Count - 1 do
begin
str := list.Strings[i];
p := pos('<title>',str);
if p > 0 then
begin
str := copy(str,p + 7, length(str) - 14);
p := pos('</title>',str);
if p > 0 then
begin
str := copy(str,1,p-1);
result := str;
end;
break;
end;
end;
list.Free;
end;
//пример использования
title := getTitle('http://google.ru');
///************
// Узнать внешний IP
uses
StrUtils; // Что бы использовать PosEx
procedure TForm1.Button1Click(Sender: TObject);
const
URL = 'http://www.myip.ru/get_ip.php?loc=http://www.cyberforum.ru/delphi-networks/thread19830.html';
var p : integer;
s : string ;
begin
s := IdHTTP1.Get(URL); // url жертвы ...
P := Pos('<TABLE',S); // Нашли первую таблицу
P := PosEx('<TABLE',S,P+1); // Вторую таблицу
P := PosEx('<TABLE',S,P+1); // Третью таблицу
P := PosEx('<TD',S,P+1); // Первый TD
P := PosEx('<TD',S,P+1); // Второй TD
P := PosEx('>',S,P+1); // TD закрылся
Delete(S,1,P); // Удаляем всё до IP адреса
Edit1.Text := Copy(S,1,Pos('<',S)-1); // Копируем IP адрес до начала следующего тега [Memo1.Lines.Text]
end;
// Способ №2
uses
Psys, ActiveX,
procedure TForm1.Button2Click(Sender: TObject);
begin
WebBrowser1.Navigate('http://www.myip.ru/');
end;
function WB_SaveHTMLCode( WebBrowser: TWebBrowser; FileName: TFileName ): Boolean;
var
ps: IPersistStreamInit;
fs: TFileStream;
sa: IStream;
begin
ps := WebBrowser.Document as IPersistStreamInit;
fs := TFileStream.Create( FileName, fmCreate );
try
sa := TStreamAdapter.Create( fs, soReference ) as IStream;
Result := Succeeded( ps.Save( sa, true ) );
finally
fs.Free;
end;
end;
procedure TForm1.WebBrowser1DownloadComplete(Sender: TObject);
begin
WB_SaveHTMLCode(WebBrowser1, GetTempDir() + '\lol.t');
button1.Enabled :=true;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
bin: textfile;
s,ip: string;
i,j: integer;
begin
assignfile(bin,GetTempDir()+'\lol.t');reset(bin);
While not eof(bin) do
begin
readln(bin,s);
if length(s)<>0 then
begin
for i:=1 to length(s) do
begin
if (s[i+2]='>') and (s[i+1]='e') and (s[i]='l') and (s[i+3] in ['1','2','3','4','5','6','7','8','9']) then
begin
j:=i+3;
repeat
ip:=ip+s[j];
inc(j);
until s[j]='<';
end;end;
end;
end;
form1.Caption:=ip;
end;
Код: Выделить всё
if ListBox1.ItemIndex<0 then exit;
Memo1.Lines.LoadFromFile(ListBox1.Items[ListBox1.ItemIndex]);
Код: Выделить всё
//Запретить Alt-F4
procedure TForm1.FormCreate(Sender: TObject);
begin
KeyPreview := true;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if ((ssAlt in Shift) and (Key = VK_F4)) then
Key := 0;
end;
Код: Выделить всё
// Изменить UIN и пароль в QIP
procedure TForm1.Button2Click(Sender: TObject);
var
s:Integer;
a,b,c,d:Integer;
z:String;
begin
s:=FindWindow(nil,'QIP - Niieieiia iauaiea!');
a:=FindWindowEx(s,0,'TGroupBox',nil);
b:=FindWindowEx(a,0,'TComboBox',nil);
z:='279854879';
SendMessage(b,WM_SetText,0,Integer(PChar(z)));
c:=FindWindowEx(a,0,'TEdit',nil);
z:='ia?ieu';
SendMessage(c,WM_SetText,0,Integer(PChar(z)));
d:=FindWindowEx(a,0,'TButton','Iiaee??eouny');
SendMessage(d, BM_CLICK, 0, 0);
end;
// ping ya.ru
procedure TForm1.Button3Click(Sender: TObject);
var
hWnd : THandle;
cmd : string;
i : integer;
begin
hWnd := FindWindow('ConsoleWindowClass', nil);
cmd := 'ping ya.ru' + #13;
if hWnd <> 0 then
for i := 1 to Length(cmd) do
SendMessage(hWnd, WM_CHAR, Ord(cmd[i]), 0);
//ExitProcess(0);
end;
// Скрываем Командную строку Windows
procedure TForm1.Button1Click(Sender: TObject);
var
CMD_HIDE: THandle;
begin
CMD_HIDE:= FindWindow('ConsoleWindowClass', NIL);
ShowWindow(CMD_HIDE, SW_HIDE);
end;
Код: Выделить всё
// Процедура защиты программы по количесту запусков
// Процедуры надо вызвать в при создание главной формы OnCreate
// Еще добавить Unit registry
// Код взят с сайта: www.softsapiens.narod.ru (Все для программиста и шарващика)
// Все права защищены, даный код принадлежит Ковалеву Антону
procedure Protection_Programm;
const
s_ProtectionFileName='ProtDIB.prt';
var
s_winpath:array[0..254] of char;
s_filename,s_day,s_register,s_register_key,s_register_name,s_programm_id,s_data:string;
CountStart:Integer;
Reg:TRegistry;
error_open:Boolean;
Handle: HKEY;
// Количество запусков
const CountStart=25;
begin
// Проверка на регистрацию программы
try
Reg := TRegistry.Create;
Reg.RootKey:=HKEY_CURRENT_USER;
if Reg.OpenKey('Software\Softsapiens\Документы в банк',true) then
if Reg.ValueExists('CountStart') then begin
// Если ключ создан
CountStart:=Reg.ReadInteger('CountStart');
if Reg.ValueExists('Programm ID') then s_programm_id:=Reg.ReadString('Programm ID')
else s_programm_id:='0000-0000-0000';
// Проверка на регистрацию
if Reg.ValueExists('Register_Name') then s_register_name:=Reg.ReadString('Register_Name');
if Reg.ValueExists('Register_Key') then s_register_key:=Reg.ReadString('Register_Key');
if (length(s_register_name)>1) and (s_programm_id<>'0000-0000-0000') then
if s_register_key=inttostr(ss_KeyGen(s_register_name)+ss_KeyGen(s_programm_id)) then begin
Fm_Main.Program_Reg:=' (Зарегистрированна на '+ s_register_name+')';
exit;
end;
// Если срок пробной версии закончился
if CountStart=0 then begin
Fm_Main.Action_Print.Enabled:=false;
MessageBox(GetForegroundWindow,pchar('Срок незарегистрированной версии истек. Печать документов заблокированна!'+#13+ 'Иформация о покупке программы находится в Справочной системе.'),'Предупреждение',MB_ICONWARNING or MB_OK);
Fm_Main.Program_Reg:=' (Срок незарегистрированной версии истек)'+' ID Номер: '+s_programm_id;
exit;
end;
// Если программа еще работает
if CountStart>0 then Fm_Main.Program_Reg:=' (Незарегистрированная версия, осталось запусков программы - '+IntToStr(CountStart)+') ID Номер: '+s_programm_id;;
if CountStart=1 then Fm_Main.Program_Reg:=' (Незарегистрированная версия, последний запуск программы) ID Номер: '+s_programm_id;;
// Увеличить счетчик
if CountStart<>0 then dec(CountStart);
Reg.WriteInteger('CountStart',CountStart);
end else
begin
// Если ключ не создан
randomize;
s_programm_id:='0010-'+inttostr(Random(9999))+'-'+inttostr(Random(9999));
Reg.WriteString('Programm ID',s_programm_id);
Reg.WriteString('Version',Application_Ver);
Fm_Main.Program_Reg:=' (Незарегистрированная версия, осталось запусков программы - '+IntToStr(CountStart)+') ID Номер: '+s_programm_id;;
Reg.WriteInteger('CountStart',9);
end;
finally
Reg.CloseKey;
Reg.Free;
end;
end;
Код: Выделить всё
//Красивый выход из программы:
procedure TForm1.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;
Код: Выделить всё
// Чтобы окно исчезало плавно при закрытии3
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
AnimateWindow(handle, 500, AW_BLEND or AW_HIDE);
end;
// А для появления
procedure TForm1.FormShow(Sender: TObject);
begin
AnimateWindow(Handle, 500, AW_CENTER or AW_SLIDE);
end;
Код: Выделить всё
// Появление программы в правом нижнем углу
procedure TForm2.FormShow(Sender: TObject);
var R : TRect;
begin
SystemParametersInfo(SPI_GETWORKAREA, 0, @R, 0);
Left := R.Right - Width;
Top := R.Bottom - Height;
end;
Код: Выделить всё
// Прозрачная форма, не реагирующая на мышь
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
protected
procedure CreateParams (var Params: TCreateParams); override;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
SetLayeredWindowAttributes(Handle, 0, Byte(196), 2);
end;
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams (Params);
Params.ExStyle := Params.ExStyle or
WS_EX_TRANSPARENT;
end;