RusFAQ.ru: Программирование на Delphi

/ КОМПЬЮТЕРЫ И ПО / Языки программирования / Delphi

Выпуск № 265
от 15.10.2005, 14:54

Вопрос № 27.462

Ответьте мне пожалуйста на такой вопрос: мне необходимо запустить два и более потока, которые сканируют директории на предмет изменения файлов (создание, удаление и.т.п). Список сканируемых директорий будут у меня храниться в листбоксе. Как мне запустить этот поток несколько раз и как мне остановить определенный поток, если пользователь решил несканировать какой то католог. Приложение: unit wfsU; interface type // Структура с информацией об изменении в файловой системе (передается в callback процедуру) PInfoCallBack = ^TInfoCallBack; TInfoCallBack = record FAction : Integer; // тип изменения (константы FILE_ACTION_XXX) FDrive : string; // диск, на котором было изменение FOldFileName : string; // имя файла до переименования FNewFileName : string; // имя файла после переименования end; // callback процедура, вызываемая при изменении в файловой системе TWatchFileSystemCallBack = procedure (pInfo: TInfoCallBack); { Запуск мониторинга файловой системы Праметры: pName - имя папки для мониторинга pFilter - комбинация констант FILE_NOTIFY_XXX pSubTree - мониторить ли все подпапки заданной папки pInfoCallBack - адрес callback процедуры, вызываемой при изменении в файловой системе} procedure StartWatch(pName: string; pFilter: cardinal; pSubTree: boolean; pInfoCallBack: TWatchFileSystemCallBack); // Остановка мониторинга procedure StopWatch; implementation uses Classes, Windows, SysUtils; const FILE_LIST_DIRECTORY = $0001; type PFileNotifyInformation = ^TFileNotifyInformation; TFileNotifyInformation = record NextEntryOffset : DWORD; Action : DWORD; FileNameLength : DWORD; FileName : array[0..0] of WideChar; end; WFSError = class(Exception); TWFS = class(TThread) private FName : string; FFilter : Cardinal; FSubTree : boolean; FInfoCallBack : TWatchFileSystemCallBack; FWatchHandle : THandle; FWatchBuf : array[0..4096] of Byte; FOverLapp : TOverlapped; FPOverLapp : POverlapped; FBytesWritte : DWORD; FCompletionPort : THandle; FNumBytes : Cardinal; FOldFileName : string; function CreateDirHandle(aDir: string): THandle; procedure WatchEvent; procedure HandleEvent; protected procedure Execute; override; public constructor Create(pName: string; pFilter: cardinal; pSubTree: boolean; pInfoCallBack: TWatchFileSystemCallBack); destructor Destroy; override; end; var WFS : TWFS; procedure StartWatch(pName: string; pFilter: cardinal; pSubTree: boolean; pInfoCallBack: TWatchFileSystemCallBack); begin WFS:=TWFS.Create(pName, pFilter, pSubTree, pInfoCallBack); end; procedure StopWatch; var Temp : TWFS; begin if Assigned(WFS) then begin PostQueuedCompletionStatus(WFS.FCompletionPort, 0, 0, nil); Temp := WFS; WFS:=nil; Temp.Terminate; end; end; constructor TWFS.Create(pName: string; pFilter: cardinal; pSubTree: boolean; pInfoCallBack: TWatchFileSystemCallBack); begin inherited Create(True); FreeOnTerminate:=True; FName:=IncludeTrailingBackslash(pName); FFilter:=pFilter; FSubTree:=pSubTree; FOldFileName:=EmptyStr; ZeroMemory(@FOverLapp, SizeOf(TOverLapped)); FPOverLapp:=@FOverLapp; ZeroMemory(@FWatchBuf, SizeOf(FWatchBuf)); FInfoCallBack:=pInfoCallBack; Resume end; destructor TWFS.Destroy; begin PostQueuedCompletionStatus(FCompletionPort, 0, 0, nil); CloseHandle(FWatchHandle); FWatchHandle:=0; CloseHandle(FCompletionPort); FCompletionPort:=0; inherited Destroy; end; function TWFS.CreateDirHandle(aDir: string): THandle; begin Result:=CreateFile(PChar(aDir), FILE_LIST_DIRECTORY, FILE_SHARE_READ+FILE_SHARE_DELETE+FILE_SHARE_WRITE, nil,OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OVERLAPPED, 0); end; procedure TWFS.Execute; begin FWatchHandle:=CreateDirHandle(FName); WatchEvent; end; procedure TWFS.HandleEvent; var FileNotifyInfo : PFileNotifyInformation; InfoCallBack : TInfoCallBack; Offset : Longint; begin Pointer(FileNotifyInfo) := @FWatchBuf[0]; repeat Offset:=FileNotifyInfo^.NextEntryOffset; InfoCallBack.FAction:=FileNotifyInfo^.Action; InfoCallBack.FDrive:=FName; SetString(InfoCallBack.FNewFileName,FileNotifyInfo^.FileName, FileNotifyInfo^.FileNameLength ); InfoCallBack.FNewFileName:=Trim(InfoCallBack.FNewFileName); case FileNotifyInfo^.Action of FILE_ACTION_RENAMED_OLD_NAME: FOldFileName:=Trim(WideCharToString(@(FileNotifyInfo^.FileName[0]))); FILE_ACTION_RENAMED_NEW_NAME: InfoCallBack.FOldFileName:=FOldFileName; end; FInfoCallBack(InfoCallBack); PChar(FileNotifyInfo):=PChar(FileNotifyInfo)+Offset; until (Offset=0) or Terminated; end; procedure TWFS.WatchEvent; var CompletionKey: Cardinal; begin FCompletionPort:=CreateIoCompletionPort(FWatchHandle, 0, Longint(pointer(self)), 0); ZeroMemory(@FWatchBuf, SizeOf(FWatchBuf)); if not ReadDirectoryChanges(FWatchHandle, @FWatchBuf, SizeOf(FWatchBuf), FSubTree, FFilter, @FBytesWritte, @FOverLapp, nil) then begin raise WFSError.Create(SysErrorMessage(GetLastError)); Terminate; end else begin while not Terminated do begin GetQueuedCompletionStatus(FCompletionPort, FNumBytes, CompletionKey, FPOverLapp, INFINITE); if CompletionKey<>0 then begin Synchronize(HandleEvent); ZeroMemory(@FWatchBuf, SizeOf(FWatchBuf)); FBytesWritte:=0; ReadDirectoryChanges(FWatchHandle, @FWatchBuf, SizeOf(FWatchBuf), FSubTree, FFilter, @FBytesWritte, @FOverLapp, nil); end else Terminate; end end end; end. unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Memo1: TMemo; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.dfm} uses wfsU; procedure MyInfoCallBack(pInfo: TInfoCallBack); const Action: array[1..3] of String = ('Создание: %s', 'Удаление: %s', 'Изменение: %s'); begin case pInfo.FAction of FILE_ACTION_RENAMED_NEW_NAME: Form1.Memo1.Lines.Add(Format('Переименование: %s в %s', [pInfo.FDrive+pInfo.FOldFileName,pInfo.FDrive+pInfo.FNewFileName])); else if pInfo.FAction<FILE_ACTION_RENAMED_OLD_NAME then Form1.Memo1.Lines.Add(Format(Action[pInfo.Faction], [pInfo.FDrive+pInfo.FNewFileName])); end; end; procedure TForm1.FormCreate(Sender: TObject); begin // мониторим, например изменения всех папок на диске C: (создание, удаление, переименование) StartWatch('C:\', FILE_NOTIFY_CHANGE_DIR_NAME, True, @MyInfoCallBack); end; procedure TForm1.FormDestroy(Sender: TObject); begin StopWatch end;

