"Липкая" форма (Delphi)

Как заставить форму приложения "прилипать" к краям экрана?

Оказывается очень просто))
Необходимо в  свойствах формы ScreenSnap сделать равным True и SnapBuffer числу пикселей между краем формы и краем экрана (по дефолту 10) после чего форма должна "прилипать" к краю экрана.
 ScreenSnap:=True;
 SnapBuffer:=10;

Функция получения PageRank (Delphi)

Ни так давно захотел определить PR блога без SEO сервисов с помощью Delphi.
Все оказалось ни так просто, как на Yandex'e при определении ТИЦ'а. Чтобы получить ТИЦ для тех, кто не знает или просто ни когда об этом, ни задумывался, необходимо выполнить запрос такого вида:
http://search.yaca.yandex.ru/yca/cy/ch/[URL сайта без http:\\]/

Пример:
http://search.yaca.yandex.ru/yca/cy/ch/nmdsoft.blogspot.com/
 

и немного распарсить страницу и получим искомый нами ТИЦ

Класс для работы с JSON в Delphi

JSON (англ. JavaScript Object Notation) — текстовый формат обмена данными, основанный на JavaScript и обычно используемый именно с этим языком. Как и многие другие текстовые форматы, JSON легко читается людьми.

Класс lkJSON для работы с  универсальными структурами данных (JSON ) в среде Delphi. Проверял на работоспособность в среде Delphi 2010, все прекрасно работает, в комплекте с классом идут примеры, посмотрев которые можно легко понять, что к чему, так же класс идет в исходном коде и  его можно доработать для своих целей.

Бот для Haddan

Новая версия бота с исправленными недочетами предыдущей версии, выявленными в результате бета-тестирования 2 игроками (ники и имена в секрете).

Внешний вид бота тоже изменился. Появилась возможность сохранения настроек, так же окно информации в котором отображается количество ресурсов которые выкопал бот в процессе работы. Так же у бота теперь привязка к железу.
Теперь бот выглядит так.

Вкладка "Главная"

1. Время  до  завершения  поиска руды.
2. Сколько  раз  копали  в  шахте.
3. Количество  ресурсов  в  инвентаре.
4. Количество  добытых  ботом  ресурсов  за  одну  сессию.

Бот для Haddan

Бот для игры Haddan автоматически выполняет все действия при добывании руды (профессия шахтер). Теперь при добыче руды не нужно вводить текст с картинки (капчу), за вас это сделает программа с помощью сервиса http://antigate.com ! Цена одной распознаной картинки, а следовательно одного подхода стоит всего 0,1 цента (3 Русских копейки) ! Бот сэкономит ваше время и деньги (на сайте хаддана эта услуга стоит намного больше !) Бота можно оставить наночь или запустить после включения компьютера и забыть. Через пару дней зайдите в игру и посмотрите свои ресурсы в инвентаре. Вы будете приятно удивлены :-)

Отправка файла Synapse

Код функции по отправке файла
Автор: Eric Paschoalick Chaves

function HttpPostFileForm(const URL, FieldName, FileName: string; const Data: TStream; const FormFields:TStrings; const ResultData:
TStrings): Boolean;
var
  HTTP: THTTPSend;
  Bound, s: AnsiString;//был string, но для России не катит ( ! )
  i:integer;
const
  CRLF=#13#10;
  FIELD_MASK = CRLF + '--%s' + CRLF +'Content-Disposition: form-data; name="%s"' + CRLF + CRLF+'%s';
begin
  Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
  HTTP := THTTPSend.Create;
  try
    s := '--' + Bound + CRLF;
    s := s + 'content-disposition: form-data; name="' + FieldName +'";';
    s := s + ' filename="' + FileName +'"' + CRLF;
    s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
    HTTP.Document.Write(Pointer(s)^, Length(s));
    HTTP.Document.CopyFrom(Data, 0);
    // Include formfield
    for i:=0 to FormFields.Count-1 do
      begin
        S:= Format(FIELD_MASK,[Bound, FormFields.Names[I],FormFields.Values[FormFields.Names[I]]]);
        HTTP.Document.Write(Pointer(S)^, Length(S));
      end;
    s := CRLF + '--' + Bound + '--' + CRLF;
    HTTP.Document.Write(Pointer(s)^, Length(s));
    HTTP.MimeType := 'multipart/form-data, boundary=' + Bound;
    Result := HTTP.HTTPMethod('POST', URL);
    ResultData.LoadFromStream(HTTP.Document);
  finally
    HTTP.Free;
  end;
