vic85

16 октября, 2018

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

2 октября, 2018

Ищу delphi разработчика для написания не глючного и без тормозов (если такое возможно) плеера на базе ffmpeg для android/ios. Демо с сайта http://flashavconverter.com у меня на андроиде вылетает.

18 августа, 2017

Я использую IStream, при компиляции под винду он лежит в WinApi.AtiveX, при компиляции под макось кажется в Types. TOleStream пришлось выдрать для макоси в отдельный файл, его же использую и для винды в вместо того что в VCL.ActiveX, так как у нас используется один сторонний компонент, который не работает если в fmx приложении подключены модули из VCL (а при подключении VCL.ActiveX к приложению это происходит)

Скрытый текст


{
  Вспомогательные классы для Com, так как Com под мак нет,
  то и модуль System.Win.ComObj в Mac версии приложения использовать нельзя.

  В этот модуль вынесены необходимые функции и классы для работы с интерфейсом IStream
}
unit suComHelpersUnit.FMX;

interface

uses
  {$IFDEF MSWINDOWS}
  WinApi.ActiveX,
  {$ELSE}
  System.Types,
  {$ENDIF}

  System.Classes, System.SysUtils,

  suStreamsConsts;

type
  TOleStream = class(TStream)
  private
    FStream: IStream;
  protected
    function GetIStream: IStream;
  public
    constructor Create(const Stream: IStream);

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
  end;

function Succeeded(Res: HResult): Boolean;

{ Raise EOleSysError exception if result code indicates an error }

procedure OleCheck(Result: HResult);

implementation
const
  SOleError = 'OLE error %.8x';

type
{ OLE exception classes }

  EOleError = class(Exception);

  EOleSysError = class(Exception)
  private
    FErrorCode: HRESULT;
  public
    constructor Create(const Message: UnicodeString; ErrorCode: HRESULT;
      HelpContext: Integer);
    property ErrorCode: HRESULT read FErrorCode write FErrorCode;
  end;

function Succeeded(Res: HResult): Boolean;
begin
  Result := Res and $80000000 = 0;
end;

{ Raise EOleSysError exception from an error code }

procedure OleError(ErrorCode: HResult);
begin
  raise EOleSysError.Create('', ErrorCode, 0);
end;

{ Raise EOleSysError exception if result code indicates an error }

procedure OleCheck(Result: HResult);
begin
  if not Succeeded(Result) then OleError(Result);
end;

{ EOleSysError }

constructor EOleSysError.Create(const Message: UnicodeString; ErrorCode: HRESULT;
  HelpContext: Integer);
var
  S: string;
begin
  S := Message;
  if S = '' then
  begin
    S := SysErrorMessage(Cardinal(ErrorCode));
    if S = '' then
      FmtStr(S, SOleError, [ErrorCode]);
  end;
  inherited CreateHelp(S, HelpContext);
  FErrorCode := ErrorCode;
end;

{ TOleStream }

constructor TOleStream.Create(const Stream: IStream);
begin
  FStream := Stream;
end;

function TOleStream.Read(var Buffer; Count: Integer): Longint;
begin
  OleCheck(FStream.Read(@Buffer, Count, @Result));
end;

function TOleStream.Seek(Offset: Integer; Origin: Word): Longint;
var
  NewPos: TsuLargeIntOrLargeUInt;
begin
  OleCheck(FStream.Seek(Offset, Origin, NewPos));
  Result := NewPos;
end;

function TOleStream.Write(const Buffer; Count: Integer): Longint;
begin
  OleCheck(FStream.Write(@Buffer, Count, @Result));
end;

function TOleStream.GetIStream: IStream;
begin
  Result := FStream;
end;

end.

и


unit suStreamsConsts;

{$I CompilerDefines.inc}

interface

uses
  Types;

type
  TsuLongIntOrFixedUInt = {$IFDEF VCL_XE8_OR_ABOVE}FixedUInt{$ELSE}Longint{$ENDIF};
  PsuLongIntOrFixedUInt = {$IFDEF VCL_XE8_OR_ABOVE}PFixedUInt{$ELSE}PLongint{$ENDIF};
  TsuLongIntOrDWORD = {$IFDEF VCL_XE8_OR_ABOVE}DWORD{$ELSE}Longint{$ENDIF};
  TsuLargeIntOrLargeUInt ={$IFDEF VCL_XE8_OR_ABOVE}UInt64{$ELSE}Int64{$ENDIF};

implementation

end.

17 августа, 2017

