Следоратор исходник на delphi

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

Следоратор исходник на delphi

Сообщение glGizma » Вс окт 03, 2021 2:10 pm

Ранее был вывалин Следоратор, но без исходника. Програ отработала своё / была протестирована и можно кидать исходник. Прога информирует пользователей, чтобы они закрыли все файлы и базы 1с для корректного резервного копирования файлов/баз. Тут хитрость такая, что Следоратор тусуется на RDP серваке, он висит в автозагрузке у всех юзеров. В логах записывается инфа о тех, кто любит игнорить админа и тем самым информирует , как баннер WinLoker.

Код можно было сократить и сделать его более красивым, но тупо лень.

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

unit Unit1; // Сергей Хахакеров ... ((( ^_^ )))

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, JvBalloonHint, JvComponentBase, JvTrayIcon,
  Menus, TlHelp32, Spin;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Memo1: TMemo;
    tl1: TLabel;
    Bevel1: TBevel;
    tl2: TLabel;
    Label3: TLabel;
    tl4: TLabel;
    tl5: TLabel;
    tl6: TLabel;
    Bevel2: TBevel;
    Button1: TButton;
    Button2: TButton;
    PopupMenu1: TPopupMenu;
    JvTrayIcon1: TJvTrayIcon;
    JvBalloonHint1: TJvBalloonHint;
    Timer1: TTimer;
    N1: TMenuItem;
    GroupBox1: TGroupBox;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Bevel3: TBevel;
    Label7: TLabel;
    N2: TMenuItem;
    Memo2: TMemo;
    Image1: TImage;
    Timer2: TTimer;
    GroupBox2: TGroupBox;
    Edit1: TEdit;
    Label8: TLabel;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    N3: TMenuItem;
    N4: TMenuItem;
    procedure xXx(Sender: TObject);
    procedure GoToTray(Sender: TObject);
    procedure RestoreFromTray(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm} {$R v.res}

const 
  week:array[1..7] of string = ('Воскресенье','Понедельник','Вторник',
                                'Среда','Четверг','Пятница','Суббота');

function GetUserFromWindows: string; // определяем имя учёточки ...
var
  UserName : string;
  UserNameLen : Dword;
begin
  UserNameLen := 255;
  SetLength(userName, UserNameLen);
  if GetUserName(PChar(UserName), UserNameLen) then
    Result := Copy(UserName,1,UserNameLen - 1)
  else
    Result := 'Unknown';
end;

function GetProcessByEXE(exename: string): THandle; //определяем запущена программа или нет
var
  hSnapshoot: THandle;
  pe32: TProcessEntry32;
begin
  Result:= 0;
  hSnapshoot:= CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  if (hSnapshoot = 0) then Exit;
  pe32.dwSize:= SizeOf(TProcessEntry32);
  if (Process32First(hSnapshoot, pe32)) then
    repeat
      if (pe32.szExeFile = exename) then
      begin
        Result:= pe32.th32ProcessID;
        exit;
      end;
    until not Process32Next(hSnapshoot, pe32);
end;

procedure TForm1.GoToTray(Sender: TObject); // Свернуть в трэй
begin
  JvTrayIcon1.HideApplication;
end;

procedure TForm1.RestoreFromTray(Sender: TObject); // Развернуть из трэй
begin
  Form1.Show;
  Form1.Visible:=True;
  Form1.Enabled:=True;
  Application.Restore;
end;

