NMDSOFT

GIF с прозрачным фоном в BMP (Delphi)

2012-01-22T21:36:00.000-08:00

var
gif:TGIFImage;
i:Integer;
begin
gif:=TGIFImage.Create;
gif.Transparent:=True;
gif.LoadFromFile('c:\1\2.gif');
for i := 0 to gif.Images.Count-1 do
begin
    with GIF.Images[i] do
      if (Transparent) then
      begin
        ActiveColorMap[GraphicControlExtension.TransparentColorIndex] := clWhite;
        GIF.Images[i].Bitmap.SaveToFile('c:\1\'+inttostr(i)+'.bmp');
      end;
end;
gif.Free;

анимированные изображения разбивает на кадры

Fast Dial 3.4 Mozilla 5.0

2011-07-05T06:58:00.000-07:00

После обновления Mozill'ы до 5 версии, я обнаружил то к чему очень привык, великолепный аддон Fast Dial перестал работать в 5 версии. Уныло, досадно, но ладно. Решил немного подождать, ну мало ли не успел может переписать под новый браузер....
Прошло около 2 дней и вышла новая версия Fast Dial 3.4, установил, но не успел даже обрадоваться, как увидел, что он тоже не работает((. Поискал, что в инете пишут, поиски оказались тщетны. Потом вновь решил поискать и наткнулся на ветку в форуме мозилы в которой говорилось о том, что другой разработчик исправил Fast Dial 3.4 и теперь, он работает, но через попу (не стал рисковать, мало ли...) и зашел на офф сайт автора компонента и обнаружил там бета версию компонента Fast Dial 3.5b1, установил и все прекрасно работает без всяких танцев.

Так что у кого такая же проблема решение тут.

ps. Я использую Fast Dial потому, что в нем нет ни чего лишнего.

Бета тестирование Delphi с 64-битным компилятором.

2011-04-06T02:09:00.000-07:00

Ура товарищи, УРА!!!!!! Открыта регистрация на бета тестирование Delphi с 64-битным компилятором.
Регистрируемся тут

Прогресс бар в стиле Vista. VistaProBar 1.5 (Delphi)

2011-04-01T23:19:00.001-07:00

Прогресс бар, как в Vist'e

Возможность регулировки размытости
Возможность регулировки скорости
Вставка суффикса
Вставка префикса
Отображение прогресса текстом
Показ процентов

Проверял в Delphi 2010 все нормально устанавливается, но для работы компонента необходим другой компонент этого же автора. На сайте у него скачал последнюю версию необходимого компонента rkSmartPath23, но архив битый пришлось скачать на одну версию по младше rkSmartPath22.

Распространяется по лицензии MPL 1.1

Блог автора компонента
Klever on Delphi

Скачать компонент VistaProBar 1.5+rkSmartPath22 можно отсюда Download
Запаковал их вместе для удобства

SmartPath v2.3 (Delphi)

2011-04-01T23:19:00.000-07:00

От автора компонента:
Компонент позволяющий перемещаться по файловой системе компьютера, как в проводнике Vista.
Путь к папке представляется, как кнопки и стрелки. Нажатие на кнопку позволит вам установить этот путь, нажатие на стрелку позволит вам выбрать папки в этой папке.

Дополнительные возможности

Отключение редактирования пути
Добавлено событие draw
Использование отображаемого имени для папок
Добавлен поиск событий.
Тонкие настройки и исправления
Стрелка отображается если в папке есть еще папки

Скриншот SmartPath версии 2

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

SmartPath версия 2.2

Теперь можно перемещаться по каталогам используя только клавиатуру
У Ownerdraw теперь есть свое собственное свойство, установите его при использовании ownerdraw события.
Добавлен ParentFont
Новое свойство ClickSetPath установит путь автоматически, когда кнопка на пути будет нажата так не нужно теперь использовать событие OnClickEvent.
Изменен AllowEdit теперь по дефолту True
OnMouseLeaveEvent
Тонкие настройки и исправления

Блог автора компонента
Klever on Delphi

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

Стеклянная кнопка rkGlassButton (Delphi)

2011-03-31T07:04:00.000-07:00

Компонент стеклянная кнопка для Delphi (устанавливал в Delphi XE версию 2 при перемещении бывают глюки, но это не беда компонент идет в исходниках в виде одного pas файла. Так что если есть желание и время можно это глюк пофиксить)

Скрин rkGlassButton 2

История развития компонента rkGlassButton 1.5

Стал лучше рендеринг
Теперь компонент может отбрасывать тени
Можно изменить цвет тени
Регулируется уровень глянцевости
Изменение позиции изображения и разрыва текста
Работает как кнопки в Windows 7

История развития компонента rkGlassButton 1.75

Добавлена обработка клавиатуры
Добавлена стрелочка при нажатии которой появляется Pop up Menu
Новый фокус рендеринга
Добавлено состояние нажата
Пофиксены некоторые ошибки

История развития компонента rkGlassButton 2

Добавлено позиционирование текста (слева, по центру, справа)
Кнопка может быть плоской (Flat)
Альтернативный рендеринг стиль
Появилась возможность отключения кнопки

Распространяется по лицензии MPL 1.1

Блог автора компонента
Klever on Delphi

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

DSpack 2.3.3 (Delphi)

2011-03-30T05:45:00.000-07:00

Компонент для написания мультимедиа приложений использующих MS Direct Show и DirectX технологии. С DSpack вы можете создать все, что вы хотите: DVD, захвата, сжатие, фильтры, ТВ, веб-камера, DV...
Корректно работает в Delphi XE, для работы примеров необходимо переименовать в uses DSUtil.pas на DSUtils.pas (в Delphi 2009 появился другой модуль с таким именем)
Запустил пример который поток видео с веб-камеры сохраняет на диск в формате avi, после чего открыл файл и в нем было действительно видео с веб-камеры, а не просто пустой файл.

Установка

Добавляем в переменные среды Delphi
- (DSPackDir)\src\Directx9
- (DSPackDir)\src\DSPack
Компилируем DirectX 9 Package (DirectX9_Dx.dpk) из папки packagesD2010.
Компилируем DSPack Package (DSPack_Dx.dpk) из папки packagesD2010.
Устанавливаем Design Package (DSPackDesign_Dx.dpk) из папки packagesD2010.

И не забываем в примерах в случае если возникает ошибка
[DCC Error] main.pas(34): E2003 Undeclared identifier: 'TSysDevEnum'
переименовывать модуль DSUtil.pas на DSUtils.pas

Скачать DSpack можно отсюда Download

JSON – SuperObject (Delphi)

2011-03-29T00:31:00.000-07:00

JSON – SuperObject библиотека для работы с JSON в Delphi, данная библиотека была проверена в Delphi 2010, всё прекрасно работает! Недавно был пост посвященный подобной библиотеке, но по функционалу и стабильности работы, она не показала себя с хорошей стороны в отличие от этой библиотеки.

Особенности:

Быстрота анализа
XML в JSON
Простота использования
Проверка валидности JSON
JSON-RPC (Remote Procedure Call (вызов удалённых процедур)).
Возможность написания JSON в удобной для человека форме.

Лицензия:
MPL или LGPL

Сайт автора компонента:
Delphi & Free Pascal ressources by Henri Gourvest

SVN:
http://superobject.googlecode.com/svn/trunk/

Скачать архив от 29.03.2010 отсюда Download

WordUnit 1.0 Программа для сбора поисковой выдачи

2011-03-15T09:01:00.000-07:00

Утилита для поиска сайтов по ключевым словам в поисковых системах GOOGLE, YANDEX, RAMBLER (хотя последним даже и не пользуюсь ни когда)) ну и бог с ним) и сохранения их в таблицу, из таблицы в файл, а дальше куда душа пожелает!
Программа получает выдачу поисковиков по запросам, которые можно сделать в конструкторе, форма конструктора идентична их онлайн версиям, так, что проблем возникнуть не должно с построением запроса.

Скрины конструкторов:

Так, что сначала добавляем запросы, регулируем глубину поиска (т.е количество страниц в поисковике), таймаут между запросами(если активирован сбор информации о PR и ТИЦ он не учитывается, потому как на сбор этой информации уходит тоже время)) ) после чего кнопкой "Старт", запускаем сбор данных. Результаты работы программы будут выводиться в таблицу в которой их можно отсортировать или удалить ненужные, так же таблицу, как с результатами так и с запросами можно сохранить и открыть с помощью любого текстового редактора. Кто умеет пользоваться Excel тот и там сможет таблички посмотреть и сделать отсев по критериям. Так же можно выполнить проверку PR'a и ТИЦ'a в ходе сбора сайтов по интересующим вас запросам.
Программа работает в 3 потока (по одному на каждый поисковый сервер) так, что чередуйте запросы по серверам(пример: GOOGLE, YANDEX, RAMBLER,GOOGLE, YANDEX, RAMBLER), иначе какой нибудь из них из-за высокой "вашей" активности может, вас забанить на некоторое время.
Программу можно использовать и для сбора сайтов с жирным PR'ом и ТИЦ'ом, но уже тематически отфильтрованным и не придется раскошеливаться на покупку подобных баз.