Я собрал пример из стартпоста на 10.1 Berlin - при выгрузке dll приложение падает, если собрать либу как bpl или добавить в CloseHD вызов FinalizeAllExceptSystemUnits из предыдущего моего коммента то выгружается все нормально. Значит дело было в локах из DllMain, но остается совершенно другая проблема.

При закрытии самого хоста в деструкторе application все падает. Дело в том что при уничтожении формы ищется новое активное окно, в нормальном приложении оно не находится и все закрывается, а после выгрузки загруженной dll c fmx такое окно находится - это ApplicationHWND из dll, оно создается при создании формы но не уничтожается. После выгрузки dll окно остается висеть, и его оконная процедура указывает на уже выгруженную область, и когда VCL находит этот хэндл и пытается сделать его активным - винда посылает этому окно сообщение и для его обработки вызывает WndProc окна которого уже нет. Все помирает.

FMX при создании окна Application позволяет получить хэндл окна снаружи с помощью RegisterApplicationHWNDProc, похоже именно так делает сама delphi что бы в себе отображать fmx формы в самой среде в десигнтайме. Что бы повторить этот трюк нужно экспортировать из dll еще одну функцию:

procedure InitApplication(VclApplicationHandleProc, VclApplicationStateProc: Pointer);
begin
  FMX.Platform.Win.RegisterApplicationHWNDProc(VclApplicationHandleProc);
  if FMX.Forms.Application <> nil then
    FMX.Forms.Application.ApplicationStateQuery := VclApplicationStateProc;
end;

Ну а в самом хосте вызвать эту функцию:

TInitVCLApplicationFunc = procedure(VclApplicationHandleProc, VclApplicationStateProc: Pointer);

var
  InitApplication: TInitVCLApplicationFunc;

function VclApplicationHandle: HWND;
begin
  Result := Vcl.Forms.Application.Handle;
end;

type
  TFMXApplicationState = (None, Running, Terminating, Terminated);

function VclApplicationState: TFMXApplicationState;
begin
  if Vcl.Forms.Application <> nil then
    Result := TFMXApplicationState.Running
  else
    Result := TFMXApplicationState.None;
end;

...

procedure TForm1.Button3Click(Sender: TObject);
begin
  HLib:=0;
  try
    HLib := LoadLibrary('Project1.dll');
    if HLib > HINSTANCE_ERROR then
      begin
        InitApplication := GetProcAddress(HLib,'InitApplication');
        CreateHD := GetProcAddress(HLib,'CreateHD');
        CloseHD := GetProcAddress(HLib,'CloseHD');      
      end else ShowMessage('Библиотека не найдена');

      InitApplication(@VclApplicationHandle, @VclApplicationState);
  except
    if HLib > HINSTANCE_ERROR then FreeLibrary(HLib);
  end;
end;

Все это набросано на коленке, и тестировалось на пустой форме, возможно есть еще какие-то ньюансы которые должны знать разработчики FMX.

Astghik · 16 августа, 2017

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

procedure Init(ParentWindow: HWND; const Rect: Windows.TRect); stdcall;
begin
  try
    StartupInput.DebugEventCallback := nil;
    StartupInput.SuppressBackgroundThread := False;
    StartupInput.SuppressExternalCodecs   := False;
    StartupInput.GdiplusVersion := 1;
    GdiplusStartup(gdiplusToken, @StartupInput, nil);

    Form1 := TForm1.Create(nil);
    Form1.Show;

    if ParentWindow <> 0 then
    begin
      //Скроем иконку приложения с панели задач
      ShowWindow(ApplicationHWND, SW_HIDE);

      //Сменим стиль окна что бы оно не перехватывало фокус с родительского окна
      SetWindowLong(FmxHandleToHWND(Form1.Handle), GWL_STYLE,
        GetWindowLong(FmxHandleToHWND(Form1.Handle), GWL_STYLE) and (not WS_POPUP) OR WS_CHILD);

      //Встроим окно в родительское
      Windows.SetParent(FmxHandleToHWND(Form1.Handle), ParentWindow);

      //Установим размеры окна такими которыми инициализирована DLL
      SetWindowPos(FmxHandleToHWND(Form1.Handle), 0, Rect.Left, Rect.Top,
        RectWidth(Rect), RectHeight(Rect), 0);
    end;
  except
    on E: Exception do
      MessageBox(0, PChar(E.Message), '', 0);
  end;
end;

