Версия для печати темы
Нажмите сюда для просмотра этой темы в оригинальном формате
Форум программистов > Delphi: Общие вопросы > Арсенал форумистов


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

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

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

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

Автор: SlaUr 15.4.2004, 10:44
 "Системный модуль"
Код

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


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

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


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

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


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

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



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

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


http://slaur.narod.ru/delphi/index.htm

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

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

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

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

Автор: Akella 28.5.2004, 12:19
Процедура поиска по всем полям
Код

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);

Автор: OlegFPM 3.6.2004, 11:45
Delphi и Microsoft Office

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

Автор: 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. Подробнее на странице - http://lenininc.narod.ru/win32api.html

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

Автор: RA 2.8.2004, 05:07
Маленький простенкий протектор для UPX'а.

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

http://forum.vingrad.ru/index.php?showtopic=27193&view=findpost&p=193439
есть мнения?....

Автор: Dynamic 17.8.2004, 15:56
Модератор: Сообщение скрыто.

Автор: The MASTER 31.8.2004, 12:54
Пример работы с 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, первая буква "О" обязательно большая! Всё удачи, если будут проблемы пиши сюда!

Автор: Akella 15.9.2004, 11:22
нужно найти номер позиции второго символа "/" из строки "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

Автор: The MASTER 15.9.2004, 13:25
Вот Примерчик сортировки!

Автор: Петрович 15.9.2004, 20:12
В архиве:

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

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

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


http://www.lsvhost.narod.ru/LSVGauge.zip

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

Автор: Akella 1.10.2004, 09:33
Отправка файлов в корзину
в секцию 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)

Автор: Girder 11.10.2004, 14:49
 Универсальная функция для обращения к любым экспортируем функциям 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 -Пример использования:
- Выдираем в http://support.microsoft.com/default.aspx?scid=kb%3Ben-us%3B811415 иконки из трея и добавляем их в ImageList и отображаем их в TreeView... 

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

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

Автор: p0s0l 12.10.2004, 16:20
И я выложу (раз уж доделал) свою версию 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;

Автор: 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.

Автор: Girder 12.11.2004, 21:39
Функция поворота изображения на заданный угол через DIB.

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


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