Программа конечно не супер быстрая, но с учетом, того что можно сразу написать много заданий, этот минус становиться незаметным))
Внешний вид программы с двумя запросами

Пробуйте, если есть идеи по дополнительному функционалу пишите постараюсь сделать.

Программу или программку можно скачать отсюда Download

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

2011-03-06T03:44:00.000-08:00

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

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

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

2011-02-27T08:13:00.000-08:00

Ни так давно захотел определить 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/

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

У google все оказалось на много запущение (скорее всего это было сделано для того, чтобы пользователи устанавливали предоставляемый Google тулбар), для того чтобы получить PageRang нашего блога или сайта неважно)) нам необходимо выполнить запрос следующего вида:
http://www.google.com/search?client=navclient-auto&ch=[CHECKSUMM]&features=Rank&q=info:[адрес сайта с http:\\]

Пример:
http://www.google.com/search?client=navclient-auto&ch=86C47EA7D&features=Rank&q=info:http://nmdsoft.blogspot.com/

CHECKSUMM-это как раз, что мешает получить PageRang сайта без программного кода простым выполнением запроса.

Для вычисления контрольной суммы используем вот эту функцию, которая после ввода URL сайта нам в ответ возвращает готовую ссылку перейдя по которой мы можем получить PR сайта (парсинга там требуется еще меньше чем в яндексе так, как там кроме надписи Rank_1:1:XX ни чего нет))

Код функции для Delphi
function Check_PR(aUrl: string): string;
const
seed='Mining PageRank is AGAINST GOOGLE'#39'S TERMS OF SERVICE. Yes, I'#39'm talking to you, scammer.';
var
i,urllen,seedlen,key: DWORD;
begin
key:=16909125;
seedlen:= Length(seed)+1;
urllen:= Length(aUrl);
for i:=1 to urllen do
begin
key:= key xor (Ord(seed[i mod seedlen]) xor Ord(aUrl[i]));
key:= key shr 23 or key shl 9;
end;
result:='http://www.google.com/search?client=navclient-auto&ch=8'+IntToHex(key,8)+'&features=Rank&q=info:'+aUrl;
end;