Отправлен: 09.10.2005, 18:15 Вопрос задал: Dadaev Zaur (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: sir henry Здравствуйте, Dadaev Zaur! Не совсем понял вопрос, но наверное Вам необходимо запустить несколько экземпляров класса типа THread, которые будут создаваться динамически, в зависимости от того, сколько нужно экземпляров. По видимому Вам необходимо создать динамический массив экземпляров класса TWFS, количество которых будет определятся по ходу работы программы: var arWFS: array of TWFS; i, j: integer; Begin {Например, выяснилось, что нужно пять экземпляров для сканирования папок} i:=5; SetLength(arWFS, i-1); {Создание потоков} For j:=0 To i-1 Do arWFS.Create(True); ... End; Запуск того или иного потока можно осуществить по его индексу: arWFS[1].Synchronize(Метод_Где_выполняется_нужный_Вам_код); Приостановить на время и запустить заново поток можно так: arWFS[1].Suspend; {Приостановить} arWFS[1].Resume; {Продолжить} Остановить поток совсем: arWFS[1].Terminate; Запускается он потом заново с помощью Sinchronize();

Ответ отправил: sir henry (статус: Профессор) Отправлен: 09.10.2005, 18:44 Оценка за ответ: 5 Комментарий оценки: Спасибо... С помощью массива проблема решилась... все работает великолепно... :))

Вопрос № 27.478

ЗДРАСТВУЙТЕ !!!! МНЕ ОЧЕНь ИНТЕРЕСНА КАК МО ЖНА В DELPHI. КОНТРОЛИРОВАТ ЗВУК , НАПРИМЕР КАК В ПЛЕЕРЕ WINAMP ПОВИШАТ И СНИЗИТ ЗВУК ... МНЕ ИНТЕРЕСНА КАК ЭТА ПИШИТЦА В ПРОГРАМЕ.. БУДУ ОЧЕНь БЛОГАДАРЕН ЕСЛИ ВЫ ОТТВЕТИТЕ НА МОИ ВАПРОС ДАРАГИЕ ЭКСпЕРТИ ....