end;

TStringList замена переносов строки запятыми

procedure TForm1.Button1Click(Sender: TObject);
var
  st:TStringList;
begin
  st:=TStringList.Create;
  try 
    st.Add('1');
    st.Add('2');
    st.Add('3');
    st.Add('4');
    st.Add('5');
    st.Delimiter:=',';
    Memo1.Text:=st.DelimitedText; //результат 1,2,3,4,5
  finally
    st.Free;
  end;
end;

Хотя можно было использовать StringReplace, но если есть это в классе то зачем))
Обратная задача

procedure TForm1.Button1Click(Sender: TObject);
var
  st:TStringList;
  i:integer;
begin

  st:=TStringList.Create;
  try
      st.Delimiter:=',';
      st.DelimitedText:= Memo1.Text;//текст разделенный запятыми

     //теперь можно обращаться по индексу
     for i := 0 to sTemp.Count - 1 do
     begin
        //переменная string:=st.string[i];

     end;
     //или
     Memo1.Lines:=st;
  finally
    st.Free;
  end;
end;

Бот для Тюряги (онлайн игра вконтакте+mail)

Сделал новую версию всех, кто купил старую версию просьба написать номер телефона с которого платили без 2 последних цифр и email для отправки новой версии бота, пишем в комментариях при модерации удалю.


Данный бот может делать автоматически или в ручном режиме следующее:

1. Собирать сигареты со двора
2. Звать всех друзей в качалку
3. Отправлять подогревы (любого уровня (если дыры в игре не закрыли, пока работает))
4. Получать подогревы
5. Выполнять движухи на зонах

Теперь и для мейла и вконтакта в одном флаконе

Для работы программы необходим логин и пароль вконтакте.
Для того чтобы программа работала корректно необходимо ей один раз показать когда вы делаете сбор во дворе, отправить подогрев и другое. Просто программе нужна точка отсчета от которой она может отталкиваться для выполнения уже тех же самых действий в автоматическом режиме.

Вирусов нет, пароли и логины, мне ваши не нужны.

НОВАЯ ВЕРСИЯ от 4 марта 2011 года.
теперь можно качать, как и говорил раньше, кто купил старую версию пишут в комментариях номер с которого платили без последних двух цифр и адрес электронной почты на который, я отправлю вам новую версию бота.

Скачать отсюда Download

НОВАЯ ВЕРСИЯ от 27 марта 2011 года.
Теперь бот работает и в mail'е достаточно выбрать переключатель нужного вам сервиса

Стоимость бота для тюряги в mail  и вконтакте 50 рублей. (смс теперь не принимаю)
Скачать бот для тюряги с поддержкой mail и вконтакта отсюда Download

Так же можете заказать бота для другой игры, путем отправки комментария в этой теме стоимость от 100 до 1500 руб в зависимости от сложности ))

ПРОИЗОШЛИ изменения на сайте так что все кто купил пишем свои номера без последних двух чисел и получаем исправленную версию (пишите в комментариях).

Для тех кто думает, что обман не качайте ваше право, не нужно меня учить жить... как нибудь сам, а тем кто хочет на халяву да ради бога только не тут))!!!

Простенький пример выполнения запроса в Wininet

По просьбе трудящихся выкладываю вот такой простенький исходник программки с помощью, которой можно получить ТИЦ и PR  сайта путем выполнения POST запроса

Скрин примера

unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,WinInet, StdCtrls;

type
  TfrmMain = class(TForm)
    Button1: TButton;
    edtSite: TEdit;
    lblTC_PR: TLabel;
    lblSite: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}
const
  // дефолное название приложение через которое якобы происходит соединение
  DefaultAppName ='Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.2.6) Gecko/20100625 Firefox/3.6.6';

function exam(msData: TMemoryStream):string;
  function DataAvailable(hRequest: pointer; out Size: cardinal): BOOLEAN;
  begin
    Result := WinInet.InternetQueryDataAvailable(hRequest, Size, 0, 0);
  end;
var
  hInternet, hConnect, hRequest: pointer;
  dwBytesRead, i, L: cardinal;
  sTemp: AnsiString; // текст страницы
  sHeader: String;