Данная функция хороша тем от готовых компонентов, что вы сами можете выбрать, чем вы будете выполнять запросы, будь то Indy или Synapse ну или ICS.
Функцию нашел путем поиска в гугле seed='Mining PageRank is AGAINST GOOGLE так, что я не первый и не последний))
Кого интересует код на других языках программирования можете посмотреть home.zhiwei.li/pagerank

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

2011-02-24T07:24:00.000-08:00

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

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

Этот класс очень помог при разборе структур типа такой:
Лично мне, показался удобнее XML для работы с которым есть XMLNative есть и DOM, но там все как то громоздко слишком, а тут все аккуратненько и компактно.
{
     "Name": "Дмитрий",
      "address": {
         "streetAddress": "СССР",
         "city": "Город",
         "postalCode": 77777
       },
      "phoneNumbers": [
          "567890",
          "5435345345345"
      ]
}

По началу естественно хотелось все это дело распарсить, но вот как представишь, как бы это выглядело в коде, голова кругом идет. Решил поискать в интернете может, кто то сталкивался с подобной проблемой и нашел сразу чуть ли не на первой странице этот класс lkJSON 1.07. О качестве говорить не могу, так ни чего подобного сам не писал, а значит буду довольствоваться тем, что дали)) Класс бесплатный, для подключения ее к проекту необходимо его положить либо рядом с файлом проекта, либо в любое другое место и естественно прописать его в переменных окружения среды Delphi (иначе толку от того что он там находиться будет мало)

Скачать можно отсюда (на всякий случай скачал, а то мало ли чего) Download

Сайт автора для скачивания более актуальной версии, я конечно буду стараться обновлять хранилища, но могу не уследить за всем

Более удобная и функциональная библиотека для работы с JSON

Бот для Haddan

2011-02-01T06:31:00.000-08:00

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

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

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

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

Вкладка "Настройки"

     5. Ваш логин в игре
     6. Ваш пароль в игре
     7. Ключ сервиса Antigate.com
(Ваши персональные данные ( логин, пароль и ключ antigate) нигде кроме Вашего компьютера не сохраняются, и никем кроме Вас не используются!)

Antigate.com - сервис для автоматического получения текста с картинок (чтобы не вводить их в ручную). Зарегистрироваться можно здесь: http://antigate.com/index.php?action=regscreen

Коды приглашений:

5547bde01c

b89dad0640

8. Время, через которое бот будет пытаться снова начать копать. Лучше оставить как есть, чтобы не палиться.
9,10. Тут и так понятно.
Вкладка "Логи работы программы"

Все действия работы программы будут отображаться здесь.

Вкладка "Регистрация"

11. Серийный номер программы. Нужен для составления ключа.
12. Ключ можно приобрести тут или написать в icq и там обсудить другой способ оплаты.
Стоимость бота 500 рублей.
13. После ввода ключа нужно нажать кнопку «Зарегистрировать».

Скачать бота можно вот отсюда Download

Бот для Haddan

2011-01-08T08:25:00.000-08:00

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

Вводим логин, пароль игры + ваш captcha ключ. Если есть идеи по дополнению функционала пишите, сделаем по возможности.

Скачать новую версию бота для Haddan можно отсюда Download

Бот в работе

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

2011-01-07T07:06:00.000-08:00

Код функции по отправке файла
Автор: 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;

Пример использования

procedure TForm1.Button1Click(Sender: TObject);
var Data:TFileStream;
FormFields:TStrings;
FileName:String;
begin
FileName:='/home/theo/test.zip';

Data:=TFileStream.Create(FileName, fmOpenRead);

FormFields:=TStringList.Create;
FormFields.Add('Feld2=testen');
FormFields.Add('Feld3=sie mit');

HttpPostFileForm('http://localhost/theohome/php/listpost.php',
'Feld1',
ExtractFileName(FileName),
Data,
FormFields,
Memo1.lines);

Data.Free;
FormFields.free;
end;

Возможно кому нибудь пригодиться

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

2011-01-06T01:13:00.000-08:00

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)

2011-01-05T08:32:00.000-08:00

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

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

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

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

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

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

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

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

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

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

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

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

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

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

2010-12-29T08:03:00.000-08:00

По просьбе трудящихся выкладываю вот такой простенький исходник программки с помощью, которой можно получить ТИЦ и 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 с неограниченным призовым фондом.

2010-12-02T06:20:00.000-08:00

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

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

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

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

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

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

Время простоя ПК

2010-11-19T08:17:00.000-08:00

function CheckIddleTime: DWord;
var
   LastInput: TLastInputInfo;
begin
   LastInput.cbSize := SizeOf(TLastInputInfo);
   GetLastInputInfo(LastInput);
   Result := GetTickCount - LastInput.dwTime;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Label1.Caption:= 'Время простоя: ' + vartostr(CheckIddleTime/1000)+' секунд(ы)';
end;

Создание именованной, совместно используемой памяти (Delphi)

2010-11-18T08:38:00.000-08:00

Отображение файла в память для совместного использования несколькими процессами.

Первый процесс создает файл Temp.txt, после чего проецирует его в память

//первый процесс
unit mainServ;

interface

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

type
TForm1 = class(TForm)
    btnCreate: TButton;
    Memo1: TMemo;
    procedure btnCreateClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);

private
    { Private declarations }
public
    { Public declarations }
end;
const
MMFName: PWideChar = 'DelphiFileMappedExample'; // имя объекта файлового отображения
bufSize=100;//размер буфера

var
Form1: TForm1;
hFile,hMapedFile:HWND;
pMapFile:Pointer;

implementation

{$R *.dfm}

