Просто и ясно о MapInfo и Delphi - Реализация CallBack вызовов MapInfo и перехват в собственной программе

unit Call;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, ActiveX, Dialogs, AxCtrls, Classes, MICallBack_TLB, StdVcl;

type
  TMapInfoCallBack = class(TAutoObject, IConnectionPointContainer, IMapInfoCallBack)
  private
    { Private declarations }
    FConnectionPoints: TConnectionPoints;
    FConnectionPoint: TConnectionPoint;
    FEvents: IMapInfoCallBackEvents;
    { note: FEvents maintains a *single* event sink. For access to more
    than one event sink, use FConnectionPoint.SinkList, and iterate
    through the list of sinks. }
  public
    procedure Initialize; override;
  protected
    { Protected declarations }
    property ConnectionPoints: TConnectionPoints read FConnectionPoints
    implements IConnectionPointContainer;
    procedure EventSinkChanged(const EventSink: IUnknown); override;
    procedure SetStatusText(const Status: WideString); safecall;
    procedure WindowContentsChanged(ID: Integer); safecall;
    procedure MyEvent(const Info: WideString); safecall;
  end;

var
  FDLLCall: THandle;

implementation
uses ComServ;

procedure TMapInfoCallBack.EventSinkChanged(const EventSink: IUnknown);
begin
  FEvents := EventSink as IMapInfoCallBackEvents;
end;

procedure TMapInfoCallBack.Initialize;
begin
  inherited Initialize;
  FConnectionPoints := TConnectionPoints.Create(Self);
  if AutoFactory.EventTypeInfo <> nil then
    FConnectionPoint := FConnectionPoints.CreateConnectionPoint(
    AutoFactory.EventIID, ckSingle, EventConnect)
  else
    FConnectionPoint := nil;
end;


procedure TMapInfoCallBack.SetStatusText(const Status: WideString);
begin
  if FEvents <> nil then
    FEvents.OnChangeStatusText(Status);
end;

procedure TMapInfoCallBack.WindowContentsChanged(ID: Integer);
begin
  if FEvents <> nil then
    FEvents.OnChangeWindowContentsChanged(ID);
end;

procedure TMapInfoCallBack.MyEvent(const Info: WideString);
begin
  if FEvents <> nil then
    FEvents.OnChangeMyEvent(Info);
end;

initialization
  TAutoObjectFactory.Create(ComServer, TMapInfoCallBack, Class_MapInfoCallBack,
  ciMultiInstance, tmApartment);

end.

// если есть обработчик
if FEvents <> nil then
begin
  // Отправка сообщения далее - в данном случае в компонент
  FEvents.OnChangeStatusText(Status);

unit KDMapInfoServer;

interface

uses
  Stdctrls, Dialogs, ComObj, Controls, Variants, ExtCtrls, Windows, ActiveX,
  Messages, SysUtils, Classes, MICallBack_TLB; // - сгенерировано из DLL

