Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Начинающим";
Текущий архив: 2013.03.22;
Скачать: [xml.tar.bz2];

Вниз

Кол-во запущенных экземпляров программы   Найти похожие ветки 

 
Влад_   (2012-04-22 12:07) [0]

Здравствуйте. Есть самописная функция, которая возвращает количество запущенных копий программы, но даже если запущена одна копия функция всегда возвращает 2. Не пойму в чем ошибка? Вот код:

function GetInsNum(const ExePath: string): Integer;
var
 hProcessSnap, hModuleSnap: THandle;
 pe32: PROCESSENTRY32;
 me32: MODULEENTRY32;
begin
 Result := 0;
 hProcessSnap := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);
 if hProcessSnap = INVALID_HANDLE_VALUE then
   Exit;
 pe32.dwSize := SizeOf(PROCESSENTRY32);
 me32.dwSize := SizeOf(MODULEENTRY32);
 if Process32First(hProcessSnap, pe32) then
 begin
   repeat
     hModuleSnap := CreateToolHelp32Snapshot(TH32CS_SNAPMODULE, pe32.th32ProcessID);
     if hModuleSnap <> INVALID_HANDLE_VALUE then
     begin
       if Module32First(hModuleSnap, me32) then
         if lstrcmpi(me32.szExePath, PChar(ExePath)) = 0 then
           Inc(Result);
       CloseHandle(hModuleSnap);
     end;
   until not Process32Next(hProcessSnap,pe32);
 end;
 CloseHandle(hProcessSnap);
end;

procedure TForm1.Button14Click(Sender: TObject);
begin
 ShowMessage(IntToStr(GetInsNum(ParamStr(0)))); // 2 ?
end;


 
Влад_   (2012-04-22 12:13) [1]

В принципе, функцию можно было бы сделать булевой и ограничится проверкой:

...
Result := lstrcmpi(me32.szExePath, PChar(ExePath)) = 0;
...
until not Process32Next(hProcessSnap,pe32) or not Result;

Но просто интересно в чем ошибка


 
KilkennyCat ©   (2012-04-22 12:19) [2]

ну дык запусти дебаггером


 
Омлет ©   (2012-04-22 12:35) [3]

Не знаю, в чем ошибка, но вот эта работает верно (но начиная с NT или XP):

function GetInsNum2(const ExePath: string): Integer;
var
 I: Integer;
 ASize: DWORD;
 hMod: HMODULE;
 hProcess: THandle;
 PIDArray: array [0..1023] of DWORD;
 ModuleName: array [0..MAX_PATH] of Char;
begin
 Result := 0;
 if EnumProcesses(@PIDArray, SizeOf(PIDArray), ASize) then
 begin
   for I := 0 to ASize div SizeOf(DWORD) - 1 do
   begin
     hProcess := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, PIDArray[I]);
     if hProcess <> 0 then
     try
       EnumProcessModules(hProcess, @hMod, SizeOf(hMod), ASize);
       GetModuleFilenameEx(hProcess, hMod, ModuleName, SizeOf(ModuleName));
       if ModuleName = ExePath then
         inc(Result);
     finally
       CloseHandle(hProcess);
     end;
   end;
 end;
end;


 
Омлет ©   (2012-04-22 12:37) [4]

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


 
Влад_   (2012-04-22 12:48) [5]

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


 
begin...end ©   (2012-04-22 13:31) [6]

> Влад_   (22.04.12 12:07)

repeat
  if pe32.th32ProcessID = 0 then
    Continue;
  ...
until not Process32Next(hProcessSnap, pe32)



Страницы: 1 вся ветка

Форум: "Начинающим";
Текущий архив: 2013.03.22;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.46 MB
Время: 0.068 c
2-1335471178
SIV5000
2012-04-27 00:12
2013.03.22
Меню > Создать


2-1334303031
rikitiki2012
2012-04-13 11:43
2013.03.22
Realtex


2-1330947283
Vyacheslav
2012-03-05 15:34
2013.03.22
Две формы: FormStyle=fsStayOnTop.. Form2 всегда выше Form1?


15-1335609759
Тут иногда бываю
2012-04-28 14:42
2013.03.22
Как точно располагать Gui в редакторе?


15-1349295678
ProgRAMmer Dimonych
2012-10-04 00:21
2013.03.22
Подсчёт ссылок на строку таблицы в MySQL





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский