Показать сообщение отдельно
  #21  
Старый 24.10.2012, 06:00
Аватар для poli-smen
poli-smen poli-smen вне форума
Профессионал
 
Регистрация: 06.08.2012
Адрес: Кривой Рог
Сообщения: 1,791
Версия Delphi: Delphi 7, XE2
Репутация: 4415
По умолчанию

Хоть практическая польза от этой "волшебной" функции довольно сомнительна, но интерес меня всё же пересилил.
Ошибки были и в том месте что я указывал выше, и в ассемблерной вставке, и даже в вызывающей строке. Кроме того я привёл эту функцию к более приличному виду, в результате получилось так:
Код:
procedure RaiseErrorFmt(const Msg: String; const Args: array of const);
begin
  raise Exception.CreateFmt(Msg, Args);
end;

function SetFunction(dll, adress, param: String): DWORD;
var
  hdll: HMODULE;
  LastError: DWORD;
  proc: Pointer;
  Params: array of DWORD;
  Strings: array of String;
  PrmCount, StrCount, p: Integer;
  p1, p2: String;
  //param = integer:8;boolean:true; ...
begin
  hdll := LoadLibrary(Pointer(dll));
  if hdll = 0 then
  begin
    LastError := GetLastError;
    RaiseErrorFmt('При загрузке библиотеки "%s" возникла ошибка №%d: "%s"',
      [dll, LastError, SysErrorMessage(LastError)]);
  end;

  try
    proc := GetProcAddress(hdll, Pointer(adress));
    if not Assigned(proc) then
      RaiseErrorFmt('В библиотеке "%s" отсутствует процедура "%s"', [dll, adress]);

    PrmCount := 0;
    StrCount := 0;

    while param <> '' do
    begin
      p := Pos(':', param);
      if p = 0 then RaiseErrorFmt('Ожидался символ ":" в строке "%s"', [param]);
      p1 := LowerCase(Copy(param, 1, p - 1));
      Delete(param, 1, p);

      p := Pos(';', param);
      if p = 0 then RaiseErrorFmt('Ожидался символ ";" в строке "%s"', [param]);
      p2 := Copy(param, 1, p - 1);
      Delete(param, 1, p);

      if Length(Params) = PrmCount then SetLength(Params, PrmCount + 10);

      if p1 = 'integer' then
      begin
        Params[PrmCount] := StrToInt(p2);
      end else
      if p1 = 'boolean' then
      begin
        Params[PrmCount] := StrToInt(p2);
      end else
      if p1 = 'pchar' then
      begin // Здесь строки нигде не сохранялись, поэтому указатели на них теряли актуальность
        if Length(Strings) = StrCount then SetLength(Strings, StrCount + 10);
        Strings[StrCount] := p2;
        Params[PrmCount] := DWORD(Strings[StrCount]);
        Inc(StrCount);
      end else
      begin
        RaiseErrorFmt('Неподдерживаемый тип "%s"', [p1]);
      end;
      Inc(PrmCount);
    end;

    asm
      PUSH ESI
      PUSH EDI
      MOV  ESI, Params
      MOV  ECX, PrmCount
      NEG  ECX
      LEA  ESP, [ESP + ECX * 4] // Здесь была ошибочная инструкция lea esp, [esp - ecx * 4]
      NEG  ECX
      MOV  EDI, ESP
      CLD
      REP  MOVSD
      MOV  EAX, proc
      CALL EAX
      MOV  Result, EAX // Сохраняем результат работы вызванной функции
      POP  EDI
      POP  ESI
    end;
  finally
    FreeLibrary(hdll);
  end;
end;

// Пример вызова (в исходном варианте здесь была ошибка):
procedure TForm1.Button1Click(Sender: TObject);
begin
  SetFunction('shell32.dll', 'ShellExecuteA', 'Integer:0;PChar:;PChar:calc.exe;PChar:;PChar:;Integer:0;');
end;
Ответить с цитированием