Модераторы: Poseidon, Snowy, bems, MetalFan

Поиск:

Ответ в темуСоздание новой темы Создание опроса
> Арсенал форумистов, Выкладывайте свои работы! 
:(
    Опции темы
p0s0l
Дата 15.4.2004, 00:04 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Г-н Посол
****


Профиль
Группа: Экс. модератор
Сообщений: 3668
Регистрация: 13.7.2003
Где: 58°38' с.ш. 4 9°41' в.д.

Репутация: 58
Всего: 112



Не раз уже встречал случаи, когда кто-нибудь хотел выложить какие-то свои наработки в Delphi: модули, исходники, компоненты, может еще что-то. Предлагалось создавать отдельный раздел, но пока не понятно, будет ли от этого толк. Пока что создаю эту тему. В дальнейшем же будет видно насчёт отдельного раздела исходников по тому, какая тут будет активность, и как к этому отнесётся Admin.

Единственное правило - в этой теме не флеймить, тут оставлять только краткое описание модулей и ссылки к ним.

Можно скинуть мне на мыло (кнопка E-Mail под моим постом) файл, и я его прикреплю к вашему сообщению при первой же возможности...



--------------------
С уважением, г-н Посол.
PM   Вверх
p0s0l
Дата 15.4.2004, 00:30 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Г-н Посол
****


Профиль
Группа: Экс. модератор
Сообщений: 3668
Регистрация: 13.7.2003
Где: 58°38' с.ш. 4 9°41' в.д.

Репутация: 58
Всего: 112



Модуль работы с ресурсами в PE файлах by Alex:
http://forum.vingrad.ru/index.php?showtopic=21183
- Извлечение иконок из ресурсов
- Добавление нового ресурса
- Изменение существующего ресурса
- Удаление ресурса
- Работа с ресурсами различных языков
- Работает в любой версии Windows
- И другое




--------------------
С уважением, г-н Посол.
PM   Вверх
SlaUr
Дата 15.4.2004, 10:44 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 408
Регистрация: 18.9.2003

Репутация: 3
Всего: 5



 "Системный модуль"
Код

-Системные папки
-Копирование удаление файлов и папок
-И многое другое


"Модуль для работы со строками" 
Код

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


"Зачатки модуля для работы с графикой"
Код

-Копирование экрана
-Изменение размеров jpg картинок


"Зачатки модуля для работы с 2000/XP"
Код

-function QuestPrezent
-SID текущего пользователя



"Примеры" 
Код

-FreeForm -Примеры  создания окна "произвольной" формы
-unrar - Пример использования unrar.dll (извлечение из архива rar)
-Resourse - Примеры  работы с ресурсами


Зайти на сайт


Это сообщение отредактировал(а) SlaUr - 22.1.2007, 07:02
PM MAIL   Вверх
Alex
Дата 16.4.2004, 23:51 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Экс. модератор
Сообщений: 4147
Регистрация: 25.3.2002
Где: Москва

Репутация: 80
Всего: 162



Функции для записи и чтение своих данных в, ЕХЕ- файле
http://forum.vingrad.ru/index.php?act=ST&f...=21513&unread=1

Модуль состоит:
1. AppendStringToFile - Дописывает строку к файлу
2. AppendedStringFromFile - Возвращает строку дописаную к файлу процедурой AppendStringToFile



--------------------
Написать можно все - главное четко представлять, что ты хочешь получить в конце. 
PM Skype   Вверх
Alex
Дата 22.4.2004, 07:43 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Экс. модератор
Сообщений: 4147
Регистрация: 25.3.2002
Где: Москва

Репутация: 80
Всего: 162



Модуль для упрощенного вызова сообщений
http://forum.vingrad.ru/index.php?act=ST&f...=21766&unread=1

Модуль служит для вывода диалоговых окон посредством Windows.MessageBox.


--------------------
Написать можно все - главное четко представлять, что ты хочешь получить в конце. 
PM Skype   Вверх
Akella
Дата 28.5.2004, 12:19 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329



Процедура поиска по всем полям
Код

Procedure FindRec(What,Mes:String;DS:TDataSet;sFields:array of String;
                             foFromBegin,foCaseSansitive,ShowMes:Boolean);
{
What            - строка для поиска (editFind.Text)
DS              - таблица (TTable,TQuery и т.д.)
Fields          - список полей, по которым нужно вести поиск (['Field1','Field3','Field7'])
foFromBegin     - поиск от начала таблицы (true - от начала или False от текущей записи)
foCaseSansitive - поиск с зависимостью от регистра символов (true - зависит от регистра или False не зависит от регистра)
}
   Function FieldInFields(_Field:String;_Fields:array of String):Boolean;//
   Var
    x:byte;
   begin//содержиться ли текущее поле в масива полей, предназначенных для поиска
     Result:=False;
     For x:=Low(_Fields) to High(_Fields) do
       if _Field = _Fields[x] then begin
         result:=true;
         exit;
       end;//if
   end;//func

Var
i,q,f,w:integer;
begin
 ds.DisableControls;//для ускорения отключаем таблицу
 w:=ds.RecNo;
 try
   //если поиск сначала таблицы
     if foFromBegin then q:=0 else q:=ds.RecNo;
   //идем по всем записям
     For i:=q to ds.RecordCount-1 do begin
   //пробег по всем полям
       For f:=0 to ds.FieldCount-1 do begin
   //если текущее поле содержится в массиве полей, предназначенных для поиска
         if FieldInFields(ds.Fields[f].FieldName,sFields) then begin
   //проверка на регистр
           if (foCaseSansitive = True) AND (POS(What,ds.Fields[f].AsString)<>0) then exit;
           if (foCaseSansitive = False) AND (POS(AnsiUpperCase(What),AnsiUpperCase(ds.Fields[f].AsString))<>0) then exit;
         end;//if FieldInFields(ds.Fields[f].FieldName,sField) then begin
       end;//For f:=0 to ds.FieldCount-1 do begin
       ds.Next;
     end;//For i:=q to ds.RecordCount-1 do begin
     ds.RecNo:=w;
     if ShowMes then ShowMessage(mes);
 finally
   ds.EnableControls;//даже если произойдет исключение, то таблицу надо включить
 end;//try-finally
end;//proc


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

FindRec(edFindText.Text,'',dm.tSpis,['Dirname','Type','PathName','Prim'],False,cbRegister.Checked,False);

PM MAIL   Вверх
OlegFPM
Дата 3.6.2004, 11:45 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 35
Регистрация: 27.4.2004

Репутация: нет
Всего: нет



Delphi и Microsoft Office

Если нужно решить какуе то задачу для Word или Excel, на Делфи и вы не знаите как это сделать,то вот простое решение :
Откройте Word или Excel, запустите на запись макрос. Решите поставленную для вас задачу, закройтье макрос.
Дальше нажмите сочитание клавишь Alt+F8, выбирите ваш макрос, по идеи он там будит один. Нажимаите кнопку "Войти" (уменя русский офис) и перед вами предстанит тело вашего макроса.
Этот текст надо будит перенести в Делфи, но не Ctrl+C и Ctrl+V, а ту последовательностть функций, которая там идет, с параметрами могут возникнуть праблемы. Дело в том что VBA иногда опускае параметры, прочтите MSDN!!!!, а в делфи этот номер не пройдет. Так же для некоторых ф-ций, количество параметров увеличено. Я столкнулся с такой проблемой, когда мне надо было сделать график, в VBA они вообще не передавались,а в делфи их было 6 штук.


PM MAIL   Вверх
LENIN INC
Дата 21.7.2004, 21:02 (ссылка)    |    (голосов: 0) Загрузка ... Загрузка ... Быстрая цитата Цитата


Unregistered











LENIN INC WIN32API Library v1.0 (build 11.05.04), Модули для создания программ на WIN32API

Вашему вниманию предлагаються модули для создания программ на чистом WIN32API в DELPHI (all version). Все функции и процедуры 100% работают в Win9X/ME/NT/2000/XP. Подробнее на странице - LENIN INC WIN32API Library v1.0 (build 11.05.04)

Суважением,
автор.

  Вверх
RA
Дата 2.8.2004, 05:07 (ссылка) |    (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Брутальный буратина
****


Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 14
Всего: 115



Маленький простенкий протектор для UPX'а.

Присоединённый файл ( Кол-во скачиваний: 300 )
Присоединённый файл  UPX_Protect.rar
PM   Вверх
Slawanix
Дата 3.8.2004, 00:23 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 177
Регистрация: 29.7.2004
Где: г. Великие Луки

Репутация: нет
Всего: 1



Процедура для тех, кто пишет синхронизатор фалов, она ищет, сортирует файлы и добавляет в таблицы StringGrid.

http://forum.vingrad.ru/index.php?showtopi...ndpost&p=193439
есть мнения?....

Это сообщение отредактировал(а) Slawanix - 3.8.2004, 23:57
--------------------
моск кипит    
PM MAIL WWW   Вверх
Dynamic
Дата 17.8.2004, 15:56 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 372
Регистрация: 5.7.2004
Где: Салехард

Репутация: 12
Всего: 15




Модератор: Сообщение скрыто.



--------------------
Было бы о чем молчать, а уж что сказать – всегда найдется...
PM MAIL WWW   Вверх
The MASTER
  Дата 31.8.2004, 12:54 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Old master)
**


Профиль
Группа: Участник
Сообщений: 862
Регистрация: 19.7.2004
Где: Санкт-Петербург

Репутация: 2
Всего: 5



Пример работы с MS Agent:

Для начала добавить компонент TMicrosoftAgent, для этого нажимаем:
Component -> Import ActiveX Control -> ищешь "Microsoft Agent Control 2" или что-то вэтом роде, далее нажимаешь Install, затем заходишь на вкладку компонентов ActiveX, оттуда кидаешь на форму компонент TAgent и далее код:

Код

uses
   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
   Dialogs, StdCtrls, OleCtrls, AgentObjects_TLB; //Добавить AgentObjects_TLB;


Код

private
   { Private declarations }
   Offcat: IAgentCtlCharacter; //Добавить Offcat: IAgentCtlCharacter;


В событие формы onCreate добавить:

Код

procedure TForm1.FormCreate(Sender: TObject);
begin
Agent1.Characters.Load('Offcat',ExtractFilePath(Application.ExeName)+'\Offcat.acs');
Offcat:=Agent1.Characters.Character('Offcat');
Offcat.Show(False);
end;


Далее создать новую кнопку и ввести:

Код

procedure TForm1.Button1Click(Sender: TObject);
begin
Offcat.Speak(edit1.text,'');
end;


Взять персоонажа можно либо из приложения Microsoft Office, либо из папки: C:\WINDOWS\srchasst\chars, от туда в папку со своим проектом копируй файл rover.acs, переименуй его в Offcat, первая буква "О" обязательно большая! Всё удачи, если будут проблемы пиши сюда!


Это сообщение отредактировал(а) The MASTER - 6.3.2005, 13:59
PM MAIL WWW ICQ   Вверх
Akella
  Дата 15.9.2004, 11:22 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329



нужно найти номер позиции второго символа "/" из строки "17/32/16"
Код

Function PosExt(symbol,str:string;beg:integer):integer;
{параметры
symbol - искомый символ
str        - строка, где производиться поиск
beg      - найти позицию str по счету beg
пример: нужно найти номер позиции 2-го[s] символа "/" из строки 17/32/16
ShowMessage(IntToStr(PosExt('/','17/23/16',2)));
}
var
i,p:integer;
begin
i:=0;
result := 0;
if (str = '') or (symbol = '') then exit;//выходим если пусто
For p:=1 to Length(str) do begin
  if str[p] = symbol then i:=i+1;
  if beg = i then
  begin
    result:= p;
    break;
  end;//if
end;//for
end;
wink.gif

Это сообщение отредактировал(а) dsergey - 16.9.2004, 09:00
PM MAIL   Вверх
The MASTER
Дата 15.9.2004, 13:25 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Old master)
**


Профиль
Группа: Участник
Сообщений: 862
Регистрация: 19.7.2004
Где: Санкт-Петербург

Репутация: 2
Всего: 5



Вот Примерчик сортировки!

Это сообщение отредактировал(а) p0s0l - 2.10.2004, 00:14

Присоединённый файл ( Кол-во скачиваний: 134 )
Присоединённый файл  unit1.pas
PM MAIL WWW ICQ   Вверх
Петрович
Дата 15.9.2004, 20:12 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1000
Регистрация: 2.12.2003
Где: Москва

Репутация: 25
Всего: 55



В архиве:

ufExSpellCheck.pas + ufExSpellCheck.dfm
Пример использования проверки граматики Word'а из Delphi. Реализовано два подхода.

Рекурсивный просмотр директорий.txt
"рыба" для рекурсивного просмотра и обработки каталога DirName
с подкаталогами.


Это сообщение отредактировал(а) p0s0l - 2.10.2004, 00:17

Присоединённый файл ( Кол-во скачиваний: 229 )
Присоединённый файл  archive.zip


--------------------
Все знать невозможно, но хочется
PM ICQ   Вверх
ДЫМ
Дата 23.9.2004, 02:45 (ссылка)  | (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 224
Регистрация: 6.1.2004

Репутация: 8
Всего: 8



Компонент LSVGauge является альтернативой стандартным
компонентам Gauge и ProgressBar
При помощи этого компонента можно создавать графические индикаторы с
оригинальным визуальным оформлением:
1) управление цветом частей текста на полосе и на фоне;
2) заполнение фона и полосы изображениями;
3) установка прозрачности заливки;
4) произвольная форма индикатора;
5) полоса с краями;
6) вывод целых блоков (в стиле ProgressBar, причем конфигурация
блоков может быть практически любой);
7) режим "бегущей полосы", когда число повторений цикла неизвестно
(возможность анимации полосы, титры на фоне см. пример);
8) простейшая трехмерная круговая диаграмма (Kind=Pie3D);
9) индикатор в стиле Partition Magic (текст центруется по текущей ширине
(высоте) полосы)
Может пригодиться тем, кто использует в своих приложениях сменные шкуры.


http://www.lsvhost.narod.ru/LSVGauge.zip
PM MAIL WWW   Вверх
p0s0l
Дата 28.9.2004, 21:04 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Г-н Посол
****


Профиль
Группа: Экс. модератор
Сообщений: 3668
Регистрация: 13.7.2003
Где: 58°38' с.ш. 4 9°41' в.д.

Репутация: 58
Всего: 112



Модератор: Прошу не флеймить и не оффтопить в этой теме! Левые посты в скоре будут удалены. Все личные сообщения пишите через PM.
Также прошу не выкладывать огроменные тексты прямо тут - либо присоединяйте файл к ответу, либо давайте ссылку на исходник! Иначе неудобно просматривать тему!
Кто не может присоединить файл к ответу (т.е. не является участником клуба), или не знает как выложить в инете свой файл - просто пока запостите в эту тему пост про свой исходник и по мылу вышлите мне сам исходник - я его присоединю к вашему посту при первой же возможности.
Чтобы написать мне письмо, жмите кнопку "E-Mail" внизу под моим постом...



--------------------
С уважением, г-н Посол.
PM   Вверх
Akella
  Дата 1.10.2004, 09:33 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329



Отправка файлов в корзину
в секцию private
Код
procedure Recycle1(const FileNames:TStrings;Wnd:HWND=0);

в секцию USES
Код
ShellAPI


Код
procedure TForm1.Recycle1(const FileNames:TStrings;Wnd:HWND=0);
var SHF:_SHFileOpStructA;
Name:PChar;
SizeName:Cardinal;
u:integer;
begin
For u:=0 to FileNames.Count-1 do
begin
SizeName:=Length(FileNames.Strings[u])+2;
GetMem(Name,SizeName);
FillChar(Name^,SizeName,0);
StrCopy(Name,PChar(FileNames.Strings[u]));
FillChar(SHF,SizeOf(SHF),0);
with SHF do
begin
 if Wnd=0 then Wnd:=Application.Handle;
 wFunc:=FO_DELETE;
 pFrom:=Name;
 fFlags:=FOF_ALLOWUNDO or FOF_NOERRORUI or FOF_NOCONFIRMATION;
end;
try
SHFileOperation(SHF);
except
end;
FreeMem(Name,SizeName);
end;
end;


использование
Код
Recycle1(od1.Files, Handle);
od1-TOpenDialog(закладка Dialogs)

Это сообщение отредактировал(а) dsergey - 1.10.2004, 09:44
PM MAIL   Вверх
Girder
Дата 11.10.2004, 14:49 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Лентяй 2
***


Профиль
Группа: Участник Клуба
Сообщений: 1993
Регистрация: 12.5.2004

Репутация: 31
Всего: 155



 Универсальная функция для обращения к любым экспортируем функциям DLL, внутри адресного пространства чужого процесса.

При этом возвращает как результат работы функции так и обработает все указатели на данные (т.е. к примеру в function ImageList_GetIconSize(ImageList: HIMAGELIST; var CX, CY: Integer): Bool - также вернет CX и CY).

Идею обращения к функции, внутри чужого процесса, предложил p0s0lно к сожалению код был реализован только под одну функцию.
 
Функция:
Код
function InjectPID_DLL(PID:Cardinal;LibHandle:HMODULE;fName:String;
                       CountParam:integer;Params:TParams;
                       var Res:Cardinal):Boolean;
{Универсальная функция для обращения к любым экспортируем функциям DLL,
внутри адресного пространства чужого процесса.

***При этом возвращает как результат работы функции так
  и обработает все указатели на данные (т.е. к примеру
  в function ImageList_GetIconSize(ImageList: HIMAGELIST; var CX, CY: Integer): Bool - также вернет CX и CY).

*** Идея инъекции: p0s0l; Оптимизированный вариант: Girder ***
Входные данные InjectPID_DLL:
- PID - идентификатор чужого процесса;
- LibName - Имя(при необходимости плюс путь) вызываемой DLL;
- fName - Имя экспортируемой функции DLL;
- CountParam - количество параметров;
- Params - параметры вызываемой функции DLL
 - Params[i].Param - Значение или указатель на данные;
 - Params[i].SizePointer - размер данных на который указывает указатель.
                           Если он равен нулю, то Params.Param - значение(иначе указатель на данные);
- Res - результат работы функции DLL
Выходные данные InjectPID_DLL:
Вслучаи успешного обрашения возвращается True иначе False;}

PS: Писал ночью...  smile т.ч. могут быть ошибки  smile (если найдете - пишите в PM).

В архиве:
Inject.pas - сама функция
Example.pas -Пример использования:
- Выдираем в WinXP иконки из трея и добавляем их в ImageList и отображаем их в TreeView... 

13 октября 2006: Поправил пример smile

Присоединённый файл ( Кол-во скачиваний: 126 )
Присоединённый файл  Girder2.zip 3,47 Kb


--------------------
Как слышим, так и пишим.
Истина где-то там...
PM   Вверх
Pathfider
Дата 11.10.2004, 22:11 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 128
Регистрация: 13.7.2004
Где: все там же

Репутация: -1
Всего: 1



Накатал тут програмку от нечего делать. Можно использовать в качестве дневника или для ведения конфеденциальных записей. Применял свой алгоритм шифрования. Работает везде (по идее), тестировалась на WinXP SP2. Если будут какие либо предложения или замечания, пожалуюста напишите!

Присоединённый файл ( Кол-во скачиваний: 271 )
Присоединённый файл  Diry.zip
--------------------
Trust is a weakness
PM MAIL   Вверх
p0s0l
Дата 12.10.2004, 16:20 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Г-н Посол
****


Профиль
Группа: Экс. модератор
Сообщений: 3668
Регистрация: 13.7.2003
Где: 58°38' с.ш. 4 9°41' в.д.

Репутация: 58
Всего: 112



И я выложу (раз уж доделал) свою версию smile...
В модуле две основых функции:
RemoteCall и AsyncRemoteCall - вторая асинхронная (работа потока не останавливается), результатов не возвращает.
Код
function RemoteCall (PID : DWORD; const FuncName, LibName : string; Params : array of TCallParam) : DWORD;
PID - ID процесса, в контексте которого будет вызвана функция
FuncName - имя функции, LibName - имя DLL
Params - параметры вызываемой функции. Передача параметров осуществляется двумя способами:
ByVal - по значению, и ByRef - по ссылке
Функция возвращает результат вызова функции в чужом процессе.
Пример 1:
Код
RemoteCall (GetCurrentProcessID, 'MessageBoxA', 'user32.dll', [ByVal(0), ByVal('Hello!'), ByVal('Caption'), ByVal(MB_ICONINFORMATION)]);

Пример 2:
Код
var s : AnsiString;
begin
 SetLength(s, 1024);
 RemoteCall (<ProcessID>, 'GetWindowTextA', 'user32.dll', [ByVal(Handle), ByRef(s), ByVal(1024)]);
 Form1.Caption := s;
end;


Присоединённый файл ( Кол-во скачиваний: 149 )
Присоединённый файл  PSL_RemoteCall.zip