Эта функция создаст форму и встроит ее на хост в vcl приложении. У формы в dfm должен быть убраны границы что бы оно вписалось. Так же для того что бы форма изменяла размеры вписываясь в хост экспортируем функцию получения хэндла

function GetFormHandle: HWND; stdcall;
begin
  Result := 0;

  try
    Result := FormToHWND(Form1);
  except
    on E: Exception do
      MessageBox(0, PChar(E.Message), '', 0);
  end;
end;

Собственно в хосте загружаем dll, и создаем форму кидая ее на панель

Init(panel1.Handle, panel1.ClientRect);

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

procedure THostForm.Panel1Resize(Sender: TObject);
var
  h: HWND;
  Rect: Windows.TRect;
begin
  h := 0;
  Rect := Panel1.ClientRect;

  if Assigned(FGetFormHandleProc) then
    h := FGetFormHandleProc;

  if h <> 0 then
    SetWindowPos(h, 0, Rect.Left, Rect.Top,
      RectWidth(Rect), RectHeight(Rect), 0);
end;

Вот так получается втсроить FMX форму из Dll в VCL приложение

16 августа, 2017

Столкнулся с похожей проблемой. Зависать FreeLibrary может если в dll в секции финализации какого-то модуля есть что-то что не положено делать в DLLMain, а делать там не положено очень много чего. Очевидное решение вызвать всю финализацию до выгрузки библиотеки. Это можно сделать если собрать dll как bpl пакет, это будет такая же dll, но у нее будут экспортироваться функции Initialize и finalize, об этом как раз есть в цикле статей из предыдущего совета. Мне помогло, но не понравилось что в bpl суется много всего и размер библиотеки сильно вырастает. Если bpl не подходит вот еще несколько костылей

1) Загрузить dll из памяти, не средствами винды а самостоятельно, примеров в интернете куча, в этом случае DllMain вызывается не загрузчиком винды (со своими локами системных структур и дедлоками), а нашим кодом который ничего не блокирует, соответственно все проходит гладко. У меня такой способ заработал. Не на всех dll такое заработает, зависит от полности эмуляции загрузчика винды, на обычной форме сработал самый простой вариант c адаптацией под Delphi 2010.

2) На стэковерфлоу у человека похожая проблема и ему помогла загрузка и выгрузка dll из секции инициализации/финализации хоста (не проверял, может и перевел не верно что он там пишет)

3) Я попробовал эмулировать вызов FinalizeUnits, тоже сработало, правда используются хаки:

{
  Модуль позволяет решить проблему с зависанием при выгрузки dll с FMX формой.
  Модуль нужно подключить самым первым в dpr файле, до подключения любых файлов
  с FMX, и вызвать функцию FinalizeAllExceptSystemUnits непосредственно перед
  выгрузкой dll через FreeLibrary.

  Например ваша dll экспортирует функцию уничтожения формы, которую вызывает
  хост перед выгрузкой, например

  procedure Done; stdcall;
  begin
    try
      //Уничтожим форму
      FreeAndNil(Form1);

      //Произведем финализацию модулей которая должна быть выполнена
      //в FreeLibrary, но все зависает
      FinalizeAllExceptSystemUnits;

      //Освобождаем GDI именно после финализации FMX
      if Assigned(GenericSansSerifFontFamily) then
        GenericSansSerifFontFamily.Free;
      if Assigned(GenericSerifFontFamily) then
        GenericSerifFontFamily.Free;
      if Assigned(GenericMonospaceFontFamily) then
        GenericMonospaceFontFamily.Free;
      if Assigned(GenericTypographicStringFormatBuffer) then
        GenericTypographicStringFormatBuffer.free;
      if Assigned(GenericDefaultStringFormatBuffer) then
        GenericDefaultStringFormatBuffer.Free;
      GdiplusShutdown(gdiplusToken);
    except
      on E: Exception do
        OutputDebugString(PChar(E.Message));
    end;
  end;
  
  author: Виктор Федоренков
  email: victor.fedorenkov@gmail.com
  skype: victor_fedorenkov
}
unit suEmulFinalizeUnitsForUnloadDllUnit;

interface

uses
  Windows,
  SysUtils;

procedure FinalizeAllExceptSystemUnits;

implementation

var
  _IsFinalizedThisUnit: Boolean = False;

//Получение структуры PackageInfo нашего приложения
//В System она находится в переменной InitTable, но не видна из других модулей
function GetInitTable: PackageInfo;
var
  Lib: PLibModule;
  Offset: LongWord;
  TypeInfo: PPackageTypeInfo;