//Создание именованной, совместно используемой памяти
procedure TForm1.btnCreateClick(Sender: TObject);
var
outBuff:array[0..bufSize] of Char;
byteWrt:Cardinal;
begin
if not Assigned(pMapFile) then
    UnmapViewOfFile(pMapFile);
if hMapedFile<>INVALID_HANDLE_VALUE then
    CloseHandle(hMapedFile);
if (hFile<>INVALID_HANDLE_VALUE) then
    CloseHandle(hFile);
hFile:=CreateFile(PWideChar('Temp.txt'),
                    GENERIC_READ or GENERIC_WRITE,
                    FILE_SHARE_READ or FILE_SHARE_WRITE,
                    nil,CREATE_ALWAYS or OPEN_EXISTING,
                    FILE_ATTRIBUTE_NORMAL,0);

if hFile=INVALID_HANDLE_VALUE then
begin
    ShowMessage('Ошибка при создании файла '+SysErrorMessage(GetLastError));
    Exit;
end;
StrPCopy(outBuff,Memo1.Lines.Text);
WriteFile(hFile,outBuff,bufSize*SizeOf(Char),byteWrt,nil);

hMapedFile:=CreateFileMapping(hFile,                //INVALID_HANDLE_VALUE-использование файла подкачки
                                nil,                  // защита по умолчанию
                                PAGE_READWRITE,       //доступ к чтению/записи
                                0,                    // макс. размер объекта
                                bufSize*SizeOf(Char), // размер буфера
                                MMFName);             // имя отраженного в памяти объекта

if hMapedFile=INVALID_HANDLE_VALUE then
begin
    ShowMessage('Ошибка при проецировании файла в память '+SysErrorMessage(GetLastError));
    CloseHandle(hFile);
    Exit;
end;
pMapFile:=MapViewOfFile(hMapedFile,           //дескриптор "проецируемого" объекта
                          FILE_MAP_ALL_ACCESS, // разрешение чтения/записи
                          0,0,
                          bufSize*SizeOf(Char));//размер буфера
if pMapFile=nil then
begin
    ShowMessage('Ошибка при отображении файла '+SysErrorMessage(GetLastError));
    CloseHandle(hMapedFile);
    CloseHandle(hFile);
    Exit;
end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if not Assigned(pMapFile) then
    UnmapViewOfFile(pMapFile);
if hMapedFile<>INVALID_HANDLE_VALUE then
    CloseHandle(hMapedFile);
if (hFile<>INVALID_HANDLE_VALUE) then
    CloseHandle(hFile);end;

end.

Когда процессу больше не нужен доступ к объекту "проекция файла в память", он должен вызвать функцию CloseHandle. Когда все дескрипторы закрыты, система может освободить секцию файла подкачки, используемого объектом.

Второй процесс может получить доступ к одним и тем же данным при помощи вызова функции OpenFileMapping с тем же самым именем, что и первый процесс. Он может затем использовать функцию MapViewOfFile, чтобы получить указатель на представление данных файла.

//второй процесс

unit clientMain;

interface

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

type
TForm1 = class(TForm)
    btnRead: TButton;
    Memo1: TMemo;
    procedure btnReadClick(Sender: TObject);
private
    { Private declarations }
public
    { Public declarations }
end;
const
MMFName: PWideChar = 'DelphiFileMappedExample'; // имя объекта файлового отображения
bufSize=100;//размер буфера

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.btnReadClick(Sender: TObject);
var
hMapedFile:HWND;
pMapFile:Pointer;

begin
hMapedFile:=OpenFileMapping(FILE_MAP_ALL_ACCESS, // доступ к чтению/записи
                              False, //имя не наследуется
                              MMFName);//имя "проецируемого " объекта

if hMapedFile=INVALID_HANDLE_VALUE then
begin
    ShowMessage('Ошибка при проецировании файла в память '+SysErrorMessage(GetLastError));
    Exit;
end;

pMapFile:=MapViewOfFile(hMapedFile,//дескриптор "проецируемого" объекта
                          FILE_MAP_ALL_ACCESS,// разрешение чтения/записи
                          0,0,
                          bufSize*SizeOf(Char));//размер буфера

if pMapFile=nil then
begin
    ShowMessage('Ошибка при отображении файла '+SysErrorMessage(GetLastError));
    CloseHandle(hMapedFile);
    Exit;
end;

Memo1.Text:=PChar(pMapFile);
UnmapViewOfFile(pMapFile);
CloseHandle(hMapedFile);
end;

end.

Когда процессу больше не нужен доступ к объекту "проекция файла в память", он должен вызвать функцию CloseHandle. Когда все дескрипторы закрыты, система может освободить секцию файла подкачки, используемого объектом.

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

Файлы, проецируемые в память

2010-11-17T05:46:00.000-08:00

Технология файлов, проецируемых в память, является изящным средством для разделения ресурсов файловой системы между процессами.
При проецировании файла на адресное пространство процесса процесс может обращаться к содержимому файла так, как если бы файл был загружен в оперативную память.
Если несколько процессов выполняют проецирование одного и того же файла, то содержимое файла будет доступно для всех процессов, то есть позволит избежать загрузки множества экземпляров файла в оперативную память.
Для проецируемых файлов применяется 64-битная адресация, что позволяет использовать данную технологию для обработки сверхбольших (до 18 экзабайт) файлов, преодолевая, тем самым, ограничение на размер файла в 2 гигабайта.

Порядок работы:

Проецируемый файл открывается при помощи функции CreateFile() или OpenFile().
Создается новый объект ядра ОС типа «файл, проецируемый в память» системным вызовом CreateFileMapping(). В качестве первого параметра в него передается описатель файла открытого функцией CreateFile().
Вызов функции MapViewOfFile() возвращает указатель на участок спроецированного файла. После вызова MapViewOfFile() можно осуществлять чтение данных из области адресного, обозначенного возвращенным указателем.
После завершения чтения вызывается функция UnmapViewOfFile(), в качестве параметра в нее передается указатель, возвращенный на этапе (3).
Закрываем описатель файла функцией CloseHandle().