--------------------
С уважением, г-н Посол.
PM   Вверх
Dr Smth
Дата 28.10.2004, 14:36 (ссылка)  | (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 100
Регистрация: 11.10.2004
Где: New Podrezkovo

Репутация: нет
Всего: 1



При составлении программ часто возникает ситуация, когда нужно что-нибудь подсчитать, и вывести результат в виде: ЧИСЛО + СЛОВО. Причём СЛОВО обозначает то, что, собственно, и нужно подсчитать. Например, нужно вывести число строк в списке TListBox в формате: 'N слов'. Благодаря особенностям великого и могучего русского языка и тому, что число N заранее неизвестно, может меняться и вычисляется самой программой, заранее также неясно в каком падеже нужно ставить следующее за числом слово.

Если плюнуть на это и написать просто: N + ' слово', то при расчётах получим малограмотные конструкции типа '17 слово' и '3 слово'.

Между тем избавиться от данной ситуации довольно просто. Я тут поразмыслил, и написал функцию, выбирающую из трёх падежей нужный. Возможно не самый оптимальный вариант, но всё же... Для более детального ознакомления смотрите комментарии в коде.

Код
program FndCase;

{$APPTYPE CONSOLE}

uses
 SysUtils;


{Функция возвращает строку, содержащую введённое число плюс введённое сцуществительное
в падеже, согдасующимся с этим числом (порядковым числительным)

Передаваемые параметры:

 i : Integer - целое число, представляющее нужное порядковое числительное;
 e_ip : String - именительный пажед единственного числа вводимого существительного
                 (кто? что?);
 e_rp : String - родительный падеж единственного числа вводимого существительного
                 (кого? чего?);
 mn_rp : String - родительный падеж множественного числа вводимого существительного
                 (кого? чего?);

Результатом является выбор между этих трёх вариантов в соответствии с порядковым
числительным}

function ChooseCase (i : Integer; e_ip, e_rp, mn_rp: String): String;
 var
   end_w : Integer;
 begin
   end_w := StrToInt(Copy(IntToStr(i), Length(IntToStr(i)) - 1, 2));
    if (end_w > 10) and (end_w < 20)
     then
       begin
        Result := IntToStr(i) + ' ' + mn_rp;
       end
     else
       begin
        end_w := StrToInt(Copy(IntToStr(end_w), Length(IntToStr(end_w)), 1));
        case end_w of
        0 : Result := IntToStr(i) + ' ' + mn_rp;
        1 : Result := IntToStr(i) + ' ' + e_ip;
        2..4 : Result := IntToStr(i) + ' ' + e_rp;
        5..9 : Result := IntToStr(i) + ' ' + mn_rp;
        end;
       end;
 end;

begin

 //Несколько примеров
 
 Randomize;
 WriteLn(ChooseCase(Random(1000), 'slovo', 'slova', 'slov'));
 WriteLn(ChooseCase(Random(1000), 'bukva', 'bukvy', 'bukv'));
 WriteLn(ChooseCase(Random(1000), 'programmist', 'programmista', 'programmistov'));
 WriteLn(ChooseCase(Random(1000), 'Andrey', 'Andreya', 'Andreev'));
 WriteLn(ChooseCase(Random(1000), 'Svetlana', 'Svetlany', 'Svetlan'));
 WriteLn(ChooseCase(Random(6000000000), 'chelovek', 'cheloveka', 'chelovek'));
 ReadLn;
end.

PM MAIL WWW   Вверх
Girder
Дата 12.11.2004, 21:39 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Лентяй 2
***


Профиль
Группа: Участник Клуба
Сообщений: 1993
Регистрация: 12.5.2004

Репутация: 31
Всего: 155



Функция поворота изображения на заданный угол через DIB.

Функция:
Код
function HBitMapRotate(BitMap:HBitMap;Angle:Extended;var X_Y:TPoint):HBitmap;
{Входные данные: BitMap - Источник рисунка
                Angle - Угол на который будет повернут BitMap
Выходные данные: HBitMapRotate - Идентификатор точечного повернутого рисунка
                 X_Y - Размеры повернутого изображения}


В архиве: Сама функция и пример использования

Это сообщение отредактировал(а) Girder - 12.11.2004, 23:56

Присоединённый файл ( Кол-во скачиваний: 133 )
Присоединённый файл  rGirder.zip


--------------------
Как слышим, так и пишим.
Истина где-то там...
PM   Вверх
p0s0l
Дата 19.11.2004, 15:11 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Г-н Посол
****


Профиль
Группа: Экс. модератор
Сообщений: 3668
Регистрация: 13.7.2003
Где: 58°38' с.ш. 4 9°41' в.д.

Репутация: 58
Всего: 112



С помощью этого модуля можно прочитать или записать в файл, который уже открыт, даже эксклюзивно! (Но файл и не обязательно должен быть открыт smile )
Но:
* работает в NT (тестил в XP, в 2k - не тестил)
* нужны права администратора
* к файлу должен быть разрешен доступ FILE_READ_ATTRIBUTES (единственное, что не получилось пока прочитать - это файлы подкачек)
* тестил на: NTFS, FAT32 (FAT16 теоретически должен поддерживаться)
* при записи нужно учитывать работу кэша...
* также, следует понимать, что размер файла нельзя изменить, т.е. дописать что-то в конец файла, или обрезать файл...

В модуле 3 функции (названия говорят сами за себя):
Код
function DF_Read (const FileName : string; Offset, Size : Cardinal; Buf : Pointer) : Boolean;
function DF_Write (const FileName : string; Offset, Size : Cardinal; Buf : Pointer) : Boolean;
function DF_GetFileSize (const FileName : string) : Int64;
FileName - имя файла
Offset - смещение внутри файла в байтах, откуда будет происходить чтение/запись
Size - размер данных для записи/чтения (в байтах)
Buf - указатель на буфер

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

Присоединённый файл ( Кол-во скачиваний: 320 )
Присоединённый файл  DFA.ZIP


--------------------
С уважением, г-н Посол.
PM   Вверх
RA
  Дата 22.11.2004, 11:02 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Брутальный буратина
****


Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 14
Всего: 115



Пример реализации Русско-Английского KeyLoggera Средствами WinApi


Присоединённый файл ( Кол-во скачиваний: 287 )
Присоединённый файл  xKeyLoger.rar
PM   Вверх
RA
Дата 26.11.2004, 02:07 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Брутальный буратина
****


Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 14
Всего: 115



* Пример внедрения длл в чужой процесс
* Пример перехвата функций Api:

FindNextFile...,
RegEnumValue...,
FormatMessage...,
WinExec...,
ShellExecute...,
CreateProcess... .

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

Присоединённый файл ( Кол-во скачиваний: 428 )
Присоединённый файл  ApiHook.rar
PM   Вверх
BSV_Sergey
Дата 26.11.2004, 17:36 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 33
Регистрация: 19.11.2004
Где: г. Москва

Репутация: нет
Всего: 3



Привет всем.
Пока не разобрался как добавить к сообщению файлы.
Если кто-нибудь озадачится вызовом отчетов Crystal Reports из приложения без установленного Crystal-а то для этого необходимо:
1. К проекту подключить модуль CRDelphi.pas,содержащий описание функций и типов для работы с Crystal Report Engine API. Модуль включен в дистрибутив CR 9.0 \\Tools\Developers
2. Библиотека содержащая функции CR API – crpe32.dll
3. Кроме того для работы программы без Crystal-а необходимы следующие библиотеки: crqe.dll, Implode.dll, querybuilder.dll, ufmanager.dll и также библиотеки используемые отчетом для подключения к источнику данных.
4. Так же необходимо внести изменения в реестр, чтобы программа могла использовать функции Crystal Report Engine. В разделы:
[HKEY_LOCAL_MACHINE\SOFTWARE\Classes\CLSID\{BDE2D224-27E0-4925-A4E1-F5F38A191ABC}]
[HKEY_CLASSES_ROOT\CLSID\{BDE2D224-27E0-4925-A4E1-F5F38A191ABC}]
5. Пример использования функций CR API в программе (Пример урезанный):

Код

if PEOpenEngine then
 begin
   nPrintJob := PEOpenPrintJob(PChar(sReportName));//Путь и имя файла отчета
   if nPrintJob = 0 then
       ShowMessage('Error Open Report')
   else
     begin
       //Получаем информацию о параметрах соединения отчета с БД
       vLogOnInfo.StructSize := PE_SIZEOF_LOGON_INFO;
       PEGetNthTableLogOnInfo(nPrintJob,0,vLogOnInfo);
       //Присваиваем необходимые значения для соединения
       vLogOnInfo.ServerName := '';
       StrPCopy(vLogOnInfo.ServerName , sServerName);//Имя сервера БД для отчета
       vLogOnInfo.Password := '';
      StrPCopy(vLogOnInfo.Password , sPassword);//Пароль для пользователя БД
       vLogOnInfo.DatabaseName := '';
      StrPCopy(vLogOnInfo.DatabaseName , sDBName);//Имя БД
       //Передаем параметры в отчет  
       if not PESetNthTableLogOnInfo(nPrintJob,0,vLogOnInfo,true) then
         ShowMessage('Mistake of transfer parameters of connection.');
        //Парамерты окна просмотра отчета
       PEOutputToWindow(nPrintJob, PChar(sRepPuth), 0,0,0,0,  WS_MAXIMIZE+ WS_MINIMIZEBOX+WS_MAXIMIZEBOX+WS_SYSMENU,0);
           vViewerOption.hasGroupTree := 1;
           vViewerOption.canDrillDown := 1;
           vViewerOption.hasNavigationControls := 1;
           vViewerOption.hasCancelButton := 1;
           vViewerOption.hasPrintButton := 1;
           vViewerOption.hasExportButton := 1;
           vViewerOption.hasZoomControl := 1;
           vViewerOption.hasCloseButton := 1;
           vViewerOption.hasProgressControls := 1;
           vViewerOption.hasSearchButton := 1;
           vViewerOption.hasPrintSetupButton := 1;
           vViewerOption.hasRefreshButton := 0;
          //Применение параметров окна просмотра
           vViewerOption.StructSize := PE_SIZEOF_WINDOW_OPTIONS;
           PESetWindowOptions(nPrintJob,vViewerOption);
        End;
       PEStartPrintJob(nPrintJob, true);
     end;
 end
else
   ShowMessage('CR Report Engine not started');



6. !!!!! ВАЖНО. При завершении работы приложения или во время его работы (зависит от того, сколько отчетов пользователь может просматривать одновременно) необходимо организовать выполнение процедуры PECloseEngine, иначе выдастся ошибка. При этом PECloseEngine нужно вызвать столько раз, сколько раз был запущен PEOpenEngine.

Я постарался сделать описание крадким, если данная тема интересна и нужна подробная информация, пишите на E-mail.

Это сообщение отредактировал(а) BSV_Sergey - 2.12.2004, 14:24
PM MAIL   Вверх
Alex
Дата 30.11.2004, 22:59 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Экс. модератор
Сообщений: 4147
Регистрация: 25.3.2002
Где: Москва

Репутация: 80
Всего: 162



Получение длинного пути из короткого:

Код

function ShortToLongFileName(FileName: string): string;
var
 KernelHandle: THandle;
 FindData: TWin32FindData;
 Search: THandle;
 GetLongPathName: function(lpszShortPath: PChar; lpszLongPath: PChar;
                           cchBuffer: DWORD): DWORD; stdcall;
begin
 KernelHandle := GetModuleHandle('KERNEL32');
 if KernelHandle <> 0 then
   @GetLongPathName := GetProcAddress(KernelHandle, 'GetLongPathNameA');

 // Использю GetLongPathName доступную в windows 98 и выше чтобы
 // избежать проблем доступа к путям UNC в системах NT/2K/XP
 if Assigned(GetLongPathName) then begin
   SetLength(Result, MAX_PATH + 1);
   SetLength(Result, GetLongPathName(PChar(FileName), @Result[1], MAX_PATH));
 end
 else begin
   Result := '';

   // Поднимаюсь на одну дирректорию выше от пути к файлу и запоминаю
   // в result.  FindFirstFile возвратит длинное имя файла полученное
   // из короткого.
   while (True) do begin
     Search := Windows.FindFirstFile(PChar(FileName), FindData);

     if Search = INVALID_HANDLE_VALUE then Break;

     Result := String('\') + FindData.cFileName + Result;
     FileName := ExtractFileDir(FileName);
     Windows.FindClose(Search);

     // Нахожу имя диска с двоеточием.
     if Length(FileName) <= 2 then Break;
   end;

   Result := ExtractFileDrive(FileName) + Result;
 end;
end;



--------------------
Написать можно все - главное четко представлять, что ты хочешь получить в конце. 
PM Skype   Вверх
Girder
Дата 3.12.2004, 13:16 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Лентяй 2
***


Профиль
Группа: Участник Клуба
Сообщений: 1993
Регистрация: 12.5.2004

Репутация: 31
Всего: 155



OpenThread - Функция получения дескриптора потока по его идентификатору для Win 9X,ME,WinNT All.

PS: данная функция присутствует только в старших версиях NT и ME, в младших версиях есть NTOpenThread. При этом в Win 9X - её вообще нет... smile

Функция:
Код

const
 THREAD_TERMINATE               =$0001;
 THREAD_SUSPEND_RESUME          =$0002;
 THREAD_GET_CONTEXT             =$0008;
 THREAD_SET_CONTEXT             =$0010;
 THREAD_SET_INFORMATION         =$0020;
 THREAD_QUERY_INFORMATION       =$0040;
 THREAD_SET_THREAD_TOKEN        =$0080;
 THREAD_IMPERSONATE             =$0100;
 THREAD_DIRECT_IMPERSONATION    =$0200;
 THREAD_ALL_ACCESS              = STANDARD_RIGHTS_REQUIRED or
                                  SYNCHRONIZE or $3FF; // == $1F03FF;

function OpenThread(dwDesiredAccess:DWord;bInheritHandle:Bool;dwThreadId:DWord):Cardinal;
//Функция получения дескриптора потока по его идентификатору для Win 9X,ME,WinNT All
//dwDesiredAccess - флаги доступа к потоку
//bInheritHandle - флаг наследования дескриптора
//dwThreadId - идентификатор потока


В примере рассматривается алгоритм поиска потока отвечающий за панель задач. Основан он на том что если поток остановить(а для этого мы должны получить дескриптор потока с соответствующими правами) и обратится к его любым методам и свойствам из другого потока, то поток инициатор обращения тоже "как бы уснет"... smile. Для этого используется SendMessage(TrayWnd,SW_Show,0,0) - которая будет ждать результат smile обработки сообщения... smile

В архиве: сама функция и пример её использования... smile

Это сообщение отредактировал(а) Girder - 3.12.2004, 13:27

Присоединённый файл ( Кол-во скачиваний: 110 )
Присоединённый файл  OpenThread.zip


--------------------
Как слышим, так и пишим.
Истина где-то там...
PM   Вверх
Dr Smth
Дата 18.12.2004, 12:50 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 100
Регистрация: 11.10.2004
Где: New Podrezkovo

Репутация: нет
Всего: 1



Модуль позволяющий, любые конвертации между темперетурными шкалами Цельсия, Фаренгейта, Ренкина и Реомюра.

Всего 20 функций, названия которых гроворят сами за себя:

Код

function CToK (Celsium_degree: Extended): Extended; // - Перевод градусов Цельсия в Кельвины и т. д.
function KToC (Kelvin_degree: Extended): Extended;
function FToC (Farengheit_degree : Extended): Extended;
function CToF (Celsium_degree : Extended) : Extended;
function RenToC (Renkin_degree : Extended): Extended;
function CToRen (Celsium_degree : Extended) : Extended;
function ReoToC (Reomur_degree : Extended): Extended;
function CToReo (Celsium_degree : Extended) : Extended;
function KToF (Kelvin_degree: Extended): Extended;
function FToK (Farengheit_degree: Extended): Extended;
function KToRen (Kelvin_degree: Extended): Extended;
function RenToK (Renkin_degree: Extended): Extended;
function KToReo (Kelvin_degree: Extended): Extended;
function ReoToK (Reomur_degree: Extended): Extended;
function RenToF (Renkin_degree: Extended): Extended;
function FToRen (Farengheit_degree: Extended): Extended;
function RenToReo (Renkin_degree: Extended): Extended;
function ReoToRen (Reomur_degree: Extended): Extended;
function FToReo (Farengheit_degree: Extended): Extended;
function ReoToF (Reomur_degree: Extended): Extended;



Присоединённый файл ( Кол-во скачиваний: 103 )
Присоединённый файл  Temperature.zip
PM MAIL WWW   Вверх
ДЫМ
Дата 20.1.2005, 02:25 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 224
Регистрация: 6.1.2004

Репутация: 8
Всего: 8



Иллюстрированный самоучитель по Delphi 7 для профессионалов


Этот самоучитель попал ко мне в виде набора HTML-страниц, что было неудобно в использовании. Я скомпилировал документ в формат chm, добавил оглавление и полнотекстовый поиск. Очень хороший самоучитель как для тех, кто серьезно занимается программированием на Delphi, так и для начинающих. Помимо всего прочего chm-файл содержит архив примеров к самоучителю с исходниками.

Скачать 3,21 Мб


PM MAIL WWW   Вверх
Петрович
Дата 21.1.2005, 11:13 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1000
Регистрация: 2.12.2003
Где: Москва

Репутация: 25
Всего: 55



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

Это сообщение отредактировал(а) Петрович - 21.1.2005, 11:30

Присоединённый файл ( Кол-во скачиваний: 350 )
Присоединённый файл  awString.zip


--------------------
Все знать невозможно, но хочется
PM ICQ   Вверх
Петрович
Дата 21.1.2005, 11:27 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1000
Регистрация: 2.12.2003
Где: Москва

Репутация: 25
Всего: 55



Многие кто писал консольные приложения наверное сталкивался с такой проблеммой:
В окне консоли используется кодировка OEM, т.е. DOS-кодировка. Поэтому, если в программе написать:
Код

WriteLn('Вася+Маша=Лубов');

то в консольно окне мы увидим "кракозябры" вместо русских букв. Это потому, что в Delphi программе естественно используется кодировка Windows.

Есть еще одна проблема:
Если в консольной программе возникает исключительная ситуация (Exception), то это вызывает малопонятное для клиента окно сообщения о системной ошибке в приложении.

Мне приходилось часто писать консольные приложения. Так вот, что бы не заниматься постоянной перекодировкой и не заботиться об необработанных программой исключениях, я написал свой модулек awConsole.
Просто добавление этого модуля в проект вызывает несколько изменений в поведении программы:
1. Весь консольный ввод/вывод осуществляется в кодировке OEM;
Достигается это подменой "драйвера" обслуживания консольных файлов Input, Output, ErrOutput.
2. Исключения не обработанные программой вызывают окно сообщения вместо системной ошибки.

Ну и есть там еще несколько полезных и не очень полезных функций.

Это сообщение отредактировал(а) Петрович - 21.1.2005, 11:30

Присоединённый файл ( Кол-во скачиваний: 162 )
Присоединённый файл  awConsole.zip


--------------------
Все знать невозможно, но хочется
PM ICQ   Вверх
Петрович
Дата 21.1.2005, 11:41 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1000
Регистрация: 2.12.2003
Где: Москва

Репутация: 25
Всего: 55



А вот еще, уже просто выдержки из библиотеки:

интерфейс:
Код

////////////////////////////////////////////////////////////////////////////////
//
// Итераторы.

type
 tRecursiveOrder = (roNone,roParentChildrens,roChildrensParent);
 tForEachProc    = procedure (Component :tObject);

procedure ForEachOwned (Component      :TComponent;
                       Proc           :tForEachProc;
                       RecursiveOrder :tRecursiveOrder =roParentChildrens
                       );
// Вызывают Proc для каждого компонента которым владеет Component.

procedure ForEachChild (WinControl    :TWinControl;
                      Proc           :tForEachProc;
                      RecursiveOrder :tRecursiveOrder =roParentChildrens;
                      IncludeNonWinControls :Boolean =False
                      );
// Вызывают Proc для каждого дочернего по отношению к WinControl эл-та управления.
// (Визуальное владение, WinControl.Controls, Parent которых = WinControl)


// Главный "кайф" этих процедур в том, что Proc может быть ЛОКАЛЬНОЙ процедурой.
// Причем, что-бы компилятор не ругался, надо поставить @ перед именем процедуры
// (см.примеры). Однако, ответственность за соответствие числа и типа параметров
// лежит на Вас.
//
// Например получение списка всех компонентов формы:
//
//    procedure TForm1.FormCreate(Sender: TObject);
//    var i :Integer;
//      procedure p(Component :TComponent);
//      begin
//        ListBox1.Items.Add(Format('%4d: %s :%s',[i,Component.Name,Component.ClassName]))
//        Inc(i);
//      end;
//    begin
//      ListBox1.Items.Add('Список компонентов принадлежащих форме')
//      i := 0;
//      ForEachOwned(Self,@p);
//    end;
//
// Или еще - открытие всех наборов данных расположенных на форме, и всех
// расположенных на ней фреймах и "подформах" :
//
//    procedure TForm1.FormShow(Sender: TObject);
//      procedure OpenDataSet(Component :tComponent);
//      begin
//        if  Component is tDataSet  then  TDataSet(Component).Open;
//      end;
//    begin
//      ForEachOwned(Self,@OpenDataSet);
//    end;
//
////////////////////////////////////////////////////////////////////////////////

Реализация "пристегнута"

А вот пример полезного использования:

Код

procedure En (Container :TWinControl; Enable :Boolean);
// Устанавливает значение свойства Enabled у Container, а также
// всем компонентам-редакторам лежащим на Container
// будет еще установлен и цвет, clWindow при Enable True и clBtnFace
// при Enable False.

const ca :array [boolean] of tColor = (clBtnFace, clWindow);

 procedure SetColor (C :TObject);
 begin
   if   (C is TCustomEdit)
     //or (C is TCustomCheckBox)
     //or (C is TCustomListBox)
     then with tHackControl(C) do begin
     Color := ca[Enabled and Enable];
   end;
 end;

begin
 Container.Enabled := Enable;
 ForEachChild(Container,@SetColor);
end;

И еще:
Код

procedure SetReadOnlyAndColorForAllWinControls(const WinControl :tWinControl; const ReadOnlyValue :Boolean; const SetColor :Boolean =True);
// Выполняет SetReadOnlyAndColor(...,ReadOnlyValue) для WinControl и всех его
// дочерних компонентов
 procedure p (o :tObject);
 begin
   if  o is tWinControl  then   SetReadOnlyAndColor(TWinControl(o),ReadOnlyValue,SetColor);
 end;
begin
 ForEachChild(WinControl,@p,roChildrensParent,False);
 SetReadOnlyAndColor(WinControl,ReadOnlyValue,SetColor);
end;

Соответственно требуется SetReadOnlyAndColor:
Код

type tHackControl = class(tControl);
procedure  SetReadOnlyAndColor(WinCtrl :tWinControl; const ReadOnlyValue :Boolean; const SetColor :Boolean =True);
// Если компонент WinCtrl имеет свойство ReadOnly то его значение
// устанавливается в ReadOnlyValue.
// Кроме того, если WinCtrl является потомком от TCustomEdit или TCustomGrid,
// то его цвет изменяется в зависимости от значения ReadOnlyValue:
//   False - устанавливается цвет clWindow;
//   True  - устанавливается цвет на 1/8 темнее clWindow;
begin
 SetProperty(WinCtrl,'ReadOnly',ReadOnlyValue);
 if  not SetColor  then  Exit;
 if  (WinCtrl is TCustomEdit ) or (WinCtrl is TCustomGrid) then begin
   if  ReadOnlyValue  then
     tHackControl(WinCtrl).Color := MulDivIntensity(clWindow,7,8)
   else
     tHackControl(WinCtrl).Color := clWindow;
   end
 else begin
//    tHackControl(WinCtrl).Color := clBtnFace;
 end;
end;



Это сообщение отредактировал(а) Петрович - 21.1.2005, 11:47

Присоединённый файл ( Кол-во скачиваний: 78 )
Присоединённый файл  Iterators.inc


--------------------
Все знать невозможно, но хочется
PM ICQ   Вверх
Петрович
Дата 21.1.2005, 11:55 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1000
Регистрация: 2.12.2003
Где: Москва

Репутация: 25
Всего: 55



Ну, пожалуй еще один модуль, и достаточно на сегодня smile
Модуль awNetwork пристегнут, а реализует он следующие функции:
Код

procedure NetGetListComputers (aList :tStrings);
procedure GetComputers        (aList :tStrings);  deprecated;
// Заполняют aList списком компьютеров обнаруженных в сети
// Ex: EWNetError - см. NetEnum;

procedure NetGetListDisks     (aList :tStrings);
// Заполняет aList списком дисковых ресурсов обнаруженных в сети
// Ex: EWNetError - см. NetEnum;

procedure NetGetListPrinters  (aList :tStrings);
// Заполняет aList списком принтеров обнаруженных в сети
// Ex: EWNetError - см. NetEnum;


procedure NetEnum (aList :tStrings; aResoureceDisplayType, aResoureceType :Cardinal);
// Заполняет aList списком ресурсов обнаруженных в сети, соответствующих
// aResoureceDisplayType и aResoureceType
// Ex: EWNetError - Все ошибки накапливаются в списке и по завершению
//                  сканирования выдается в одном Ex.
//                  При этом, в результирующий список попадают все ресурсы не
//                  вызвавшие ошибок. Это позволяет получить максимально полный
//                  список ресурсов, даже при наличии ошибок, которые можно
//                  просто игнорировать.

procedure ForEachNetResource (Proc: Pointer);
// Итератор вызывающий ЛОКАЛЬНУЮ процедуру Proc для каждого ресурса найденного в
// сети. Процедура Proc должна быть ОБЯЗАТЕЛЬНО ЛОКАЛЬНОЙ процедурой вида:
//    procedure (const NetRes :NetResource); register;
// В качестве примера, можно посмотреть на реализацию функции NetEnum.
// Ex: EWNetError - Все ошибки накапливаются в списке и по завершению
//                  сканирования выдается в одном Ex.
//                  При этом, Proc будет вызвана для всех ресурсов не вызвавших
//                  ошибок. Это позволяет обработать максимально полный
//                  список ресурсов, даже при наличии ошибок, которые можно
//                  просто игнорировать.

///////////////////////////////////////////////// пока доступны только под WinNT

procedure NetGetListServers  (aList :tStrings);
// Заполняют aList списком серверов обнаруженных в сети.
// Только под WinNT.
// Ex: EWNetError

procedure NetGetListSQLServers  (aList :tStrings);
// Заполняют aList списком SQL-серверов (MS-SQL) обнаруженных в сети.
// Только под WinNT.
// Ex: EWNetError

procedure NetEnumServers(aList :tStrings; ServersType :Cardinal =SV_TYPE_ALL);
// Заполняет aList списком серверов обнаруженных в сети, соответствующего типа.
// Только под WinNT.
// Ex: EWNetError

procedure NetEnumShare (aList :tStrings; ServerName :String ='');
// Заполняет aList списком разделяемых ресурсов предоставляемых сервером
// ServerName. По умолчанию своих.
// Только под WinNT.
// Ex: EWNetError

function ServerInfoStr (ServerName :String) :String;
// Возвращает строку с информацией о сервере ServerName.
// Строки имеет вид:
//   под NT+ - <ServerPlatform> <Version> <ServerType>
//   под 9x  -                  <Version> <ServerType>
// В принципе, это работающий, но рабочий вариант :).
// Ex: EOSError


Присоединённый файл ( Кол-во скачиваний: 179 )
Присоединённый файл  awNetwork.zip


--------------------
Все знать невозможно, но хочется
PM ICQ   Вверх
Петрович
Дата 23.1.2005, 11:27 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1000
Регистрация: 2.12.2003
Где: Москва

Репутация: 25
Всего: 55



А вот еще модуль. Его я обычно использую для измерения времени исполнения процедур и даже отдельны фрагментов кода. Разрешающая способность составляет 1 такт процессора. Точность измерения конечно ниже, поскольку зависит от работы кэша процессора. Но она все равно значительно выше нежели все остальные известные мне способы использующие те или иные аппаратные таймеры.


Присоединённый файл ( Кол-во скачиваний: 241 )
Присоединённый файл  awStopWatch.zip


--------------------
Все знать невозможно, но хочется
PM ICQ   Вверх
Петрович
Дата 30.1.2005, 20:51 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1000
Регистрация: 2.12.2003
Где: Москва

Репутация: 25
Всего: 55



Вот, тут DRKB v2.3 натолкнул на мысль опубликовать еще один из модулей. К сожалению, автора исходного модуля мне установить не удалсь. Жаль, идеи заложенные в его модуле были очень хороши. Я лишь чуть усовершенствовал их.
Интерфейс:
Код

unit SafeUnit;

// Является ремейком модуля "SafeUnit" неизвестного мне автора.

interface

uses Classes;

/////////////////////////////////////////////////////////////////////////// IsAs
(*
Позволяет упростить вот такие фрагметы кода:

 if aSomeObject is TMyObject then begin
   aMyObject := aSomeObject as TMyObject;
   // некоторые действия с aMyObject
 end;

При использовании функции IsAs это будет выглядить так:

 if IsAs (aMyObject, aSomeObject, TMyObject) then begin
   ... // некоторые действия с aMyObject
 end;

*)

function IsAs (out   aReference {: Pointer};
              const aObject     : TObject;
              const aClass      : TClass) : Boolean;

////////////////////////////////////////////////////////////////// ExceptionSafe
(* - "Накопитель" исключений
Позволяет делать например следующее

   with ExceptionSafe do
     try
       // Некоторые действия которые могут возбудить исключение
       for aIndex := 1 to 10 do
         try
           ... // Некоторые действия которые могут возбудить исключение
         except
           SaveException;  // <- запоминание текста возникшего исключения в списке ExceptionSafe
         end;
       ... // Некоторые действия которые могут возбудить исключение
       for aIndex := 10 to 20 do
         try
           ... // Некоторые действия которые могут возбудить исключение
         except
           SaveException;  // <- запоминание текста возникшего исключения в списке ExceptionSafe
         end;
       ... // Некоторые действия которые могут возбудить исключение
     except
       SaveException;  // <- запоминание текста возникшего исключения в списке ExceptionSafe
     end;
   end;// <===

 Тогда, в момент выхода из With (<===), если был сохранен текст хотя бы
 одного исключения, будет возбуждено Exception, с текстом всех сохраненных
 в этом блоке исключений.
 Формат текста:
   Ex1.ClassName+': '+Ex1.Message  {+^M^J^I+ExN.ClassName+' '+ExN.Message}
*)

type
 IExceptionSafe = interface
   procedure SaveException;
 end;

function ExceptionSafe :IExceptionSafe;

///////////////////////////////////////////////////////////////////// ObjectSafe
(* - Безопасный "контейнер" объектов и компонентов

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

 procedure TestTheSafe;
 var
   aMyObject    :TMyObject;
   aMyComponent :TMyComponent;
 begin
   with ObjectSafe do begin

     // создание и регистрация объекта:
     New (aMyObject, TMyObject.Create);
     // или
     aMyObject := TMyObject.Create; Guard(aMyObject);

     // создание и регистрация компонента
     aMyComponent := TMyComponent.Create (Safe);

     ... // Некоторые действия которые могут возбудить исключение

     // уничтожение экземпляра aMyObject
     Dispose(aMyObject);

     ... // Некоторые действия которые могут возбудить исключение

   end; // <===
 end;

 Тогда, в момент выхода из With (<===), все объекты и компоненты
 зарегестрированные в ObjectSafe, будут автоматически уничтожены (Free).
 Причем, это произойжет даже если With будет покинут в результате
 возникновения исключительной ситуации.

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

type
 IObjectSafe = interface
   function  Safe : TComponent;

   function  New     (out   aReference {: Pointer};
                      const aObject     : TObject) : IObjectSafe;

   procedure Guard   (const aObject     : TObject);

   procedure Dispose (var   aReference {: Pointer});
 end;

function ObjectSafe                                 : IObjectSafe; overload;
function ObjectSafe (out aObjectSafe : IObjectSafe) : IObjectSafe; overload;


////////////////////////////////////////////////////////////////////////////////


implementation /////////////////////////////////////////////////////////////////

Если интересно, то бери пристегнутый файл smile.

Присоединённый файл ( Кол-во скачиваний: 109 )
Присоединённый файл  SafeUnit.pas


--------------------
Все знать невозможно, но хочется
PM ICQ   Вверх
Петрович
Дата 8.2.2005, 10:35 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1000
Регистрация: 2.12.2003
Где: Москва

Репутация: 25
Всего: 55



Для пользователей библиотеки EhLib.
Мною, а так-же Alex'ом были сделаны несколько доработок некоторых модулей этой библиотеки.
Мои доработки следующие:
  • (DBGridEh.pas) Изменена реакция на Ctrl+Up, Ctrl+Down, Ctrl+Shift+Up и Ctrl+Shift+Down.
    Ранее, они были эквивалентны соответственно сочетаниям Ctrl+PgUp, Ctrl+PgDown, Ctrl+Shift+PgUp и Ctrl+Shift+PgDown. Теперь, они действуют почти как в IDE Delphi - прокрутка окна просмотра, по возможности без изменения текущей позиции в наборе данных:
    Ctrl+Up - перемещение окна просмотра вверх (прокрутка вниз);
    Ctrl+Down - перемещение окна просмотра вниз (прокрутка вверх);
    Ctrl+Shift+Up - не действует;
    Ctrl+Shift+Down - не действует.
  • (DBGridEh.pas) Исправлена ошибка. По крайней мере в v3.2 наблюдалось забавное поведение фильтра. А именно:
    Если задать (с клавиатуры) выражение фильтрования в каком-то поле, например во втором, и нажать Enter, то все прекрастно отфильтруется. Однако, если после этого сделать Grid.ClearFilter а затем Grid.ApplyFilter то, в отличие от ожиданий, ничего не произойдет. Т.е. не смотря на Grid.ClearFilter, во втором поле останется строка с условием фильтрования, и Dataset останется отфильтрованным!
    Поисходило это потому, что при Grid.ApplyFilter из редактора фильтра "извлекалось" текущее содержимое, и "запихивалось" обратно в STFilter.ExpressionStr соответствующей колонки.
    Отсюда, если перед Grid.ApplyFilter "перейти" в другую колонку, все будет нормально smile.
    В v3.4 такого дефекта вроде-бы не наблюдается, однако, "лечилка" не мешает, поэтому оставлена.
  • (DBGridEh.pas) Изменено поведение при изменении фильтра и порядка сортировки.
    В исходном варианте, при испоьзовании датасетов требующих переоткрытия для обновления данных после изменения текста запроса, были на мой взгляд два неприятных момента которые я устранил:

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

    b. Если колонки грида созданы динамически, а не в дизайнере (такое иногда
    бывает smile, то после переоткрытия теряется информация о маркерах
    сортировки, значениях фильтров, ширин колонок, и пр.. В общем всего что
    хранится в списке колонок, поскольку при закрытии датасета он очищается,
    а после открытия, создается заново со значениями по умолчанию.
    Чтобы предотвратить подобный ход событий, перед закрытием датасета,
    всем колонкам ставится признак IsStored (якобы они созданы в дизайнере).
    Естественно, реальное значение свойства IsStored всех колонок сохраняется
    и восстанавливается после открытия датасета.

    В моей реализации устранения этих моментов есть подводный камень:

    Может возникнуть ошибка, если после переоткрытия датасета изменится
    состав возвращаемых им полей. Например если датасет используется
    в рамках ReadCommited транзакции, и к моменту его переоткрытия кто-то,
    изменил на SQL-сервере метаданные объекта входящего в запрос. Хотя по моему,
    такая ситуация вряд-ли может встретиться в реальной жизни. Да и в случае
    "статически" (в дизайнере) созданных полей возникнет та-же бяка (хотя,
    пожалуй еще хуже будет).

    Конечно, сохранение позиции, надо-бы сделать включаемым/отключаемым опцией
    в OptionsEh. Но для этого, требуется коррекция еще и других модулей EhLib.
    Поэтому, это лучше делать автору.

    А вот фича "b", должна быть обязательно устранена, поскольку ее наличие
    делает невозможным нормальное использование сортировки и фильтрования
    с датасетами требующими переоткрытия.
  • (DbUtilsEh.pas) Исправлена ошибка/недочет.

    В исходном варианте, в выражении фильтрования, нельзя было использовать константу 'NOW' допустимую в SQL.
  • (EhLibADO.pas) Расширены возможности.

    В ADODataSetDriverName добавлена поддержка для MS SQL-сервера (по имени OLEDB провайдера).
  • (EhLibIBX.pas) Исправлена ошибка.

    Некоторые версии сервера Interbase не допускает использования номеров полей
    в выражении ORDER BY, поэтому в конструктор объектов этого модуля добавлено:
Измененные модули для версии 3.5 приложены к посту. Для других версий можно сделать аналогично. Для этого, все мои изменения отмечены условной трансляцией по символу NoChangesBySAP

Это сообщение отредактировал(а) Петрович - 8.2.2005, 11:18

Присоединённый файл ( Кол-во скачиваний: 164 )
Присоединённый файл  EhLib_v3_5_units_modified_by_Petrovich.zip


--------------------
Все знать невозможно, но хочется
PM ICQ   Вверх
Петрович
Дата 8.2.2005, 11:15 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1000
Регистрация: 2.12.2003
Где: Москва

Репутация: 25
Всего: 55



Для пользователей библиотеки EhLib.
Мною, а так-же Alex'ом были сделаны несколько доработок некоторых модулей этой библиотеки.

Доработки от Alex:
  • (DBCtrlsEh.pas и ToolCtrlsEh.pas) для контролов которые могут содержать доп.кнопки (наследники TCustomDBEditEh), добавлена возможность индивидуального управления активностью этих кнопок.
  • (DBCtrlsEh.pas) исправлена ошибка (неточность) при работе с датами без указания года
Измененные модули для версии 3.5 приложены к посту. Для других версий можно сделать аналогично. Для этого, все изменения отмечены коментарием Alx

Это сообщение отредактировал(а) Петрович - 18.2.2005, 00:27

Присоединённый файл ( Кол-во скачиваний: 99 )
Присоединённый файл  EhLib_v3_5_units_modified_by_Alex.zip


--------------------
Все знать невозможно, но хочется
PM ICQ   Вверх
RA
Дата 16.2.2005, 18:42 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Брутальный буратина
****


Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 14
Всего: 115



Пример передачи файлов при помощи TClientSocke и TServerSocket

Очень многих интересует данный вопрос поэтому выкладываю сырячек.

Это пока так, зарисовочка, в дальнейшем планируется
доработать, оптимизировать и добавить кое-какие вещи.

Ну и соответвенно сделать примеры с использованием ICS и Indy.


Присоединённый файл ( Кол-во скачиваний: 546 )
Присоединённый файл  CustomWinSocket_0.1.rar
PM   Вверх
SoWa
Дата 17.2.2005, 14:29 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Харекришна
****


Профиль
Группа: Комодератор
Сообщений: 2422
Регистрация: 18.10.2004

Репутация: 2
Всего: 74



Посмотрев примеры в DRKB для перевода числа из одной системы счисления в другую, понял, что они предназначены не для глупого списывания, поэтому написал собственную функцию! код немного не оптимизированный, но все равно работает!
ПРЕДУПРЕЖДЕНИЕ: СИСТЕМЫ ПЕРЕВОДА ОТ 2 ДО 36!!! НЕ БОЛЬШЕ!
Код

function FromToAnySys(fromSys,ToSys: integer; chislo: string): string;
var
i,k,mo: integer;
d: integer;
buk: integer;
step: integer;
s,sl: string;
s1: integer;
m: string;

function revert(n: string): string;
var i: integer;
q: string;
begin
for i:=length(n) downto 1 do
begin
 q:=q+n[i];
end;
revert:=q;
end;

begin
m:='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
s:='';
d:=0;
for i:=1 to length(chislo) do
begin
 for k:=1 to 37 do
  begin
   if chislo[i]=m[k] then buk:=k-1;
  end;
 step:=strtoint(floattostr(power(FromSys,(length(chislo)-i))));
 d:=d+(buk*step);
end;

while d<>0 do
begin
 mo:=d mod ToSys;
 s:=s+m[mo+1];
 d:=d div ToSys;
end;

result:=revert(s);
end;



--------------------
Всем добра smile
PM MAIL ICQ   Вверх
Петрович
Дата 18.2.2005, 00:31 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1000
Регистрация: 2.12.2003
Где: Москва

Репутация: 25
Всего: 55



Вот реализация доработок EhLib от меня и Alex для версии 3.06. Подробнее см. здесь и здесь

Присоединённый файл ( Кол-во скачиваний: 153 )
Присоединённый файл  EhLib_v3_6_units_modified_by_Petrovich_Alex.zip


--------------------
Все знать невозможно, но хочется
PM ICQ   Вверх
p0s0l
Дата 5.3.2005, 18:44 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Г-н Посол
****


Профиль
Группа: Экс. модератор
Сообщений: 3668
Регистрация: 13.7.2003
Где: 58°38' с.ш. 4 9°41' в.д.

Репутация: 58
Всего: 112



Этот пример показывает, как всего парой десятков строк можно использовать WMI (Windows Management Instrumentation) для просмотра информации о системе, железе, программах и многом другом...

Для компиляции нужно иметь библиотеки Jedi WinAPI...
Скачать их можно тут: http://members.chello.nl/m.vanbrakel2/ (архив около 2 метров)

При запуске программы будет показано три окошка:
Левое верхнее - список классов. Например, Win32_BIOS - инфа о биосе, Win32_Processor - о процессоре и т.д.
Правое верхнее окно - объявление выбранного класса (свойства и методы)
Нижнее - экземпляры выбранного класса...

WMI.ZIP (5 kb)

Присоединённый файл ( Кол-во скачиваний: 175 )
Присоединённый файл  WMI.ZIP


--------------------
С уважением, г-н Посол.
PM   Вверх
Girder
Дата 6.3.2005, 06:38 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Лентяй 2
***


Профиль
Группа: Участник Клуба
Сообщений: 1993
Регистрация: 12.5.2004

Репутация: 31
Всего: 155



Компонент для работы с драйверами программы FileMon (Sysinternals - www.sysinternals.com).
***В компоненте реализованна полная потдержка управляющих команд в плоть до версии драйвера v436.
***Особые благодарности, за тест и конструктивные предложения: p0s0l

PS: Данный компонент выкладывается для ознакомительных целей. Использование его в своих программах допускается smile ... но на свой страх и риск! Так как Sysinternals запрещает использование их драйверов отдельно от FileMon smile

В присоединенке: Компонент и пример его использования(А также драйверы: новые и старые).

PS2: К сожалению... так и не смог найти подходящию иконку для компонента smile

Присоединённый файл ( Кол-во скачиваний: 168 )
Присоединённый файл  FileMon.zip


--------------------
Как слышим, так и пишим.
Истина где-то там...
PM   Вверх
Akella
  Дата 18.3.2005, 10:09 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329



Сделал небольшой архив с примерами

Имя Описание
папки

05_1 Пример использования компонентов TTreeView и TTreeList
для просмотра информации из системного реестра Windows
05_2 Простой пример разработки собственного компонента
06_1 Ресурсы манифеста Windows XP
07_1 Пример использования в приложении списка объектов на основе
класса TList
07_2 Пример использования в приложении списка строк на основе
класса TStringList
10_1 Пример приложения, использующего компоненты Delphi
для отображения графики
10_2 Приложение для просмотра растровых приложений JPG, JPEG, BMP
11_1 Пример простейшего приложения баз данных
12_1 Пример использования параметров компонентов запросов SQL
и взаимодействия таких компонентов на основе передачи значений
параметров
14_1 Приложение баз данных, использующее отношение "один-ко-многим"
между таблицами базы данных
14_2 Приложение баз данных, демонстрирующее варианты поиска записей
в таблице базы данных
14_3 Пример использования закладок (класс TBookmark) в наборах
данных Delphi
15_1 Приложение баз данных, использующее компоненты синхронного
просмотра
16_1 Приложение баз данных, напрямую использующее API BDE
для полного удаления записей из таблиц базы данных
16_2 Приложение баз данных, напрямую использующее API BDE
для представления данных
17_1 Приложение баз данных, демонстрирующее возможности технологии
dbExpress
19_1 Приложение баз данных, демонстрирующее возможности
технологии ADO
21_1 Пример простого распределенного приложения баз данных
25_1 Пример использования компонента проекта отчета Rave Reports
и разработки простых отчетов в визуальной среде Rave Reports
26_1 Пример использования настраиваемого соединения на основе
компонента TRvCustomConnection
26_2 Пример отчетов Rave Reports для приложений баз данных
27_1 Пример реализации Drag-and-Drop
27_2 Пример реализации Drag-and-Dock
27_3 Пример реализации управления мышью
28_1 Пример создания динамической библиотеки
29_1 Приложение, использующее отдельный поток к памяти для расчета
числа
30_1 Приложение, использующее компоненты многомерного представления
данных
31_1 Пример приложения, использующего Shell API

пару папок удалил из архива, т.к. он получается больше 250 кБ.

Присоединённый файл ( Кол-во скачиваний: 483 )
Присоединённый файл  Example.zip
PM MAIL   Вверх
Akella
Дата 22.3.2005, 12:16 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329



Примеры для работы с
1. MS Word
2. pop3
3. smtp
4. socket
5. mail - отправка почты

Примеры не мои личные

Присоединённый файл ( Кол-во скачиваний: 436 )
Присоединённый файл  dsergey.zip
PM MAIL   Вверх
Akella
  Дата 22.3.2005, 12:35 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329



Обмен данными между процессами. Сам не тестировал.

Присоединённый файл ( Кол-во скачиваний: 134 )
Присоединённый файл  FileMapping_ExchangeData.zip
PM MAIL   Вверх
ДЫМ
Дата 3.4.2005, 03:13 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 224
Регистрация: 6.1.2004

Репутация: 8
Всего: 8



Быстрая функция для разбивки строки на части (слова) в один цикл.

Код

type TDelim=set of Char;
        TArrayOfString=Array of String;
 

//*******************
//
// Разбивает строку с разделителями на части
// и возвращает массив частей
//
// fcToParts
//

function fcToParts(sString:String;tdDelim:TDelim):TArrayOfString
var iCounter,iBegin:Integer;
begin//fc
if length(sString)>0 then
 begin
  include(tdDelim,#0);iBegin:=1; SetLength(Result,0);
  For iCounter:=1 to Length(sString)+1 do
   begin//for
    if (sString[iCounter] in tdDelim) then
     begin
      SetLength(Result,Length(Result)+1);
      Result[Length(Result)-1]:=Copy(sString,iBegin,iCounter-iBegin);
      iBegin:=iCounter+1;
     end;
  end;//for
 end;//if
end;//fc


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

Код

var
 StrArr:TArrayOfString

StrArr:=fcToParts('строка1-строка2@строка3',['-','@']):


PM MAIL WWW   Вверх
ДЫМ
Дата 17.4.2005, 01:56 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 224
Регистрация: 6.1.2004

Репутация: 8
Всего: 8



Делал тут ListBox с подсказками, получился такой вот компонент.

Компонент LSVListBox, потомок TListBox, использует всплывающие подсказки (Hint) для полного отображения
не умещающихся строк и позволяет изменять стиль подсказок (шрифт, цвета, дополнительные рамки, тень,
авторазмер), установить разные стили подсказок для выделенных и невыделенных пунктов.
Помимо этого не умещающиеся строки корректно обрезаются (с троеточием), имеется возможность изменить цвета для выделенных пунктов, отключить фокусирующий прямоугольник, уменьшено мерцание при прорисовке элементов, добавлены обработчики событий OnMouseEnter и OnMouseLeave

Это сообщение отредактировал(а) ДЫМ - 18.4.2005, 01:09

Присоединённый файл ( Кол-во скачиваний: 122 )
Присоединённый файл  LSVListBox.zip
PM MAIL WWW   Вверх
Akella
Дата 14.5.2005, 10:11 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329



Функция подмены разделителя целой и дробной части при вводе данных прямо в сетку, а также при вводе даты. Пользователя не должен думать о том, что ему правльно вводить в качетсве разделителя: точку или запятую
TfmMain - TForm

TDBGridEh - сетка из пакета EhLib, можно необязательно сетку, можно, просто TEdit.

Код

в разделе 
  public
    { Public declarations }

главной формы объявляем
    Procedure DecPoint(Sender: TObject; var Key: Char);
для доступности из всех остальных форм


Код

Procedure TfmMain.DecPoint(Sender: TObject; var Key: Char);
begin
 if (Sender is TDBGridEh) then
   if (Sender as TDBGridEh).SelectedField.DataType=ftFloat then
      if (Key='.') or (Key=',') then Key:=DecimalSeparator;

 if (Sender is TDBEditEh) then
   if (Sender as TDBEditEh).Field.DataType=ftDate then
      if (Key='.') or (Key=',') then Key:=DateSeparator;
end;


использование в OnKeyPress
Код

procedure TfmMain.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  DecPoint(Sender,Key);
end;

PM MAIL   Вверх
Alex
Дата 24.6.2005, 04:32 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Экс. модератор
Сообщений: 4147
Регистрация: 25.3.2002
Где: Москва

Репутация: 80
Всего: 162



Две полезные процедуры:

Код

uses
   StrUtils;

procedure CopyComponentProp(Source, Target: TObject; aExcept: array of string);
// Копирование всех одинаковых по названию свойств/методов одного компонента в
// другой за исключение "Name", "Left", "Top" и тех которые заданы в aExcept
// Примеры использования:
// CopyComponentProp(N11, N21, []);
// CopyComponentProp(ListBox2, ListBox3, []);
// CopyComponentProp(ListView1, ListView2, ['Items', 'Color']);
var
  I, Index: Integer;
  PropName: string;
  Source_PropList  , Target_PropList  : PPropList;
  Source_NumProps  , Target_NumProps  : Word;
  Source_PropObject, Target_PropObject: TObject;

  // Поиск в списке свойства с заданным именем

  function FindProperty(const PropName: string; PropList: PPropList; NumProps: Word): Integer;
  var
    I: Integer;
  begin
    Result:= -1;
    for I:= 0 to NumProps - 1 do
      if CompareStr(PropList^[I]^.Name, PropName) = 0 then begin
        Result:= I;
        Break;
      end;
  end;

begin
  if not Assigned(Source) or not Assigned(Target) then Exit;

  Source_NumProps:= GetTypeData(Source.ClassInfo)^.PropCount;
  Target_NumProps:= GetTypeData(Target.ClassInfo)^.PropCount;

  GetMem(Source_PropList, Source_NumProps * SizeOf(Pointer));
  GetMem(Target_PropList, Target_NumProps * SizeOf(Pointer));
  try
    // Получаем список свойств
    GetPropInfos(Source.ClassInfo, Source_PropList);
    GetPropInfos(Target.ClassInfo, Target_PropList);

    for I:= 0 to Source_NumProps - 1 do begin
      PropName:= Source_PropList^[I]^.Name;

      if  (AnsiIndexText('None'  , aExcept                ) =  -1) and
         ((AnsiIndexText(PropName, ['Name', 'Left', 'Top']) <> -1) or
          (AnsiIndexText(PropName, aExcept                ) <> -1)) then Continue;

      Index:= FindProperty(PropName, Target_PropList, Target_NumProps);
      if Index = -1 then Continue; // не нашли

      // Проверить совпадение типов
      if Source_PropList^[I]^.PropType^.Kind <> Target_PropList^[Index]^.PropType^.Kind then
        Continue;

      case Source_PropList^[I]^.PropType^^.Kind of
        tkClass:  begin
                    Source_PropObject:= GetObjectProp(Source, Source_PropList^[I    ]);
                    Target_PropObject:= GetObjectProp(Target, Target_PropList^[Index]);
                    CopyComponentProp(Source_PropObject, Target_PropObject, ['None']);
                  end;
        tkMethod: SetMethodProp(Target, PropName, GetMethodProp(Source, PropName));
      else
        SetPropValue(Target, PropName, GetPropValue(Source, PropName));
      end;
    end;
  finally
    FreeMem(Source_PropList);
    FreeMem(Target_PropList);
  end;
end;


Код

uses
   StrUtils

procedure AssignComponentProp(Source, Target: TObject; aProp: array of string);
// Копирование свойств/методов заданых в aProp одного компонента в другой
// Пример использования:
// AssignedComponentProp(ListView1, ListView2, ['Items', 'Color']);
var
  I, Index: Integer;
  PropName: string;
  Source_PropList  , Target_PropList  : PPropList;
  Source_NumProps  , Target_NumProps  : Word;
  Source_PropObject, Target_PropObject: TObject;

  // Поиск в списке свойства с заданным именем

  function FindProperty(const PropName: string; PropList: PPropList; NumProps: Word): Integer;
  var
    I: Integer;
  begin
    Result:= -1;
    for I:= 0 to NumProps - 1 do
      if CompareStr(PropList^[I]^.Name, PropName) = 0 then begin
        Result:= I;
        Break;
      end;
  end;

begin
  if not Assigned(Source) or not Assigned(Target) then Exit;

  Source_NumProps:= GetTypeData(Source.ClassInfo)^.PropCount;
  Target_NumProps:= GetTypeData(Target.ClassInfo)^.PropCount;

  GetMem(Source_PropList, Source_NumProps * SizeOf(Pointer));
  GetMem(Target_PropList, Target_NumProps * SizeOf(Pointer));
  try
    // Получаем список свойств
    GetPropInfos(Source.ClassInfo, Source_PropList);
    GetPropInfos(Target.ClassInfo, Target_PropList);

    for I:= 0 to Source_NumProps - 1 do begin
      PropName:= Source_PropList^[I]^.Name;

      if (AnsiIndexText('None'  , aProp   ) = -1) and
         (AnsiIndexText(PropName, aProp   ) = -1) then Continue;

      Index:= FindProperty(PropName, Target_PropList, Target_NumProps);
      if Index = -1 then Continue; // не нашли

      // Проверить совпадение типов
      if Source_PropList^[I]^.PropType^.Kind <> Target_PropList^[Index]^.PropType^.Kind then
        Continue;

      case Source_PropList^[I]^.PropType^^.Kind of
        tkClass:  begin
                    Source_PropObject:= GetObjectProp(Source, Source_PropList^[I    ]);
                    Target_PropObject:= GetObjectProp(Target, Target_PropList^[Index]);
                    AssignComponentProp(Source_PropObject, Target_PropObject, ['None']);
                  end;
        tkMethod: SetMethodProp(Target, PropName, GetMethodProp(Source, PropName));
      else
        SetPropValue(Target, PropName, GetPropValue(Source, PropName));
      end;
    end;
  finally
    FreeMem(Source_PropList);
    FreeMem(Target_PropList);
  end;
end;



--------------------
Написать можно все - главное четко представлять, что ты хочешь получить в конце. 
PM Skype   Вверх
Alex
Дата 2.7.2005, 12:25 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Экс. модератор
Сообщений: 4147
Регистрация: 25.3.2002
Где: Москва

Репутация: 80
Всего: 162



Для пользователей библиотеки EhLib.
  • (DBCtrlsEh.pas и ToolCtrlsEh.pas) для контролов которые могут содержать доп.кнопки (наследники TCustomDBEditEh), добавлена возможность индивидуального управления активностью этих кнопок.
  • (DBCtrlsEh.pas) исправлена ошибка (неточность) при работе с датами без указания года.
  • (ToolCtrlsEh.pas) для контролов которые могут содержать доп.кнопки (наследники TCustomDBEditEh), добавлено свойство Action. При задании свойства от Action кнопка наследует свойства: Enabled, Hint, ShortCut и Visible. Свойство доступно в Delphi 6 и выше.
Измененные модули для версии 3.6 приложены к посту. Для других версий можно сделать аналогично. Для этого, все изменения отмечены коментарием Alx

Присоединённый файл ( Кол-во скачиваний: 60 )
Присоединённый файл  EhLib_v3_6_units_modified_by_Alex.rar 55,99 Kb


--------------------
Написать можно все - главное четко представлять, что ты хочешь получить в конце. 
PM Skype   Вверх
RA
Дата 2.7.2005, 14:05 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Брутальный буратина
****


Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 14
Всего: 115



Функция конвертации текста HTML содержащего строки вида &# 123; в читабельбный вид



Код

Function PreDecode(s:string):string;
  function AddNumericChar(I: Integer):string;
  var
    W: WideChar;
    Buffer: array[0..10] of char;
  begin
    if I = 9 then result := ' '
       else if I < ord(' ') then  result := '?'  {control char}
           else if (I < 256)  then   result := Chr(I)
    else
    begin
    W := WideChar(I);
    SetString(result, Buffer, WideCharToMultiByte(CP_ACP, 0,
          @W, 1, @Buffer, SizeOf(Buffer), nil, nil))
    end;
  end;

var val,i,ik:integer; sq:string;
begin
  for i:=1 to Length(s) do
  begin
      if ( (s[i]='&') and (s[i+1] ='#') ) then
       begin
          sq := Copy(s,i+2,length(s));
          for ik:=1 to length(sq) do
          begin
            if not ( sq[ik] in ['0'..'9'] ) then
            break;
          end;
          if  Copy(sq,1,ik-1) <> '' then
          val := StrToInt( Copy(sq,1,ik-1) ) else val:=-1;
          if ( (val <> -1) and (sq[ik] = ';')  )
          then
           begin
             Result:=Result+AddNumericChar(val);
             Delete(s,i,ik+1);
            end;
       end else  result:=Result+s[i];
  end;

end;





PM   Вверх
Rrader
  Дата 28.7.2005, 16:53 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Inspired =)
***


Профиль
Группа: Экс. модератор
Сообщений: 1535
Регистрация: 7.5.2005

Репутация: 70
Всего: 191



В аттаче пример работы с TaskBar (получене текста всех кнопок).

Это сообщение отредактировал(а) Rrader - 18.7.2008, 15:54

Присоединённый файл ( Кол-во скачиваний: 42 )
Присоединённый файл  Toolbar_Button_Enum.rar 7,59 Kb


--------------------
Let's do this quickly!
Rest in peace, Vit!
PM MAIL Skype   Вверх
Rrader
  Дата 19.8.2005, 09:05 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Inspired =)
***


Профиль
Группа: Экс. модератор
Сообщений: 1535
Регистрация: 7.5.2005

Репутация: 70
Всего: 191



 Функция, которая нарисует на форме сетку и сделает форму похожей на дизайнер форм Delphi. По умолчанию в дизайнере Delphi отступы равны 8 пикселям smile 
Код

Procedure TForm1.DrawGrid;
Var
  TmpBmp: TBitmap;
Begin
  TmpBmp := TBitmap.Create;
  Try
    With TmpBmp Do
    Begin
      Width := 8;
      Height := 8;
      Canvas.Brush.Color := clBtnFace;
      Canvas.FillRect(TmpBmp.Canvas.ClipRect);
      Canvas.Pixels[0, 0] := clBlack;
      Canvas.Pixels[0, Height] := clBlack;
      Canvas.Pixels[Width, 0] := clBlack;
      Canvas.Pixels[Width, Height] := clBlack;
    End;
    With Canvas, Brush Do
    Begin
      Bitmap := TBitmap.Create;
      Try
        Bitmap.Assign(TmpBmp);
        Canvas.FillRect(Canvas.ClipRect);
      Finally
        Bitmap.Free;
      End;
    End;
  Finally
    TmpBmp.Free;
  End;
End;

{ Использование }
Procedure TForm1.FormPaint(Sender: TObject);
Begin
  DrawGrid; 
End;
 
Ещё способ, рисует сетку либо линии на компоненте AObject цветом FGridColor, в параметре ACanvas нужно передать холст компонента, FSizeX и FSizeY определяют размер сетки либо линий:
Код

...
  { Тип }
  TGridType = (gtDots, gtLines);
...
Procedure Draw(AObject: TControl; ACanvas: TCanvas; FGridType: TGridType; FGridColor: TColor;
  FSizeX, FSizeY: Integer);
Var
  ColorRGB, X, Y, MaxX, MaxY: Integer;
  DC: HDC;
Begin
  MaxX := AObject.ClientWidth Div FSizeX;
  MaxY := AObject.ClientHeight Div FSizeY;
  Case FGridType of
    gtDots:
      Begin
        ColorRGB := ColorToRGB(FGridColor);
        DC := ACanvas.Handle;
        For X := 0 To MaxX Do
          For Y := 0 To MaxY Do
          SetPixel(DC, X * FSizeX, Y * FSizeY, ColorRGB);
      End;
    gtLines:
      Begin
        ACanvas.Pen.Color := FGridColor;
        For X := 0 To MaxX Do
        Begin
          ACanvas.MoveTo(X * FSizeX, 0);
          ACanvas.LineTo(X * FSizeY, AObject.ClientHeight);
        End;
        For Y := 0 To MaxY Do
        Begin
          ACanvas.MoveTo(0, Y * FSizeY);
          ACanvas.LineTo(AObject.ClientWidth, Y * FSizeY);
        End;
      End;
  End;
End;
  

Это сообщение отредактировал(а) Rrader - 24.6.2006, 11:57


--------------------
Let's do this quickly!
Rest in peace, Vit!
PM MAIL Skype   Вверх
Rrader
  Дата 12.11.2005, 14:13 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Inspired =)
***


Профиль
Группа: Экс. модератор
Сообщений: 1535
Регистрация: 7.5.2005

Репутация: 70
Всего: 191



Пример использование методов интерфейса IShellDispatch (это интересно smile ).
Код

Unit UMain;

Interface

Uses
  Windows, Messages, SysUtils, Classes,
  Graphics, Controls, Forms, Dialogs, StdCtrls,
  ComObj, ActiveX, XPMan;

Const
  CLASS_Shell: TGUID = '{13709620-C279-11CE-A49E-444553540000}';

Type
  TMainForm = Class(TForm)
    FolderBtn: TButton;
    GroupBox1: TGroupBox;
    OpenBtn: TButton;
    EdFolder: TEdit;
    MinAllBtn: TButton;
    UnMinAllBtn: TButton;
    RunBtn: TButton;
    ExitWinBtn: TButton;
    FindBtn: TButton;
    CmpFndBtn: TButton;
    GroupBox2: TGroupBox;
    DTBtn: TButton;
    TaskBtn: TButton;
    Helpbtn: TButton;
    ApplBtn: TButton;
    Label1: TLabel;
    EdAppl: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure FolderBtnClick(Sender: TObject);
    procedure OpenBtnClick(Sender: TObject);
    procedure MinAllBtnClick(Sender: TObject);
    procedure UnMinAllBtnClick(Sender: TObject);
    procedure RunBtnClick(Sender: TObject);
    procedure ExitWinBtnClick(Sender: TObject);
    procedure FindBtnClick(Sender: TObject);
    procedure CmpFndBtnClick(Sender: TObject);
    procedure HelpbtnClick(Sender: TObject);
    procedure DTBtnClick(Sender: TObject);
    procedure TaskBtnClick(Sender: TObject);
    procedure ApplBtnClick(Sender: TObject);
  Private
    { Private declarations }
  Public
    { Public declarations }
  End;

  FolderItemVerb = Interface(IDispatch)
    ['{08EC3E00-50B0-11CF-960C-0080C7F4EE85}']
    Function Get_Application: IDispatch; Safecall;
    Function Get_Parent: IDispatch; Safecall;
    Function Get_Name: WideString; Safecall;
    Procedure DoIt; Safecall;
    Property Application: IDispatch Read Get_Application;
    Property Parent: IDispatch Read Get_Parent;
    Property Name: WideString Read Get_Name;
  End;

  FolderItemVerbs = Interface(IDispatch)
    ['{1F8352C0-50B0-11CF-960C-0080C7F4EE85}']
    Function Get_Count: Integer; Safecall;
    Function Get_Application: IDispatch; Safecall;
    Function Get_Parent: IDispatch; Safecall;
    Function Item(index: OleVariant): FolderItemVerb; Safecall;
    Function _NewEnum: IUnknown; Safecall;
    Property Count: Integer Read Get_Count;
    Property Application: IDispatch Read Get_Application;
    Property Parent: IDispatch Read Get_Parent;
  End;

  FolderItem = Interface(IDispatch)
    ['{FAC32C80-CBE4-11CE-8350-444553540000}']
    Function Get_Application: IDispatch; Safecall;
    Function Get_Parent: IDispatch; Safecall;
    Function Get_Name: WideString; Safecall;
    Procedure Set_Name(Const pbs: WideString); Safecall;
    Function Get_Path: WideString; Safecall;
    Function Get_GetLink: IDispatch; Safecall;
    Function Get_GetFolder: IDispatch; Safecall;
    Function Get_IsLink: WordBool; Safecall;
    Function Get_IsFolder: WordBool; Safecall;
    Function Get_IsFileSystem: WordBool; Safecall;
    Function Get_IsBrowsable: WordBool; Safecall;
    Function Get_ModifyDate: TDateTime; Safecall;
    Procedure Set_ModifyDate(pdt: TDateTime); Safecall;
    Function Get_Size: Integer; Safecall;
    Function Get_type_: WideString; Safecall;
    Function Verbs: FolderItemVerbs; Safecall;
    Procedure InvokeVerb(vVerb: OleVariant); Safecall;
    Property Application: IDispatch Read Get_Application;
    Property Parent: IDispatch Read Get_Parent;
    Property Name: WideString Read Get_Name Write Set_Name;
    Property Path: WideString Read Get_Path;
    Property GetLink: IDispatch Read Get_GetLink;
    Property GetFolder: IDispatch Read Get_GetFolder;
    Property IsLink: WordBool Read Get_IsLink;
    Property IsFolder: WordBool Read Get_IsFolder;
    Property IsFileSystem: WordBool Read Get_IsFileSystem;
    Property IsBrowsable: WordBool Read Get_IsBrowsable;
    Property ModifyDate: TDateTime Read Get_ModifyDate Write Set_ModifyDate;
    Property Size: Integer Read Get_Size;
    Property Type_: WideString Read Get_type_;
  End;

  FolderItems = Interface(IDispatch)
    ['{744129E0-CBE5-11CE-8350-444553540000}']
    Function Get_Count: Integer; Safecall;
    Function Get_Application: IDispatch; Safecall;
    Function Get_Parent: IDispatch; Safecall;
    Function Item(Index: OleVariant): FolderItem; Safecall;
    Function _NewEnum: IUnknown; Safecall;
    Property Count: Integer Read Get_Count;
    Property Application: IDispatch Read Get_Application;
    Property Parent: IDispatch Read Get_Parent;
  End;

  Folder = Interface(IDispatch)
    ['{BBCBDE60-C3FF-11CE-8350-444553540000}']
    Function Get_Title: WideString; Safecall;
    Function Get_Application: IDispatch; Safecall;
    Function Get_Parent: IDispatch; Safecall;
    Function Get_ParentFolder: Folder; Safecall;
    Function Items: FolderItems; Safecall;
    Function ParseName(Const bName: WideString): FolderItem; Safecall;
    Procedure NewFolder(Const bName: WideString; vOptions: OleVariant); Safecall;
    Procedure MoveHere(vItem: OleVariant; vOptions: OleVariant); Safecall;
    Procedure CopyHere(vItem: OleVariant; vOptions: OleVariant); Safecall;
    Function GetDetailsOf(vItem: OleVariant; iColumn: SYSINT): WideString; Safecall;
    Property Title: WideString Read Get_Title;
    Property Application: IDispatch Read Get_Application;
    Property Parent: IDispatch Read Get_Parent;
    Property ParentFolder: Folder Read Get_ParentFolder;
  End;

  IShellDispatch = Interface(IDispatch)
    ['{D8F015C0-C278-11CE-A49E-444553540000}']
    Function Get_Application: IDispatch; Safecall;
    Function Get_Parent: IDispatch; Safecall;
    Function NameSpace(vDir: OleVariant): Folder; Safecall;
    Function BrowseForFolder(Hwnd: Integer; Const Title: WideString;
      Options: Integer; RootFolder: OleVariant): Folder; Safecall;
    Function Windows: IDispatch; Safecall;
    Procedure Open(vDir: OleVariant); Safecall;
    Procedure Explore(vDir: OleVariant); Safecall;
    Procedure MinimizeAll; Safecall;
    Procedure UndoMinimizeALL; Safecall;
    Procedure FileRun; Safecall;
    Procedure CascadeWindows; Safecall;
    Procedure TileVertically; Safecall;
    Procedure TileHorizontally; Safecall;
    Procedure ShutdownWindows; Safecall;
    Procedure Suspend; Safecall;
    Procedure EjectPC; Safecall;
    Procedure SetTime; Safecall;
    Procedure TrayProperties; Safecall;
    Procedure Help; Safecall;
    Procedure FindFiles; Safecall;
    Procedure FindComputer; Safecall;
    Procedure RefreshMenu; Safecall;
    Procedure ControlPanelItem(Const szDir: WideString); Safecall;
    Property Application: IDispatch Read Get_Application;
    Property Parent: IDispatch Read Get_Parent;
  End;

  CoShell = Class
    Class Function Create: IShellDispatch;
    Class Function CreateRemote(Const MachineName: String): IShellDispatch;
  End;

Var
  MainForm: TMainForm;
  I: IShellDispatch;

Implementation

{$R *.dfm}

{ CoShell }

Class Function CoShell.Create: IShellDispatch;
Begin
  Result := CreateComObject(CLASS_Shell) As IShellDispatch;
End;

Class Function CoShell.CreateRemote(Const MachineName: String): IShellDispatch;
Begin
  Result := CreateRemoteComObject(MachineName, CLASS_Shell) As IShellDispatch;
End;

Procedure TMainForm.FormCreate(Sender: TObject);
Begin
  I := CoShell.Create;
End;

Procedure TMainForm.FolderBtnClick(Sender: TObject);
Var
  F: Folder;
Begin
  { Работа с папкой }
  F := I.BrowseForFolder(Handle, 'IShellDispatch example', 0, 0);
  If F = NIL Then Exit;
  If F.ParentFolder <> NIL Then
  Begin
    { Показ имени родительской папки }
    ShowMessage(F.ParentFolder.Title);
    { Показ количества дочерних папок }
    ShowMessage(IntToStr(F.Items.Count));
  End;
End;

Procedure TMainForm.OpenBtnClick(Sender: TObject);
Begin
  { Открытие папки }
  Try
    I.Explore(EdFolder.Text);
  Except
    Exit;
  End;
End;

Procedure TMainForm.MinAllBtnClick(Sender: TObject);
Begin
  { Свернуть все окна }
  I.MinimizeAll;
End;

procedure TMainForm.UnMinAllBtnClick(Sender: TObject);
Begin
  I.UndoMinimizeALL;
End;

Procedure TMainForm.RunBtnClick(Sender: TObject);
Begin
  { Окно "Выполнить..." }
  I.FileRun;
End;

Procedure TMainForm.ExitWinBtnClick(Sender: TObject);
Begin
  { Выключить Windows }
  I.ShutdownWindows;
End;

Procedure TMainForm.FindBtnClick(Sender: TObject);
Begin
  { Поиск }
  I.FindFiles;
End;

Procedure TMainForm.CmpFndBtnClick(Sender: TObject);
Begin
  { Поиск компьютеров }
  I.FindComputer;
End;

Procedure TMainForm.HelpbtnClick(Sender: TObject);
Begin
  { Вызов справки }
  I.Help;
End;

Procedure TMainForm.DTBtnClick(Sender: TObject);
Begin
  { Апплет: дата/время }
  I.SetTime;
End;

Procedure TMainForm.TaskBtnClick(Sender: TObject);
Begin
  { Апплет: панель задач }
  I.TrayProperties;
End;

Procedure TMainForm.ApplBtnClick(Sender: TObject);
Begin
  { Запуск своего апплета }
  I.ControlPanelItem(EdAppl.Text);
End;

End.

Проект с формой находится в аттаче.

Присоединённый файл ( Кол-во скачиваний: 132 )
Присоединённый файл  IShellDispatch.zip 11,87 Kb


--------------------
Let's do this quickly!
Rest in peace, Vit!
PM MAIL Skype   Вверх
Rrader
Дата 10.1.2006, 02:30 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Inspired =)
***


Профиль
Группа: Экс. модератор
Сообщений: 1535
Регистрация: 7.5.2005

Репутация: 70
Всего: 191



Как сделать ProgressBar таким же, как на заставке Windows XP
Вопос задается часто, вот решение без каких-либо компонентов:
Код

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    ProgressBar1: TProgressBar;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

const
  PBS_MARQUEE = $08;
  PBM_SETMARQUEE = WM_USER + 10;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  FSpeed: Integer;
begin
  FSpeed := 100;
  SetWindowLong(ProgressBar1.Handle, GWL_STYLE,
    GetWindowLong(ProgressBar1.Handle, GWL_STYLE) Or PBS_MARQUEE);
  { Включить }
  SendMessage(ProgressBar1.Handle, PBM_SETMARQUEE, 1, FSpeed);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  { Выключить }
  SendMessage(ProgressBar1.Handle, PBM_SETMARQUEE, 0, 0);
end;

end.



--------------------
Let's do this quickly!
Rest in peace, Vit!
PM MAIL Skype   Вверх
vstepanov78
Дата 10.1.2006, 02:33 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 3
Регистрация: 10.1.2006
Где: Москва

Репутация: нет
Всего: нет



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

ALLLIB. НАБОР ИСХОДНИКОВ ДЛЯ РАСШИРЕНИЯ ФУНКЦИОНАЛА СТАНДАРТНЫХ БИБЛИОТЕК DELPHI. ВЕРСИЯ ОТ 9.01.2006

Исходники библиотек: http://vstepanov78.narod.ru/alllib.zip
Краткая справка: http://vstepanov78.narod.ru/prog.htm#alllib

ОБЗОР ФУНКЦИОНАЛА

1. ОБЩИЕ ФУНКЦИИ (типы, строки, варианты, память, списки, таблицы, потоки, файлы, ini, реестр, многопоточность, исключения, языки):
- КОНВЕРТАЦИЯ ТИПОВ: конвертация строк и вариантов в типы и наоборот с автораспознаванием многих форматов независимо от настроек разделителей Windows (включая сложные форматы вроде '1 443,45', '12=34', '1111011b', '30-JAN-2004', '30/01/04 11:12:55.945', 'Wed Mar 13 19:15:06 UTC+0300 2002'), варианты функций без порождения исключений и использования SysUtils и с порождением исключений;
- КОДИРОВАНИЕ: кодирование и декодирование (строки C++/JScript и Pascal, Base64, HTML, URLEncode/URLDecode, KOI, ISO, Wide формата Windows NT и с нечетным количеством байт, XOR и др.), в том числе поддерживается быстрое кодирование длинных строк; разбор Delphi-форм DFM, включая бинарные; проверка соответствия маске и извлечение по маске (маски - с символами '?' и '*'); увеличение, уменьшение и округление даты до секунд, минут, часов, дней, месяцев, лет; поиск и замена в строке, добавление и извлечение строки из массива, хранимого в строке; извлечение строки текста при разных вариантах перевода строки, выравнивание колонок текста, функции парсинга выражений без использования объектов;
- ПАМЯТЬ: контроль утечек объектов и возможность контроля утечек памяти, дескрипторов; работа со списком и списком списков без SysUtils и использования объектов с заданием емкости, работа со строкой с заданием емкости и перераспределением памяти при превышении емкости, наращиваемой шагами; буфер в строку, изменение регистра и регистронезависимое сравнение блоков памяти, перемещение с перекрытием;
- СПИСКИ: индексируемые списки и таблицы без изменения порядка элементов с построением индекса при первой попытке поиска, поиск в таблице по любому набору колонок (списки и таблицы - указателей, строк, вариантов); иерархия без VCL;
- ПОТОКИ: обертки потоков с кэшированием чтения и записи, возможностью чтения следующего фрагмента данных без смещения позиции благодаря кэшу, извлечением следующей строки до перевод строки;
- ФАЙЛЫ: список файлов, копирование и удаление по маске с возможностью просмотра подкаталогов, вызовом прогресса; собственное имя DLL, получение версии библиотеки; поиск файла в %PATH%, разбор командной строки; работа с ярлыками, Map-файлами; простые функции файл в строку и строка в файл; простая функция записи в лог или на консоль с однозначно интерпретируемым форматом лога, поддержка отладки во многих функциях и объектах библиотеки; диалоги выбора файла и папки без VCL и SysUtils; вставка и извлечение из буфера обмена с правильной обработкой русских букв;
- INI: ini в памяти или потоке, возможность работы с секцией без имени, значениями параметров любой длины, быстрый поиск, сохранение комментариев; быстрое чтение иерархической конфигурации в многомерный массив вариантов;
- РЕЕСТР: реестр с корректной работой при ограниченных правах доступа, экспортом, импортом и удалением ключа с подразделами;
- МНОГОПОТОЧНОСТЬ: threadvar с инициализацией и завершением, правильной работой в Delphi 3, поддержка многопоточности всем кодом, инициализация и автоосвобождение объектов без увеличения кода приложения в случае подключения библиотеки без обращений к объекту библиотеки из приложения, работа с критическими секциями без SysUtils;
- ИСКЛЮЧЕНИЯ: отдельные модули сокращенных аналогов SysUtils для небольших приложений; объекты исключений с именем процедуры и кодом ошибки, в том числе поддержкой определения текста по коду ошибки Windows; список информации об исключениях;
- ЯЗЫКИ: русские и английские языковые константы, динамический выбор языка; чтение текущего языка системы; сумма прописью для разных валют на русском и английском с torry.ru без необходимости ini-файла; проверка ключевания счета;
- УДОБНЫЕ ФУНКЦИИ И ДР.: прочие функции для конвертации типов, удобной работы со строками вроде IIf, IfEmpty, AddPrefix, AddPostfix, JoinStr, вариантами, файлами.

2. СПЕЦИАЛИЗИРОВАННЫЕ ФУНКЦИИ (окна, база, интернет, COM, интерпретация скриптов, процессы, сжатие, привязка к компьютеру, графика):
- ДИАЛОГИ: диалоги без VCL, SysUtils и ресурсов - функции ввода строки, пароля, логина и пароля, просмотра и редактирование текста с выбором кодировки, ввода имени файла или выбора каталога, ввода случайной последовательности (функции взывают дочерние объекты от единого абстрактного объекта диалога без VCL); добавление иконки в системную область панели задач; получение списка окон верхнего уровня или иерархии с дочерними окнами; скроллирование в конец и поиск в TRichEdit в VCL, быстрое получение и обновление списка TListView и иерархии TTreeView из списка и иерархии в памяти;
- БАЗЫ ДАННЫХ: работа с базами данных через ADO без VCL, загрузка выборки таблиц в индексируемую таблицу вариантов в памяти и обновление выборки таблицы в базе по содержимому таблицы в памяти при заданных ключевых полях, в том числе с корректной работой с BLOB-полями для MS-SQL, Sybase, Oracle (с поддержкой ISO Cyrillic), Interbase; получение версии ADO;
- ИНТЕРНЕТ: работа с сокетами для сервера и клиента без VCL и SysUtils; отсылка HTTP- или HTTPS-запроса с получением ответа через WinInet; подключение к интернету, выход из Offline-режима браузера, получение собственных IP-адресов, разбор HTTP-ссылки; обертки ASP- и HTML-объектов с общим предком, делающим однотипным доступ к параметрам (полям) формы из сервера и клиента; общий метод чтения из ASP параметров сертификата CryptoAPI/Крипто-Про и Сигнал-КОМ Inter-PRO Client; отсылка почты простой функцией;
- СКРИПТЫ: поддержка интерфейса IActiveScript устанавливаемого с браузером интерпретатора JScript, VBScript (напрямую, без использования ScriptControl); поддержка интерфейса IDispatch (без необходимости написания и регистрации ocx), например, для встраивания COM-объекта в пространство имен IActiveScript для обращения к нему из скрипта; внутренний парсер функции строки обращения к COM-объекту с параметрами; получение GUID;
- ПРОЦЕССЫ: список имен и идентификаторов процессов (с поддержкой Windows 95/NT+); запуск задачи с ожиданием завершения или ожиданием создания ею первого окна, открытие документа (также есть возможность ожидания заданного промежутка времени с обработкой событий без VCL или ожидания появления файла); объекты межзадачного обмена с помощью сообщений Windows и прямой записи в память процесса; запуск приложения от имени пользователя; запуск и остановка сервиса, включая таймаут ожидания зависимых сервисов; запуск и остановка приложений COM+ в Component Services;
- СЖАТИЕ: сжатие и распаковка строки путем использования библиотеки Delphi ZLib (без внешних dll); распаковка CAB-файла;
- ПРИВЯЗКА К КОМПЬЮТЕРУ: привязка приложения к компьютеру, чтение напрямую из оборудования идентификатора и серийного номера CPU (также корректное определение частоты процессора), версии, даты, производителя и серийного номера BIOS, модели, версии и серийного номера контроллера HDD (возможно чтение для первых четырех жестки дисков) - всего используется порядка 14 различных способов обращении к оборудованию, благодаря чему поддерживаются Windows 95/98/ME/NT/2000/XP/2003, получение одинаковой информации при различных правах пользователя, включая гостевые; также чтение системной информации PCI-драйверах, версии Windows и Internet Explorer, доступных шрифтах;
- ГРАФИКА: поддержка загрузки GIF, PCX - позаимствованы с torry.ru, сделана динамическая инициализация; поддержка загрузки других форматов графики, в том числе TIF, PNG с помощью GDI+ (сделана динамически, т.к. библиотека может отсутствовать в старых Windows); функция изменения яркости картинки;
- ФИНАНСОВЫЕ И ДР.: прочие специализированные функции и классы конвертации, в том числе в и из формата 1С, поддержки HTTP-транспорта, получения информации об автозагружаемых процессах Windows.

3. КРИПТОГРАФИЯ (поддержка библиотек асимметричной шифрации и ЭЦП, симметричная шифрация и CRC):
- CRYPTOAPI/КРИПТО-ПРО: асимметричная шифрация и дешифрация, подпись и проверка ЭЦП с использованием CryptoAPI RSA, RSA-128 и Крипто-Про ГОСТ 28147-89, ГОСТ Р 34.11/34.10-94/2001 с возможностью кэширования ключей (прямое обращение к CryptoAPI), доступна симметричная шифрация (на сессионном ключе) и асимметричная шифрация на секретном и открытом ключе, секретном ключе и сертификате, автораспознавание Base64 и PEM-форматов запроса и сертификата, возможность хранения ключей Крипто-Про в файлах с временным импортом в реестр на период криптооперации и экспортом после нее; генерация ключей, формирование запросов на сертификат и установка сертификатов без и с использованием xenroll.dll, выпуск или отзыв сертификата по запросу в Microsoft Certification Authority, проверка действительности сертификата; поиск сертификата в хранилище по набору параметров, чтение его полей, добавление сертификата в хранилище, диалоги просмотра и выбора сертификатов; список установленных в системе типов криптопровайдеров, их имен и параметров, поддерживаемых алгоритмов и алгоритмов по умолчанию;
- СИГНАЛ-КОМ: асимметричная шифрация и дешифрация, подпись и проверка ЭЦП с использованием trial-версии Сигнал-КОМ Message-PRO RSA и СКЗИ ГОСТ 28147-89, ГОСТ Р 34.11/34.10-94/2001 с возможностью кэширования ключей; значения полей сертификата и просмотр содержимого сертификата аналогично диалогу в Сигнал-КОМ Inter-PRO; эмуляция диалога генерации случайной последовательности при ее отсутствии для ранних версий mespro.dll (аналогично имеющемуся в поздних);
- СИММЕТРИЧНОЕ ШИФРОВАНИЕ И CRC: симметричная шифрация и дешифрация по алгоритмам Blowfish, RC6, GOST, контрольная сумма CRC32 - позаимствованы с torry.ru, добавлена возможность кэширования ключей шифрования, чтобы не проводить повторную инициализацию, занимающую некоторое время, добавлена возможность поточного шифрования; формирование и однозначный разбор строки X500 с поддержкой имен параметров, используемых в CryptoAPI и Message-PRO.

ОСОБЕННОСТИ БИБЛИОТЕК:
- совместимость с Delphi 3 - Delphi 7 (преимущественно тестируется на Delphi 5);
- при подключении модулей в код EXE добавляются только те функции и объекты, которые реально вызываются в программе;
- динамическое подключение функций различных API, если они могут отсутствовать в Windows 95 или Windows NT, при этом для последних, по возможности, вызывается альтернативная функция, иногда недокументированная;
- все глобальные описания и объекты многопоточны или чаще создается отдельная копия глобального объекта в каждом потоке;
- библиотеки не требуют установки компонентов и прописывания путей в Delphi, при компиляции нет Warnings и Hints, публичные объекты и функции откомментированы на русском.


ПРИЛАГАЕТСЯ: UTILS.EXE. УТИЛИТА С ИНТЕРФЕЙСОМ И ПОДДЕРЖКОЙ КОМАНДНОЙ СТРОКИ И ЕЕ ИСХОДНИКИ НА DELPHI (ТРЕБУЮТ ALLLIB). ВЕРСИЯ ОТ 9.01.2006

Утилита и ее исходники: http://vstepanov78.narod.ru/utils.zip

Функции: графический просмотр и проигрывание файлов, блокнот с поддержкой шифрования, вывода оглавления; конвертация (Base64 и др.) и двоичный редактор файлов; просмотр, правка и экспорт в SQL-запросы значений полей базы данных, включая BLOB-поля; список запущенных процессов с корректным завершением; список активных окон по задачам; системная информация; запускаемые при старте Windows процессы; отправка и прием данных через серверный или клиентский сокет, включая двоичные данные, WhoIs, отправка почты; генерация ключей, запрос, издание и установка сертификатов, в том числе для сервера, для алгоритмов CryptoAPI RSA и Крипто-Про ГОСТ; шифрация и дешифрация, подпись и проверка ЭЦП для алгоритмов CryptoAPI RSA и Крипто-Про ГОСТ, а также Сигнал-КОМ Message-PRO, перепривязка секретного ключа от одного сертификата CryptoAPI к другому.

PM MAIL WWW   Вверх
Foley
Дата 21.2.2006, 00:53 (ссылка) |   (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Фсемба Яцца
*


Профиль
Группа: Участник
Сообщений: 235
Регистрация: 31.1.2006
Где: Россия, Арх.обл

Репутация: 2
Всего: 7



Мини - прога для расчета промежутка времени...


Присоединённый файл ( Кол-во скачиваний: 77 )
Присоединённый файл  raschet_vremeni.zip 9,07 Kb
PM MAIL ICQ   Вверх
CaNIBaLchik
Дата 1.3.2006, 11:24 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 48
Регистрация: 8.2.2006
Где: Томск

Репутация: нет
Всего: нет



Компилятор с подсветкой символов.

BDS2005

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

реализован алгоритмом рекурсивный спуск, обратная польская строка

Присоединённый файл ( Кол-во скачиваний: 179 )
Присоединённый файл  Kompilyator.rar 88,16 Kb
PM MAIL ICQ   Вверх
Girder
Дата 4.3.2006, 00:25 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Лентяй 2
***


Профиль
Группа: Участник Клуба
Сообщений: 1993
Регистрация: 12.5.2004

Репутация: 31
Всего: 155



Учимся работать с "многопоточными файлами" в NT.

За не большой теорией... обращаемся к топику smile : http://forum.vingrad.ru/index.php?showtopic=85363

1. Создание(изменение) и чтение "Опциональных потоков"
Код
procedure TForm1.Button1Click(Sender: TObject);
begin
 //сохраняем то что в Memo в "многопоточный файл"
 Memo1.Lines.SaveToFile('k:\memo.txt');
 Memo2.Lines.SaveToFile('k:\memo.txt:memo2'); //опциональный поток
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
 //читаем в обратном порядке из "многопоточного файла"
 Memo1.Lines.LoadFromFile('k:\memo.txt:memo2'); //опциональный поток
 Memo2.Lines.LoadFromFile('k:\memo.txt');
end;


Как видно из первого примера... что бы прочитать "Опциональный поток" нам необходимо знать его "имя"... smile . Если вам не известно енто "имя", а очень хочется... тогда код 2 пункта предназначен для вас smile .

2. Определяем инфу о файле/директории - читаем инфу о потоках:
*** Не забудьте включить SE_BACKUP_NAME привелегию ***
Код
function InfoFileStreams(const FileName:String; Delete:Boolean; out RStreams:String):Boolean;
{Входные данные:
- FileName: Имя файла/дирректории.
- Delete: Если Truе то... по мимо инфы еще и удаляем "Опциональные потоки" файла.
Выходные данные:
- True: Что-то смоглы определить :)
- RStreams - Определенная инфа}
const Error_Buffer_Overflow=$80000005;
type
 _IO_STATUS_BLOCK=packed record
   Status:DWord;
   Information:DWord;
 end;
 FILE_STREAM_INFORMATION=packed record 
   NextEntry:DWord;
   NameLength:DWord;
   Size:Int64;
   AllocationSize:Int64;
   Name:WideChar;
 end;
 _FILE_INFORMATION_CLASS=(FileDirectoryInformation=1,FileFullDirectoryInformation,
                          FileBothDirectoryInformation,FileBasicInformation,
                          FileStandardInformation,FileInternalInformation,
                          FileEaInformation,FileAccessInformation,FileNameInformation,
                          FileRenameInformation,FileLinkInformation,FileNamesInformation,
                          FileDispositionInformation,FilePositionInformation,FileFullEaInformation,
                          FileModeInformation,FileAlignmentInformation,FileAllInformation,
                          FileAllocationInformation,FileEndOfFileInformation,FileAlternateNameInformation,
                          FileStreamInformation,FilePipeInformation,FilePipeLocalInformation,
                          FilePipeRemoteInformation,FileMailslotQueryInformation,FileMailslotSetInformation,
                          FileCompressionInformation,FileObjectIdInformation,FileCompletionInformation,
                          FileMoveClusterInformation,FileQuotaInformation,FileReparsePointInformation,
                          FileNetworkOpenInformation,FileAttributeTagInformation,FileTrackingInformation,
                          FileMaximumInformation);
var NtQueryInformationFile: function (FileHandle:DWord; out IoStatusBlock: _IO_STATUS_BLOCK; FileInformation:Pointer; Length:DWord; FileInformationClass:_FILE_INFORMATION_CLASS):DWord; stdcall;
    fHandle:DWord;
    StreamIS:DWord;
    StreamInfo,tSI:^FILE_STREAM_INFORMATION;
    IoSB:_IO_STATUS_BLOCK;
    t:DWord;
    sN,sT:String;
    NextEntry,sM:Boolean;
begin
 Result:=false;
 NtQueryInformationFile:=GetProcAddress(GetModuleHandle('ntdll.dll'),'NtQueryInformationFile');
 if Assigned(NtQueryInformationFile)=false then exit;
 fHandle:=CreateFile(PChar(FileName),GENERIC_READ,FILE_SHARE_READ or FILE_SHARE_WRITE,nil,
                     OPEN_EXISTING,FILE_FLAG_BACKUP_SEMANTICS,0);
 if fHandle<>INVALID_HANDLE_VALUE then
  begin
   StreamIS:=0;
   GetMem(StreamInfo,StreamIS);
   repeat
    FreeMem(StreamInfo,StreamIS);
    StreamIS:=StreamIS+16384;
    GetMem(StreamInfo,StreamIS);
    t:=NtQueryInformationFile(fHandle,IoSB,StreamInfo,StreamIS,FileStreamInformation);
   until (t<>Error_Buffer_Overflow);
   if (t=0)and(IoSB.Information<>0) then
    begin
     tSI:=StreamInfo;
     sN:='';
     NextEntry:=True;
     Result:=true;
     sM:=false;
     while NextEntry do
      begin
       if tSI^.NextEntry=0 then NextEntry:=false;
       sT:=Copy(PWideChar(@tSI^.Name),0,tSI^.NameLength div SizeOf(WideChar));
       if (sM=false)and(AnsiCompareText(sT,'::$DATA')=0) then
        begin
         sM:=true;
         sN:=sN+'Основной поток: '+sT+'; Размер: '+IntToStr(tSI^.Size)+' байт'+chr($D)+chr($A);
        end else
        begin
         sN:=sN+'Опциональный поток: '+sT+'; Размер: '+IntToStr(tSI^.Size)+' байт'+chr($D)+chr($A);
         if Delete then
          if DeleteFile(FileName+sT) then sN:=sN+'Удален!'+chr($D)+chr($A);
        end;
       tSI:=Pointer(DWord(tSI)+tSI^.NextEntry);
      end;
     RStreams:=sN;
    end;
   FreeMem(StreamInfo,StreamIS);
   CloseHandle(fHandle);
  end;
end;


Ну и до кучи... пример использывания InfoFileStreams:
Код

const
  SE_BACKUP_NAME = 'SeBackupPrivilege';

function NTSetPrivilege(sPrivilege:string;fEnabled:LongBool):boolean;
var hToken:THandle;
    TokenPriv,PrevTokenPriv:TOKEN_PRIVILEGES;
    PrivSet:PRIVILEGE_SET;
    f:LongBool;
    i:Cardinal;
begin
 Result:=false;
 if Win32Platform<>VER_PLATFORM_WIN32_NT then exit;
 PrivSet.PrivilegeCount:=1;
 PrivSet.Control:=0;
 PrivSet.Privilege[0].Attributes:=0;
 if LookupPrivilegeValue(nil,PChar(sPrivilege),PrivSet.Privilege[0].Luid) then
  if OpenProcessToken(GetCurrentProcess(),TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,hToken) then
   begin
    try
     if PrivilegeCheck(hToken,PrivSet,f)and(f<>fEnabled) then
      if LookupPrivilegeValue(nil,PChar(sPrivilege),TokenPriv.Privileges[0].Luid) then
       begin
        TokenPriv.PrivilegeCount:=1;
        if fEnabled then TokenPriv.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED else
         TokenPriv.Privileges[0].Attributes:=0;
        i:=0;
        PrevTokenPriv:=TokenPriv;
        AdjustTokenPrivileges(hToken,false,TokenPriv,SizeOf(PrevTokenPriv),PrevTokenPriv,i);
        Result:=GetLastError=ERROR_SUCCESS;
       end;
    except
    end;
    CloseHandle(hToken);
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var s:string;
begin
 NTSetPrivilege(SE_BACKUP_NAME,true);
 if InfoFileStreams('k:\memo.txt',false,s) then Memo1.Lines.Text:=s;
 //Удаляем опциональные потоки
 //if InfoFileStreams('k:\memo.txt',true,s) then Memo1.Lines.Text:=s;
end;


Удачи.


--------------------
Как слышим, так и пишим.
Истина где-то там...
PM   Вверх
former
Дата 27.3.2006, 20:05 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


MEMS Expert
***


Профиль
Группа: Завсегдатай
Сообщений: 1166
Регистрация: 1.3.2006
Где: Россия

Репутация: 5
Всего: 17



Народ, ранее в этом разделе публиковалась ссылка на SoftUtl.zip. Сейчас она не работает. Если у кого есть и не жалко, дайте ссылку или киньте на мыло.


--------------------
Достаточно снизить уровень мышления, чтобы иные почувствовали почву под ногами.
PM MAIL   Вверх
Guedda
Дата 28.3.2006, 19:30 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Подрывник
****


Профиль
Группа: Завсегдатай
Сообщений: 3137
Регистрация: 27.12.2005
Где: Ростов-на-Дону

Репутация: 14
Всего: 78



Вот мой модуль для работы с Ini файлами... Должен всем пригодиться...
MyIni.pas:
Код

//Модуль для работы с данными в конфигурационном файле.
//Функции упрощают использование конфиг. файлов.
//Данный материал можно изменять по Вашему усмотрению...
//При нахождении ошибкок пишите на [email protected]
unit MyIni.pas

interface

uses
  IniFiles;

procedure WriteIniData(Section, Ident, Value : string);
procedure WriteIniDataInt(Section, Ident : string; Value : Integer);
procedure WriteIniDataBool(Section, Ident : string; Value : boolean);
function ReadIniData(Section, Ident : string; Default : string = '') : string;
function ReadIniDataInt(Section, Ident : string; Default : Integer = 0) : Integer;
function ReadIniDataBool(Section, Ident : string; Default : boolean = false) : boolean;

implementation

var
  IniFile : TIniFile;
  Path : string;

procedure WriteIniData(Section, Ident, Value : string);
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  IniFile.WriteString(Section, Ident, Value);
  IniFile.Free;
end;

procedure WriteIniDataInt(Section, Ident : string; Value : Integer);
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  IniFile.WriteInteger(Section, Ident, Value);
  IniFile.Free;
end;

procedure WriteIniDataBool(Section, Ident : string; Value : boolean);
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  IniFile.WriteBool(Section, Ident, Value);
  IniFile.Free;
end;

function ReadIniData(Section, Ident : string; Default : string = '') : string;
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  Result := IniFile.ReadString(Section, Ident, Default);
  IniFile.Free;
end;

function ReadIniDataInt(Section, Ident : string; Default : Integer = 0) : Integer;
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  Result := IniFile.ReadInteger(Section, Ident, Default);
  IniFile.Free;
end;

function ReadIniDataBool(Section, Ident : string; Default : boolean = false) : boolean;
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  Result := IniFile.ReadBool(Section, Ident, Default);
  IniFile.Free;
end;

initialization
  GetDir(0, Path);

end.



--------------------
Ll 2
PM MAIL WWW ICQ Skype GTalk   Вверх
Rrader
  Дата 29.3.2006, 03:15 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Inspired =)