type
  // запись "типа" Variant
  TEvalResult = record
    AsVariant: OLEVariant;
    AsString: string;
    AsInteger: Integer;
    AsFloat: Extended;
    AsBoolean: Boolean;
  end;

  type
  // Событие на изменение SetStatusText // генерируется при обратном вызове
  TSetStatusTextEvent = procedure(Sender : TObject; StatusText: WideString) of object;
  // WindowContentsChanged
  TWindowContentsChanged = procedure(Sender : TObject; ID : Integer) of object;
  // Для собственных событий
  TMyEvent = procedure(Sender : TObject; Info : WideString) of object;

  TEvent = class(TInterfacedObject,IUnknown,IDispatch)
  private
    FAppConnection : Integer;
    FAppDispatch : IDispatch;
    FAppDispIntfIID : TGUID;
  protected
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount,
    LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(dispid: Integer; const IID: TGUID; LocaleID: Integer;
    Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  public
    constructor Create( AnAppDispatch : IDispatch; const AnAppDispIntfIID : TGUID);
    destructor Destroy ; override;
  end;


  TKDMapInfoServer = class(TComponent)
  private
    { Private declarations }
    FOwner : TWinControl; // Владелец
    Responder : Variant;  // Для OLE Disp

    FServer : Variant;
    FHandle : THandle;    // Зарезервировано
    FActive : Boolean;    // Запущен/незапущен
    FPanel : TPanel;      // Панель вывода

    srv_OLE : OLEVariant;
    srv_disp : IMapInfoCallBackDisp;
    srv_vTable : IMapInfoCallBack;

    FEvent : TEvent;

    FSetStatusTextEvent : TSetStatusTextEvent; // события компонента
    FWindowContentsChanged : TWindowContentsChanged;
    FMyEvent : TMyEvent;

    Connected : Boolean; // Установлено ли соединение
    MapperID : Cardinal; // ИД окна

    procedure SetActive(const Value: Boolean);
    procedure SetPanel(const Value: TPanel);
    procedure CreateMapInfoServer;
    procedure DestroyMapInfoServer;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    // Данная процедура выполеняет метод сервера MapInfo - Do
    procedure ExecuteCommandMapBasic(Command: string; const Args: array of const);
    function Eval(Command: string; const Args: array of const): TEvalResult; virtual;
    procedure WindowMapDef;
    procedure OpenMap(Path : string);
    procedure RepaintWindowMap;
    // Дополнил для генерации события SetStatus при изменении строки состояния
    // в MapInfo
    procedure DoSetStatus(StatusText: WideString);
    // Дополнил.для генерации события WindowContentsChanged при изменении окна
    // в MapInfo
    procedure DoWindowContentsChanged(ID : Integer);
    // Дополнил для генерации собственно события в MapInfo
    procedure DoMyEvent(Info: WideString);
  published
    { Published declarations }
    // Создает соединение с сервером MapInfo
    property Active: Boolean read FActive write SetActive;
    property PanelMap : TPanel read FPanel write SetPanel;

    // Событие возникающее при изменении строки состояния MapInfo
    property StatusTextChange : TSetStatusTextEvent read FSetStatusTextEvent
    write FSetStatusTextEvent;
    property WindowContentsChanged : TWindowContentsChanged read FWindowContentsChanged
    write FWindowContentsChanged;

    property MyEventChange : TMyEvent read FMyEvent write FMyEvent;
  end;

var
  // О это вообще хитрость - используеться для определения созданного компонента
  // TKDMapInfoServer (см. SetStatusText и Create
  KDMapInfoServ : TKDMapInfoServer;

procedure register;

implementation

// Вот тут то и хитрость если сервер создан то тогда и вызываем SetStatus
//// IF KDMapInfoServ <> nil Then
/// KDMapInfoServ.SetStatus(StatusText);

procedure register;
begin
  RegisterComponents('Kuzan', [TKDMapInfoServer]);
end;

{ TKDMapInfoServer }

constructor TKDMapInfoServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FOwner := AOwner as TWinControl;

  KDMapInfoServ := Self; // **** Вот тут и указываеться созданный компонент
  // TKDMapInfoServer
  FHandle := 0;
  FActive := False;
  Connected := False;
end;

destructor TKDMapInfoServer.Destroy;
begin
  DestroyMapInfoServer;
  inherited Destroy;
end;

procedure TKDMapInfoServer.CreateMapInfoServer;
begin
  try
    FServer := CreateOleObject('MapInfo.Application');
  except
    FServer := Unassigned;
  end;
  // Скрываем панели управления MapInfo
  ExecuteCommandMapBasic('Alter ButtonPad ID 4 ToolbarPosition (0, 0) Show Fixed', []);
  ExecuteCommandMapBasic('Alter ButtonPad ID 3 ToolbarPosition (0, 2) Show Fixed', []);
  ExecuteCommandMapBasic('Alter ButtonPad ID 1 ToolbarPosition (1, 0) Show Fixed', []);
  ExecuteCommandMapBasic('Alter ButtonPad ID 2 ToolbarPosition (1, 1) Show Fixed', []);
  ExecuteCommandMapBasic('Close All', []);
  ExecuteCommandMapBasic('Set ProgressBars Off', []);
  ExecuteCommandMapBasic('Set Application Window %D', [FOwner.Handle]);
  ExecuteCommandMapBasic('Set Window Info Parent %D', [FOwner.Handle]);

  FServer.Application.Visible := True;
  if IsIconic(FOwner.Handle)then ShowWindow(FOwner.Handle, SW_Restore);
  BringWindowToTop(FOwner.Handle);

  srv_ole := CreateOleObject('MICallBack.MapInfoCallBack') as IDispatch;
  srv_vtable := CoMapInfoCallBack.Create;
  srv_disp := CreateComObject(CLASS_MapInfoCallBack) as IMapInfoCallBackDisp;
  FEvent := TEvent.Create(srv_disp,IMapInfoCallBackEvents);

  // Указываем MapInfo что нужно передовать обратные вызовы нашему OLE
  // а тм далее по цепочке (см.начало)
  FServer.SetCallBack(srv_disp);
end;

procedure TKDMapInfoServer.DestroyMapInfoServer;
begin
  ExecuteCommandMapBasic('End MapInfo', []);
  FServer := Unassigned;
end;

procedure TKDMapInfoServer.ExecuteCommandMapBasic(Command: string;
const Args: array of const);
begin
  if Connected then
    try
      FServer.do(Format(Command, Args));
    except
      on E: Exception do MessageBox(FOwner.Handle,
      PChar(Format('Ошибка выполнения () - %S', [E.message])),
      'Warning', MB_ICONINFORMATION or MB_OK);
    end;
end;

function TKDMapInfoServer.Eval(Command: string;
const Args: array of const): TEvalResult;

  function IsInt(Str : string): Boolean;
  var
    Pos : Integer;
  begin
    Result := True;
    for Pos := 1 to Length(Trim(Str)) do
    begin
      if (Str[Pos] <> '0') and (Str[Pos] <> '1') and
      (Str[Pos] <> '2') and (Str[Pos] <> '3') and
      (Str[Pos] <> '4') and (Str[Pos] <> '5') and
      (Str[Pos] <> '6') and (Str[Pos] <> '7') and
      (Str[Pos] <> '8') and (Str[Pos] <> '9') and
      (Str[Pos] <> '.') then
      begin
        Result := False;
        Exit;
      end;
    end;
  end;

var
  ds_save: Char;
begin
  if Connected then
  begin
    Result.AsVariant := FServer.Eval(Format(Command, Args));
    Result.AsString := Result.AsVariant;
    Result.AsBoolean := (Result.AsString = 'T') or (Result.AsString = 't');

    if IsInt(Result.AsVariant) then
    begin
      try
        ds_save := DecimalSeparator;
        try
          DecimalSeparator := '.';
          Result.AsFloat := StrToFloat(Result.AsString);
        finally
          DecimalSeparator := ds_save;
        end;
      except
        Result.AsFloat := 0.00;
      end;

      try
        Result.AsInteger := Trunc(Result.AsFloat);
      except
        Result.AsInteger := 0;
      end;
    end
    else
    begin
      Result.AsInteger := 0;
      Result.AsFloat := 0.00;
    end;
  end;
end;

procedure TKDMapInfoServer.SetActive(const Value: Boolean);
begin
  FActive := Value;

  if FActive then
  begin
    CreateMapInfoServer;
    WindowMapDef;
    Connected := True;
  end
  else
  begin
    if Connected then
    begin
      DestroyMapInfoServer;
      Connected := False;
    end;
  end;
end;

procedure TKDMapInfoServer.SetPanel(const Value: TPanel);
begin
  FPanel := Value;
end;

procedure TKDMapInfoServer.WindowMapDef;
begin
  ExecuteCommandMapBasic('Set Next Document Parent %D Style 1', [FPanel.Handle]);
  RepaintWindowMap;
end;

procedure TKDMapInfoServer.OpenMap(Path: string);
begin
  ExecuteCommandMapBasic('Run Application "%S"', [Path]);
  MapperID := Eval('WindowInfo(FrontWindow(),%D)',[12]).AsInteger;
  RepaintWindowMap;
end;

procedure TKDMapInfoServer.DoSetStatus(StatusText: WideString);
begin
  if Assigned(FSetStatusTextEvent) then
    FSetStatusTextEvent(Self,StatusText);
end;

procedure TKDMapInfoServer.DoWindowContentsChanged(ID: Integer);
begin
  if Assigned(FWindowContentsChanged) then
    FWindowContentsChanged(Self,ID);
end;

procedure TKDMapInfoServer.DoMyEvent(Info: WideString);
begin
  if Assigned(FWindowContentsChanged) then
    FMyEvent(Self,Info);
end;

procedure TKDMapInfoServer.RepaintWindowMap;
begin
  with PanelMap do
    MoveWindow(MapperID, 0, 0, FPanel.ClientWidth, FPanel.ClientHeight, True);
end;

{ TEvent }

function TEvent._AddRef: Integer;
begin
  Result := 2; // Заглушка
end;

function TEvent._Release: Integer;
begin
  Result := 1; // Заглушка
end;

constructor TEvent.Create(AnAppDispatch: IDispatch;
const AnAppDispIntfIID: TGUID);
begin
  inherited Create;
  FAppDispatch := AnAppDispatch;
  FAppDispIntfIID := AnAppDispIntfIID;
  // Передадим серверу
  InterfaceConnect(FAppDispatch,FAppDispIntfIID,self,FAppConnection);
end;

destructor TEvent.Destroy;
begin
  InterfaceDisConnect(FAppDispatch,FAppDispIntfIID,FAppConnection);
  inherited;
end;

function TEvent.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount,
LocaleID: Integer; DispIDs: Pointer): HResult;
begin
  // Заглушка не реализовано
  Result := E_NOTIMPL;