Задание.
Решить задачу из лабораторной работы №5 с использованием файлов, проецируемых в память, вместо каналов. Требуется запустить «программу-писатель» и несколько экземпляров «программы-читателя». Программа-писатель постоянно обновляет содержимое некоторого файла. Программы читатели проецируют данный файл на собственное адресное пространство. При обновлении файла происходит автоматическое обновление содержимого файла в окнах программ-читателей.

Решение реализовал вот так:
если увидите ошибки в коде, напишите пожалуйста, я обязательно исправлю и приму к сведению, что ни так. Чтобы не возникало потом подобных ляпов.

//сервер
unit mainServ;

interface

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

type
TfrmServer = class(TForm)
    btnCreate: TButton;
    Memo1: TMemo;
    Timer1: TTimer;
    procedure btnCreateClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);

private
    { Private declarations }
    procedure CreateFileMap;
    procedure CloseFileMap;
public
    { Public declarations }
end;

const
MMFName: PWideChar = 'DelphiFileMappedExample'; // имя объекта файлового отображения
bufSize=2048;//размер буфера

var
hFile,hMapedFile:HWND;
pMapFile:Pointer;
frmServer: TfrmServer;
WM_WRITEFILEMAP:Cardinal;

implementation

{$R *.dfm}

procedure TfrmServer.btnCreateClick(Sender: TObject);
begin
CreateFileMap;////Создание именованной, совместно используемой памяти
end;

procedure TfrmServer.CloseFileMap;
begin
if not Assigned(pMapFile) then
    UnmapViewOfFile(pMapFile);
if hMapedFile<>INVALID_HANDLE_VALUE then
    CloseHandle(hMapedFile);
if (hFile<>INVALID_HANDLE_VALUE) then
    CloseHandle(hFile);
end;

//Создание именованной, совместно используемой памяти
procedure TfrmServer.CreateFileMap;
var
outBuff:array[0..bufSize] of Char;
byteWrt:Cardinal;
begin
CloseFileMap;
hFile:=CreateFile(PWideChar('Temp.txt'),
                    GENERIC_READ or GENERIC_WRITE,
                    FILE_SHARE_READ or FILE_SHARE_WRITE,
                    nil,CREATE_ALWAYS or OPEN_EXISTING,
                    FILE_ATTRIBUTE_NORMAL,0);

if hFile=INVALID_HANDLE_VALUE then
begin
    ShowMessage('Ошибка при создании файла '+SysErrorMessage(GetLastError));
    Exit;
end;
Memo1.MaxLength:=bufSize;
StrPCopy(outBuff,Memo1.Lines.Text);
WriteFile(hFile,outBuff,bufSize*SizeOf(Char),byteWrt,nil);

hMapedFile:=CreateFileMapping(hFile,                //INVALID_HANDLE_VALUE-использование файла подкачки
                                nil,                  // защита по умолчанию
                                PAGE_READWRITE,       //доступ к чтению/записи
                                0,                    // макс. размер объекта
                                bufSize*SizeOf(Char), // размер буфера
                                MMFName);             // имя отраженного в памяти объекта

if hMapedFile=INVALID_HANDLE_VALUE then
begin
    ShowMessage('Ошибка при проецировании файла в память '+SysErrorMessage(GetLastError));
    CloseHandle(hFile);
    Exit;
end;
pMapFile:=MapViewOfFile(hMapedFile,           //дескриптор "проецируемого" объекта
                          FILE_MAP_ALL_ACCESS, // разрешение чтения/записи
                          0,0,
                          bufSize*SizeOf(Char));//размер буфера
if pMapFile=nil then
begin
    ShowMessage('Ошибка при отображении файла '+SysErrorMessage(GetLastError));
    CloseHandle(hMapedFile);
    CloseHandle(hFile);
    Exit;
end;
//оповещаем всех клиентов о том, что файл изменился))
SendMessage(HWND_BROADCAST,WM_WRITEFILEMAP,0,0);
end;

procedure TfrmServer.FormClose(Sender: TObject; var Action: TCloseAction);
begin
CloseFileMap;
end;

procedure TfrmServer.Timer1Timer(Sender: TObject);
begin
Memo1.Lines.Add(TimeToStr(time));
if Length(Memo1.Text) >=bufSize then
    Memo1.Clear;
CreateFileMap;
end;

initialization
WM_WRITEFILEMAP:=RegisterWindowMessage('WM_WRITEFILEMAP');

end.

//клиент

unit clientMain;

interface

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

type
TfrmClient = class(TForm)
    btnRead: TButton;
    Memo1: TMemo;
    procedure btnReadClick(Sender: TObject);
private
    { Private declarations }
public
    { Public declarations }
protected
    procedure WndProc(var Msg: TMessage); override;
end;
const
MMFName: PWideChar = 'DelphiFileMappedExample'; // имя объекта файлового отображения
bufSize=100;//размер буфера

var
frmClient: TfrmClient;
WM_WRITEFILEMAP:Cardinal;

implementation

{$R *.dfm}

procedure TfrmClient.btnReadClick(Sender: TObject);
var
hMapedFile:HWND;
pMapFile:Pointer;

begin
hMapedFile:=OpenFileMapping(FILE_MAP_ALL_ACCESS, // доступ к чтению/записи
                              False, //имя не наследуется
                              MMFName);//имя "проецируемого " объекта