***


Профиль
Группа: Экс. модератор
Сообщений: 1535
Регистрация: 7.5.2005

Репутация: 70
Всего: 191



 А вот мой, ещё проще:
Код

Unit USDKINIFiles;

{ From Windows Messages SDK }

Interface

Uses Windows, SysUtils;

Type
  TINIFile = Class(TObject)
  Private
    FFileName: String;
  Public
    Constructor Create(Const FileName : String);
    Destructor Destroy; Override;
    Function ReadString(Const Section, Key, Default: String): String;
    Function ReadInteger(Const Section, Key: String;
      Default: Longint): Longint;
    Function ReadBool(Const Section, Key: String; Default: Boolean): Boolean;
    Function WriteString(Const Section, Key, Value: String): Boolean;
    Function WriteInteger(Const Section, Key: String;
      Value: Longint): Boolean;
    Function WriteBool(Const Section, Key: String; Value: Boolean): Boolean;
    Procedure UpdateFile;
    Property FileName: String Read FFileName;
  End;

Implementation

{ TINIFile }

Constructor TIniFile.Create(Const FileName: String);
Begin
  FFileName := FileName;
End;

Destructor TIniFile.Destroy;
Begin
  UpdateFile;
  Inherited Destroy;
End;

Function TIniFile.ReadBool(Const Section, Key: String;
  Default: Boolean): Boolean;