Отправлен: 10.10.2005, 03:20 Вопрос задал: ZURAB PAGODIN (статус: Посетитель) Всего ответов: 3 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Samum Здравствуйте, ZURAB PAGODIN! Смотрите примеры в приложении, надеюсь это то, что вам надо. Приложение: { X: The low-order word contains the left-channel volume setting, and the high-order word contains the right-channel setting. A value of 65535 represents full volume, and a value of 0000 is silence. If a device does not support both left and right volume control, the low-order word of dwVolume specifies the volume level, and the high-order word is ignored. } procedure SetVolume(X: Word); var iErr: Integer; i: integer; a: TAuxCaps; begin for i := 0 to auxGetNumDevs do begin auxGetDevCaps(i, Addr(a), SizeOf(a)); if a.wTechnology = AUXCAPS_CDAUDIO then break; end; // Устанавливаем одинаковую громкость для левого и правого каналов. // VOLUME := LEFT*$10000 + RIGHT*1 iErr := auxSetVolume(i, (X * $10001)); if (iErr‹›0) then ShowMessage('No audio devices are available!'); end; function GetVolume: Word; var iErr: Integer; i: integer; a: TAuxCaps; vol: word; begin for i := 0 to auxGetNumDevs do begin auxGetDevCaps(i, Addr(a), SizeOf(a)); if a.wTechnology = AUXCAPS_CDAUDIO then break; end; iErr := auxGetVolume(i, addr(vol)); GetVolume := vol; if (iErr‹›0) then ShowMessage('No audio devices are available!'); end; --------- Если бы программистам за их ошибки отрывали части тела, то в конце концов им пришлось бы использовать голову!

Ответ отправил: Samum (статус: Специалист) Отправлен: 10.10.2005, 07:57

Отвечает: sir henry Здравствуйте, ZURAB PAGODIN! Например, можно использовать такие функции из модуля MMSystem: waveOutSetVolume(OUT, AVolume) ; {Для изменения громкости wave-файлов} midiOutSetVolume(OUT, AVolume) ; {Для изменения громкости midi-файлов} OUT - это хэндл устройства, с помощью которого воспроизводится звук. AVolume - уровень звука, типа DWORD. Здесь старший байт - это правый канал, а младший - левый. Общий уровень громкости регулируется так: AuxSetVolume(OUT, AVolume) Список устройств можно получить так: procedure TForm1.FormCreate(Sender: TObject); var i: integer; cap: TAuxCaps; begin for i := 0 to auxGetNumDevs - 1 do begin auxGetDevCaps(i, Addr(cap), SizeOf(cap)); ListBox1.Items.Add(cap.szPname) end; end; Общий звук будет регулироваться так: var LeftVolume, RightVolume: word; {Уровень громкости в левом (правом) канале} Begin AuxSetVolume(ListBox1.ItemIndex, LeftVolume shl 16 + RightVolume); End; Список Wave и Midi устройств для вывода звука получают с помощью функций: waveOutGetDevCaps() midiOutGetDevCaps() Полностью их синтаксис не привожу - он есть в хелпе.

Ответ отправил: sir henry (статус: Профессор) Отправлен: 10.10.2005, 08:35

Отвечает: Romodos Здравствуйте, ZURAB PAGODIN! Надо использовать миксеры В приложении пример модуля не поместился - слишком большой - пиши на romodos@yandex.ru - вышлю по е-майл, там можно понять --------- FAQ me off!

Ответ отправил: Romodos (статус: 10-ый класс) Отправлен: 10.10.2005, 20:56

Вопрос № 27.498

Помогите! Нужно с сервера(ServerSocket) перекинуть в клиент (ClientSocket) папку с файлами и папками. Подскажите как это реализовать. P.S. Файлы уже научился перекидывать, но вот папки....:(

Отправлен: 10.10.2005, 11:03 Вопрос задал: Сергей Борисович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Werewolf Здравствуйте, Сергей Борисович! Как вариант передавайте дерево подпапок и создавайте их с помощью CreateDir(directoryname) затем передавайте в созданные папки файлы.

Ответ отправил: Werewolf (статус: 10-ый класс) Отправлен: 11.10.2005, 00:38 Оценка за ответ: 5 Комментарий оценки: Точно! :) А это идея....спасибо

Вопрос № 27.502

Здравствуйте, эксперты! Вопрос следубщий: подскажите рабочий DBTree с встроенным drag/drop и предназначенный для работы с TOracleDataSet (DOA) или хотя бы TDataSet.

Отправлен: 10.10.2005, 13:12 Вопрос задал: Lector (статус: 5-ый класс) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Werewolf Здравствуйте, Lector! По поводу DbTree смотрите на http://www.torry.ru/pages.php?id=536 что-нибудь из старенького и бесплатного должно подойти. P.S.: так же Вам может пригодится http://www.farpost.com/personal/dmitryb/oraclecutils_di.htm

Ответ отправил: Werewolf (статус: 10-ый класс) Отправлен: 11.10.2005, 01:05 Оценка за ответ: 4 Комментарий оценки: На torry все компоненты с реалиованным drug и drop платные. А о существовании компонента из PS я не знал.

© 2001-2005, RusFAQ.ru, Россия, Москва. Все права защищены.
Идея, дизайн, программирование, авторское право: Калашников О.А.