Автор: p0s0l 19.11.2004, 15:11
С помощью этого модуля можно прочитать или записать в файл, который уже открыт, даже эксклюзивно! (Но файл и не обязательно должен быть открыт 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 сам себя изменяет - считается количество запусков программы...

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

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

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

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

Автор: BSV_Sergey 26.11.2004, 17:36
Привет всем.
Пока не разобрался как добавить к сообщению файлы.
Если кто-нибудь озадачится вызовом отчетов 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.

Автор: Alex 30.11.2004, 22:59
Получение длинного пути из короткого:

Код

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;

Автор: Girder 3.12.2004, 13:16
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

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

Всего 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;

Автор: ДЫМ 20.1.2005, 02:25
Иллюстрированный самоучитель по Delphi 7 для профессионалов


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

http://www.lsvhost.narod.ru/Documents/Delphi7Prof.zip

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

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

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

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

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

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

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

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

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

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

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: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

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

Автор: Петрович 30.1.2005, 20:51
Вот, тут 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.

Автор: Петрович 8.2.2005, 10:35
Для пользователей библиотеки 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:15
Для пользователей библиотеки EhLib.
Мною, а так-же Alex'ом были сделаны несколько доработок некоторых модулей этой библиотеки.

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

Автор: RA 16.2.2005, 18:42
Пример передачи файлов при помощи TClientSocke и TServerSocket

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

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

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

Автор: SoWa 17.2.2005, 14:29
Посмотрев примеры в 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;

Автор: Петрович 18.2.2005, 00:31
Вот реализация доработок EhLib от меня и Alex для версии 3.06. Подробнее см. http://forum.vingrad.ru/index.php?showtopic=21411&view=findpost&p=322225 и http://forum.vingrad.ru/index.php?showtopic=21411&view=findpost&p=322233

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

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

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

WMI.ZIP (5 kb)

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

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

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

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

Автор: Akella 18.3.2005, 10:09
Сделал небольшой архив с примерами

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

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 кБ.

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

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

Автор: Akella 22.3.2005, 12:35
Обмен данными между процессами. Сам не тестировал.

Автор: ДЫМ 3.4.2005, 03:13
Быстрая функция для разбивки строки на части (слова) в один цикл.

Код

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',['-','@']):

Автор: ДЫМ 17.4.2005, 01:56
Делал тут ListBox с подсказками, получился такой вот компонент.

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

Автор: Akella 14.5.2005, 10:11
Функция подмены разделителя целой и дробной части при вводе данных прямо в сетку, а также при вводе даты. Пользователя не должен думать о том, что ему правльно вводить в качетсве разделителя: точку или запятую
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;

Автор: Alex 24.6.2005, 04:32
Две полезные процедуры:

Код

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;

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

Автор: RA 2.7.2005, 14:05
Функция конвертации текста 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;

Автор: Rrader 28.7.2005, 16:53
В аттаче пример работы с TaskBar (получене текста всех кнопок).

Автор: Rrader 19.8.2005, 09:05
 Функция, которая нарисует на форме сетку и сделает форму похожей на дизайнер форм 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 12.11.2005, 14:13
Пример использование методов интерфейса 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.

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

Автор: Rrader 10.1.2006, 02:30
Как сделать 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.

Автор: vstepanov78 10.1.2006, 02:33
Периодически читаю рассылку этого форума. Хочу поделиться своими наработками (обновленной версией). Последние лет 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 к другому.

Автор: Foley 21.2.2006, 00:53
Мини - прога для расчета промежутка времени...

Автор: CaNIBaLchik 1.3.2006, 11:24
Компилятор с подсветкой символов.

BDS2005

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

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

Автор: Girder 4.3.2006, 00:25
Учимся работать с "многопоточными файлами" в 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;


Удачи.

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

Автор: Guedda 28.3.2006, 19:30
Вот мой модуль для работы с 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.

Автор: Rrader 29.3.2006, 03:15
 А вот мой, ещё проще:
Код

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  

Автор: Guedda 29.3.2006, 12:17
Да по-моему это обрезанный класс TIniFile...

Автор: Sh@dow 6.4.2006, 13:36
Хотел бы поделиться некоторыми наработками под 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

Автор: RA 29.4.2006, 19:34
совмещённые, между собой: 
ToolBar2000 v2.1.7 и TBX v2.2

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

http://files.vingrad.ru/spawn/TBX2.2_TB2K2.1.7.rar 

Автор: TP@MB@Y 12.5.2006, 22:06
Как-то мне пришлось для удобства написать эту функцию. Но она настолько полезна, что я ее пользую во многих своих проектах. Сорри если такое уже было.

Код

//Функция возвращающая 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 

Автор: Sansei 14.5.2006, 18:13
Начинающие системные программисты всегда ощущают дискомфорт и профессиональную неполноценность при отсутствии крайне необходимого им системного драйвера для чтения записи портов и 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-коды и название применяемой функции мы можем приступить к написанию тестового приложения, полный рабочий пример которого можно взять http://jungle.mam.by/work/oscidrv.zip. Я не буду комментировать его т.к., а я лично одобряю позицию, о которой говорил в самом начале этой статьи: не нужно постигать то, в чем мы не заинтересованы, нам важен конечный результат. Тестовое приложение реализует одним модулем необходимый набор функций для начинающего системного программиста, а именно: чтение/запись портов и MSR-регистров процессора. 

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

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

Автор: Budy 9.6.2006, 20:32
Два компонента 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. 

Автор: Angel_19 31.7.2006, 23:45
Кто нибудь юзал исходники Sansei? Я попробовал, у меня чт-то они глючат... 

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

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

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

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

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

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

 smile 

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

Автор: ctulhu 11.2.2007, 09:16
Модуль для работы с файловой системой на ООП-основе.

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

Автор: Alexeyt 26.2.2007, 20:00
//Раз народ выкладывает свои реализации работы с 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.

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

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

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

user posted image

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

Автор: lukas 8.5.2007, 22:47
Функция возвращения 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. в коде интерпретатора можно сильно сократить всю свою писанину. (У меня было так).

Автор: AlexxxM 23.5.2007, 17:25
На работе возникла проблема при открытии заказа рассылать письма по отделам (Список рассылки + пользователь кто внес запись). Список рассылки довольно статичен, а вот пользователей человек 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'а которые использовались в коде

Автор: Akella 13.7.2007, 07:58
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;

Автор: Rodman 13.7.2007, 13:10
XML формируется по всем открытым пунктам! Так чт разворачивайте, если надо!

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

Автор: RA 16.8.2007, 14:43
Вот случайно где-то нашёл такой хороший компонент с примером использования 

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

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

http://rapidshare.com/files/49501095/Packers_and_same_Sourse.rar.html


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

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

Автор: Rrader 15.9.2007, 14:59
Open Directory Dialog 1.2 by Rrader, Alix

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

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

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

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! У тебя точно такой же http://forum.vingrad.ru/index.php?showtopic=21411&view=findpost&p=686784, прям один в один smile 

Автор: lukas 13.11.2007, 19:18
давно никак не доходили руки написать объект копирующий компоненты, можно копировать компоненты с одной формы на другую сохраняя все свойства, единственное у копий нет имен, поэтому имена нужно дать после копирования. 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.

Автор: san46 29.12.2007, 11:04
Компонент для Delphi. Вывод линейных графиков.

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

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

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

http://san-46.narod.ru/GraphLinear.htm. Там можно посмотреть скриншоты, детальное описание и скачать исходники компонента с примером.

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

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

Автор: Doga 6.3.2008, 21:23
Всем привет.

http://www.radikal.ru

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

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

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

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

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

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

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

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

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

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

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

http://radikal.ru/fp/b1a60c3a668a48d99281902035888ec3

http://radikal.ru/fp/5ed4875124b2405e934af279210e9ee7

http://radikal.ru/fp/af6d516762f64dca972e7f2f083f37fa


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

Автор: KgCoder 15.4.2008, 12:22
Цитата(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;

Автор: RA 1.6.2008, 13:38
Полноценный редактор ресурсов

user posted image



бинарник
http://www.btinternet.com/~wilsoncpw/xnresourceeditor.zip
сорс
http://www.btinternet.com/~wilsoncpw/xn_resourceeditor_source.zip


Допы тут:
http://www.wilsonc.demon.co.uk/files/d10/

Автор: Beltar 7.6.2008, 10:46
2 RA

Доп компоненты не устанавливаются. Требует пакет LowLevel100.

Автор: Bose 11.9.2008, 13:42
Я тут пытался разобраться, как получить список всех 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. Так что их формат легко изменить, подправив пару строк кода.

Автор: RA 11.9.2008, 17:39
Цитата(Beltar @  7.6.2008,  10:46 Найти цитируемый пост)
Доп компоненты не устанавливаются. Требует пакет LowLevel100. 


Ну и в чемё проблема
http://www.wilsonc.demon.co.uk/files/d10/ -> NTLowLevel100.zip    

Автор: CHERRY 9.10.2008, 11:49
Эта прога может читать файлы 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.

Автор: san46 13.11.2008, 09:38
Комплексная программа для разработки баз данных различного назначения.

Когда перед программистом, работающим с 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

Автор: Akella 15.11.2008, 16:30
Пример организации панели кнопок как у 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

Автор: RA 19.4.2009, 20:26
Эмулятор наличия запущеной 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.

Автор: hkdkest 15.6.2009, 00:17
Исходники:

• http://codingrus.ru/infusions/pro_download_panel/download.php?did=192
user posted image
Привязка к записи скринщота и видео файла. Воспроизведение происходит средствами программы FilmsBase. Реализован поиск (как в Chetmax) и фильтр по жанрам.


• http://codingrus.ru/infusions/pro_download_panel/download.php?did=195
Задача курсового проекта заключается в создании такой информационной системы, которая включала бы в себя следующие возможности:
1. Добавление, удаление и редактирование информации о магазинах, продавцах, поставщиках, продажах, покупателях, заказах, комплектующих, каталоге. Необходимо предусмотреть для обеспечения наиболее эффективной работы пользователя удаление и редактирование путем непосредственного выбора записи из таблицы.
2. Просмотр информации о магазинах, продавцах, поставщиках, продажах, покупателях, заказах, комплектующих, каталоге.
3. Просмотр и печать информации о проданных товарах, содержащей сведения о покупателе, магазине, количестве и цене конкретного товара.
4. Просмотр и печать информации о комплектующих требуемого компьютера.
5. Осуществление поиска необходимой информации о товарах, магазинах, продавцах, поставщиках, продажах, покупателях, заказах, комплектующих и каталоге.
6. Осуществление операций продажи, заказов, а также, просмотр полного перечня сотрудников, клиентов и поставщиков конкретного магазина, выбор которого осуществляется при запуске клиентского приложения.
7. Возможность перехода из системы текущего магазина в систему необходимого.
8. Возможность входа в систему с разными уровнями доступа к данным: пользовательский (осуществляет только просмотр информации) и администраторский (осуществляет все возможные операции, представленные в системе).
9. Возможность смены пользователя в ходе работы программы.
10. Осуществление контроля введенных данных: проверка на соответствие типов, на ввод обязательных полей данных , а также, на ввод только возможных значений, считываемых из необходимых таблиц.
11. Возможность просмотра информации из таблиц в режиме реального времени.

• http://codingrus.ru/infusions/pro_download_panel/download.php?did=193
user posted image
 Разработанная программа производит лексический анализ исходного текста программы, написанной на языке программирования Pascal, распознает идентификаторы следующего типа: имена массивов, процедур, функций. 
В языках программирования выделяются следующие основные типы лексем:
• Идентификаторы;
• Служебные слова;
• Целые и вещественные константы;
• Строки;
• Операции;
• Разделители.
В ходе лексического анализа происходит разбиение входной строки символов на лексические единицы и обработка выделенных лексем.
Программа проста в использовании и рассчитана на средний уровень квалификации возможного пользователя.

• http://codingrus.ru/infusions/pro_download_panel/download.php?did=389

Автор: Yanis 15.7.2009, 13:46
Склонение временных единиц соответственно числу.

Согласитесь, довольно криво звучит и выглядит: 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;

Автор: sbfactory 19.4.2010, 11:58
Доброго времени суток уважаемые коллеги и просто любители программирования.
Решил выложить 100% рабочую сборку библиотеки GDI+ (с рабочим модулем Direct Draw) Для Delphi 2010 (http://sbfactory.ru/free/gdi+_delphi2010.zip).
Лучшее описание, которое встречал тут - http://www.rsdn.ru/article/gdi/gdiplus2mag.xml
Если у кого будут вопросы по установке и использованию, могу проконсультировать: ICQ 571-880-051;
С уважением  к вам, Сергей.

Автор: SeregaAltmer 21.9.2010, 14:36
TOptions. Компонент Delphi для удобной работы с опциями.

TOptions - небольшой но мощный инструмент, организующий удобную работу с опциями. Компонент представляет собой удобный, полноценый интерфейс для работы с опциями. Используя его в своих программах вы по максимуму минимизируете свои временные затраты, на разработку модуля по работе с опциями.

Для хранения опций, компонент позволяет использовать: реестр, ini-файлы и оперативную память.

Компонент может самостоятельно взаимодействовать с "контролами настроек" расположенными на форме с опциями.

http://buba-group.ru/index.php/toptionsabout smile

Автор: RomanEEP 20.9.2011, 16:29
Компактный и очень быстрый формат хранения данных. Задуман как замена 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 как байт

Автор: igorsh 15.12.2011, 12:34
Расширение функциональности компонента 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;

Автор: V0LT 12.5.2012, 11:30
Простой класс для работы с базой 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.

Автор: san46 12.5.2012, 11:59
Цитата
Простой класс для работы с базой Firebird
Да, неплохо. А если надо откатить транзакцию, то как это делается с применением представленного класса?

Автор: V0LT 12.5.2012, 15:25
По хорошему я бы это написал в данный класс но мне это потребовалось лишь однажды 
... а можно переделать конструктор так, что бы в деструкторе производилось либо 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:44
Новый 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.

Автор: san46 12.5.2012, 15:58
Цитата
не люблю я try ... except
Оно так. Тем более, чего этой конструкции здесь делать, если выполняется одиночный модифицирующий запрос - сервер при ошибке и без того откатит транзакцию. В общем, идея класса понятна и дальнейшее его развитие - дело вкуса.
Спасибо.

Автор: V0LT 12.5.2012, 16:04
всегда пожалуйста smile 
... я думаю было бы полезно обмениваться не только громоздкими исходниками новейших классов, но и различными надстройками над классами 

Автор: V0LT 3.10.2012, 17:01
И снова обновление класса 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;

Автор: Akella 3.10.2012, 22:09
http://www.sql.ru/blogs/x11

Автор: V0LT 9.10.2012, 11:55
Исходник класса TIBSQLWT -  для выполнения SQL запросов (Firebird)

Автор: CynicRus 1.3.2013, 08:29
Сей модуль был написан мной на Delphi XE, но должен без проблем скомпилироваться в любой другой версии дельфей , для Lazarus+FPC будет необходимо внести небольшие коррективы. Модуль реализует функциональность 'human-like mouse movements', тоесть движения мышью как человеческие. Модуль будет полезен для тех, кто разрабатывает всяческих ботов для игр или интернет казино\покера. Не требует никаких дополнительных модулей кроме Windows.pas.

В архиве собственно юнит и небольшая демка.

Автор: ЧеловекБорща 25.6.2013, 19:03
Доброго времени. 

Сетевой компонент для работы с 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), таких как: OnWorkBegin, OnWork, OnWorkEnd из которых можно получить информацию о передаваемых размерах данных(всего, текущее значение), скорости передачи, остатке времени.
  • Методы загрузки файлов 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 у меня не альтернатива, а всего лишь некоторое дополнение для уже существующего.
http://arhangelsoft.ru/delphi/advanced-synapse-library-thttpsendex/
Предложения, комментарии, критика и исправления - приветствуются на сайте или email.

Автор: Beltar 30.10.2013, 22:00
 Lines на доске из шестиугольников, зачем и почему оно сделано никто не знает. Для отрисовки использовался сей двиг.

http://www.afterwarp.net/asphyre/files/AsphyreSphinx304.rar

Сырец XE3.

Технически ничего интересного, несложная рисовка с помощью готового DirectX движка, чтобы игра не занимала проц на 100% есть ограничение fps. Алгоритм Дейкстры и самопальный алгоритм определения клика по шестиугольной клетке. Была идея сделать уничтожение нескольких типов фигур, как в Lines 98, но так и не сделано.

Автор: Beltar 30.10.2013, 22:01
Сама откомпилированная игра.

Автор: CynicRus 11.4.2014, 11:51
Класс для получения хэндлов с контролов формы, самих окон. Очень часто использую.

Код

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 12.4.2014, 13:55
Только что закончил, класс для создания скриншотов. Умеет снимать с помощью 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 Только для снятия скрина с видеоплееров и т.д. С простыми окнами оно не будет работать как надо.

Автор: navodri 27.7.2014, 10:58
Цитата(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. Подробнее на странице - http://lenininc.narod.ru/win32api.html

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

Эта штука теперь http://win32api-library.hol.es/. На сайте можно скачать демонстрационные файлы.

А вот фото примеров, которые входят в библиотеку LENIN INC WIN32API Library: 
user posted image

Автор: Doga 20.3.2015, 18:21
http://www.radikal.ru

Модифицированные компоненты TJvTabBar и TJvModernTabBarPainter из библиотеки JEDI VCL (исходник JvTabBar.pas из версии 3.47, сборка 4571).

 TJvTabBar может использоваться для организации закладок дочерних окон MDI-приложения, для альтернативной отрисовки закладок компонента TPageControl и многого другого.

Автор: kami 18.4.2015, 20:36
Долго искал исходники инженерного калькулятора... К сожалению, в сети распространен только один, написанный во времена D7(или ранее), с кучей глобальных переменных, дублирующимся кодом и прочими недостатками, мешающими если не модифицировать, то хотя бы понять его.
Предлагаю упрощенный вариант, основанный на алгоритме http://algolist.ru/syntax/parsear.php
Из исходного алгоритма убраны скобки (мне они были не нужны) и добавлены тригонометрические функции.
Визуальная часть - фрейм FireMonkey (т.е. - минимум Delphi XE), "бакенд" использует дженерики, посему - минимум D2009. Написано под XE7.

Автор: Beltar 19.4.2015, 21:54
В сети закончились калькуляторы?

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

Обратная польская запись, 51 функция (считая унарные плюс/минус и т. п.), включая среднее арифметическое. Правда без бутылки там сейчас и я не разберусь, мне на это смотреть страшно.

Автор: CynicRus 22.6.2015, 10:53
Всем привет. Выкладываю здесь, быть может кому нибудь пригодится.

И так, реализация Deformable Template Models (DTM).

Суть:
Есть главная точка, и подточки, содержащие в себе смещения до главной точки. В каждой точке содержится: x,y - коодинаты, color - цвет точки, tolerance - допустимая погрешность цвета, AreaSize - размер области. На данный момент не играет роли. 

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

В принципе - ничего сложного.

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

Скрин с разметкой:
http://shot.qip.ru/00G1vx-6w5qyEAsM/

Скрин с результатами поиска:
http://shot.qip.ru/00G1vx-5w5qyEAsN/

Бинарник и свежий исходный код всегда можно забрать тут:
https://github.com/CynicRus/dtmeditor/releases/tag/0.9b

PS: если вы нашли ###код, у вас появились мысли по оптимизации, или просто достойная критика - с радостью всё выслушаю. 
Лицензия GPL v 3.

СУВ,
Cynic.

Автор: Дмитрий01 29.8.2015, 17:37
Цитата(p0s0l @ 15.4.2004,  00:04)
Можно скинуть мне на мыло (кнопка E-Mail под моим постом) файл, и я его прикреплю к вашему сообщению при первой же возможности...

Не очень понимаю, что вы имеете в виду под выражением 
Цитата

скинуть мне на мыло

и слово "пост" .

Автор: Дмитрий01 29.8.2015, 18:00
Доброго времени суток.
Предлагаю вашему вниманию простую, но удобную графическую библиотеку. 

За вопросами обращайтесь по E-Mail адресу.
Зарание извиняюсь за её имя. 

Автор: Plankin 30.1.2016, 18:33
Цитата(RA @ 16.2.2005,  18:42)
Пример передачи файлов при помощи TClientSocke и TServerSocket

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

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

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

Файл то передается, но самому файлу после передачи хана.
Тупо передавал текстовый файл, на 3 строчки, после передача получил мусор в файле, одни знаки вопроса и все!!!

Автор: kami 31.1.2016, 22:05
Цитата(Plankin @  30.1.2016,  18:33 Найти цитируемый пост)
Тупо передавал текстовый файл, на 3 строчки, после передача получил мусор в файле, одни знаки вопроса и все!!! 

Try this  smile http://forum.vingrad.ru/index.php?showtopic=290376&view=findpost&p=2090440

Powered by Invision Power Board (http://www.invisionboard.com)
© Invision Power Services (http://www.invisionpower.com)