Begin
  Result := ReadInteger(Section, Key, Ord(Default)) <> 0;
End;

Function TIniFile.ReadInteger(Const Section, Key: String;
  Default: Integer): Longint;
Var
  IntStr: String;
Begin
  IntStr := ReadString(Section, Key, '');
  If (Length(IntStr) > 2) And (IntStr[1] = '0') And
     ((IntStr[2] = 'X') Or (IntStr[2] = 'x')) Then
    IntStr := '$' + Copy(IntStr, 3, MaxInt);
  Result := StrToIntDef(IntStr, Default);
End;

Function TIniFile.ReadString(Const Section, Key, Default: String): String;
Var
  Buffer: Array[0..2047] Of Char;
Begin
  SetString(Result, Buffer, GetPrivateProfileString(PChar(Section),
    PChar(Key), PChar(Default), Buffer, SizeOf(Buffer), PChar(FFileName)));
End;

Procedure TIniFile.UpdateFile;
Begin
  WritePrivateProfileString(NIL, NIL, NIL, PChar(FFileName));
End;

Function TIniFile.WriteBool(Const Section, Key: String;
  Value: Boolean): Boolean;
Const
  Values: Array[Boolean] Of String = ('0', '1');
Begin
  Result := WriteString(Section, Key, Values[Value]);
End;

Function TIniFile.WriteInteger(Const Section, Key: String;
  Value: Integer): Boolean;
Begin
  Result := WriteString(Section, Key, IntToStr(Value));
End;

Function TIniFile.WriteString(Const Section, Key, Value: String): Boolean;
Begin
  Result := WritePrivateProfileString(PChar(Section), PChar(Key),
    PChar(Value), PChar(FFileName));
