Ок, и так поехали:
первая программа, та которая устанавливает таймеры и реагирует на событие для считывания новых таймеров из файла(запущена постоянно):
| Код |
program TimeServ;
uses
Windows,
Messages,
ShFolder,
Classes,
IniFiles,
SysUtils;
const
EventName = '{58F4D8A4-CAD7-46DA-A3D1-238B95659E68}';
type
PDataTimer = ^TDataTimer;
TDataTimer = packed record // структура, адрес переменной которой передается в TimerAPCProc
hTimer: THandle;
StrDateTime: PChar;
end;
var
hEvent: THandle;
idThread: DWORD;
hTimers: array of THandle;
StrFilePath: string;
Sections: TStrings;
function GetStrFilePath: string;
var
StrBuffer: array [0 .. MAX_PATH - 1] of Char;
StrAppDataFolder: string;
begin
ShGetFolderPath(0, CSIDL_APPDATA, 0, 0, StrBuffer);
StrAppDataFolder := StrBuffer + '\TimeManager';
if not DirectoryExists(StrAppDataFolder) then
ForceDirectories(StrAppDataFolder);
Result := StrAppDataFolder + '\TimeManager.ini';
end;
procedure TimerAPCProc(lpArgToCompletionRoutine: PDataTimer; dwTimerLowValue: DWORD; dwTimerHighValue: DWORD); stdcall;
begin
with TIniFile.Create(StrFilePath) do
try
if MessageBox(0, PChar(ReadString(lpArgToCompletionRoutine.StrDateTime, 'Note', '') + #13#10#13#10 + 'Удалить это напоминание?'), 'Напоминание', MB_ICONQUESTION or MB_YESNO) = idYes then
begin
CancelWaitableTimer(lpArgToCompletionRoutine.hTimer);
CloseHandle(lpArgToCompletionRoutine.hTimer);
EraseSection(lpArgToCompletionRoutine.StrDateTime);
Dispose(lpArgToCompletionRoutine);
end;
finally
Free;
end;
end;
procedure InstallTimers;
var
iTimer: integer;
sysTime: SYSTEMTIME;
fTime: FILETIME;
DataTimer: PDataTimer;
begin
with TIniFile.Create(StrFilePath) do
try
ReadSections(Sections);
if Sections.Count > 0 then
begin
SetLength(hTimers, Sections.Count);
for iTimer := 0 to Sections.Count - 1 do
begin
hTimers[iTimer] := CreateWaitableTimer(nil, false, nil);
DateTimeToSystemTime(StrToDateTime(Sections[iTimer]), sysTime);
SystemTimeToFileTime(sysTime, fTime);
LocalFileTimeToFileTime(fTime, fTime);
New(DataTimer);
DataTimer.hTimer := hTimers[iTimer];
DataTimer.StrDateTime := PChar(Sections[iTimer]);
SetWaitableTimer(hTimers[iTimer], TLargeInteger(fTime), Round(Frac(StrToDateTime(ReadString(Sections[iTimer], 'Period', '0'))) * 86400) * 1000, @TimerAPCProc, DataTimer, false); // период записывается в формате DateTime, перевожу в миллисекунды
end;
end;
finally
Free;
end;
end;
procedure UninstallTimers;
var
iTimer: integer;
begin
for iTimer := 0 to Length(hTimers) - 1 do
begin
CancelWaitableTimer(hTimers[iTimer]);
CloseHandle(hTimers[iTimer]);
end;
SetLength(hTimers, 0);
Sections.Clear;
end;
function ThreadEvent(Param: Pointer): DWORD; stdcall;
begin
while true do
begin
if WaitForSingleObject(hEvent, INFINITE) = WAIT_OBJECT_0 then
begin
UninstallTimers;
InstallTimers;
end;
end;
Result := 0;
end;
begin
StrFilePath := GetStrFilePath;
Sections := TStringList.Create;
InstallTimers;
hEvent := CreateEvent(nil, false, false, EventName);
CloseHandle(CreateThread(nil, 0, @ThreadEvent, nil, 0, idThread));
while true do
SleepEx(INFINITE, True);
UninstallTimers;
Sections.Free;
end.
|
теперь вторая, та которая записывает таймеры и дергает событие(запускается нерегулярно):
в ней в принципе ничего сложного нету, она записывает в файл таймеры, которые вводятся с использованием форм и по завершению дергает событие.. Я думаю саму запись ненужно показывать, приведу FormClose, который собственно и дергает событие:
| Код |
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); // Close
var
hEvent: THandle;
begin
hEvent := CreateEvent(nil, false, false, EventName);
if hEvent = INVALID_HANDLE_VALUE then
Exit;
if GetLastError = ERROR_ALREADY_EXISTS then
SetEvent(hEvent);
CloseHandle(hEvent);
end;
|
Код трассировал, SetEvent срабатывает, т.е. само событие 100% дергается.. |