if hMapedFile=INVALID_HANDLE_VALUE then
begin
    ShowMessage('Ошибка при проецировании файла в память '+SysErrorMessage(GetLastError));
    Exit;
end;

pMapFile:=MapViewOfFile(hMapedFile,//дескриптор "проецируемого" объекта
                          FILE_MAP_ALL_ACCESS,// разрешение чтения/записи
                          0,0,
                          bufSize*SizeOf(Char));//размер буфера

if pMapFile=nil then
begin
    ShowMessage('Ошибка при отображении файла '+SysErrorMessage(GetLastError));
    CloseHandle(hMapedFile);
    Exit;
end;

Memo1.Text:=PChar(pMapFile);
UnmapViewOfFile(pMapFile);
CloseHandle(hMapedFile);
end;

procedure TfrmClient.WndProc(var Msg: TMessage);
begin
inherited;
if Msg.Msg=WM_WRITEFILEMAP then
    btnReadClick(Self);

end;

initialization
WM_WRITEFILEMAP:=RegisterWindowMessage('WM_WRITEFILEMAP');

end.

Исходные коды проекта для delphi 2010 можно скачать отсюда Download немного переделав они будут работать и под Delphi 7

Программа для информирования пользователя о смене языка ввода 2 (Написана на Delphi)

2010-11-12T06:09:00.000-08:00

Немного изменил интерфейс, добавил то, что просили

Если нужен дополнительный функционал пишите.

Скачать программу под Windows XP SP3 можно отсюда Download
Скачать программу под Windows XP SP3 и Windows 7 64 можно отсюда Download

Как и просили исходник Windows 7 64
Так как нет возможности создания 64-х разрядной DLL сделал по таймеру))

Листинг Windows 7 64

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, AppEvnts,MMSystem,Registry, Menus,IniFiles,ShellAPI;

type
TfrmMain = class(TForm)
    pmMain: TPopupMenu;
    mniExit: TMenuItem;
    dlgOpen1: TOpenDialog;
    chkRun: TCheckBox;
    lblSite: TLabel;
    grp1: TGroupBox;
    lblRus: TLabel;
    lblEng: TLabel;
    chkCursor: TCheckBox;
    GroupBox2: TGroupBox;
    chkSay: TCheckBox;
    btnRusSound: TButton;
    btnEngSound: TButton;
    GroupBox3: TGroupBox;
    chkBeep: TCheckBox;
    btnSound: TButton;
    imgRusCur: TImage;
    imgEngCur: TImage;
    GroupBox1: TGroupBox;
    Label3: TLabel;
    Label4: TLabel;
    imgRusCurSel: TImage;
    imgEngCurSel: TImage;
    chkCursorSel: TCheckBox;
    lblSite2: TLabel;
    TrayIcon1: TTrayIcon;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure mniExitClick(Sender: TObject);
    procedure btnExitClick(Sender: TObject);
    procedure btnRusSoundClick(Sender: TObject);
    procedure btnEngSoundClick(Sender: TObject);
    procedure btnSoundClick(Sender: TObject);
    procedure chkSayClick(Sender: TObject);
    procedure chkBeepClick(Sender: TObject);
    procedure chkCursorClick(Sender: TObject);
    procedure lblSiteClick(Sender: TObject);
    procedure lblSiteMouseEnter(Sender: TObject);
    procedure lblSiteMouseLeave(Sender: TObject);
    procedure chkCursorSelClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure chkRunClick(Sender: TObject);
    procedure imgRusCurDblClick(Sender: TObject);
    procedure imgEngCurDblClick(Sender: TObject);
    procedure imgRusCurSelDblClick(Sender: TObject);
    procedure imgEngCurSelDblClick(Sender: TObject);
    procedure lblSite2Click(Sender: TObject);
    procedure lblSite2MouseEnter(Sender: TObject);
    procedure lblSite2MouseLeave(Sender: TObject);
    procedure TrayIcon1DblClick(Sender: TObject);
    procedure pmMainChange(Sender: TObject; Source: TMenuItem; Rebuild: Boolean);
    procedure Timer1Timer(Sender: TObject);

private
    { Private declarations }
    hLib:THandle;
    iLang:integer;
    pathForData:TStringList;
    procedure OpenDialog(aValue,aSubValue,aFilter:string;OpenDial:Boolean=True);
    procedure LoadOprionsFull;
    procedure PlaySound(aValue:string);
protected
    procedure WndProc(var Msg: TMessage); override;
    Procedure ControlWindow(Var Msg:TMessage); message WM_SYSCOMMAND;
public
    { Public declarations }
end;

var
frmMain: TfrmMain;

implementation

{$R *.dfm}
function SetWinCursor(aCurName,aCurNameType: string): boolean;
var Reg: TRegistry;
begin
Result:=true;
if not(FileExists(aCurName)) then
begin
    Result:=false;
    Exit;
end;
Reg:=TRegistry.Create;
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Control Panel\Cursors', false)=false then
begin
    Result:=false;
    exit;
end;
reg.WriteExpandString(aCurNameType, aCurName);
Reg.free;
SystemParametersInfo(SPI_SETCURSORS, 0, nil, 0);
end;

procedure TfrmMain.btnEngSoundClick(Sender: TObject);
begin
openDialog('Sound','Eng','Sound Wav|*.wav');
end;

procedure TfrmMain.btnExitClick(Sender: TObject);
begin
   frmMain.Close;
end;

procedure TfrmMain.btnRusSoundClick(Sender: TObject);
begin
openDialog('Sound','Rus','Sound Wav|*.wav');
end;

procedure TfrmMain.btnSoundClick(Sender: TObject);
begin
openDialog('Sound','Beep','Sound Wav|*.wav');
end;