End;

End.
 
Guedda, Try-Finally не видно... smile  

Это сообщение отредактировал(а) Rrader - 24.6.2006, 12:01


--------------------
Let's do this quickly!
Rest in peace, Vit!
PM MAIL Skype   Вверх
Guedda
Дата 29.3.2006, 12:17 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Подрывник
****


Профиль
Группа: Завсегдатай
Сообщений: 3137
Регистрация: 27.12.2005
Где: Ростов-на-Дону

Репутация: 14
Всего: 78



Да по-моему это обрезанный класс TIniFile...


--------------------
Ll 2
PM MAIL WWW ICQ Skype GTalk   Вверх
Sh@dow
Дата 6.4.2006, 13:36 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 32
Регистрация: 1.7.2004

Репутация: нет
Всего: 1



Хотел бы поделиться некоторыми наработками под MS SQL. Так как в разделе баз данных подобного раздела нет выкладываю сюда. Может кому и пригодяться. На авторство не претендую smile .

Код

-- Возвращает строку в DOS кодировке 
-- dbo.WIN_DOS_STRING(expression)
--    expression - строка в WIN кодировке
CREATE FUNCTION dbo.WIN_DOS_STRING
(
  @ws VARCHAR(8000)    -- строка
)
RETURNS VARCHAR(8000)
AS  
BEGIN
    DECLARE    @ss        int,                -- счетчик
                @ds        varchar(8000),    -- DOS строка
                @ls        int,                -- длина обр. строки
                @os        int                -- код 1-го обраб-го символа
    SET @ds=''
    SET @ls=LEN(@ws)
    SET @ss=0
    WHILE @ss<@ls
    BEGIN
        SET @os=ASCII(SUBSTRING(@ws,1,1))
        SET @ds=@ds+CASE
            WHEN @os>=192 AND @os<=239 THEN  CHAR(@os-64)-- 128.180
            WHEN @os>=240 AND @os<=256 THEN  CHAR(@os-16)-- 224.239
            WHEN @os=168 THEN  CHAR(240) --Ё
            WHEN @os=184 THEN  CHAR(241) --ё
            ELSE CHAR(@os)
        END                        
        SET @ss=@ss+1
        SET @ws=SUBSTRING(@ws,2,LEN(@ws)-1)
    END
    RETURN @ds
END



Код

/*
перекодировка символа Widows в code128
*/
CREATE FUNCTION dbo.Win2code128
(@winchar as varchar(1))
RETURNS int
 AS  
BEGIN 

DECLARE @code as int
DECLARE @T TABLE( a int, b VARCHAR(1) )

