Полезные коды

Исходники делфи, готовые программы/приложения и т.д.
Ответить
Аватара пользователя
glGizma
Site Admin
Сообщения: 214
Зарегистрирован: Ср сен 27, 2017 2:20 pm

Полезные коды

Сообщение glGizma » Вс ноя 26, 2017 8:16 am

Код: Выделить всё

{
	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;

Ответить