begin
  Result:='';
  try
    hInternet := InternetOpen(PChar(DefaultAppName),INTERNET_OPEN_TYPE_PRECONFIG, Nil, Nil, 0);
    if Assigned(hInternet) then
    begin
      // Открываем сессию
      //http://ip-whois.net/pr_cy_check.php обратите внимание как записал в коде адрес сайта
      hConnect := InternetConnect(hInternet, PWideChar('ip-whois.net'),INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);
      if Assigned(hConnect) then
      begin
        // открываем запрос
        hRequest := HttpOpenRequest(hConnect, PWideChar('POST'),
          PWideChar('/pr_cy_check.php'), HTTP_VERSION, nil, Nil,
          INTERNET_FLAG_KEEP_CONNECTION, 1);

        sHeader:='Accept: */*';
        HttpAddRequestHeaders(hRequest, Pointer(sHeader), Length(sHeader), HTTP_ADDREQ_FLAG_ADD);
        sHeader:= 'Content-Type: application/x-www-form-urlencoded';
        HttpAddRequestHeaders(hRequest, Pointer(sHeader), Length(sHeader), HTTP_ADDREQ_FLAG_ADD);
        sHeader:= 'Accept-Language: ru-ru,ru;q=0.8,en-us;q=0.5,en;q=0.3';
        HttpAddRequestHeaders(hRequest, Pointer(sHeader), Length(sHeader), HTTP_ADDREQ_FLAG_ADD);
        sHeader:= 'Accept-Charset: windows-1251,utf-8;q=0.7,*;q=0.7';
        HttpAddRequestHeaders(hRequest, Pointer(sHeader), Length(sHeader), HTTP_ADDREQ_FLAG_ADD);

        if Assigned(hRequest) then
        begin
          // Отправляем запрос
          i := 1;
          if HttpSendRequest(hRequest, nil, 0, msData.memory, msData.Size) then
          begin
            repeat
              DataAvailable(hRequest, L); // Получаем кол-во принимаемых данных
              if L = 0 then
                break;
              SetLength(sTemp, L + i);
              if not InternetReadFile(hRequest, @sTemp[i], sizeof(L),dwBytesRead) then
                break; // Получаем данные с сервера
              inc(i, dwBytesRead);
            until dwBytesRead = 0;
            sTemp[i] := #0;
            Result:=sTemp;
          end;
        end;
      end;
    end;
  finally
    InternetCloseHandle(hRequest);
    InternetCloseHandle(hConnect);
    InternetCloseHandle(hInternet);
  end;
end;

function TC_PR(aValue:string):string;
var
  i:Integer;
  TC,PR:string;
begin
  i:=AnsiPos('</h2><h3>ТИЦ: ',aValue);
  if i=0 then
  begin
    Result:='Неизвестно!';
    Exit;
  end;
  Delete(aValue,1,i+length('</h2><h3>ТИЦ: ')-1);
  i:=AnsiPos('</h3><h3>PR: ',aValue);
  TC:=Copy(aValue,0,i-1);
  Delete(aValue,1,i+length('</h3><h3>PR: ')-1);
  i:=AnsiPos('</h3><br>',aValue);
  PR:=Copy(aValue,0,i-1);
  Result:='ТИЦ '+TC+' PR '+PR;
end;

procedure TfrmMain.Button1Click(Sender: TObject);
var
  zapros:TStringStream;
  sTemp:string;
begin
  zapros:=TStringStream.Create;
  zapros.WriteString('T1='+edtSite.Text+'&B1=T2=%D3%E7%ED%E0%F2%FC+%D2%C8%D6+%E8+PR');
  sTemp:=exam(zapros);
  if Length(sTemp)>0 then
    lblTC_PR.Caption:=TC_PR(sTemp);

  zapros.Free;
end;

end.

Скачать исходник проекта можно отсюда Download

Конкурс на WebDelphi с неограниченным призовым фондом.

Хочу поздравить всех со вторым днем зимы и сообщить о прекрасном известии.

1 декабря 2010 года (т.е. вчера) начался конкурс по программированию с неограниченным призовым фондом ( все зависит от количества принявших в нем участие людей( 50 рублей за каждого нового конкурсанта), но начальный призовой фонд составляет 1000 рублей ).

Принять участие в конкурсе могут все программисты круг не ограничивается только Delphi (нас ни так много, но мы в тельняшках).

Если вы не профессионал то не беда, программу будут оценивать только по ее функционалу далекие от программирования люди следовательно и у вас есть шанс занять почетное первое место в этом конкурсе.

Правила и требования для участия в конкурсе можете просмотреть на сайте автора конкурса!


Желаю удачи!!!