begin
  Result := nil;

  Lib := LibModuleList;

  if not Assigned(Lib) then
    Exit;

  //Если загружено несколько модулей (BPL пакетов), то выходим,
  //я не изучал как работает механизм загрузки/выгрузки BPL, поэтому на всякий
  //случай выходим
  if Assigned(Lib^.Next) then
    Exit;

  Typeinfo := Lib^.TypeInfo;
  if Assigned(TypeInfo) then
  begin
    //Мы имеем TPackageTypeInfo
    //Теперь по нему можно получить PackageInfo
    //Воспользуемся особенностями компилятора.
    //В IDA видно, что ссылка TypeInfo указывает на середину структуры
    //PackageInfo программы
    //Поэтому для того что бы вычислить PackageInfo нужно вычесть из адреса
    //TypeInfo смещение этого поля
    Offset := LongWord(@PackageInfoTable(nil^).TypeInfo);
    Result := PackageInfo(PByte(TypeInfo) - Offset);
  end;
end;

//Проведем финализацию всего кроме RTL
procedure FinalizeAllExceptSystemUnits;
var
  P: Pointer;
  Count: Integer;
  OldProtect: LongWord;
  LExitProc: procedure;
  InitTable: PackageInfo;
  Table: PUnitEntryTable;
begin
  while ExitProc <> nil do
  begin
    @LExitProc := ExitProc;
    ExitProc := nil;
    LExitProc;
  end;

  InitTable := GetInitTable;

  if not Assigned(InitTable) then
    Exit;

  Table := InitTable^.UnitInfo;

  if not Assigned(Table) then
    Exit;

  //Мы не можем получить доступ к количеству инициализированных модулей, поэтому
  //будем работать из расчета что были инициализированы все модули.
  //Ведь так и есть, инициализирована только часть модулей может быть если
  //при нициализации произошло исключние в одном из модулей, но тогда будет
  //запущена финализация всего и видимо библиотека не будет загружена
  Count := InitTable^.UnitCount;

  //Разрешаем изменять структуру в которой хранятся ссылки на инициализаю/финализацию всех юнитов
  //для того что бы затирать уже вызваные секции финализации
  if not VirtualProtect(Table, SizeOf(PackageUnitEntry) * Count,
        PAGE_READWRITE, OldProtect) then
    Exit;

  try
    //Вызываем секции финализации пока не будет вызвана секция этого модуля
    //Так как этот модуль указан первым в dpr файле, то перед ним останется
    //только системные модули (менеджер памяти, sysutils) которые и без того
    //нормально финализируются в dll, и их работа нужна что бы отработать
    //выгрузку dll
    while not _IsFinalizedThisUnit do
    begin
      Dec(Count);

      //Получим указатель на секцию финализации модуля
      P := Table^[Count].FInit;

      //Удалим из структуры указатель на эту функцию что бы родной механизм
      //финализации повторно не начал ее выгружать
      Table^[Count].FInit := nil;

      if Assigned(P) and Assigned(Pointer(P^)) then
      asm
        //Похоже какой-то баг компилятора в 10.1 Berlin, и вызов финализации
        //через TProc(P)(; как это сделано в оригинальной System.FinalizeUnits падает,
        //поэтому вызываем ассемблером
        call [p];
      end;
    end;
  except
    FinalizeAllExceptSystemUnits;  //Пробуем финализировать другие модули
    raise;
  end;
end;

initialization

finalization
  //Выставим флаг что прошла финализация модуля
  _IsFinalizedThisUnit := True;
end.

Интересно услышать комментарий спецов по последнему способу, может я что-то не учел

Brovin Yaroslav · 7 октября, 2014

Посмотри у меня в блоге пример

http://victor-vik.blogspot.ru/2014/09/how-execute-console-application-with.html

Войти

vic85

Постов

Зарегистрирован

Посещение

Победитель дней

Тип контента

Профили

Форумы

Сообщения, опубликованные vic85

Ищу разработчика для создания не глючного видео плеера на основе ffmpeg для IOS/Android

Ищу разработчика для создания не глючного видео плеера на основе ffmpeg для IOS/Android

Аналог IStream для FMX

Зависание приложения при выгрузке dll библиотеки с формой FireMonkey

встраивание Fire Monkey в Windows приложение

Зависание приложения при выгрузке dll библиотеки с формой FireMonkey

[OSX] Как прочитать вывод другого консольного приложения из своего?

Сайт

FGX

Активность