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);

 BringWindowTo(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  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;