procedure TfrmMain.chkSayClick(Sender: TObject);
begin
OpenDialog('Sound','SayEnable', BoolToStr(chkSay.Checked),false);
end;

procedure TfrmMain.ControlWindow(var Msg: TMessage);
begin
inherited;

if Msg.WParam=SC_MINIMIZE then
Begin
    TrayIcon1.Visible:=true;
    TrayIcon1.ShowBalloonHint;
    ShowWindow(Handle,SW_HIDE);
End;

end;

procedure TfrmMain.chkBeepClick(Sender: TObject);
begin
OpenDialog('Sound','BeepEnable', BoolToStr(chkBeep.Checked),false);
end;

procedure TfrmMain.chkCursorClick(Sender: TObject);
begin
OpenDialog('Cursor','Enable', BoolToStr(chkCursor.Checked),false);
end;

procedure TfrmMain.chkCursorSelClick(Sender: TObject);
begin
OpenDialog('CursorSel','Enable', BoolToStr(chkCursorSel.Checked),false);
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
pathForData:=TStringList.Create;
iLang:= GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, nil));
LoadOprionsFull;
end;

procedure TfrmMain.lblSiteClick(Sender: TObject);
begin
ShellExecute(frmMain.Handle, nil, 'http://nmdsoft.blogspot.com/', nil, nil, SW_RESTORE);
end;

procedure TfrmMain.lblSiteMouseEnter(Sender: TObject);
begin
lblSite.Font.Color:=clBlue;
end;

procedure TfrmMain.lblSiteMouseLeave(Sender: TObject);
begin
lblSite.Font.Color:=clBlack;
end;

procedure TfrmMain.LoadOprionsFull;
var
ini:TIniFile;
begin
pathForData.Clear;
ini:=TIniFile.Create(ExtractFilePath(ParamStr(0))+'Options.ini');
try
    chkCursor.Checked:= StrToBool(ini.ReadString('Cursor','Enable','0'));
    //edtRusCur.Text:=ini.ReadString('Cursor','Rus',ExtractFilePath(ParamStr(0))+'Rus.cur');
    //edtEngCur.Text:=ini.ReadString('Cursor','Eng',ExtractFilePath(ParamStr(0))+'Eng.cur');
    pathForData.Add(ini.ReadString('Cursor','Rus',ExtractFilePath(ParamStr(0)))+'Rus.cur');
    pathForData.Add(ini.ReadString('Cursor','Eng',ExtractFilePath(ParamStr(0))+'Eng.cur'));
    imgRusCur.Picture.Icon.Handle :=LoadCursorFromFile(PWideChar(pathForData.Strings[0]));
    imgEngCur.Picture.Icon.Handle :=LoadCursorFromFile(PWideChar(pathForData.Strings[1]));

    chkCursorSel.Checked:= StrToBool(ini.ReadString('CursorSel','Enable','0'));
    //edtRusCurSel.Text:=ini.ReadString('CursorSel','Rus',ExtractFilePath(ParamStr(0))+'RusSel.cur');
    //edtEngCurSel.Text:=ini.ReadString('CursorSel','Eng',ExtractFilePath(ParamStr(0))+'EngSel.cur');
    pathForData.Add(ini.ReadString('CursorSel','Rus',ExtractFilePath(ParamStr(0))+'RusSel.cur'));
    pathForData.Add(ini.ReadString('CursorSel','Eng',ExtractFilePath(ParamStr(0))+'EngSel.cur'));
    imgRusCurSel.Picture.Icon.Handle :=LoadCursorFromFile(PWideChar(pathForData.Strings[2]));
    imgEngCurSel.Picture.Icon.Handle :=LoadCursorFromFile(PWideChar(pathForData.Strings[3]));

    chkSay.Checked:= StrToBool(ini.ReadString('Sound','SayEnable','-1'));
    //edtRusSound.Text:=ini.ReadString('Sound','Rus',ExtractFilePath(ParamStr(0))+'Rus.wav');
    //edtEngSound.Text:=ini.ReadString('Sound','Eng',ExtractFilePath(ParamStr(0))+'Eng.wav');
    pathForData.Add(ini.ReadString('Sound','Rus',ExtractFilePath(ParamStr(0))+'Rus.wav'));
    pathForData.Add(ini.ReadString('Sound','Eng',ExtractFilePath(ParamStr(0))+'Eng.wav'));

    chkBeep.Checked:= StrToBool(ini.ReadString('Sound','BeepEnable','0'));
    //edtBeep.Text:=ini.ReadString('Sound','Beep',ExtractFilePath(ParamStr(0))+'Beep.wav');
    pathForData.Add(ini.ReadString('Sound','Beep',ExtractFilePath(ParamStr(0))+'Beep.wav'));
finally
    ini.Free;
end;
end;

procedure TfrmMain.mniExitClick(Sender: TObject);
begin
frmMain.Close;
end;

procedure TfrmMain.OpenDialog(aValue,aSubValue,aFilter:string;OpenDial:Boolean);
var
ini:TIniFile;
begin
ini:=TIniFile.Create(ExtractFilePath(ParamStr(0))+'Options.ini');
if OpenDial then
begin
    dlgOpen1.Filter:=aFilter;
    if dlgOpen1.Execute then
    begin
      try
        ini.WriteString(aValue,aSubValue,dlgOpen1.FileName);
      finally
        ini.Free;
      end;
    end;
end
else
   begin
    try
      ini.WriteString(aValue,aSubValue,aFilter);
    finally
      ini.Free;
    end;
end;
LoadOprionsFull;
end;

procedure TfrmMain.PlaySound(aValue: string);
begin
if FileExists(aValue) then
    sndPlaySound(PwideChar(aValue), SND_ASYNC)