end;

function TEvent.GetTypeInfo(index, LocaleID: Integer;
out TypeInfo): HResult;
begin
  // Заглушка не реализовано
  Result := E_NOTIMPL;
end;

function TEvent.GetTypeInfoCount(out Count: Integer): HResult;
begin
  // Заглушка не реализовано
  Count := 0;
  Result := S_OK;
end;

function TEvent.Invoke(dispid: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
var
  Info,Status : string;
  IDWin : Integer;
begin
  case dispid of
    1 :
    begin
      Status := TDispParams(Params).rgvarg^[0].bstrval;
      if KDMapInfoServ <> nil then
        KDMapInfoServ.DoSetStatus(Status);
    end;
    2 :
    begin
      IDWin := TDispParams(Params).rgvarg^[0].bval;
      if KDMapInfoServ <> nil then
        KDMapInfoServ.DoWindowContentsChanged(IDWin);
    end;
    3 :
    begin
      Info := TDispParams(Params).rgvarg^[0].bstrval;
      if KDMapInfoServ <> nil then
        KDMapInfoServ.DoMyEvent(Info);
    end;
  end;
  Result := S_OK;
end;

function TEvent.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  Result := E_NOINTERFACE;
  if GetInterface(IID,Obj) then
    Result := S_OK;
  if IsEqualGUID(IID,FAppDispIntfIID) and GetInterface(IDispatch,Obj) then
    Result := S_OK;
end;

end.

  // Создаем наш сервер OLE
  srv_ole := CreateOleObject('MICallBack.MapInfoCallBack') as IDispatch;
  srv_vtable := CoMapInfoCallBack.Create;
  // Получаем Idispatch созданного сервера
  srv_disp := CreateComObject(CLASS_MapInfoCallBack) as IMapInfoCallBackDisp;
  FEvent := TEvent.Create(srv_disp,IMapInfoCallBackEvents);
  // Указываем MapInfo что нужно передовать обратные вызовы нашему OLE серверу
  // а там далее по цепочке (см.начало)
  FServer.SetCallBack(srv_disp);
end;

TEvent = class(TInterfacedObject,IUnknown,IDispatch)
private
  FAppConnection : Integer;
  FAppDispatch : IDispatch;
  FAppDispIntfIID : TGUID;
protected
  function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  function _AddRef: Integer; stdcall;
  function _Release: Integer; stdcall;
  function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  function GetTypeInfo(index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  function Invoke(dispid: Integer; const IID: TGUID; LocaleID: Integer;
  Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
public
  constructor Create( AnAppDispatch : IDispatch;
  const AnAppDispIntfIID : TGUID);
  destructor Destroy ; override;
end;

FEvent := TEvent.Create(srv_disp,IMapInfoCallBackEvents);