procedure TForm1.xXx(Sender: TObject); // Работаем с тагами
var day:integer;
begin
  if tl4.Caption = 'Определяю...' then
    begin
      GoToTray(Sender); // Если юзер пытается закрыть программу, прячем её ва трей
      Timer2.Enabled:=FALSE;
    end;
  case TComponent(Sender).Tag of
  1: MessageBox(Handle,'Привет! Я Следоратор! Я слежу, чтобы резервные копии документов, '+
  'баз 1с и прочих файлов сервера были очень хорошо сохранены и зашифрованы без потерь и ошибок.'+#13#13+
  'Разработал: Хахакеров Сергей Алексеевич'+#13+
  'Для: ООО КОМЕТА'+#13+
  'Версия: 0.1 (тестовая) от 28.01.2021',
  'О программме: Следоратор',MB_OK or MB_ICONASTERISK); // выводим окно О_проге!
  2:
    begin
      day:=DayOfWeek(date); //определяем день недели  ...
      Label6.caption:=FormatDateTime(week[day]+' (DD.MM.YY)',now);
      Label7.caption:=FormatDateTime('HH:NN:SS',now); // текущее время

      // Запускаем сканер
      if (Label7.caption = '15:59:55') OR (Label7.caption = '16:59:55')
                                       OR (Label7.caption = '17:59:55')
                                       OR (Label7.caption = '18:59:55')
                                       OR (Label7.caption = '19:59:55')
      then Timer2.Enabled:=TRUE else begin
                                       if (Label7.caption = '16:00:05')
                                       OR (Label7.caption = '17:00:05')
                                       OR (Label7.caption = '18:00:05')
                                       OR (Label7.caption = '19:00:05')
                                       OR (Label7.caption = '20:00:05')
      then Timer2.Enabled:=FALSE;
      end;

    end;
  3:
    begin
      GoToTray(Sender); // Если юзер пытается закрыть программу, прячем её ва трей
      Timer2.Enabled:=FALSE;
    end;
  4:
    begin
      //SpinEdit1.Value:=SpinEdit1.Value+1;
     //Определяем запущена 1с или нет ...
      if GetProcessByEXE('1cv8c.exe') OR GetProcessByEXE('1cv8.exe') OR GetProcessByEXE('1cv8s.exe') = 0
        then
          begin
            tl4.Caption:='Закрыт';
            tl4.font.Color:=clBlue;
          end
        else
          begin
            tl4.Caption:='Открыт';
            tl4.font.Color:=clRed;
            // Если 1с работает то выаодим окно оповещения ...
            if (Label7.caption = '15:59:59') OR (Label7.caption = '16:59:59')
                                             OR (Label7.caption = '17:59:59')
                                             OR (Label7.caption = '18:59:59')
                                             OR (Label7.caption = '19:59:59')
            then
              begin
                RestoreFromTray(Sender); // показываем окно .
                memo2.Lines.Clear; // очищаем лог..
                // загружаем лог если есть
                try memo2.Lines.LoadFromFile(ExtractFilePath(Application.ExeName)+'sledlog\'+GetUserFromWindows+'.txt'); except end;
                Memo2.Lines.Add('Не закрыта программа 1с '
                                +Label7.caption+' '
                                +Label6.caption+' '
                                +GetUserFromWindows);
                // сохраняем логи для админа (если юзер косячит)
                memo2.Lines.SaveToFile(ExtractFilePath(Application.ExeName)+'sledlog\'+GetUserFromWindows+'.txt');
              end;
          end;

      //Определяем запущен ворд или нет ...
      if GetProcessByEXE('winword.exe') OR GetProcessByEXE('WINWORD.EXE') = 0
        then
          begin
            tl5.Caption:='Закрыт';
            tl5.font.Color:=clBlue;
          end
        else
          begin
            tl5.Caption:='Открыт';
            tl5.font.Color:=clRed;
            // Если ворд работает то выводим окно оповещения ...
            if (Label7.caption = '15:59:58') OR (Label7.caption = '16:59:58')
                                             OR (Label7.caption = '17:59:58')
                                             OR (Label7.caption = '18:59:58')
                                             OR (Label7.caption = '19:59:58')
            then
              begin
                RestoreFromTray(Sender);
                memo2.Lines.Clear;
                try memo2.Lines.LoadFromFile(ExtractFilePath(Application.ExeName)+'sledlog\'+GetUserFromWindows+'.txt'); except end;
                Memo2.Lines.Add('Не закрыта программа word '
                                +Label7.caption+' '
                                +Label6.caption+' '
                                +GetUserFromWindows);
                memo2.Lines.SaveToFile(ExtractFilePath(Application.ExeName)+'sledlog\'+GetUserFromWindows+'.txt');
              end;
          end;
      //Определяем запущен эксель или нет ...
      if GetProcessByEXE('excel.exe') OR GetProcessByEXE('EXCEL.EXE') = 0
        then
          begin
            tl6.Caption:='Закрыт';
            tl6.font.Color:=clBlue;
          end
        else
          begin
            tl6.Caption:='Открыт';
            tl6.font.Color:=clRed;
            // Если эксель работает то выводим окно оповещения ...
            if (Label7.caption = '15:59:57') OR (Label7.caption = '16:59:57')
                                             OR (Label7.caption = '17:59:57')
                                             OR (Label7.caption = '18:59:57')
                                             OR (Label7.caption = '19:59:57')
            then
              begin
                RestoreFromTray(Sender);
                memo2.Lines.Clear;
                try memo2.Lines.LoadFromFile(ExtractFilePath(Application.ExeName)+'sledlog\'+GetUserFromWindows+'.txt'); except end;
                Memo2.Lines.Add('Не закрыта программа excel '
                                +Label7.caption+' '
                                +Label6.caption+' '
                                +GetUserFromWindows);
                memo2.Lines.SaveToFile(ExtractFilePath(Application.ExeName)+'sledlog\'+GetUserFromWindows+'.txt');
              end;
          end;
    end;
  5: application.Terminate;
  6: timer1.Enabled:=FALSE;
  7: if edit1.Text = GetUserFromWindows+'2020' then
    begin
      Button4.Enabled:=TRUE;
      Button5.Enabled:=TRUE;
      N4.Enabled:=TRUE;
      Button3.Enabled:=FALSE;
      Edit1.Enabled:=FALSE;
      memo2.Lines.Add('Вы вошли в систему');
    end
                                               else memo2.Lines.Add('Пароль не верный!');
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Определяем уникальный id пользователя ...
  form1.Caption:='Следоратор ['+GetUserFromWindows+']';
end;

// если юзер хитрый и может закрыть прогу , делаем запрет и сворачиваем с трей!.
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caNone;
  Application.Minimize;
  GoToTray(Sender);
end;

end.
Вложения
sledorator.rar
(274.3 КБ) 291 скачивание
sled.png
sled.png (44.61 КБ) 9745 просмотров

Ответить