insert into @T
select 0 a,' ' b
union all
select 1 a,'!' b
union all
select 2 a,'"' b
union all
select 3 a,'#' b
union all
select 4 a,'$' b
union all
select 5 a,'%' b
union all
select 6 a,'&' b
union all
select 7 a,'''' b
union all
select 8 a,'(' b
union all
select 9 a,')' b
union all
select 10 a,'*' b
union all
select 11 a,'+' b
union all
select 12 a,',' b
union all
select 13 a,'-' b
union all
select 14 a,'.' b
union all
select 15 a,'/' b
union all
select 16 a,'0' b
union all
select 17 a,'1' b
union all
select 18 a,'2' b
union all
select 19 a,'3' b
union all
select 20 a,'4' b
union all
select 21 a,'5' b
union all
select 22 a,'6' b
union all
select 23 a,'7' b
union all
select 24 a,'8' b
union all
select 25 a,'9' b
union all
select 26 a,':' b
union all
select 27 a,';' b
union all
select 28 a,'<' b
union all
select 29 a,'=' b
union all
select 30 a,'>' b
union all
select 31 a,'?' b
union all
select 32 a,'@' b
union all
select 33 a,'A' b
union all
select 34 a,'B' b
union all
select 35 a,'C' b
union all
select 36 a,'D' b
union all
select 37 a,'E' b
union all
select 38 a,'F' b
union all
select 39 a,'G' b
union all
select 40 a,'H' b
union all
select 41 a,'I' b
union all
select 42 a,'J' b
union all
select 43 a,'K' b
union all
select 44 a,'L' b
union all
select 45 a,'M' b
union all
select 46 a,'N' b
union all
select 47 a,'O' b
union all
select 48 a,'P' b
union all
select 49 a,'Q' b
union all
select 50 a,'R' b
union all
select 51 a,'S' b
union all
select 52 a,'T' b
union all
select 53 a,'U' b
union all
select 54 a,'V' b
union all
select 55 a,'W' b
union all
select 56 a,'X' b
union all
select 57 a,'Y' b
union all
select 58 a,'Z' b
union all
select 59 a,'[' b
union all
select 60 a,'\' b
union all
select 61 a,']' b
union all
select 62 a,'^' b
union all
select 63 a,'_' b
union all
select 64 a,'`' b
union all
select 65 a,'a' b
union all
select 66 a,'b' b
union all
select 67 a,'c' b
union all
select 68 a,'d' b
union all
select 69 a,'e' b
union all
select 70 a,'f' b
union all
select 71 a,'g' b
union all
select 72 a,'h' b
union all
select 73 a,'i' b
union all
select 74 a,'j' b
union all
select 75 a,'k' b
union all
select 76 a,'l' b
union all
select 77 a,'m' b
union all
select 78 a,'n' b
union all
select 79 a,'o' b
union all
select 80 a,'p' b
union all
select 81 a,'q' b
union all
select 82 a,'r' b
union all
select 83 a,'s' b
union all
select 84 a,'t' b
union all
select 85 a,'u' b
union all
select 86 a,'v' b
union all
select 87 a,'w' b
union all
select 88 a,'x' b
union all
select 89 a,'y' b
union all
select 90 a,'z' b
union all
select 91 a,'{' b
union all
select 92 a,'|' b
union all
select 93 a,'}' b
union all
select 94 a,'~' b
union all
select 95 a,char(161) b
union all
select 96 a,char(162) b
union all
select 97 a,char(163) b
union all
select 98 a,char(164) b
union all
select 99 a,char(165) b
union all
select 100 a,char(166) b
union all
select 101 a,char(167) b
union all
select 102 a,char(168) b
union all
select 103 a,char(169) b
union all
select 104 a,char(170) b
union all
select 105 a,char(171) b
union all
select 106 a,char(172) b

select @code=a
from @T
where ascii(b)=ascii(@winchar)

set @code=isnull(@code,0)

return (@code)

END


Код

/*возвращает строку для формирования штрихкода со стартовыми, стоповыми символами и контрольной суммой по кодировке code128 подсистемы B на входе строка, состоящая из цифр (если какой-то другой символ, то он обрабатывается как 0) */

CREATE FUNCTION dbo.getcode128
(@string as varchar(50) )
RETURNS varchar(50)
 AS  
BEGIN 

DECLARE @position int, @stringnew varchar(50), @sum int, @codestart int, @codestop int
SET @position = 1
SET @stringnew = ''
set @codestart=104
set @codestop=106
set @sum=@codestart

WHILE @position <= DATALENGTH(@string)
   BEGIN
   SELECT @stringnew=@stringnew+SUBSTRING(@string, @position, 1), 
          @sum=@sum+@position*
          (case when SUBSTRING(@string, @position, 1)='1' then 17 else
          case when SUBSTRING(@string, @position, 1)='2' then 18 else
          case when SUBSTRING(@string, @position, 1)='3' then 19 else
          case when SUBSTRING(@string, @position, 1)='4' then 20 else
          case when SUBSTRING(@string, @position, 1)='5' then 21 else
          case when SUBSTRING(@string, @position, 1)='6' then 22 else
          case when SUBSTRING(@string, @position, 1)='7' then 23 else
          case when SUBSTRING(@string, @position, 1)='8' then 24 else
          case when SUBSTRING(@string, @position, 1)='9' then 25 else
          16
          end
          end
          end
          end
          end
          end
          end
          end
          end)
   SET @position = @position + 1
   END

set @stringnew=dbo.code128toWin(@codestart)+@stringnew+dbo.code128toWin(@sum-@sum/103*103)+dbo.code128toWin(@codestop)

return (@stringnew)

END


Код

/* Функция переводит число в строковое выражение числа с запятой, которое понимает Ёксель
*P* 15.11.02  */

CREATE FUNCTION Float2Str
(@val as float )
RETURNS varchar(24)
 AS  
BEGIN 

declare @s as varchar(24)
set @s=str(@val,21,2)
return stuff(@s,len(@s)-2,1,',')

END


Код

-- Возвращает строку в WIN кодировке, на базе WIN_DOS_String()
-- dbo.DOS_WIN_STRING(expression)
--    expression - строка в DOS кодировке
CREATE FUNCTION dbo.DOS_WIN_STRING
(
  @ds VARCHAR(8000)    -- строка в DOS кодировке
)
RETURNS VARCHAR(8000)
AS  
BEGIN
    DECLARE    @ss        int,        -- счетчик
            @ws        varchar(8000),    -- WIN строка
            @ls        int,        -- длина обр. строки
            @os        int        -- код 1-го обраб-го символа
    SET @ws=''
    SET @ls=LEN(@ds)
    SET @ss=0
    WHILE @ss<@ls
    BEGIN
        SET @os=ASCII(SUBSTRING(@ds,1,1))
        SET @ws=@ws+CASE
            WHEN @os>=128 AND @os<=180 THEN  CHAR(@os+64)-- 192.239
            WHEN @os>=224 AND @os<=239 THEN  CHAR(@os+16)-- 240.256
            WHEN @os=240 THEN  CHAR(168) --Ё
            WHEN @os=241 THEN  CHAR(184) --ё
            ELSE CHAR(@os)

    END                        
        SET @ss=@ss+1
        SET @ds=SUBSTRING(@ds,2,LEN(@ds)-1)
    END
    RETURN @ws
END


Код

CREATE FUNCTION [dbo].[CalcDate] 
 (
  @date datetime, --исходная дата
  @Month int,  -- кол-во месяцев добавить (отриц. - вычесть)
  @Begin bit  -- 0 - получить кон. дату месяца, 1-получить нач. дату месяца
 )  
RETURNS datetime AS  
BEGIN 
  declare @d datetime
  set @d = DateAdd(m, @Month, @date)
  if (@Begin=0)
  begin
    set @d = DateAdd( m , 1, @d)
    set @d = DateAdd(day,  -(day(@d) ) , @d  )
  end
  else
    set @d = DateAdd(day, -(day(@d)-1) , @d )
  Return( @d )
 
END


Код

-- Возвращает строку дополненную с начала заданным символом до нужной длины
-- dbo.LONGSTRING(expression , symbol , length )
--    expression - дополняемая строка
--    symbol - символ для дополнения
--    length - длина возвращаемой строки. Если длина меньше длины expression
--                    expression урезается до заданной длины
-- Примеры: dbo.LONGSTRING('4','0',3) 
--            Результат: 004
--    dbo.LONGSTRING('123456789','0',4) 
--            Результат: 6789        
CREATE FUNCTION dbo.BLONGSTRING
(
  @bs NVARCHAR(4000),
  @sim NVARCHAR(4000),
  @long INT
)
RETURNS NVARCHAR(4000)
AS  
BEGIN
    DECLARE @lnst nvarchar(4000)
    SET @bs=LTRIM(RTRIM(@bs))
    SET @lnst=REVERSE(SUBSTRING(REVERSE(REPLICATE(@sim, @long)+@bs),1,@long))
    RETURN @lnst
END

PM MAIL   Вверх
RA
Дата 29.4.2006, 19:34 (ссылка) |  (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Брутальный буратина
****


Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 14
Всего: 115



совмещённые, между собой: 
ToolBar2000 v2.1.7 и TBX v2.2

http://g32.org и http://www.jrsoftware.org

Скачать 
PM   Вверх
TP@MB@Y
Дата 12.5.2006, 22:06 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 370
Регистрация: 18.12.2004
Где: Москва

Репутация: нет
Всего: 4



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

Код

//Функция возвращающая N-ое слово в строке
//Если N=0, то функция возвращает подстоку начиная с первого разделителя
function GetWord(str:string;n:word;sep:char):string;
var i,space,l,j:integer;
    buf:string;
begin
 l:=length(str);
 if n=0 then begin  //особый параметр
              j:=pos(GetWord(str,2,sep),str);
              GetWord:=copy(str,j,l-j+1);
              exit
             end;
 space:=0;
 i:=0;
 while (space<>(n-1))and(i<=l) do
  begin
   i:=i+1;
   if str[i]=sep then space:=space+1
  end;
 i:=i+1;
 buf:='';
 while (i<=l)and(str[i]<>sep) do
  begin
   buf:=buf+str[i];
   i:=i+1
  end;
 GetWord:=buf;
end;


Если кто не понял, то функция возвращает n-ое слово из строки str, считая за разделитель символ sep

Надеюсь комунибуть пригодится! smile 
PM   Вверх
Sansei
  Дата 14.5.2006, 18:13 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 1
Регистрация: 14.5.2006

Репутация: нет
Всего: нет



Начинающие системные программисты всегда ощущают дискомфорт и профессиональную неполноценность при отсутствии крайне необходимого им системного драйвера для чтения записи портов и MSR-регистров. Как же быть, когда знаний порой не достаточно, а времени на изучение тонкостей написания драйверов не хватает, а порой и не возникает? В этом случае есть два выхода. Найти в Интернете бесплатный либо позаимствовать уже готовый полноценный драйвер. Первый, как правило, обеспечивает только чтение и запись портов ввода-вывода, чего естественно недостаточно. Второй зачастую стоит больших денег, что естественно нас не устраивает. Поэтому мы попробуем найти простенькую бесплатную программу, драйвер которой сделает нас полноценными системными программистами. 

Я не стал обременять себя поиском необходимой программы, а сразу обратился на один попсовый среди оверклокеров рунета форум. Программа, по сути, ничем не примечательна и актуальностью не выделяется, чего не скажешь о её авторе. По сути, очередной банальный идентификатор CPU, самопально написанный на презренном многими программистами Delphi 7.0. Скачав последнюю бета версию 1.0, я приступил к её изучению.

Для начала, я загрузил программу в известный PE-редактор PE Explorer 1.96 с целью анализа прилинкованных к EXE-файлу ресурсов, среди которых мог обнаружится сам драйвер. Как я и ожидал, драйвер быстро обнаружился в секции RC Data под именем OSCI_DRVNT. Сохраняем драйвер в виде sys-файла на диск выбором команды контекстного меню Save Resource As…. В последующем он понадобился для компиляции в файл ресурсов и, как результат, подключения готового Res-файла к тестовому Delphi-приложению директивой {$R driver.res}.

Следующий этап заключается в поиске необходимых нам так называемых IOCTL-кодов, через которые происходит обращение приложения к драйверу. По сути, это команды, в ответ на которые драйвер выполняет ту или иную функцию, например читает порт или перезаписывает MSR-регистр процессора. В итоге, драйвер возвращает результат выполненной функции приложению. Для поиска IOCTL-кодов я прибегнул к встроенному дизассемблеру программы PE Explorer. Данный дизассемблер хорошо подходит для программ, скомпилированных на Delphi и предоставляет код ассемблера в удобном для изучения виде. 

Дизассемблировав EXE-файл, нажатием Ctrl+F вводим запрос IOCTL. Естественно, первая попытка найти соответствие символьной константы необходимому IOCTL-коду неудачна, поэтому двигаем поиск дальше нажатием клавиши F3. И вот она удача! Полный перечень IOCTL-кодов обнаружился!

user posted image

Итак, видим, что для того, чтобы считать данные MSR-регистра необходимо обратиться к драйверу с IOCTL-кодом IOCTL_READ_MSR, числовое значение в hex-формате  которого равно 9C402604h. Драйвер понимает и множество других IOCTL-кодов, смысл которых нам раскрывают интуитивно понятные имена символьных констант. Прекрасно понимая, что автор программы – полный «лом» в написании драйверов, всё-таки не могу не упрекнуть его за такое упущение! 

Финальный шаг состоит в определении названия функции, с помощью которой приложение отправляет драйверу IOCTL-код. Их две: DeviceIoControl и WriteFile. Учитывая, что первая функция применяется гораздо чаще и является, по сути, классической в данной случае, с её поиска мы и начнем.

Поднимаемся в самое начало дизассемблированного кода, и начинаем поиск по критерию IOCTL_READ_MSR. Первый найденный результат доказывает, что для обращения к драйверу применяется классическая функция DeviceIoControl – сместившись на 20 строчек по коду выше обнаруживаем вызов данной функции из библиотеки kernel32.dll!

Теперь, когда мы знаем все IOCTL-коды и название применяемой функции мы можем приступить к написанию тестового приложения, полный рабочий пример которого можно взять здесь. Я не буду комментировать его т.к., а я лично одобряю позицию, о которой говорил в самом начале этой статьи: не нужно постигать то, в чем мы не заинтересованы, нам важен конечный результат. Тестовое приложение реализует одним модулем необходимый набор функций для начинающего системного программиста, а именно: чтение/запись портов и MSR-регистров процессора. 

Для вашего приложения понадобится лишь прилагаемый к архиву модуль PortIO.pas и сам драйвер в виде ресурса driver.res. Инсталляцию и инициализацию драйвера берет на себя модуль.

В завершении этой статьи я хотел бы акцентировать ваше внимание на том, что моя статья опубликована исключительно в образовательных целях и не носит какой-либо противозаконный характер! Удачи!
 

Это сообщение отредактировал(а) Sansei - 14.5.2006, 18:19

Присоединённый файл ( Кол-во скачиваний: 104 )
Присоединённый файл  oscidrv.zip 17,14 Kb
PM MAIL   Вверх
Budy
Дата 9.6.2006, 20:32 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 616
Регистрация: 6.2.2004
Где: Екатеринбург

Репутация: 1
Всего: 2



Два компонента esNumLabel и esTextLabel. Ложатся в палитру Standart.
Оба компонента предназначены для необычного вывода соответственно чисел и строк.
1) Готовый BPL. Ссылка http://frombudy.narod.ru/upload/delphi/esComponent.rar.
Как установить? Заходим в меню "Component/Install packeges...", жмем "Add..." и указываем распакованный BPL.
2) Исходники. Ссылка http://frombudy.narod.ru/upload/delphi/esComponent_units.rar

Немного о компонентах:
•Размер выравнивается самостоятельно, изменение Width и Height ни к чему не привидет.
•Есть возможность использовать свой стиль символов.
esNumLabel: обратите внимание на следующие property: Number, NumberImage, NumberShow, Transparent.
esTextLabel: обратите внимание на следующие property: Caption, TextImage, Transparent.
•При написании компонентов использовал класс TGraphicControl.
•Предупреждаю: Использовать, изменять и распространять данные ресурсы разрешаю.

Ресурсы создал от нечего делать, да и попрактиковался немного smile
Кстати, буду рад выслушать все ваши комментарии в мой адрес, пожалуйста пользуемся Личными сообщениями или почтой mailto:[email protected].

С уважением, Budy. 


--------------------
Как ты назовешь свой корабль, так на нем и напишут
user posted image
PM MAIL WWW ICQ   Вверх
Angel_19
Дата 31.7.2006, 23:45 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 73
Регистрация: 5.4.2005

Репутация: нет
Всего: нет



Кто нибудь юзал исходники Sansei? Я попробовал, у меня чт-то они глючат... 
PM ICQ   Вверх
Rouse_
Дата 11.8.2006, 18:09 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 469
Регистрация: 23.4.2005

Репутация: 5
Всего: 29



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

Небольшая полезность: PEDump Shell Extension
Ссылка: http://rouse.front.ru/propsheet.zip а также в прикрепленке
Размер: 139 600 байт
В архиве, помимо исходников сама утилита.

Выглядит данная утилита вот так: user posted image

Что из себя представляет:
Выводит список импорта - экспорта выбранного РЕ файла на закладке свойств файла. Собственно, помимо демо получения самих списков импорта/экспорта показывает работу с IShellPropSheetExt, при помощи которого реализуется сама закладка, есть работа с активизацией контекста манифеста (интересно будет тем, кто работает с диалогами под ХР), в качестве вкусностей - юнит с реализацией функций ImageRvaToVa и ImageDirectoryEntryToData. 

Надеюсь данная работа будет вам интересна.

Помимо этого обновил сайт примером работы с корзиной, впрочем не маленькие, сами разберетесь: http://rouse.front.ru/

 smile 

Всем удачных выходных. 

Присоединённый файл ( Кол-во скачиваний: 153 )
Присоединённый файл  propsheet.zip 136,33 Kb


--------------------
 Vae Victis
(Горе побежденным (лат.))
Демо с открытым кодом: http://rouse.drkb.ru 
PM MAIL WWW ICQ   Вверх
ctulhu
Дата 11.2.2007, 09:16 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 32
Регистрация: 7.2.2007

Репутация: нет
Всего: нет



Модуль для работы с файловой системой на ООП-основе.

  - класс для работы с директориями
  - класс для работы с содержимым директорий
  - возможность работы с текстовыми файлами



Присоединённый файл ( Кол-во скачиваний: 117 )
Присоединённый файл  FileSystem.pas 14,75 Kb
PM MAIL   Вверх
Alexeyt
Дата 26.2.2007, 20:00 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 332
Регистрация: 15.9.2006
Где: около Москвы

Репутация: нет
Всего: 2



//Раз народ выкладывает свои реализации работы с ini файлами, выложу я:

Модуль работы с реестром - быстрый, на одном API. Никаких классов. Чтение/запись строки/числа/binary. Есть поддержка юникода в более новой версии, кому нужно - пишите.

Код

// RegProc.pas - simple Registry reading/writing
// Written by Alexey Torgashin, thanks to Eugene Roshal

unit RegProc;

interface

uses Windows;

procedure SetRegKeyStr(RootKey: HKEY; SubKey: PChar; Name: PChar; const Value: string);
procedure SetRegKeyInt(RootKey: HKEY; SubKey: PChar; Name: PChar; const Value: DWORD);
procedure SetRegKeyBin(RootKey: HKEY; SubKey: PChar; Name: PChar; const DataPtr: pointer; DataSize: DWORD);
function GetRegKeyStr(RootKey: HKEY; SubKey: PChar; Name: PChar; const Default: string): string;
function GetRegKeyInt(RootKey: HKEY; SubKey: PChar; Name: PChar; const Default: DWORD): DWORD;
function GetRegKeyBin(RootKey: HKEY; SubKey: PChar; Name: PChar; var DataPtr: pointer; var DataSize: DWORD): boolean;
     
implementation

function CreateRegKey(RootKey: HKEY; SubKey: PChar): HKEY;
var
  Disposition: DWORD;
begin
  if RegCreateKeyEx(RootKey, SubKey, 0, nil,
                    REG_OPTION_NON_VOLATILE, KEY_WRITE, nil,
                    Result, @Disposition)<>ERROR_SUCCESS
    then Result:= 0;
end;

function OpenRegKey(RootKey: HKEY; SubKey: PChar): HKEY;
begin
  if RegOpenKeyEx(RootKey, SubKey, 0, KEY_QUERY_VALUE, Result)<>ERROR_SUCCESS
    then Result:= 0;
end;

procedure SetRegKeyStr(RootKey: HKEY; SubKey: PChar; Name: PChar; const Value: string);
var
  h: HKEY;
begin
  h:= CreateRegKey(RootKey, SubKey);
  RegSetValueEx(h, Name, 0, REG_SZ, PChar(Value), Length(Value)+1);
  RegCloseKey(h);
end;

procedure SetRegKeyInt(RootKey: HKEY; SubKey: PChar; Name: PChar; const Value: DWORD);
var
  h: HKEY;
begin
  h:= CreateRegKey(RootKey, SubKey);
  RegSetValueEx(h, Name, 0, REG_DWORD, @Value, SizeOf(DWORD));
  RegCloseKey(h);
end;

procedure SetRegKeyBin(RootKey: HKEY; SubKey: PChar; Name: PChar; const DataPtr: pointer; DataSize: DWORD);
var
  h: HKEY;
begin
  h:= CreateRegKey(RootKey, SubKey);
  RegSetValueEx(h, Name, 0, REG_BINARY, DataPtr, DataSize);
  RegCloseKey(h);
end;

function GetRegKeyStr(RootKey: HKEY; SubKey: PChar; Name: PChar; const Default: string): string;
var
  h: HKEY;
  Buffer: PChar;
  DataType, DataSize: DWORD;
begin
  Result:= Default;
  h:= OpenRegKey(RootKey, SubKey);
  if (RegQueryValueEx(h, Name, nil, @DataType, nil, @DataSize)<>ERROR_SUCCESS)
    or (DataType<>REG_SZ) then
    begin RegCloseKey(h); Exit end;

  GetMem(Buffer, DataSize);
  if (RegQueryValueEx(h, Name, nil, @DataType, PByte(Buffer), @DataSize)<>ERROR_SUCCESS)
    or (DataType<>REG_SZ) then
    begin RegCloseKey(h); Exit end;

  Result:= Buffer;
  FreeMem(Buffer, DataSize);
  RegCloseKey(h);
end;

function GetRegKeyInt(RootKey: HKEY; SubKey: PChar; Name: PChar; const Default: DWORD): DWORD;
var
  h: HKEY;
  DataType, DataSize: DWORD;
begin
  DataSize:= SizeOf(DWORD);
  h:= OpenRegKey(RootKey, SubKey);
  if (RegQueryValueEx(h, Name, nil, @DataType, PByte(@Result), @DataSize)<>ERROR_SUCCESS)
    or (DataType<>REG_DWORD)
    then Result:= Default;
  RegCloseKey(h);
end;

function GetRegKeyBin(RootKey: HKEY; SubKey: PChar; Name: PChar; var DataPtr: pointer; var DataSize: DWORD): boolean;
var
  h: HKEY;
  DataType: DWORD;
begin
  h:= OpenRegKey(RootKey, SubKey);
  Result:= (RegQueryValueEx(h, Name, nil, @DataType, PByte(DataPtr), @DataSize)=ERROR_SUCCESS)
    and (DataType=REG_BINARY);
  if not Result then
    begin DataPtr:= nil; DataSize:= 0 end;
  RegCloseKey(h);
end;

end.




PM WWW   Вверх
Alexeyt
Дата 26.2.2007, 20:47 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 332
Регистрация: 15.9.2006
Где: около Москвы

Репутация: нет
Всего: 2



Юнит для работы с Directory Junctions под Win2000/XP+. Чтение директории назначения + создание/удаление junctions. Плюс консольная утилита, на основе этого юнита, которая создает junctions из командной строки.


Это сообщение отредактировал(а) Alexeyt - 1.3.2007, 21:45

Присоединённый файл ( Кол-во скачиваний: 42 )
Присоединённый файл  Junc.zip 32,70 Kb
PM WWW   Вверх
Alexeyt
Дата 1.3.2007, 13:02 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 332
Регистрация: 15.9.2006
Где: около Москвы

Репутация: нет
Всего: 2



Выделил из своего компонента код, содержащий TScrollBox + TImage + обвязку.
Получился компонент ATImageBox.

Можно загружать рисунок и задавать ему разный масштаб, подгонять размеры, перетаскивать мышью и т.д. Свойства: ImageFitToWindow, ImageFitOnlyBig, ImageCenter, ImageScale и т.д.

user posted image

Обсуждение (на этом форуме) здесь: http://forum.vingrad.ru/topic-139061.html


Присоединённый файл ( Кол-во скачиваний: 84 )
Присоединённый файл  ATImageBox.zip 392,75 Kb
PM WWW   Вверх
lukas
Дата 8.5.2007, 22:47 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 771
Регистрация: 23.2.2007

Репутация: 3
Всего: 15



Функция возвращения N-ого параметра из строкового выражения типа <название>(параметр1 ... параметрN)

Где N - номер параметра, Atype - символ разделитель параметров. 

Если разделительный символ содержится в параметре, то параметр нужно заключить в двойные кавычки " ".

Код

function GetParam(S:string; n:byte; Atype:char):string;
   var
   ind,i:integer; ts:string; stroka:boolean;
begin
 if pos('(',s)=0 then exit;
 if pos(')',s)=0 then exit;

 if s='' then begin result:=''; exit; end;
 delete(s,1,pos('(',s)); delete(s,length(s),1);
 if s='' then begin result:=''; exit; end;
 stroka:=false; ind:=1; i:=1;
  repeat
      if (stroka=false)and((s[i]=Atype)or(s[i]='')) then begin
       result:=ts;
       ts:='';
       ind:=ind+1;
       i:=i+1;
      end;
  if s[i]='"' then
  stroka:=not(stroka);
     ts:=ts+s[i]; i:=i+1;
  until ind=n+1;
  if result[1]='"' then delete(result,1,1);
  if result[length(result)]='"' then delete(result,length(result),1);
  result:=trim(result);
end;


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

Код

...
ShowMessage(GetParam('line(0,0,2,4)',3,','));
...


Еще одна функция, возвращает кол-во параметров:
Код


function GetParamCount(S:string; Atype:char):byte;
   var
   ind,i:integer; stroka:boolean;
begin
 result:=0;
 if pos('(',s)=0 then exit;
 if pos(')',s)=0 then exit;

 if s='' then begin result:=0; exit; end;
 delete(s,1,pos('(',s)); delete(s,length(s),1);
 if s='' then begin result:=0; exit; end;
 stroka:=false; ind:=1; i:=1;

  for i:=1 to length(s) do begin
      if (stroka=false)and((s[i]=Atype)or(s[i]='')) then begin
       ind:=ind+1;
      end;
  if s[i]='"' then
  stroka:=not(stroka);
 end;
  result:=ind;
end;


P.S. в коде интерпретатора можно сильно сократить всю свою писанину. (У меня было так).

Это сообщение отредактировал(а) lukas - 8.5.2007, 22:48


--------------------
http://code.google.com/p/orionphp/ - opensource скриптовой язык Orion (аналог PHP) для freepascal/delphi.
PM MAIL WWW   Вверх
AlexxxM
Дата 23.5.2007, 17:25 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 17
Регистрация: 15.5.2007

Репутация: нет
Всего: нет



На работе возникла проблема при открытии заказа рассылать письма по отделам (Список рассылки + пользователь кто внес запись). Список рассылки довольно статичен, а вот пользователей человек 40 плюс ко всему они довольно часто меняются. Поэтому возникла идея брать e-mail пользователя из Active Directory (благо e-mail всегда заполняется системщиками).

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

Забыл сказать известны домены и логин пользователя ( не известно какой organisation union (группа в AD) является родительским для пользователя и т. п., ну в общем основной проблемой было получить ADsPath пользователя) 

Код

uses ActiveDs_TLB, adshlp;

....

var
  str1: string;
  search: IDirectorySearch;
  p : array[0..0] of PWideChar;
  opt : array[0..0] of ads_searchpref_info;  //структура для поиска в AD
                                             //(все поля в MSDN)
  hr : HRESULT;
  dwErr : DWord;
  szErr : array[0..255] of WideCHar;
  szName : array[0..255] of WideChar;
  ptrResult : THandle;
  col : ads_search_column;
  usr : IAdsUser;
begin
//Используем Active Directory

    try
      AdsGetObject('LDAP://DC=sss,DC=ru', IDirectorySearch, search); //создаем объект поиска
    except on E : Exception do
      ShowMessage(E.Message+' Соединение С Активной Директорией нет!');
    end;

    try
      p[0] := StringToOleStr('ADsPath'); //что ищем (путь к юзеру) 'LDAP://DC=sss,DC=ru...'
      opt[0].dwSearchPref := ADS_SEARCHPREF_SEARCH_SCOPE; //область поиска
      opt[0].vValue.dwType := ADSTYPE_INTEGER; //для ADS_SEARCHPREF_SEARCH_SCOPE должно быть ADSTYPE_INTEGER
      opt[0].vValue.Integer := ADS_SCOPE_SUBTREE;// поиск по всему дереву
      hr := search.SetSearchPreference(@opt[0],1);  //устанавливаем параметры
      if (hr <> 0) then
      begin
        hr := ADsGetLastError(dwErr, @szErr[0], 254, @szName[0], 254);
        ShowMessage(WideCharToString(szErr));
        Exit;
      end;
      hr := search.ExecuteSearch('(&(objectCategory=user)(samAccountName='+UserName+'))',@p[0], 1, ptrResult);
            //запускаем поиск с условием (Category = User) и samAccountName = UserName просто Login без домена
            //hr := search.GetNextRow(ptrResult);
      while (hr <> S_ADS_NOMORE_ROWS) do
      begin
        hr := search.GetColumn(ptrResult, p[0],col);
        if Succeeded(hr) then
        begin
          if col.pADsValues <> nil
          then str1 := col.pAdsvalues^.CaseIgnoreString; //получаем результаты поиска
          search.FreeColumn(col);
        end;
        Hr := search.GetNextRow(ptrResult);
      end;
      except on E : Exception do
        ShowMessage(E.Message+' Работа с Active Directory не завершенa!');
      end;

      try
        ADsGetObject(str1, IADsUser, usr);  //по найденому ADsPath создаем интерфейс пользователя
      except on E : Exception do
        ShowMessage(E.Message+' Пользователь не найден!');
      end;

      IdMessage1.Recipients.Add.Text:= usr.EmailAddress;
      //Конец использования Active Directory
end;




+ файл с примерами (не помню откуда скачал). В директории common 2 uses'а которые использовались в коде


Это сообщение отредактировал(а) AlexxxM - 23.5.2007, 18:52

Присоединённый файл ( Кол-во скачиваний: 79 )
Присоединённый файл  AdsCode.zip 101,72 Kb
PM MAIL   Вверх
Akella
Дата 13.7.2007, 07:58 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329



Rodman нашел примеры работы TreeView с XML
Код

procedure Tree2XML(tree: TTreeView);
var
  tn : TTreeNode;
  XMLDoc : TXMLDocument;
  iNode : IXMLNode;

  procedure ProcessTreeItem(
        tn    : TTreeNode; 
        iNode : IXMLNode);
  var
    cNode : IXMLNode;
  begin
    if (tn = nil) then Exit;
    cNode := iNode.AddChild('item');
    cNode.Attributes['text'] := tn.Text;
    cNode.Attributes['imageIndex'] := tn.ImageIndex;
    cNode.Attributes['stateIndex'] := tn.StateIndex;

    //child nodes
    tn := tn.getFirstChild;
    while tn <> nil do
    begin
      ProcessTreeItem(tn, cNode);
      tn := tn.getNextSibling;
    end;
  end; (*ProcessTreeItem*)
begin
  XMLDoc := TXMLDocument.Create(nil);
  XMLDoc.Active := True;
  iNode := XMLDoc.AddChild('tree2xml');
  iNode.Attributes['app'] := ParamStr(0);

  tn := tree.TopItem;
  while tn <> nil do
  begin
    ProcessTreeItem (tn, iNode);

    tn := tn.getNextSibling;
  end;

  XMLDoc.SaveToFile(ChangeFileExt(ParamStr(0),'.XML'));

  XMLDoc := nil;
end; (* Tree2XML *)


Код

procedure XML2Tree(
          tree   : TTreeView; 
          XMLDoc : TXMLDocument);
var
  iNode : IXMLNode;

  procedure ProcessNode(
        Node : IXMLNode; 
        tn   : TTreeNode);
  var
    cNode : IXMLNode;
  begin
    if Node = nil then Exit;
    with Node do
    begin
      tn := tree.Items.AddChild(tn, Attributes['text']);
      tn.ImageIndex := Integer(Attributes['imageIndex']);
      tn.StateIndex := Integer(Attributes['stateIndex']);
    end;


    cNode := Node.ChildNodes.First;
    while cNode <> nil do
    begin
      ProcessNode(cNode, tn);
      cNode := cNode.NextSibling;
    end;
  end; (*ProcessNode*)
begin
  tree.Items.Clear;
  XMLDoc.FileName := ChangeFileExt(ParamStr(0),'.XML');
  XMLDoc.Active := True;

  iNode := XMLDoc.DocumentElement.ChildNodes.First;

  while iNode <> nil do
  begin
    ProcessNode(iNode,nil);
    iNode := iNode.NextSibling;
  end;

  XMLDoc.Active := False;
end;

PM MAIL   Вверх
Rodman
Дата 13.7.2007, 13:10 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


CIO
****


Профиль
Группа: Участник
Сообщений: 6144
Регистрация: 7.5.2006
Где: Ukraine ⇛ Kyiv ci ty

Репутация: 7
Всего: 122



XML формируется по всем открытым пунктам! Так чт разворачивайте, если надо!
PM MAIL WWW Skype GTalk YIM MSN   Вверх
ne0n
Дата 14.8.2007, 22:28 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


PlayBoy
**


Профиль
Группа: Участник
Сообщений: 733
Регистрация: 5.8.2005
Где: Н.Новгород

Репутация: 1
Всего: 11



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

Присоединённый файл ( Кол-во скачиваний: 95 )
Присоединённый файл  my_article.rar 106,80 Kb
PM MAIL ICQ   Вверх
RA
Дата 16.8.2007, 14:43 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Брутальный буратина
****


Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 14
Всего: 115



Вот случайно где-то нашёл такой хороший компонент с примером использования 

Reader for ОS/2, NЕ, PE32, PE32+ and VxD executable file types.


Цитата

enumerated structures that are evaluated:
    * DOS, Filе, Optional and CLR headers
    * CLR Mеtadata streams
    * Sections
    * Directories
    * Imports
    * Exports
    * Resources
    * .NET Metadata
    * Load Config
    * Debug
    * Thrеad Local Storage
    * Exceptions
    * Units smile 
    * Forms
    * Packages
    * Classes
    * Flags
    * Version Info


Добавил
+ FileMode = 0

Это сообщение отредактировал(а) RA - 19.8.2007, 23:04

Присоединённый файл ( Кол-во скачиваний: 100 )
Присоединённый файл  Demo.7z 26,92 Kb
PM   Вверх
ne0n
Дата 17.8.2007, 11:27 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


PlayBoy
**


Профиль
Группа: Участник
Сообщений: 733
Регистрация: 5.8.2005
Где: Н.Новгород

Репутация: 1
Всего: 11



В последнее время участился интерес к упаковщикам и протекторам...вот собрал колекцию  исходников,собранную по всему нету, на данную тему smile там болешь 15 исходнтков пакерров(крипторов), ну и соответствующие искодники, которые пригодяться при написании своего собственного пакера\криптора\протектора(даже включил исходники некоторых автоматических распаковщиков) Думаю комунибудь то да прикодиться smile 

http://rapidshare.com/files/49501095/Packe...Sourse.rar.html


з.ы. архив весит чуть более десяти метров...

Это сообщение отредактировал(а) ne0n - 17.8.2007, 15:19
PM MAIL ICQ   Вверх
EvilsInterrupt
Дата 19.8.2007, 20:59 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Executables research
***


Профиль
Группа: Завсегдатай
Сообщений: 1019
Регистрация: 14.7.2007
Где: Железнодорожный, МО, Россия

Репутация: 3
Всего: 9



RA, Держи файл для проверки на котором твой компонент не верно ф-ционирует ))) проверка шла согласно данным от PE_Tools by Neox

Присоединённый файл ( Кол-во скачиваний: 37 )
Присоединённый файл  file.7z 0,48 Kb
PM MAIL WWW ICQ Jabber   Вверх
Rrader
  Дата 15.9.2007, 14:59 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Inspired =)
***


Профиль
Группа: Экс. модератор
Сообщений: 1535
Регистрация: 7.5.2005

Репутация: 70
Всего: 191



Open Directory Dialog 1.2 by Rrader, Alix

Разработан был давно, но не выкладывался smile 

Позволяет изменять стандартный диалог SHBrowseForFolder



Присоединённый файл ( Кол-во скачиваний: 72 )
Присоединённый файл  ODD_1.2.zip 13,46 Kb


--------------------
Let's do this quickly!
Rest in peace, Vit!
PM MAIL Skype   Вверх
Alix
Дата 24.9.2007, 18:37 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


L45
**


Профиль
Группа: Участник
Сообщений: 581
Регистрация: 4.5.2005
Где: Pskov/Spb

Репутация: 7
Всего: 23



Несколько давно написанных юнитов, возможно кому-то будет интересно. Возможно что-то я бы сейчас написал по другому... а может и нет ) Так что не пинать если что.

CDDrives.pas - возвращает буквы всех установленных CD-ROM'ов
ClipBoard.pas - модуль для работы с буфером обмена, всего пара функций - GetText и SetText. Перед началом работы надо проинициализировать. Использует только модуль windows, так что не увеличивает размер программы.
IniFilesLight.pas - класс TIniFilesLite для работы с ini-файлами. Умеет почти то же, что и TIniFiles (read/write string/integer/bool + updatefile (aka flush)). Использует только windows. Ну еще SysUtils, но если надо, можно легко избавиться.
TrayIcon.pas - простенький класс создающий иконку в трее (TNotifyIconData_50), поддерживает balloon tooltips и анимацию (не помню точно как, вроде by showNextFrame method). Обработка сообщений осуществляется создавшим иконку окном, т.к. она не содержит своего обработчика. Использует windows, messages, shellAPI, graphics {for TBitmap only}, sysUtils {for strPCopy only}.
PopupMenu.pas - Класс для создания popupmenu, поддерживает только appendMenuItem, popup, cursorPopUp. Можно задавать шрифт элементов, понимает разделители. НО не имеет своего кода отрисовки. Использует windows, messages, sysutils.
battery.dpr - программа, ради которой и писались два последних модуля. Индикатор заряда батарей в качестве замены стандартному виндовскому. Написан на winapi, заодно есть и пример работы с GDI при отрисовке элементов popup menu (в стиле типа MSO XP). Если хотите - доделывайте, но и сейчас неплохо работает ). Bitmaps.res прилагается. Использовано: windows, messages, shellAPI, graphics, sysUtils, TrayIcon, 'PopupMenu.pas'. Праверять, конечно, надо на ноуте )

Есть вопросы? You are welcome!

PS: сейчас почитал топик, привет, Rrader! У тебя точно такой же код для чтения ini файлов, прям один в один smile 

Это сообщение отредактировал(а) Alix - 24.9.2007, 21:39

Присоединённый файл ( Кол-во скачиваний: 74 )
Присоединённый файл  lix_units.rar 8,37 Kb


--------------------
Знание только тогда знание, когда оно приобретено усилиями своей мысли, а не памятью (с) Л. Толстой
High tech. Low live. (с) Gardner Dozois
PM MAIL ICQ Skype   Вверх
lukas
Дата 13.11.2007, 19:18 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 771
Регистрация: 23.2.2007

Репутация: 3
Всего: 15



давно никак не доходили руки написать объект копирующий компоненты, можно копировать компоненты с одной формы на другую сохраняя все свойства, единственное у копий нет имен, поэтому имена нужно дать после копирования. NetSize - отвечает за смещение объекта при копировании,

Метод AddObjFrom добавляет компоненты (названия которых находятся в LIST с формы FRM) в буфер 
Метод LoadObjTo выгружает объекты в буфере на форму FRM со смещение NetSize

P.S. Все классы копируемых объектов должны быть зарегистрированы, делаем это так: RegisterClass(TButton) и т.п.


Код

unit MSBCopyer;

interface

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

type
  TObjCopyer = class

public
    OBJList:TList; // указатели на MemoryStream - объектов
    OBJClass:TStrings; // название классов
    OBJCaption:TStrings; // заголовки объектов
    constructor Create;
    destructor Destroy;
    procedure AddObjFrom(FRM:TForm; LIST:TStrings);
    procedure LoadObjTo(FRM:TForm; NetSize:Integer = 5);
  end;

implementation


constructor TObjCopyer.Create;
begin
OBJList:=TList.Create;
OBJClass:=TStringList.Create;
OBJCaption:=TStringList.Create;
end;

destructor TObjCopyer.Destroy;
begin
OBJList.Free; OBJClass.Free;  OBJCaption.Free;
end;

procedure TObjCopyer.AddObjFrom(FRM:TForm; LIST:TStrings);
   Var
   MEM:TMemoryStream;
   i:integer;
   s:string;
   TMP:TComponent;
begin
OBJList.Clear; OBJClass.Clear; OBJCaption.Clear;
  for i:=0 to LIST.Count-1 do
   begin
    TMP:=FRM.FindComponent(LIST[I]);
    if TMP=nil then continue;
     MEM:=TMemoryStream.Create;
     TMP.Name:='';
     MEM.WriteComponent(TMP);
     MEM.Position:=0;
     TMP.Name:=LIST[I];
     OBJList.Add(MEM);
     OBJClass.Add(TMP.ClassName);
     if GetPropInfo(TMP,'Caption')<>nil then
     OBJCaption.Add(GetPropValue(TMP,'Caption'))
     else if GetPropInfo(TMP,'Text')<>nil then
     OBJCaption.Add(GetPropValue(TMP,'Text')) else
     OBJCaption.Add('');
   end;
end;

procedure TObjCopyer.LoadObjTo(FRM:TForm; NetSize:Integer = 5);
  Var
  I:Integer;
  MEM:TMemoryStream;
  ComponentClass:TComponentClass;
  Component:TComponent;
  TMP:TComponent;
begin
  for i:=0 to OBJList.Count-1 do
   begin
     ComponentClass:=TComponentClass(GetClass(OBJClass[i]));
     Component:=ComponentClass.Create(FRM);
     IF Component is TControl then
     begin
      TControl(Component).Parent:=FRM;
      TControl(Component).SetTextBuf(PChar(OBJCaption[i]));
     end;
     MEM:=TMemoryStream(OBJList[i]);
     MEM.ReadComponent(Component);
       IF Component is TControl then
       begin
        TControl(Component).Left:=TControl(Component).Left+NetSize;
        TControl(Component).Top:=TControl(Component).Top+NetSize;
       end;
   end;
end;

end.


Это сообщение отредактировал(а) lukas - 13.11.2007, 19:22


--------------------
http://code.google.com/p/orionphp/ - opensource скриптовой язык Orion (аналог PHP) для freepascal/delphi.
PM MAIL WWW   Вверх
san46
Дата 29.12.2007, 11:04 (ссылка) |    (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 15
Регистрация: 30.11.2006

Репутация: нет
Всего: нет



Компонент для Delphi. Вывод линейных графиков.

Возможности:
- Кривых на графике может быть более одной (кривые выводятся только в run-time заполнением массивов значений точек).
- Автомасштабирование. При добавлении точек в кривую и выходе их значений за установленные максимум или минимум по обеим осям происходит пересчет максимальных и/или минимальных значений.
- Ручное масштабирование графика мышкой или с клавиатуры (после формирования всех кривых).
- Панорамирование графика при масштабе > 100% - сдвиг по всем четырем направлениям также мышкой или с клавиатуры.
- "Датализация" точек - два режима отображения кривых.
- Отображение значений точек в виде хинта при нахождении курсора мыши около точки.
- Наличие "навигатора" - отдельное полупрозрачное окно (площадь 1/16 от площади компонента), отображающее весь график и которое можно таскать мышкой по экрану.
- Можно изменять: цвет компонента, цвет кривых, цвет осей, видимость сетки графика.

Компонент ведет себя весьма прилично - при перерисовке (а это может происходить очень часто, например, при панорамировании, добавлении точек) график не дергается.

Пригодится для тех (ИМХО), кто не хочет связываться с TChart с его непомерно обширными настройками, кому достаточно отображать линейные графики (кривые).

Страница компонента. Там можно посмотреть скриншоты, детальное описание и скачать исходники компонента с примером.

PM MAIL   Вверх
EvilsInterrupt
Дата 2.3.2008, 15:37 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Executables research
***


Профиль
Группа: Завсегдатай
Сообщений: 1019
Регистрация: 14.7.2007
Где: Железнодорожный, МО, Россия

Репутация: 3
Всего: 9



Возникла задача написать приложение, которое расширяет свои возможности за счет использования подключенных плагинов. Логично положить, что плагины можно подключить на этапе запуска приложения или на этапе обнаружения новых плагинов в то время как основное приложение уже работает. Мне как раз понадобился механизм, который будет в доп. потоке обнаруживать новые плагины и будет своего рода шпионом за папкой с плагинами.

Цель класса: Ожидать добавления в папку с плагинами добавления новых плагинов и при наступлении этого  события дернуть CALLBACK ф-цию или в простонародье "ивент" ;)

Присоединённый файл ( Кол-во скачиваний: 74 )
Присоединённый файл  u_TPluginChangeNotification.pas 4,72 Kb
PM MAIL WWW ICQ Jabber   Вверх
Doga
Дата 6.3.2008, 21:23 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 115
Регистрация: 20.12.2007
Где: Россия, Обнинск

Репутация: нет
Всего: нет



Всем привет.

user posted image

TRGrid это чистый VCL-компонент, является наследником базового класса TCustomControl. При разработке использовались исходные коды классов TCustomGrid и TRxDrawGrid (RxLib). По своей сути TRGrid можно назвать виртуальным, он ничего не знает о данных, которыми он управляет. Всю необходимую информацию для их отображения он получает от приложения с помощью событий. В отличие от компонентов аналогичного типа TRGrid имеет следующие особенности:
    
    1. Умеет создавать объединения  ячеек в виде прямоугольника  как в области фиксированных, так и в области не фиксированных ячеек. Единственное ограничение: объединённая ячейка должна распологаться только в одной из областей и не может распологаться сразу в двух областях (фиксированных и не фиксированных ячеек).    

    2. Имеет возможность скрывать и показывать колонки и строки в любом порядке, без переинициализации данных.
    
    3. Имеет три режима маркировки данных: по колонкам, по строкам и по ячейкам. Маркировка может производиться в любом порядке и не сбрасывается при перемещении курсора с ячейки на ячейку. Одновременно можно использовать только один из трёх режимов маркировки.

    4. Для каждого из состояний ячейки (активная ячейка, ячейка текущей строки/колонки, маркированная ячейка, фиксированная, ...) предусмотрены настраиваемые наборы шрифтов и цветов фона. Так же имеется возможность чередующейся окраски фона строк и (или) колонок.

    5. Умеет отображать картинки как прозрачные, так и не прозрачные в любой из ячеек с требуемой привязкой относительно границ ячейки.

    6. Умеет отображать текст и в многострочном и в обычном режиме (в одну строку) с автоматической заменой не вмещающегося в границы ячейки текста на многоточие ("..."). При этом так же имеется возможность его позиционирования относительно границ ячейки.

    7. Фиксированные ячейки могут исполнять роль кнопок. Для этого предусмотрена анимация нажатия и имеются соответствующие события.

    8. Поддерживается сортировка строк с помощью внешних функций сравнения. При этом возможна сортировка и всех строк и только не фиксированной области строк.

    9. Для хранения разнообразных внешних данных каждая строка, колонка и ячейка предоставляет возможность использования указателей типа void * (pointer). Для своевременной инициализации и очистки данных так же предусмотрены соответствующие события.

    10. Имеется полный набор событий для ручной прорисовки ячеек.

Компонент бесплатный.

Примеры работ с использованием компонента TRGrid:

user posted image

user posted image

user posted image


P.S Компонент TRGrid обновлён до версии 1.20. Текущая сборка содержит исходники компонента и примера.
А также, полный хелп на русском языке в формате HLP и CHM.




Это сообщение отредактировал(а) Doga - 15.5.2015, 10:53

Присоединённый файл ( Кол-во скачиваний: 184 )
Присоединённый файл  RvaLib.zip 723,89 Kb
PM MAIL WWW   Вверх
KgCoder
Дата 15.4.2008, 12:22 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 93
Регистрация: 6.3.2008
Где: KGstan

Репутация: нет
Всего: нет



Цитата(Dr Smth @ 28.10.2004,  14:36)
При составлении программ часто возникает ситуация, когда нужно что-нибудь подсчитать, и вывести результат в виде: ЧИСЛО + СЛОВО. Причём СЛОВО обозначает то, что, собственно, и нужно подсчитать. Например, нужно вывести число строк в списке TListBox в формате: 'N слов'. Благодаря особенностям великого и могучего русского языка и тому, что число N заранее неизвестно, может меняться и вычисляется самой программой, заранее также неясно в каком падеже нужно ставить следующее за числом слово.

Если плюнуть на это и написать просто: N + ' слово', то при расчётах получим малограмотные конструкции типа '17 слово' и '3 слово'.

Между тем избавиться от данной ситуации довольно просто. Я тут поразмыслил, и написал функцию, выбирающую из трёх падежей нужный. Возможно не самый оптимальный вариант, но всё же... Для более детального ознакомления смотрите комментарии в коде.

Код
program FndCase;

{$APPTYPE CONSOLE}

uses
  SysUtils;


{Функция возвращает строку, содержащую введённое число плюс введённое сцуществительное
 в падеже, согдасующимся с этим числом (порядковым числительным)

 Передаваемые параметры:

  i : Integer - целое число, представляющее нужное порядковое числительное;
  e_ip : String - именительный пажед единственного числа вводимого существительного
                  (кто? что?);
  e_rp : String - родительный падеж единственного числа вводимого существительного
                  (кого? чего?);
  mn_rp : String - родительный падеж множественного числа вводимого существительного
                  (кого? чего?);

 Результатом является выбор между этих трёх вариантов в соответствии с порядковым
 числительным}

function ChooseCase (i : Integer; e_ip, e_rp, mn_rp: String): String;
  var
    end_w : Integer;
  begin
    end_w := StrToInt(Copy(IntToStr(i), Length(IntToStr(i)) - 1, 2));
     if (end_w > 10) and (end_w < 20)
      then
        begin
         Result := IntToStr(i) + ' ' + mn_rp;
        end
      else
        begin
         end_w := StrToInt(Copy(IntToStr(end_w), Length(IntToStr(end_w)), 1));
         case end_w of
         0 : Result := IntToStr(i) + ' ' + mn_rp;
         1 : Result := IntToStr(i) + ' ' + e_ip;
         2..4 : Result := IntToStr(i) + ' ' + e_rp;
         5..9 : Result := IntToStr(i) + ' ' + mn_rp;
         end;
        end;
  end;

begin

  //Несколько примеров
  
  Randomize;
  WriteLn(ChooseCase(Random(1000), 'slovo', 'slova', 'slov'));
  WriteLn(ChooseCase(Random(1000), 'bukva', 'bukvy', 'bukv'));
  WriteLn(ChooseCase(Random(1000), 'programmist', 'programmista', 'programmistov'));
  WriteLn(ChooseCase(Random(1000), 'Andrey', 'Andreya', 'Andreev'));
  WriteLn(ChooseCase(Random(1000), 'Svetlana', 'Svetlany', 'Svetlan'));
  WriteLn(ChooseCase(Random(6000000000), 'chelovek', 'cheloveka', 'chelovek'));
  ReadLn;
end.

Короче и красивее:

Код

function padej(i:integer;a,b,c:string):string;
var
  t:integer;
begin
  if t>20 then while t>10 do t:=t-10; //Доводим до нужной кондиции
  case t of
    1: result:=IntToStr(i)+' '+a; // - именительный пажед единственного числа (кто? что?);
    2..4: result:=IntToStr(i)+' '+b; // - родительный падеж единственного числа (кого? чего?);
    0,5..20: result:=IntToStr(i)+' '+c; // - родительный падеж множественного числа (кого? чего?);
  end;
end;


Это сообщение отредактировал(а) KgCoder - 15.4.2008, 13:09
PM MAIL   Вверх
RA
Дата 1.6.2008, 13:38 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Брутальный буратина
****


Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 14
Всего: 115



Полноценный редактор ресурсов

user posted image



бинарник
http://www.btinternet.com/~wilsoncpw/xnresourceeditor.zip
сорс
http://www.btinternet.com/~wilsoncpw/xn_re...itor_source.zip


Допы тут:
http://www.wilsonc.demon.co.uk/files/d10/

Это сообщение отредактировал(а) RA - 17.6.2008, 13:27

Присоединённый файл ( Кол-во скачиваний: 67 )
Присоединённый файл  xn_resourceeditor_source.zip 184,17 Kb
PM   Вверх
Beltar
Дата 7.6.2008, 10:46 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 627
Регистрация: 11.1.2006

Репутация: 3
Всего: 7



2 RA

Доп компоненты не устанавливаются. Требует пакет LowLevel100.


--------------------
Опытный программист на C++ легко решает любые не существующие в Паскале проблемы. smile(с) я, хотя может и нет
Пищущий на C++ мужик. Даже если это мужик сидит в написанном на Delphi и жрущем паскалевскую библиотеку билдере.
PM MAIL   Вверх
Bose
Дата 11.9.2008, 13:42 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Участник Клуба
Сообщений: 1458
Регистрация: 5.3.2005
Где: Riga, Latvia

Репутация: 23
Всего: 51



Я тут пытался разобраться, как получить список всех resourcestrings в программе. Этот вопрос неоднократно поднимался на разных форумах, но полное решение нигде не приводилось. Как оказалось, готовое решение всё же есть, и в довольно неожиданном для меня месте. В Program Files\Borland\Delphi6\Demos\ResXplor. =) Я лишь собрал все необходимые классы и типы в одном модуле. 

Модуль экспортирует одну функцию scCollectResourceStrings:

Код

    procedure scCollectResourceStrings( aExeFilename: string; aPerformForEveryFoundString: TscOnGetResString);


у этой функции два параметра:
1) aExeFilename: string - путь до файла с ресурсами
2) aPerformForEveryFoundString: TscOnGetResString - callback фунция, вызываемая для каждого найденного ресурса строкового типа.

Код

    TscOnGetResString = procedure (aText, aData: string) of object;


У callback функции два параметра:
aText - resourcestring
aData - представляет из себя строку формата: "ID ресурса = текст ресурса".

aText и aData формируются в процедуре TStringResource.ForEveryString. Так что их формат легко изменить, подправив пару строк кода.

Присоединённый файл ( Кол-во скачиваний: 34 )
Присоединённый файл  scTranslatorResParser.zip 4,69 Kb
PM MAIL WWW Skype   Вверх
RA
Дата 11.9.2008, 17:39 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Брутальный буратина
****


Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 14
Всего: 115



Цитата(Beltar @  7.6.2008,  10:46 Найти цитируемый пост)
Доп компоненты не устанавливаются. Требует пакет LowLevel100. 


Ну и в чемё проблема
http://www.wilsonc.demon.co.uk/files/d10/ -> NTLowLevel100.zip    
PM   Вверх
CHERRY
Дата 9.10.2008, 11:49 (ссылка) |    (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Прохожий
*


Профиль
Группа: Участник
Сообщений: 150
Регистрация: 17.6.2002
Где: Одесса

Репутация: нет
Всего: -2



Эта прога может читать файлы MS Word и отображать их в Мемо или RichEdit.
Тестировалась на Word-ах от Office 97 до 2003
Код

unit WordToText;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    BitBtn1: TBitBtn;
    procedure BitBtn1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

Const
 rus_big='АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ';
rus_small='абвгдежзийклмнопрстуфхцчшщъыьэюя';

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.BitBtn1Click(Sender: TObject);
Var fDoc:File;  f:TextFile;
BChar: array[1..100000] of Char;
NumRead,i,j,k,n,fSize,Ch12Size,StartDoc,EndDoc:LongInt;
ss:AnsiString;
fName:String;
Ch,Ch1,Ch2:Array of Char;

//Определим начало тела файла
function detect_start:Integer;
Var i:Integer;
Begin
 i:=-1;
 While i<=Ch12Size-1 Do
 Begin
  INC(i);
  if (Ord(Ch1[i])=$20)and(Ord(Ch2[i])=$00) Then
  Begin
   if (Ord(Ch2[i+1])<>$00)and(Ord(Ch2[i+1])<>$04) Then continue;
   if (Ord(Ch2[i-1])<>$00)and(Ord(Ch2[i-1])<>$04) Then continue;
   if (Ord(Ch2[i-1])= $00)and(Ord(Ch1[i-1])= $00) Then continue;
   While(Ord(Ch1[i])+Ord(Ch2[i])<>$0)and((Ord(Ch2[i])=$0)or(Ord(Ch2[i])=$4)) Do DEC(i);

   If (Ord(Ch1[i])=$FF)and(Ord(Ch2[i])=$FF) Then
   Begin
    Result:=Ch12Size;
    Break;
   End;

   INC(i);
   Result:=i;
   Break
  End;
 End;
End;

//Определим конец тела файла
function detect_end:Integer;
Var sz,nullcount,ffcount:Integer;
Begin
 sz:=Ch12Size; i:=StartDoc;//i должно равняться StartDoc
 While i<=sz Do
 Begin
  INC(i);
    nullcount:=0;
    ffcount:=0;
  while (Ord(Ch1[i])=$00)and(Ord(Ch2[i])=$00) do
  Begin
   INC(nullcount); INC(i); if(i>=sz) Then break;
  End;
  while (Ord(Ch1[i])=$FF)and(Ord(Ch2[i])=$FF) do
  Begin
   INC(ffcount); INC(i); if(i>=sz) Then break;
  End;
    if nullcount>300 Then Begin Result:=(i-nullcount); EXIT End;
    if ffcount>10 Then Begin Result:=(i-ffcount);  EXIT End;
 End;
End;

//Начало
BEGIN
  with TOpenDialog.Create(nil) do
   try
    Filter := 'word documents (*.doc)|*.doc';
    if not Execute then Exit;
    fName := FileName;
   finally
   Free;
   end;

 AssignFile(fDoc, fName);
 Reset(fDoc, 1);
 fSize:=FileSize(fDoc);
 SetLength(Ch,fSize);
 SetLength(Ch1,fSize div 2);
 SetLength(Ch2,fSize div 2);

 i:=0;k:=0;n:=0;

 //Читаем файл в массив по 100 KBt
 While i<fSize Do
 Begin
  BlockRead(fDoc, BChar, SizeOf(BChar), NumRead);
  i:=i+NumRead;
  For j:=1 To NumRead Do
  Begin
   Ch[k]:=BChar[j];
   //делим массив на первый и второй байты в символьном виде
   //если "к" четное то
   if (k mod 2)=0 Then Ch1[n]:=Ch[k]//массив первых байтов
   Else   //если "к" нечетное то
   Begin
    Ch2[n]:=Ch[k];//массив вторых байтов
    INC(n);
   End;
   INC(k);
  End;
 End;
 CloseFile(fDoc);

 Ch12Size:=High(Ch1);

 StartDoc:= detect_start;//ориентировочно начало текста документа
 EndDoc  := detect_end;  //ориентировочно конец текста документа
 ss:=''; //сюда будем записывать текст

 fORM1.Caption:='Старт='+IntToStr(StartDoc*2)+'    Финиш='+IntToStr(EndDoc*2);
 
 //Главный цикл по тексту документа
 For i:=StartDoc to EndDoc Do
 Begin

  if Ord(Ch2[i])=$00 Then
  Begin
    //первая половина таблицы - латиница, цифры и знаки
    If Ord(Ch1[i])=$0D Then ss:=ss+#13;
    If (Ord(Ch1[i])>=$20)and(Ord(Ch1[i])<=$7F) Then ss:=ss+Ch1[i];
  End;

  if Ord(Ch2[i])=$04 then
  Begin
    //русские буквы
    If (Ord(Ch1[i])>=$10)and(Ord(Ch1[i])<=$2F) Then ss:=ss+rus_big  [Ord(Ch1[i])-$10+1];
    if (Ord(Ch1[i])>=$30)and(Ord(Ch1[i])<=$4F) Then ss:=ss+rus_small[Ord(Ch1[i])-$30+1];
    if (Ord(Ch1[i])=$01) Then ss:=ss+'Ё';
    if (Ord(Ch1[i])=$51) Then ss:=ss+'ё';
    //украинские буквы
    if (Ord(Ch1[i])=$54) Then ss:=ss+'є';
    if (Ord(Ch1[i])=$04) Then ss:=ss+'Є';
    if (Ord(Ch1[i])=$56) Then ss:=ss+'і';
    if (Ord(Ch1[i])=$06) Then ss:=ss+'І';
    if (Ord(Ch1[i])=$57) Then ss:=ss+'ї';
    if (Ord(Ch1[i])=$07) Then ss:=ss+'Ї';
  End;
    //Символы
  if Ord(Ch2[i])=$20 then
  Begin
    if (Ord(Ch1[i])>=$14) Then ss:=ss+' - ';//тире;
    if (Ord(Ch1[i])>=$1C) Then ss:=ss+'"';  //открыв. кавычка;
    if (Ord(Ch1[i])>=$1D) Then ss:=ss+'"';  //закрыв. кавычка;
  End;
 End;//For i:=StartDoc to EndDoc

   AssignFile(f,'out.txt');
   ReWrite(f);
   WriteLn(f,ss);
   CloseFile(f);

   Memo1.Lines.Text:=SS;
 end;
end.


--------------------
Трясу надежды ветвь, но где желанный плод?
PM MAIL WWW   Вверх
san46
Дата 13.11.2008, 09:38 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 15
Регистрация: 30.11.2006

Репутация: нет
Всего: нет



Комплексная программа для разработки баз данных различного назначения.

Когда перед программистом, работающим с Delphi, встает задача сделать серьезную базу данных, то выбор у него невелик, особенно, 
если речь идет о бесплатных инструментах и бесплатных СУБД. 
Firebird и IBX (закладка "Intrbase" в палитре компонентов Delphi) вот, пожалуй, и весь выбор.
Для тех, кто в разработку баз данных не ввязывался, конечно, могут все начать с нуля, но предлагаю обратить внимание на эту программу.

"Комплексность" предлагаемой программы заключается в том, что разработчик базы данных (назовем это проектом) и пользователь проекта действуют в одной среде - все взаимосвязано.
Программа сделана на Delphi, в роли СУБД выступает Firebird. 
Разработка предлагаемой программы началась в 2002 году и до сегодняшнего дня поддерживается.

Некоторые возможности программы: 
  (далее термин Справочник - эквивалент термина Таблица, который используется в большинстве СУБД).
- Создание справочников любой структуры. 
  Для ввода табличных данных можно создавать элементы структуры типа "таблица".
  Все или часть структурных элементов разработчик размещает на форме ввода, 
  в которые пользователь будет вводить данные. 
  Объекты связанные с элементами типа "таблица" отображаются на форме для ввода данных именно как таблица.
  К объектам ввода можно "привязывать" функции для обработки вводимых данных. 
  Все это несколько напоминает работу в Delphi.
- Логические связи справочников и их данных.
  Понятие это расплывчато и, если конкретные логические связи зависят от задачи, то для примера, под этим можно понимать и ссылочную целостность данных, 
  и возможность создания записей одного справочника из другого, и что-то еще - все зависит от целей проекта базы данных.
- Изменения проекта разработчиком может происходить "на лету", т.е. в период эксплуатации уже готового проекта разработчиком могут вноситься изменения любого рода.
- В справочниках можно разрабатывать отчеты различного вида, в т.ч. и табличного для печати.
  Есть и специальные отчеты-справочники, которые не хранят данные в базе, а требуются только для того чтобы
  собирать информацию из базы и формировать отчеты (печатные формы).
- Есть экспорт данных в наиболее популярные приложения (MS Office и OpenOffice).
- Ограничение доступа пользователей к определенной разработчиком группе справочников.
- Возможно задействовать иерархическую модель справочников - справочники могут быть вложенными один в другой с любой степенью вложенности 
  (характеристики "родительского" справочника могут наследоваться полностью или частично).
- Встроенный язык программирования с более чем 140 встроенных функций, оптимизированных по скорости выполнения.
- Библиотека функций разработчика проекта, где он может писать свои функции, доступные из любого места проекта.
- Работа с плагинами (DLL) и DBF файлами. 

И еще много чего есть в этой разработке.
Работа "комплекса" происходит через локальную сеть. 
Возможна работа через интернет с помощью VPN или ZeBeDee без каких либо переделок. 

Для ознакомления можно скачать однопользовательскую сборку. 
Для ее работы не нужно устанавливать Firebird. Но полноценная работа с проектами и в этом случае гарантируется, 
т.к. управляется база тем же сервером Firebird, но называемым Embedded, который устанавливать не требуется.
Для работы в сети нужна сетевая сборка (также свободна для скачивания).
Проекты разработанные и в однопользовательской и в сетевой сборках одинаковы. Различие только в методе соединения с базами содержащие проекты.

Все это удовольствие БЕСПЛАТНО. Плюс бесплатный Firebird. При необходимости можно использовать и бесплатный OpenOffice.

Ресурс здесь: http://san-46.narod.ru

Это сообщение отредактировал(а) san46 - 13.11.2008, 09:40
PM MAIL   Вверх
Akella
Дата 15.11.2008, 16:30 (ссылка) |    (голосов:1) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329



Пример организации панели кнопок как у 1С в многодокументальном приложении (MDI).

Создание и показ кнопки на панели. Этот код вызывается при создании каждой дочерней формы
Код

procedure TfmMain.CreateFormButton(form1:TForm);
var
  ABar : TdxBar;
  NewButton : TdxBarButton;
  NewItemLink : TdxBarItemLink;
begin
   inc(iButtonsCount);
   ABar := Bar1;
   NewButton := TdxBarButton.Create(self);

   NewItemLink := ABar.ItemLinks.Add;
   NewItemLink.Item := NewButton;
   NewItemLink.Item.Tag := form1.Handle;

   NewButton.Tag          := form1.Handle;
   NewButton.Name         := 'dxButton'+IntToStr(NewButton.Tag);
   NewButton.Caption      := form1.Caption + '[' + IntToStr(iButtonsCount) + ']';
   NewButton.Hint         := form1.Caption;
   NewButton.OnClick      := dxBarButtonClick;
   NewButton.ButtonStyle  := bsChecked;
   NewButton.Down         := true;
   NewButton.PaintStyle   := psCaptionGlyph;
   NewButton.GroupIndex   := 1;
   NewButton.Glyph.Width  := 16;//GetSystemMetrics(SM_CXSMICON);
   NewButton.Glyph.Height := 16;//GetSystemMetrics(SM_CYSMICON);
   NewButton.Glyph.Canvas.Draw(0,0,form1.Icon);
   ABar.Control.RepaintBar;
end;


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

procedure TfmArrival.FormCreate(Sender: TObject);
begin
  fmMain.CreateFormButton(self);
end;

т.е. на каждую форму вешаем код создания кнопки ( fmMain.CreateFormButton(self))



Код удаления кнопки с панели при закрытии формы
Код

procedure TfmMain.DeleteFormButton(form1:TForm);
Var
 i:integer;
begin
  for I := 0 to Bar1.ItemLinks.Count - 1 do
    if Bar1.ItemLinks[i].Item is TdxBarButton then
      if TdxBarButton(Bar1.ItemLinks[i].Item).Tag = form1.Handle then begin
        Bar1.ItemLinks[i].Item.Free;
        Break;
      end;
end;


Пример использования (код цепляем на событие закрытия каждой дочерней формы)
Код

procedure TfmArrival.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  fmMain.DeleteFormButton(self);
  Action    := caFree;
  fmArrival := nil;
end;


Код подсвечивания кнопки активного окна, тоже цепляем на событие активации каждой дочерней формы
Код

procedure TfmMain.SetDownFormButton(form1:TForm);
Var
 i:integer;
begin
  for I := 0 to Bar1.ItemLinks.Count - 1 do
    if Bar1.ItemLinks[i].Item is TdxBarButton then
      if TdxBarButton(Bar1.ItemLinks[i].Item).Tag = form1.Handle then begin
        TdxBarButton(Bar1.ItemLinks[i].Item).Down := false;

      end;

  for I := 0 to Bar1.ItemLinks.Count - 1 do
    if Bar1.ItemLinks[i].Item is TdxBarButton then
      if TdxBarButton(Bar1.ItemLinks[i].Item).Tag = form1.Handle then begin
        TdxBarButton(Bar1.ItemLinks[i].Item).Down := true;
        break;
      end;
end;


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

procedure TfmArrival.FormActivate(Sender: TObject);
begin
  fmMain.SetDownFormButton(self);
end;


В секции private главной формы
Код

  private
    { Private declarations }
    iButtonsCount:integer;
    procedure dxBarButtonClick(Sender: TObject);


Код который будет выполняться при нажатии на кнопку на панели
Код

procedure TfmMain.dxBarButtonClick(Sender: TObject);
var
  lWinControl: TWinControl;
begin
  lWinControl := FindControl((sender as TdxBarButton).Tag);
  if Assigned(lWinControl) and (lWinControl is TForm) then
    TForm(lWinControl).BringToFront;
end;


При создании главной формы
Код

procedure TfmMain.FormCreate(Sender: TObject);
begin
  iButtonsCount := 0;
end;


На главной форме внизу лежит Bar1 типа TdxBar
PM MAIL   Вверх
RA
Дата 19.4.2009, 20:26 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Брутальный буратина
****


Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

Репутация: 14
Всего: 115



Эмулятор наличия запущеной IDE Delphi

Код

//e-mail: [email protected]
//Использование: подключите этот модуль в файл проекта (*.dpr) в секцию uses
unit eml;

interface
uses
  Windows, Messages;

procedure ShutDown;
function WindowProc(hWnd,Msg,wParam,lParam:Longint):Longint; stdcall;
procedure emulator;

var
wClass,wclass2,wclass3,wclass4:   TWndClass;  // class struct for main window
hInst:    HWND;
Msg:      TMSG;       // message struct

implementation

procedure ShutDown;
begin
  UnRegisterClass('TAppBuilder',hInst);
  UnRegisterClass('TApplication',hInst);
  UnRegisterClass('TPropertyInspector',hInst);
  UnRegisterClass('TAlignPalette',hInst);
  ExitProcess(hInst); //end program
end;

function WindowProc(hWnd,Msg,wParam,lParam:Longint):Longint; stdcall;
begin
  Result:=DefWindowProc(hWnd,Msg,wParam,lParam);
end;

procedure emulator;
begin
  hInst:=GetModuleHandle(nil); // get the application instance

  with wClass do
  begin
    Style:=         0;
    hIcon:=         LoadIcon(hInst,'MAINICON');
    lpfnWndProc:=   @WindowProc;
    hInstance:=     hInst;
    hbrBackground:= COLOR_BTNFACE+1;
    lpszClassName:= 'TAppBuilder';
    hCursor:=       LoadCursor(0,IDC_ARROW);
  end;

  with wClass2 do
  begin
    Style:=         0;
    hIcon:=         LoadIcon(hInst,'MAINICON');
    lpfnWndProc:=   @WindowProc;
    hInstance:=     hInst;
    hbrBackground:= COLOR_BTNFACE+1;
    lpszClassName:= 'TApplication';
    hCursor:=       LoadCursor(0,IDC_ARROW);
  end;

  with wClass3 do
  begin
    Style:=         0;
    hIcon:=         LoadIcon(hInst,'MAINICON');
    lpfnWndProc:=   @WindowProc;
    hInstance:=     hInst;
    hbrBackground:= COLOR_BTNFACE+1;
    lpszClassName:= 'TAlignPalette';
    hCursor:=       LoadCursor(0,IDC_ARROW);
  end;

  with wClass4 do
  begin
    Style:=         0;
    hIcon:=         LoadIcon(hInst,'MAINICON');
    lpfnWndProc:=   @WindowProc;
    hInstance:=     hInst;
    hbrBackground:= COLOR_BTNFACE+1;
    lpszClassName:= 'TPropertyInspector';
    hCursor:=       LoadCursor(0,IDC_ARROW);
  end;

  RegisterClass(wClass);
  RegisterClass(wClass2);
  RegisterClass(wClass3);
  RegisterClass(wClass4);

  CreateWindow(
    'TAppBuilder',           // Registered Class Name
    'Delphi',                       // Title of Window
    WS_POPUP,              // Make it Visible
    -1,                      // Left
    -1,                      // Top
    0,                      // Width
    0,                      // Height
    0,                       // Parent Window Handle
    0,                       // Handle of Menu
    hInst,                   // Application Instance
    nil);                    // Structure for Creation Data


   CreateWindow(
    'TApplication',           // Registered Class Name
    'Delphi 2007',                       // Title of Window
    WS_POPUP,              // Make it Visible
    -1,                      // Left
    -1,                      // Top
    0,                      // Width
    0,                      // Height
    0,                       // Parent Window Handle
    0,                       // Handle of Menu
    hInst,                   // Application Instance
    nil);

    CreateWindow(
    'TAlignPalette',           // Registered Class Name
    'Delphi 2007',                       // Title of Window
    WS_POPUP,              // Make it Visible
    -1,                      // Left
    -1,                      // Top
    0,                      // Width
    0,                      // Height
    0,                       // Parent Window Handle
    0,                       // Handle of Menu
    hInst,                   // Application Instance
    nil);

    CreateWindow(
    'TPropertyInspector',           // Registered Class Name
    'Delphi 2007',                       // Title of Window
    WS_POPUP,              // Make it Visible
    -1,                      // Left
    -1,                      // Top
    0,                      // Width
    0,                      // Height
    0,                       // Parent Window Handle
    0,                       // Handle of Menu
    hInst,                   // Application Instance
    nil)
end;

initialization
    emulator
finalization
    shutdown
end.


Присоединённый файл ( Кол-во скачиваний: 33 )
Присоединённый файл  eml.rar 0,98 Kb
PM   Вверх
hkdkest
  Дата 15.6.2009, 00:17 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 300
Регистрация: 30.11.2008

Репутация: нет
Всего: 1



Исходники:

• База данных фильмов FilmsBase
user posted image
Привязка к записи скринщота и видео файла. Воспроизведение происходит средствами программы FilmsBase. Реализован поиск (как в Chetmax) и фильтр по жанрам.


• БД сеть компьютерных магазинов
Задача курсового проекта заключается в создании такой информационной системы, которая включала бы в себя следующие возможности:
1. Добавление, удаление и редактирование информации о магазинах, продавцах, поставщиках, продажах, покупателях, заказах, комплектующих, каталоге. Необходимо предусмотреть для обеспечения наиболее эффективной работы пользователя удаление и редактирование путем непосредственного выбора записи из таблицы.
2. Просмотр информации о магазинах, продавцах, поставщиках, продажах, покупателях, заказах, комплектующих, каталоге.
3. Просмотр и печать информации о проданных товарах, содержащей сведения о покупателе, магазине, количестве и цене конкретного товара.
4. Просмотр и печать информации о комплектующих требуемого компьютера.
5. Осуществление поиска необходимой информации о товарах, магазинах, продавцах, поставщиках, продажах, покупателях, заказах, комплектующих и каталоге.
6. Осуществление операций продажи, заказов, а также, просмотр полного перечня сотрудников, клиентов и поставщиков конкретного магазина, выбор которого осуществляется при запуске клиентского приложения.
7. Возможность перехода из системы текущего магазина в систему необходимого.
8. Возможность входа в систему с разными уровнями доступа к данным: пользовательский (осуществляет только просмотр информации) и администраторский (осуществляет все возможные операции, представленные в системе).
9. Возможность смены пользователя в ходе работы программы.
10. Осуществление контроля введенных данных: проверка на соответствие типов, на ввод обязательных полей данных , а также, на ввод только возможных значений, считываемых из необходимых таблиц.
11. Возможность просмотра информации из таблиц в режиме реального времени.

• Распознавание идентификаторов при лексическом анализе программ
user posted image
 Разработанная программа производит лексический анализ исходного текста программы, написанной на языке программирования Pascal, распознает идентификаторы следующего типа: имена массивов, процедур, функций. 
В языках программирования выделяются следующие основные типы лексем:
• Идентификаторы;
• Служебные слова;
• Целые и вещественные константы;
• Строки;
• Операции;
• Разделители.
В ходе лексического анализа происходит разбиение входной строки символов на лексические единицы и обработка выделенных лексем.
Программа проста в использовании и рассчитана на средний уровень квалификации возможного пользователя.

• Игра "Астероиды"

PM MAIL WWW   Вверх
Yanis
Дата 15.7.2009, 13:46 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
****


Профиль
Группа: Участник Клуба
Сообщений: 2937
Регистрация: 9.2.2004
Где: Москва

Репутация: 72
Всего: 111



Склонение временных единиц соответственно числу.

Согласитесь, довольно криво звучит и выглядит: 1 минут(ы) или 5 года(лет). Понадобилось и я написал функцию, которая определяет какой падеж подставлять к числу n. Вторым параметром в функции идёт размерность единицы: секунды, минуты, час, день, неделя, месяц, год, век. Больше измерений не придумал, но при желании легко добавить. Главное сохранять порядок — по возрастанию.

Код
type
  TUnit = (uSec, uMin, uHour, uDay, uWeek, uMonth, uYear, uAge);
  TCase = (cNominative,       // именительный падеж
           cGenitiveSingular, // родительный падеж ед. ч.
           cGenitivePlural);  // родительный падеж, мн. ч.

function TfrmMain.DeclensionRus(n: Integer; u: TUnit): string;
const
  res_f = '%d %s';
  rus_u: array[0..7] of array[0..2] of string = ((('секунда'), ('секунды'), ('секунд')),
                                                 (('минута'), ('минуты'), ('минут')),
                                                 (('час'), ('часа'), ('часов')),
                                                 (('день'), ('дня'), ('дней')),
                                                 (('неделя'), ('недели'), ('недель')),
                                                 (('месяц'), ('месяца'), ('месяцев')),
                                                 (('год'), ('года'), ('лет')),
                                                 (('век'), ('века'), ('веков')));

var
  c: TCase;
  l, l2: integer;
begin
  Result := '';

  // последняя (l) цифра в числе и две последних (l2) цифры числа
  l := n mod 10; l2 := n mod 100;

  if (l = 1) and (l2 <> 11) then
    c := cNominative
  else
    if ((l = 2) and (l2 <> 12)) or ((l = 3) and (l2 <> 13)) or ((l = 4) and (l2 <> 14)) then
      c := cGenitiveSingular
    else
      c := cGenitivePlural;

  Result := Format(res_f, [n, rus_u[Byte(u)][Byte(c)]]);
end;



--------------------
user posted image *щёлк*
PM MAIL WWW ICQ   Вверх
sbfactory
Дата 19.4.2010, 11:58 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 26
Регистрация: 26.2.2010

Репутация: нет
Всего: нет



Доброго времени суток уважаемые коллеги и просто любители программирования.
Решил выложить 100% рабочую сборку библиотеки GDI+ (с рабочим модулем Direct Draw) Для Delphi 2010 (скачать).
Лучшее описание, которое встречал тут - http://www.rsdn.ru/article/gdi/gdiplus2mag.xml
Если у кого будут вопросы по установке и использованию, могу проконсультировать: ICQ 571-880-051;
С уважением  к вам, Сергей.

Это сообщение отредактировал(а) sbfactory - 19.4.2010, 12:08
PM MAIL   Вверх
SeregaAltmer
Дата 21.9.2010, 14:36 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 13
Регистрация: 15.9.2010

Репутация: нет
Всего: нет



TOptions. Компонент Delphi для удобной работы с опциями.

TOptions - небольшой но мощный инструмент, организующий удобную работу с опциями. Компонент представляет собой удобный, полноценый интерфейс для работы с опциями. Используя его в своих программах вы по максимуму минимизируете свои временные затраты, на разработку модуля по работе с опциями.

Для хранения опций, компонент позволяет использовать: реестр, ini-файлы и оперативную память.

Компонент может самостоятельно взаимодействовать с "контролами настроек" расположенными на форме с опциями.

ссылка на офсайт smile

Это сообщение отредактировал(а) SeregaAltmer - 21.9.2010, 14:36
PM MAIL   Вверх
RomanEEP
Дата 20.9.2011, 16:29 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 424
Регистрация: 18.5.2006
Где: Коломна

Репутация: 5
Всего: 8



Компактный и очень быстрый формат хранения данных. Задуман как замена xml в тех местах, где нужна очень большая скрость чтения/записи.
Использование:
Код

var
  Doc: TXBSDoc;
begin
  Doc := TXBSDoc.Create('Info');
  try
    Doc.WriteString('Name', 'Иван');
    Doc.WriteInteger('Age', 33);
    with Doc.NodeNew('Results') do
    begin
      Str['Title'] := 'КМС';
      Int['Year'] := 2011;
      Int['Place'] := 2;
    end;
    Doc.SaveToFile('Info.dat');
  finally
    Doc.Free;
  end;
end;

Обновил - ускорена работа в целом + уменьшен размер файла засчет спец записи пустых строк и записи целых чисел < 255 как байт

Это сообщение отредактировал(а) RomanEEP - 20.10.2011, 16:54

Присоединённый файл ( Кол-во скачиваний: 37 )
Присоединённый файл  XBSFormat.pas 24,81 Kb
PM MAIL   Вверх
igorsh
Дата 15.12.2011, 12:34 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 17
Регистрация: 20.3.2006

Репутация: нет
Всего: нет



Расширение функциональности компонента TcxLookupComboBox из библиотеки DevExpress. Если у компонента установлено свойство IncrementalFilteringLike, то при наборе текста в выпадающем списке строки фильтруются по вхождению (т.е. применяется оператор LIKE).
Расширение реализовано через "хак" (делалось для Delphi 2007), но в Delphi 2010 это можно сделать законным способом через helpers.

Код юнита:
Код

{
Юнит расширяет функциональные возможности TcxLookupComboBox
}
unit UcxLookupComboBoxExt;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
  Dialogs, DB, cxClasses, cxGraphics, cxControls,
  cxContainer, cxEdit, cxTextEdit, cxMaskEdit, cxDropDownEdit, cxLookupEdit,
  cxDBLookupEdit, cxDBLookupComboBox, cxFilter;

type
  TcxLookupComboBoxProperties = class(cxDBLookupComboBox.TcxLookupComboBoxProperties)
  protected
    class function GetLookupDataClass: TcxInterfacedPersistentClass; override;
  end;
  
  TcxCustomDBLookupEditLookupData = class(cxDBLookupEdit.TcxCustomDBLookupEditLookupData)
  protected
    function Locate(var AText, ATail: string; ANext: Boolean): Boolean; override;
  end;

  TcxLookupComboBox = class(cxDBLookupComboBox.TcxLookupComboBox)
  private
    FIncrementalFilteringLike: Boolean;
  protected
    procedure Initialize; override;
  public
    class function GetPropertiesClass: TcxCustomEditPropertiesClass; override;

    // Свойство влияет на принудительную установку фильтра на выпадающий список через оператор LIKE
    property IncrementalFilteringLike: Boolean read FIncrementalFilteringLike write FIncrementalFilteringLike;
  end;

implementation

{ TcxCustomDBLookupEditLookupData }

function TcxCustomDBLookupEditLookupData.Locate(var AText, ATail: string;
  ANext: Boolean): Boolean;
begin
  if (Self.GetOwner as TcxLookupComboBox).IncrementalFilteringLike then
  begin
    Result := True;
    DisableChanging;
    try
      DataController.Filter.Clear;
      DataController.Filter.Root.AddItem(DataController.GetItem(Properties.ListFieldIndex), foLike, '%'+AText+'%', '');
      DataController.Filter.Active := True;
      UpdateDropDownCount;
    finally
      EnableChanging;
    end;
  end else
  begin
    Result := inherited Locate(AText, ATail, ANext);
  end;
end;

{ TcxLookupComboBox }

class function TcxLookupComboBox.GetPropertiesClass: TcxCustomEditPropertiesClass;
begin
  Result := TcxLookupComboBoxProperties;
end;

procedure TcxLookupComboBox.Initialize;
begin
  inherited;
  FIncrementalFilteringLike := False;
end;

{ TcxLookupComboBoxProperties }

class function TcxLookupComboBoxProperties.GetLookupDataClass: TcxInterfacedPersistentClass;
begin
  Result := TcxCustomDBLookupEditLookupData;
end;

end.


Использование:
В секции uses раздела interface самым последним в списке юнитов указываем UcxLookupComboBoxExt, теперь все компоненты TcxLookupComboBox, которые есть на форме получать дополнительную функциональность. Далее в конструкторе формы у нужных компонентов TcxLookupComboBox выставляем свойство IncrementalFilteringLike := True;

Пример:
Код

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  lkpItems.IncrementalFilteringLike := True;

  mtTable.FieldDefs.Add('id', ftInteger);
  mtTable.FieldDefs.Add('name', ftString, 200);
  mtTable.CreateTable;
  mtTable.Open;

  for i:=1 to 100 do
  begin
    mtTable.Append;
    mtTable['id'] := i;
    mtTable['name'] := IntToStr(i) + ' запись ' + IntToStr(i) + ' fff';
    mtTable.Post;
  end;
end;

PM MAIL   Вверх
V0LT
Дата 12.5.2012, 11:30 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2



Простой класс для работы с базой Firebird позволяет организовать запрос в минимум строк
Бонус: автоматически создающаяся и удаляющаяся транзакция, отличное быстродействие, отличная замена IBQuery, юзается на крупном проекте smile  

Пример
Код

{
var
  SQL: TIBSQLWT;}
{...}
{параметры юзать так - SQL.ParamByName('PARAMNAME').AsInteger}

  SQL := TIBSQLWT.Create(MainDB);
  SQL.SQL.CommaText := 'SELECT NAME FROM DOCS';
  SQL.ExecQuery;
  while not SQL.Eof do
  begin
    str := SQL.Current.ByName('NAME').AsTrimString;
    SQL.Next;
  end;
  SQL.Free;


Реализация класса
Код
unit IBSQLWTUnit;

interface

uses IBSQL, IBDatabase;

type
  TIBSQLWT = class(TIBSQL) // IBSQL потребляет меньше памяти чем IBQuery
  private                         // но немного урезан по функциональности
    TransactionNum: Integer;
  public
    constructor Create(inDatabase: TIBDatabase); reintroduce;
    destructor Destroy; override;
  end;

implementation

{ Реализация IBSQLWT }

//------------------------------------------------------------------------------

{ Конструктор создаёт и добавляет транзакцию
  Вход:
     inDatabase - экземпляр TIBDatabase }
constructor TIBSQLWT.Create(inDatabase: TIBDatabase);
begin
  inherited Create(inDatabase);
  Database := inDatabase;
  Transaction :=  TIBTransaction.Create(Database);
  Transaction.AddDatabase(Database);
  TransactionNum := Database.AddTransaction(Transaction);
  Transaction.StartTransaction();
end;


//------------------------------------------------------------------------------

{ Деструктор выполняет подтверждение и уничтожение транзакции }
destructor TIBSQLWT.Destroy;
begin
  Transaction.Commit();
  Database.RemoveTransaction(TransactionNum);
  Transaction.Free;
  inherited;
end;

end.


Это сообщение отредактировал(а) V0LT - 9.10.2012, 11:53
PM MAIL ICQ   Вверх
san46
Дата 12.5.2012, 11:59 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 15
Регистрация: 30.11.2006

Репутация: нет
Всего: нет



Цитата
Простой класс для работы с базой Firebird
Да, неплохо. А если надо откатить транзакцию, то как это делается с применением представленного класса?
PM MAIL   Вверх
V0LT
Дата 12.5.2012, 15:25 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2



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

Код

{
var
  SQL: TIBSQLWT;}
{...}
{параметры юзать так - SQL.ParamByName('PARAMNAME').AsInteger}

  SQL := TIBSQLWT.Create(MainDB);

  SQL.SQL.CommaText := 'SELECT NAME FROM DOCS';
  SQL.ExecQuery;
  while not SQL.Eof do
  begin
    str := SQL.Current.ByName('NAME').AsTrimString;
    SQL.Next;
  end;

  SQL.Transaction.Rollback();// или Commit();
  SQL.SQL.Clear;
  SQL.Close;
  SQL.Transaction.StartTransaction();

{с новыми силами оформляем запрос}

  SQL.SQL.CommaText := 'SELECT NAME FROM DOCS';
  SQL.ExecQuery;
  while not SQL.Eof do
  begin
    str := SQL.Current.ByName('NAME').AsTrimString;
    SQL.Next;
  end;

  SQL.Free;


... и ещё, так же деструктор класса возможно лучше обернуть в try ... except и в except добавил бы Rollback пример ниже
не люблю я try ... except smile 

Код

  destructor TSimpleSQLQuery.Destroy;
  begin
    try
      Transaction.Commit();
    except
      Transaction.Rollback();
    end;
    Database.RemoveTransaction(TransactionNum);
    Transaction.Free;
    inherited;
  end;


Это сообщение отредактировал(а) V0LT - 12.5.2012, 15:37
PM MAIL ICQ   Вверх
V0LT
Дата 12.5.2012, 15:44 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2



Новый TIBSQLWT - теперь банановый с rollback'ом

Код

{...}
  SQL := TIBSQLWT.Create(MainDB); // перед Free будет Commit
{...}


Код

{...}
  SQL := TIBSQLWT.Create(MainDB, True); // перед Free будет Rollback
{...}


Код

unit IBSQLWTUnit;

interface

uses IBSQL, IBDatabase;

type
  TIBSQLWT = class(TIBSQL) // IBSQL потребляет меньше памяти чем IBQuery
  private                         // но немного урезан по функциональности
    RollbackOnFree: Boolean;
    TransactionNum: Integer;
  public
    constructor Create(inDatabase: TIBDatabase; inRollbackOnFree: Boolean = False); reintroduce;
    destructor Destroy; override;
  end;

implementation

{ Реализация IBSQLWT }

//------------------------------------------------------------------------------

{ Конструктор создаёт и добавляет транзакцию в очередь
  Вход:
     inDatabase - экземпляр TIBDatabase }
constructor TIBSQLWT.Create(inDatabase: TIBDatabase; inRollbackOnFree: Boolean);
begin
  inherited Create(inDatabase);
  RollbackOnFree := inRollbackOnFree;
  Database := inDatabase;
  Transaction :=  TIBTransaction.Create(Database);
  Transaction.AddDatabase(Database);
  TransactionNum := Database.AddTransaction(Transaction);
  Transaction.StartTransaction();
end;


//------------------------------------------------------------------------------

{ Деструктор выполняет подтверждение и уничтожение транзакции }
destructor TIBSQLWT.Destroy;
begin
  if not RollbackOnFree then
    Transaction.Commit()
  else
    Transaction.Rollback();
  Database.RemoveTransaction(TransactionNum);
  Transaction.Free;
  inherited;
end;

end.


Это сообщение отредактировал(а) V0LT - 12.5.2012, 16:00
PM MAIL ICQ   Вверх
san46
Дата 12.5.2012, 15:58 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 15
Регистрация: 30.11.2006

Репутация: нет
Всего: нет



Цитата
не люблю я try ... except
Оно так. Тем более, чего этой конструкции здесь делать, если выполняется одиночный модифицирующий запрос - сервер при ошибке и без того откатит транзакцию. В общем, идея класса понятна и дальнейшее его развитие - дело вкуса.
Спасибо.

Это сообщение отредактировал(а) san46 - 12.5.2012, 15:59
PM MAIL   Вверх
V0LT
Дата 12.5.2012, 16:04 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2



всегда пожалуйста smile 
... я думаю было бы полезно обмениваться не только громоздкими исходниками новейших классов, но и различными надстройками над классами 
PM MAIL ICQ   Вверх
V0LT
Дата 3.10.2012, 17:01 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2



И снова обновление класса TIBSQLWT smile 

Использовать так ... и никак иначе
Код
procedure TForm1.Button1Click(Sender: TObject);
begin
  TIBSQLWT.IterateExecQuery(IBDatabase1,
  'SELECT SHORTNAME FROM LOGINS ORDER BY ID', Iter);
end;

procedure TForm1.Iter(Current: TIBXSQLDA);
begin
  Memo1.Lines.Add(Current.ByName('NAME').AsTrimString);
end;


А тем временем в классе ...
Код
TIBSQLWTProc = procedure(Current: TIBXSQLDA) of object;

class function TIBSQLWT.IterateExecQuery(inDatabase: TIBDatabase;
                                         inQuery: string;
                                         Callback: TIBSQLWTProc;
                                         inRollbackOnFree: Boolean = False): Boolean;
var
  SQLQuery: TIBSQLWT;
begin
  SQLQuery := TIBSQLWT.Create(inDatabase, inRollbackOnFree);
  try
    SQLQuery.SQL.Add(inQuery);
    SQLQuery.ExecQuery;
    while not SQLQuery.Eof do
    begin
      if Assigned(Callback) then Callback(SQLQuery.Current);
      SQLQuery.Next;
    end;
  finally
    FreeAndNil(SQLQuery);
  end;
end;


Это сообщение отредактировал(а) V0LT - 9.10.2012, 11:55
PM MAIL ICQ   Вверх
Akella
Дата 3.10.2012, 22:09 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Творец
****


Профиль
Группа: Модератор
Сообщений: 18485
Регистрация: 14.5.2003
Где: Корусант

Репутация: 36
Всего: 329



PM MAIL   Вверх
V0LT
Дата 9.10.2012, 11:55 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 91
Регистрация: 16.6.2009

Репутация: нет
Всего: 2



Исходник класса TIBSQLWT -  для выполнения SQL запросов (Firebird)

Это сообщение отредактировал(а) V0LT - 9.10.2012, 11:56

Присоединённый файл ( Кол-во скачиваний: 9 )
Присоединённый файл  uIBSQLWT.pas 4,62 Kb
PM MAIL ICQ   Вверх
CynicRus
Дата 1.3.2013, 08:29 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 248
Регистрация: 31.5.2012

Репутация: нет
Всего: 5



Сей модуль был написан мной на Delphi XE, но должен без проблем скомпилироваться в любой другой версии дельфей , для Lazarus+FPC будет необходимо внести небольшие коррективы. Модуль реализует функциональность 'human-like mouse movements', тоесть движения мышью как человеческие. Модуль будет полезен для тех, кто разрабатывает всяческих ботов для игр или интернет казино\покера. Не требует никаких дополнительных модулей кроме Windows.pas.

В архиве собственно юнит и небольшая демка.

Присоединённый файл ( Кол-во скачиваний: 11 )
Присоединённый файл  HumanMouse.zip 94,37 Kb
PM MAIL   Вверх
ЧеловекБорща
  Дата 25.6.2013, 19:03 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 94
Регистрация: 5.6.2010

Репутация: нет
Всего: нет



Доброго времени. 

Сетевой компонент для работы с HTTP протоколом. 
В основу лег довольно простой, без наворотов, Synapse THTTPSend, вместе с этим каждый раз нужно дико нагромождать кода, для тойже отправи TMultipartformdataStream куда-либо, что не айс. 
Потому написал для этого наворот.
Естественно, я некоторые вещи улучшил в наследнике(THTTPSendEx).

Основные отличия от оригинала:
  • Несколько вариаций конструктора класса, которые позволяют задать User-Agent и версию HTTP протокола, по умолчанию используется User-Agent мазилы и HTTP 1.1(В оригинале, HTTP 1.0 и пустой User-Agent)
  • БОгатое наличие GET/POST вариаций и передаваемых в/из функцию/метод параметров в основном это string, TStrings, TStream, TMultipartformdataStream и все наследуемые от них.
  • Наличие самописной реализации TMultipartformdataStream, писалось для удобной отправки файлов/данных ну и пара POST-методов с участием этого типа данных. 
  • Наличие событий аналогичных TidHTTP(Indy Project), таких как: OnWorkBeginOnWorkOnWorkEnd из которых можно получить информацию о передаваемых размерах данных(всего, текущее значение), скорости передачи, остатке времени.
  • Методы загрузки файлов DownloadFile и DowndloadFileToTemp думаю из названия ясно =) 
  • Функции URLIsAlive(Ответ = 200), URLIsDead(Ответ = 404)
  • ЧеловекоПонятные свойства IsRedirect, IsSuccessfull, IsntFound в отличии от аналогов(ErrorCode = 301) or (ErrorCode = 302), (ErrorCode = 200), (ErrorCode = 404). В случае IsRedirect в свойстве класса Location будет ссылка перенаправления.
  • Метод ClearAll, в отличии от стандартного он так же очищает и Cookies класса, т.к. стандартный Clear метод класса этого не делает.
  • Событие OnSocketStatus, на тот случай если используя THTTPSendEx вам нужно событие THTTPSendEx.Socket.OnStatus ,но т.к. THTTPSendEx его уже занял для реаизации OnWork* событий, то данное событие быстро исправит ситуацию(прототип тот же).
Пока вроде бы все... 
В планах реализовать автоматическую поддержку GZIP ну и с Cookies что-то придумать..

Требования к использованию:
  • Среда разработки Delphi не ниже 2009 версии.
  • Наличие установленного стандартного набора классов Synapse у меня не альтернатива, а всего лишь некоторое дополнение для уже существующего.
Проект развивается и обитает тут
Предложения, комментарии, критика и исправления - приветствуются на сайте или email.


Это сообщение отредактировал(а) ЧеловекБорща - 25.6.2013, 19:04

Присоединённый файл ( Кол-во скачиваний: 13 )
Присоединённый файл  clHTTPSendEx_0.0.0.8.zip 6,98 Kb
PM MAIL   Вверх
Beltar
Дата 30.10.2013, 22:00 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 627
Регистрация: 11.1.2006

Репутация: 3
Всего: 7



 Lines на доске из шестиугольников, зачем и почему оно сделано никто не знает. Для отрисовки использовался сей двиг.

http://www.afterwarp.net/asphyre/files/AsphyreSphinx304.rar

Сырец XE3.

Технически ничего интересного, несложная рисовка с помощью готового DirectX движка, чтобы игра не занимала проц на 100% есть ограничение fps. Алгоритм Дейкстры и самопальный алгоритм определения клика по шестиугольной клетке. Была идея сделать уничтожение нескольких типов фигур, как в Lines 98, но так и не сделано.

Это сообщение отредактировал(а) Beltar - 30.10.2013, 22:05

Присоединённый файл ( Кол-во скачиваний: 5 )
Присоединённый файл  Asphyre_HexLines.rar 122,61 Kb


--------------------
Опытный программист на C++ легко решает любые не существующие в Паскале проблемы. smile(с) я, хотя может и нет
Пищущий на C++ мужик. Даже если это мужик сидит в написанном на Delphi и жрущем паскалевскую библиотеку билдере.
PM MAIL   Вверх
Beltar
Дата 30.10.2013, 22:01 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 627
Регистрация: 11.1.2006

Репутация: 3
Всего: 7



Сама откомпилированная игра.

Присоединённый файл ( Кол-во скачиваний: 8 )
Присоединённый файл  Release.rar 710,76 Kb


--------------------
Опытный программист на C++ легко решает любые не существующие в Паскале проблемы. smile(с) я, хотя может и нет
Пищущий на C++ мужик. Даже если это мужик сидит в написанном на Delphi и жрущем паскалевскую библиотеку билдере.
PM MAIL   Вверх
CynicRus
Дата 11.4.2014, 11:51 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 248
Регистрация: 31.5.2012

Репутация: нет
Всего: 5



Класс для получения хэндлов с контролов формы, самих окон. Очень часто использую.

Код

unit DTM_HandlePicker;

interface
   uses
    System.Classes,System.SysUtils,Vcl.Controls,Vcl.Graphics,
    Vcl.Forms,Winapi.Windows;
type
 THandlePicker = class
   private
    FHandle: HDC;
    FHasPicked: Boolean;
   public
    property Handle: HDC read FHandle write FHandle;
    property HasPicked: Boolean read FHasPicked write FHasPicked;
    constructor Create;
    procedure Reset;
    procedure Drag;
 end;

implementation

{ THandlePicker }

constructor THandlePicker.Create;
begin
 Reset;
end;

procedure THandlePicker.Drag;
var
  TargetRect: TRect;
  Region : HRGN;
  Cursor : TCursor;
  TempHandle : Hwnd;
  DragForm : TForm;
  EdgeForm : TForm;
  Style : DWord;
  W,H: integer;
const
  EdgeSize =4;
  WindowCol = clred;
begin;
  Cursor:= Screen.Cursor;
  Screen.Cursor:= crCross;
  TempHandle := GetDesktopWindow;
  EdgeForm := TForm.Create(nil);
  EdgeForm.Color:= WindowCol;
  EdgeForm.BorderStyle:= bsNone;


  DragForm := TForm.Create(nil);
  DragForm.Color:= WindowCol;
  DragForm.BorderStyle:= bsNone;
  Style := GetWindowLong(DragForm.Handle, GWL_EXSTYLE);
  SetWindowLong(DragForm.Handle, GWL_EXSTYLE, Style or WS_EX_LAYERED or WS_EX_TRANSPARENT);
  SetLayeredWindowAttributes(DragForm.Handle, 0, 100, LWA_ALPHA);

  try
  while GetAsyncKeyState(VK_LBUTTON) <> 0 do
  begin;

    Handle:= WindowFromPoint(Mouse.CursorPos);
    if (Handle <> TempHandle) and (Handle <> EdgeForm.Handle) then
    begin;
      EdgeForm.Show;
      DragForm.Show;
      GetWindowRect(Handle, TargetRect);
      W :=TargetRect.Right - TargetRect.Left+1;
      H :=TargetRect.Bottom - TargetRect.Top+1;
      DragForm.SetBounds(TargetRect.Left,TargetRect.top,W,H);

      SetWindowRgn(EdgeForm.Handle,0,false);
      Region := CreateRectRgn(0,0,w-1,h-1);
      CombineRgn(Region,Region,CreateRectRgn(EdgeSize,EdgeSize,w-1-(edgesize),h-1-(edgesize)),RGN_XOR);
      SetWindowRgn(edgeform.Handle,Region,true);
      EdgeForm.SetBounds(TargetRect.Left,TargetRect.top,W,H);
      TempHandle  := Handle;
    end;
    Application.ProcessMessages;
    Sleep(30);
  end;
  Handle := TempHandle;
  haspicked:= true;
  Screen.Cursor:= cursor;
  finally
  DragForm.Hide;
  DragForm.Free;
  EdgeForm.Hide;
  EdgeForm.Free;
  end;
end;

procedure THandlePicker.Reset;
begin
  HasPicked:=false;
  Handle:=0;
end;

end.


Как использовать - создаем экземпляр класса, и в обработчике MouseDown - вызываем метод Drag. В свойстве Handle - будет тот хэндл, который мы выделили.

Это сообщение отредактировал(а) CynicRus - 11.4.2014, 13:32
PM MAIL   Вверх
CynicRus
Дата 12.4.2014, 13:55 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 248
Регистрация: 31.5.2012

Репутация: нет
Всего: 5



Только что закончил, класс для создания скриншотов. Умеет снимать с помощью Winapi, DirectX,DirectDraw. Написан на Delphi XE3, проверен в Win7 x32\64.

Код

unit DTM_ImageCatcher;

interface
  uses
   System.Classes,System.SysUtils,Vcl.Controls,Vcl.Graphics,
    Vcl.Forms,Winapi.Windows,Winapi.D3DX9,Direct3D9,DirectDraw;

  type
    TCatchType = (ctWinapi = 0,ctDirectX = 1,ctDDraw);
    TImageCatcher = class
      private
        FBitmap: Vcl.Graphics.TBITMAP;
        FCatchType: TCatchType;
        FTargetHandle: HWND;
        procedure GetTargetRect(out Rect: TRect);
        procedure GetDDrawData();
        procedure GetDirectXData();
        procedure GetWinapiData();
        procedure GetTargetDimensions(out w, h: integer);
        procedure GetTargetPosition(out left, top: integer);
      public
        constructor Create;
        procedure Reset;
        destructor Destroy;override;

        procedure GetScreenShot();
        procedure ActivateTarget;
        property Bitmap: Vcl.Graphics.TBITMAP read FBitmap write FBitmap;
        property CatchType: TCatchType read FCatchType write FCatchType;
        property TargetHandle: HWND read FTargetHandle write FTargetHandle;
    end;
implementation

{ TImageCather }

procedure TImageCatcher.ActivateTarget;
begin
 SetForegroundWindow(TargetHandle);
end;


constructor TImageCatcher.Create;
begin
 Reset;
 FBitmap:=Vcl.Graphics.TBitmap.Create;
 FBitmap.PixelFormat:=pf24bit;
end;

destructor TImageCatcher.Destroy;
begin
  FreeAndNil(FBitmap);
  inherited;
end;

procedure TImageCatcher.GetDDrawData();
var
  DDSCaps: TDDSCaps;
  DesktopDC: HDC;
  DirectDraw: IDirectDraw;
  Surface: IDirectDrawSurface;
  SurfaceDesc: TDDSurfaceDesc;
  x, y, w, h: integer;
begin
  GetTargetDimensions(w, h);
  GetTargetPosition(x, y);
  if DirectDrawCreate(nil, DirectDraw, nil) = DD_OK then
    if DirectDraw.SetCooperativeLevel(GetDesktopWindow, DDSCL_EXCLUSIVE or DDSCL_FULLSCREEN or DDSCL_ALLOWREBOOT) = DD_OK then
    begin
      FillChar(SurfaceDesc, SizeOf(SurfaceDesc), 0);
      SurfaceDesc.dwSize := Sizeof(SurfaceDesc);
      SurfaceDesc.dwFlags := DDSD_CAPS;
      SurfaceDesc.ddsCaps.dwCaps := DDSCAPS_PRIMARYSURFACE;
      SurfaceDesc.dwBackBufferCount := 0;
      if DirectDraw.CreateSurface(SurfaceDesc, Surface, nil) = DD_OK then
      begin
        if Surface.GetDC(DesktopDC) = DD_OK then
          try
            Bitmap.Width := Screen.Width;
            Bitmap.Height := Screen.Height;
            BitBlt(Bitmap.Canvas.Handle, 0, 0, W, H, DesktopDC, x, y, SRCCOPY);
          finally
            Surface.ReleaseDC(DesktopDC);
          end;
      end;
    end;
end;

procedure TImageCatcher.GetDirectXData();
var
  BitsPerPixel: Byte;
  pD3D: IDirect3D9;
  pSurface: IDirect3DSurface9;
  g_pD3DDevice: IDirect3DDevice9;
  D3DPP: TD3DPresentParameters;
  ARect: TRect;
  LockedRect: TD3DLockedRect;
  BMP: VCL.Graphics.TBitmap;
  i, p: Integer;
  x, y: integer;
  w, h: integer;
begin
  GetTargetDimensions(w, h);
  GetTargetPosition(x, y);
  BitsPerPixel := 32;
  FillChar(d3dpp, SizeOf(d3dpp), 0);
  with D3DPP do
  begin
    Windowed := True;
    Flags := D3DPRESENTFLAG_LOCKABLE_BACKBUFFER;
    SwapEffect := D3DSWAPEFFECT_DISCARD;
    BackBufferWidth := Screen.Width;
    BackBufferHeight := Screen.Height;
    BackBufferFormat := D3DFMT_X8R8G8B8;
  end;
  pD3D := Direct3DCreate9(D3D_SDK_VERSION);
  pD3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, GetDesktopWindow, D3DCREATE_SOFTWARE_VERTEXPROCESSING, @ D3DPP, g_pD3DDevice);
  g_pD3DDevice.CreateOffscreenPlainSurface(Screen.Width, Screen.Height, D3DFMT_A8R8G8B8, D3DPOOL_SCRATCH, pSurface, nil);
  g_pD3DDevice.GetFrontBufferData(0, pSurface);
  ARect := Screen.DesktopRect;
  pSurface.LockRect(LockedRect, @ ARect, D3DLOCK_NO_DIRTY_UPDATE or D3DLOCK_NOSYSLOCK or D3DLOCK_READONLY);
  BMP := VCL.Graphics.TBitmap.Create;
  BMP.Width := Screen.Width;
  BMP.Height := Screen.Height;
  case BitsPerPixel of
    8: BMP.PixelFormat := pf8bit;
    16: BMP.PixelFormat := pf16bit;
    24: BMP.PixelFormat := pf24bit;
    32: BMP.PixelFormat := pf32bit;
  end;
  p := Cardinal(LockedRect.pBits);
  for i := 0 to Screen.Height - 1 do
  begin
    CopyMemory(BMP.ScanLine[i], Ptr(p), Screen.Width * BitsPerPixel div 8);
    p := p + LockedRect.Pitch;
  end;
  Bitmap.SetSize(w, h);
  BitBlt(Bitmap.Canvas.Handle, 0, 0, w, h, BMP.Canvas.Handle, x, y, SRCCOPY);
  BMP.Free;
  pSurface.UnlockRect;
end;

procedure TImageCatcher.GetScreenShot();
begin
  case CatchType of
    ctWinapi: GetWinapiData();
    ctDirectX: GetDirectXData();
    ctDDraw: GetDDrawData();
  end;
  SetForegroundWindow(Application.Handle);
end;

procedure TImageCatcher.GetTargetDimensions(out w, h: integer);
var
  Rect: TRect;
begin
  GetTargetRect(rect);
  w := Rect.Right - Rect.Left;
  h := Rect.Bottom - Rect.Top;
end;

procedure TImageCatcher.GetTargetPosition(out left, top: integer);
var
  Rect: TRect;
begin
  GetTargetRect(rect);
  left := Rect.Left;
  top := Rect.Top;
end;

procedure TImageCatcher.GetTargetRect(out Rect: TRect);
begin
  GetWindowRect(TargetHandle, Rect);
end;

procedure TImageCatcher.Reset;
begin
  CatchType := ctWinapi;
  TargetHandle := 0;
end;

procedure TImageCatcher.GetWinapiData();
var
  hWinDC: THandle;
  w, h: integer;
begin
  GetTargetDimensions(w, h);
  hWinDC := GetWindowDC(TargetHandle);
  Bitmap.Width := w;
  Bitmap.Height := h;
  hWinDC := GetWindowDC(TargetHandle);
  BitBlt(Bitmap.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height, hWinDC, 0, 0, SRCCOPY);
  ReleaseDC(TargetHandle, hWinDC);
end; 

end.


Как использовать:
Создать экземляр класса, скормить в TargetHandle - HWND требуемого окна,выставить режим снятия скриншота(ctWinapi,ctDDraw,ctDirectX), затем при нажатии кнопки выполнить метод класса ActivateClient; После GetScreenShot; и в поле Bitmap будет находится скрин окна.
Внимание:
Использовать режим ctDDraw Только для снятия скрина с видеоплееров и т.д. С простыми окнами оно не будет работать как надо.

Это сообщение отредактировал(а) CynicRus - 12.4.2014, 15:15
PM MAIL   Вверх
navodri
Дата 27.7.2014, 10:58 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 173
Регистрация: 26.10.2007

Репутация: нет
Всего: -1



Цитата(LENIN INC @ 21.7.2004,  21:02)
LENIN INC WIN32API Library v1.0 (build 11.05.04), Модули для создания программ на WIN32API

 Вашему вниманию предлагаються модули для создания программ на чистом WIN32API в DELPHI (all version). Все функции и процедуры 100% работают в Win9X/ME/NT/2000/XP. Подробнее на странице - LENIN INC WIN32API Library v1.0 (build 11.05.04)

Суважением, 
автор.

Эта штука теперь здесь. На сайте можно скачать демонстрационные файлы.

А вот фото примеров, которые входят в библиотеку LENIN INC WIN32API Library
user posted image
PM MAIL WWW   Вверх
Doga
Дата 20.3.2015, 18:21 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 115
Регистрация: 20.12.2007
Где: Россия, Обнинск

Репутация: нет
Всего: нет



user posted image

Модифицированные компоненты TJvTabBar и TJvModernTabBarPainter из библиотеки JEDI VCL (исходник JvTabBar.pas из версии 3.47, сборка 4571).

 TJvTabBar может использоваться для организации закладок дочерних окон MDI-приложения, для альтернативной отрисовки закладок компонента TPageControl и многого другого.





Это сообщение отредактировал(а) Doga - 9.7.2015, 14:48

Присоединённый файл ( Кол-во скачиваний: 14 )
Присоединённый файл  JvTabBar.zip 17,57 Kb
PM MAIL WWW   Вверх
kami
Дата 18.4.2015, 20:36 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Завсегдатай
Сообщений: 1806
Регистрация: 25.8.2007
Где: Санкт-Петербург

Репутация: 23
Всего: 72



Долго искал исходники инженерного калькулятора... К сожалению, в сети распространен только один, написанный во времена D7(или ранее), с кучей глобальных переменных, дублирующимся кодом и прочими недостатками, мешающими если не модифицировать, то хотя бы понять его.
Предлагаю упрощенный вариант, основанный на алгоритме http://algolist.ru/syntax/parsear.php
Из исходного алгоритма убраны скобки (мне они были не нужны) и добавлены тригонометрические функции.
Визуальная часть - фрейм FireMonkey (т.е. - минимум Delphi XE), "бакенд" использует дженерики, посему - минимум D2009. Написано под XE7.

Это сообщение отредактировал(а) kami - 18.4.2015, 20:39

Присоединённый файл ( Кол-во скачиваний: 9 )
Присоединённый файл  Calculators.zip 5,74 Kb
PM MAIL WWW   Вверх
Beltar
Дата 19.4.2015, 21:54 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 627
Регистрация: 11.1.2006

Репутация: 3
Всего: 7



В сети закончились калькуляторы?

Наверное, каждый второй, начиная писать, делал свой калькулятор. У меня 10 лет назад получился вот такой.

Обратная польская запись, 51 функция (считая унарные плюс/минус и т. п.), включая среднее арифметическое. Правда без бутылки там сейчас и я не разберусь, мне на это смотреть страшно.

Присоединённый файл ( Кол-во скачиваний: 6 )
Присоединённый файл  Translator.rar 265,65 Kb


--------------------
Опытный программист на C++ легко решает любые не существующие в Паскале проблемы. smile(с) я, хотя может и нет
Пищущий на C++ мужик. Даже если это мужик сидит в написанном на Delphi и жрущем паскалевскую библиотеку билдере.
PM MAIL   Вверх
CynicRus
Дата 22.6.2015, 10:53 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Бывалый
*


Профиль
Группа: Участник
Сообщений: 248
Регистрация: 31.5.2012

Репутация: нет
Всего: 5



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

И так, реализация Deformable Template Models (DTM).

Суть:
Есть главная точка, и подточки, содержащие в себе смещения до главной точки. В каждой точке содержится: x,y - коодинаты, color - цвет точки, tolerance - допустимая погрешность цвета, AreaSize - размер области. На данный момент не играет роли. 

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

В принципе - ничего сложного.

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

Скрин с разметкой:
user posted image

Скрин с результатами поиска:
user posted image

Бинарник и свежий исходный код всегда можно забрать тут:
https://github.com/CynicRus/dtmeditor/releases/tag/0.9b

PS: если вы нашли ###код, у вас появились мысли по оптимизации, или просто достойная критика - с радостью всё выслушаю. 
Лицензия GPL v 3.

СУВ,
Cynic.
PM MAIL   Вверх
Дмитрий01
Дата 29.8.2015, 17:37 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 6
Регистрация: 29.8.2015
Где: Сестрорецк Примор ск. ш. д. 285

Репутация: нет
Всего: нет



Цитата(p0s0l @ 15.4.2004,  00:04)
Можно скинуть мне на мыло (кнопка E-Mail под моим постом) файл, и я его прикреплю к вашему сообщению при первой же возможности...

Не очень понимаю, что вы имеете в виду под выражением 
Цитата

скинуть мне на мыло

и слово "пост" .
PM MAIL   Вверх
Дмитрий01
Дата 29.8.2015, 18:00 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 6
Регистрация: 29.8.2015
Где: Сестрорецк Примор ск. ш. д. 285

Репутация: нет
Всего: нет



Доброго времени суток.
Предлагаю вашему вниманию простую, но удобную графическую библиотеку. 

За вопросами обращайтесь по E-Mail адресу.
Зарание извиняюсь за её имя. 


Присоединённый файл ( Кол-во скачиваний: 8 )
Присоединённый файл  AllegroUnit.pas 5,50 Kb
PM MAIL   Вверх
Plankin
Дата 30.1.2016, 18:33 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Новичок



Профиль
Группа: Участник
Сообщений: 1
Регистрация: 30.1.2016

Репутация: нет
Всего: нет



Цитата(RA @ 16.2.2005,  18:42)
Пример передачи файлов при помощи TClientSocke и TServerSocket

Очень многих интересует данный вопрос поэтому выкладываю сырячек.

Это пока так, зарисовочка, в дальнейшем планируется 
доработать, оптимизировать и добавить кое-какие вещи.

Ну и соответвенно сделать примеры с использованием ICS и Indy.

Файл то передается, но самому файлу после передачи хана.
Тупо передавал текстовый файл, на 3 строчки, после передача получил мусор в файле, одни знаки вопроса и все!!!
PM MAIL   Вверх
kami
Дата 31.1.2016, 22:05 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Эксперт
***


Профиль
Группа: Завсегдатай
Сообщений: 1806
Регистрация: 25.8.2007
Где: Санкт-Петербург

Репутация: 23
Всего: 72



Цитата(Plankin @  30.1.2016,  18:33 Найти цитируемый пост)
Тупо передавал текстовый файл, на 3 строчки, после передача получил мусор в файле, одни знаки вопроса и все!!! 

Try this  smile SimpleTCPTransfer
PM MAIL WWW   Вверх
Ответ в темуСоздание новой темы Создание опроса
Правила форума "Delphi: Общие вопросы"
SnowyMetalFan
bemsPoseidon
Rrader

Запрещается!

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делиться вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи


Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.

 
0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Общие вопросы | Следующая тема »


 




[ Время генерации скрипта: 0.8973 ]   [ Использовано запросов: 22 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.