else
    ShowMessage('Файл '+aValue+ 'не найден!!! Озвучка невозможна!!');
end;

procedure TfrmMain.pmMainChange(Sender: TObject; Source: TMenuItem; Rebuild: Boolean);
begin
frmMain.Close;
end;

procedure TfrmMain.Timer1Timer(Sender: TObject);
var
KBL_RUS:Integer;
KBL_ENG:Integer;
begin
    KBL_RUS:=68748313;
    KBL_ENG:=67699721;
if iLang<>GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, nil)) then
begin
    iLang:=GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, nil));
    if GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, nil)) = KBL_RUS then
      begin
        if chkCursor.Checked then
          SetWinCursor(pathForData.Strings[0],'Arrow'); //SetWinCursor(edtRusCur.Text,'Arrow');

        if chkCursorSel.Checked then
          SetWinCursor(pathForData.Strings[2],'IBeam'); //SetWinCursor(edtRusCurSel.Text,'IBeam');

        if chkSay.Checked then
          PlaySound(pathForData.Strings[4]);//PlaySound(edtRusSound.Text);

        if chkBeep.Checked then
          PlaySound(pathForData.Strings[6]);//PlaySound(edtBeep.Text);
      end;
      if GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, nil)) = KBL_ENG then
      begin
        if chkCursor.Checked then
          SetWinCursor(pathForData.Strings[1],'Arrow');//SetWinCursor(edtEngCur.Text,'Arrow');

        if chkCursorSel.Checked then
          SetWinCursor(pathForData.Strings[3],'IBeam'); //SetWinCursor(edtEngCurSel.Text,'IBeam');

        if chkSay.Checked then
          PlaySound(pathForData.Strings[5]);//PlaySound(edtEngSound.Text);

        if chkBeep.Checked then
          PlaySound(pathForData.Strings[6]);//PlaySound(edtBeep.Text);
      end;
end;
end;

procedure TfrmMain.TrayIcon1DblClick(Sender: TObject);
begin
ShowWindow(Handle,SW_RESTORE);
SetForegroundWindow(Handle);
TrayIcon1.Visible:=False;
end;

procedure TfrmMain.WndProc(var Msg: TMessage);

begin
inherited;

end;

procedure TfrmMain.FormShow(Sender: TObject);
var
reg:TRegistry;
begin
reg := TRegistry.Create;
with reg do
begin
    try
      RootKey := HKEY_LOCAL_MACHINE;
      OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Run', true);
      if ValueExists('NMDsoft') then
        chkRun.Checked:=True;
    finally
      CloseKey;
      Free;
    end;
end;
end;

procedure TfrmMain.chkRunClick(Sender: TObject);
var
reg:TRegistry;
begin
reg := TRegistry.Create;
with reg do
begin
    try
      RootKey := HKEY_LOCAL_MACHINE;
      OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Run', true);
      if chkRun.Checked then
        WriteString('NMDsoft', ParamStr(0))
      else
        if ValueExists('NMDsoft') then
           DeleteValue('NMDsoft');
    finally
      CloseKey;
      Free;
    end;
end;
end;

procedure TfrmMain.imgRusCurDblClick(Sender: TObject);
begin
openDialog('Cursor','Rus','Cursors|*.cur|Animate cursors|*.ani');
end;

procedure TfrmMain.imgEngCurDblClick(Sender: TObject);
begin
openDialog('Cursor','Eng','Cursors|*.cur|Animate cursors|*.ani');
end;

procedure TfrmMain.imgRusCurSelDblClick(Sender: TObject);
begin
openDialog('CursorSel','Rus','Cursors|*.cur|Animate cursors|*.ani');
end;

procedure TfrmMain.lblSite2Click(Sender: TObject);
begin
ShellExecute(frmMain.Handle, nil, 'http://blogistor.com/', nil, nil, SW_RESTORE);
end;

procedure TfrmMain.lblSite2MouseEnter(Sender: TObject);
begin
lblSite2.Font.Color:=clBlue;
end;

procedure TfrmMain.lblSite2MouseLeave(Sender: TObject);
begin
lblSite2.Font.Color:=clBlack;
end;

procedure TfrmMain.imgEngCurSelDblClick(Sender: TObject);
begin
openDialog('CursorSel','Eng','Cursors|*.cur|Animate cursors|*.ani');
end;

end.

Программа для информирования пользователя о смене языка ввода (Написана на Delphi)

2010-11-05T03:56:00.000-07:00

Программа информирует вас о смене языка ввода так, как это не всегда происходит при нажатии комбинации клавиш которые, как раз отвечают за это дело, но эта программа известит вас об этом звуковым сигналом или сменой указателя мыши и гудком все это дело настраивается без проблем в программе.
Программа работает в ОС Windows XP SP3
Скриншот программы

Программа бесплатная так, что вы ее используете на свой страх и риск!
Я не несу ответственности за вред который вы причините используя эту программу!
ВИРУСОВ НЕТ!
Скачать программу под Windows XP SP3 можно отсюда Download
Скачать программу под Windows 7 64 можно отсюда Download

В дополнение ко все хочу сказать, что я не пытался сделать PuntoSwithcher, слишком много автоматизации иногда мешает им ни когда не пользовался и не собираюсь, каждому своё!

Google Chrome Frame for Delphi 2010

2010-11-01T08:55:00.000-07:00

Компонент для использования функций Google Chrome в своих приложениях или же написания своего браузера на основе Google Chrome в Delphi.
Скриншот примера идущего в комплекте с компонентом.

ActiveX из npchrome_frame.dll не импортируется полностью и один хороший человек написал компонент на радость пользователям Delphi сайт автора компонента.

Компонент Google Chrome Frame для Delphi 2010 можно скачать отсюда Download