Статьи Королевства Дельфи
Как заставить MapInfo пересылать
Итак представляю переработанный компонент - 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 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; { Private declarations } 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. И так что добавилось - Метод CreateMapInfoServer; // Создаем наш сервер 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; Здесь мы столкнулись с еще одним методом MapInfo помимо рассмотренных ранее методов Do и Eval- Метод SetCallBack(IDispatch) Описание -
Регистрирует объект механизма-управления объектами OLE (OLE Automation) как получатель уведомлений, генерируемых программой MapInfo. Только одна функция уведомления может быть зарегистрирована в каждый данный момент. Параметр интерфейс Idispatch объекта OLE (COM)
