ActiveX를 특정 URL에서만 실행

From YYpBD's MediaWiki

[강좌] ActiveX Form 에 parameter 전달, 특정 URL 에서만 실행  
{==========================================================
아래 소스는 제가 개발했던 ActiveX Installer 의 소스입니다.
호출되는 함수중 몇가지는 다른 unit 에 있어 이대로 컴파일 하면 에러가 날것입니다.

기본적으로 생성되는 ActiveXForm 의 소스와 아래 소스를 비교하셔서
빠진 부분을 복사해서 사용하시면 됩니다.
물론 ClassName 등은 새로 생성된 것으로 바꿔주시구요.

private 부분에 추가된 함수들은 그냥 복사해서 사용하세요.
파고 들어가면 머리 깨집니다. -_-;;

ExecuteInstallDlg; 프로시져에서 실제 무엇을 하는지를 결정합니다.
전 이 프로시져에서 새로운 폼을 띄워서 셋업파일 전송의 프로그레시브바를 넣었습니다.

아래 소스의 실행모습은
www.4nb.co.kr 의 화상채팅을 클릭하시면 실행되는 예를 보실수 있습니다.

아래 소스에 포함된 기능으로는

1. object 태그의 param 으로 부터 넘어온 인자를 읽어들인다.
2. 특정 Domain 이외의 것에서는 실행되지 않는다.(주석처리 되었음)
3. 각종 보안창을 잠재운다.
4. ActiveXForm 의 Create event 를 강제로 만든다.
  (form create event 에서는 전달된 parameter 을 알수가 없다.)

}//==========================================================

unit AXChat_4nbImpl1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, AXChat_4nbProj1_TLB, StdVcl,
// add
MSHTML, userfunc, installunit, StdCtrls;

const
USER_ACTIVEFORM_START = wm_user+100;
// <=======


type
TAXChat_4nb = class(TActiveForm, IAXChat_4nb, IPersistPropertyBag, IObjectSafety)
   Button1: TButton;
   procedure Button1Click(Sender: TObject);
   procedure ActiveFormCreate(Sender: TObject);
private
   { Private declarations }
FEvents: IAXChat_4nbEvents;

// Active X 파라미터를 초기에 읽기 위한 Message Procedure
procedure ActiveXformCreateinit(var msg:TMessage);message USER_ACTIVEFORM_START;
// <=========

   procedure ActivateEvent(Sender: TObject);
procedure ClickEvent(Sender: TObject);
   procedure CreateEvent(Sender: TObject);
   procedure DblClickEvent(Sender: TObject);
   procedure DeactivateEvent(Sender: TObject);
   procedure DestroyEvent(Sender: TObject);
   procedure KeyPressEvent(Sender: TObject; var Key: Char);
   procedure PaintEvent(Sender: TObject);
protected
   { Protected declarations }
   procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); override;
   procedure EventSinkChanged(const EventSink: IUnknown); override;
   function Get_Active: WordBool; safecall;
   function Get_AutoScroll: WordBool; safecall;
   function Get_AutoSize: WordBool; safecall;
   function Get_AxBorderStyle: TxActiveFormBorderStyle; safecall;
   function Get_Caption: WideString; safecall;
   function Get_Color: OLE_COLOR; safecall;
   function Get_Cursor: Smallint; safecall;
   function Get_DoubleBuffered: WordBool; safecall;
   function Get_DropTarget: WordBool; safecall;
   function Get_Enabled: WordBool; safecall;
   function Get_Font: IFontDisp; safecall;
   function Get_HelpFile: WideString; safecall;
   function Get_KeyPreview: WordBool; safecall;
   function Get_PixelsPerInch: Integer; safecall;
   function Get_PrintScale: TxPrintScale; safecall;
   function Get_Scaled: WordBool; safecall;
   function Get_Visible: WordBool; safecall;
   function Get_VisibleDockClientCount: Integer; safecall;
procedure _Set_Font(const Value: IFontDisp); safecall;
   procedure Set_AutoScroll(Value: WordBool); safecall;
   procedure Set_AutoSize(Value: WordBool); safecall;
   procedure Set_AxBorderStyle(Value: TxActiveFormBorderStyle); safecall;
   procedure Set_Caption(const Value: WideString); safecall;
   procedure Set_Color(Value: OLE_COLOR); safecall;
   procedure Set_Cursor(Value: Smallint); safecall;
   procedure Set_DoubleBuffered(Value: WordBool); safecall;
   procedure Set_DropTarget(Value: WordBool); safecall;
   procedure Set_Enabled(Value: WordBool); safecall;
   procedure Set_Font(var Value: IFontDisp); safecall;
   procedure Set_HelpFile(const Value: WideString); safecall;
   procedure Set_KeyPreview(Value: WordBool); safecall;
   procedure Set_PixelsPerInch(Value: Integer); safecall;
   procedure Set_PrintScale(Value: TxPrintScale); safecall;
   procedure Set_Scaled(Value: WordBool); safecall;
procedure Set_Visible(Value: WordBool); safecall;

// Add
{ IPersistPropertyBag }
// IPersistPropertyBag 구현을 위한 추가부분..
// param 태그 옵션을 통해 ActiveX 컨트롤로 정보전달을 위해서..
function IPersistPropertyBag.GetClassID = PersistPropBagGetClassID ;
function IPersistPropertyBag.initNew = PersistPropBagInitNew ;
function IPersistPropertyBag.Load = PersistPropBagLoad ;
function IPersistPropertyBag.Save = PersistPropBagSave ;
function PersistPropBagGetClassID(out classID : TCLSID) : HResult; stdcall;
function PersistPropBagInitNew : HResult ; stdcall ;
function PersistPropBagLoad(const pPropBag:IPropertyBag ;
const pErrorLog:IErrorLog) : HResult ; stdcall ;
function PersistPropBagSave(const pPropBag:IPropertyBag ;
fClearDirty:BOOL ; fAveAllProperties:BOOL) : HResult ; stdcall ;

// IObjectSafety 구현을 위한 추가부분..
// 안전하지 못하다는 보안메시지를 나오지 않게하기 위해서..
function ObjectSafetyGetInterfaceSafetyOptions(const IID: TIID;
pdwSupportedOptions,
pdwEnabledOptions: PDWORD): HResult; stdcall;
function IObjectSafety.GetInterfaceSafetyOptions =
ObjectSafetyGetInterfaceSafetyOptions ;
function ObjectSafetySetInterfaceSafetyOptions(const IID: TIID;
dwOptionSetMask,
dwEnabledOptions: DWORD): HResult; stdcall;
function IObjectSafety.SetInterfaceSafetyOptions =
ObjectSafetySetInterfaceSafetyOptions ;
// <=============


public
{ Public declarations }
// ActiveX parameter variable
ParamUserName     : string;
Paramsex          : string;
ParamAge          : string;
ParamLocal        : string;
ParamManImage     : string;
ParamServerIP     : string;
ParamHTTPFileURL  : string;
ParamCompanyName  : string; // 4nb, open4u 등 영문의 trim string
ParamProjectKind  : string; // AVChat, AVMeet, AVCall 등
ParamInstallDlgCaption:string; // Install dialog box caption

ParamExecZipName  : string;
ParamExecName     : string;
ParamDataZipName  : string;
// <=========

procedure Initialize; override;

// add
function GetDOM:string;
procedure ExecuteInstallDlg;
// <==========

end;

implementation

uses ComObj, ComServ;

{$R *.DFM}

{ TAXChat_4nb }

procedure TAXChat_4nb.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage);
begin
{ Define property pages here.  Property pages are defined by calling
   DefinePropertyPage with the class id of the page.  For example,
     DefinePropertyPage(Class_AXChat_4nbPage); }
end;

//==========>
// IPersistPropertyBag의 method들의 구현부..
function TAXChat_4nb.PersistPropBagGetClassID(out classID:TCLSID) : HResult ; stdcall;
begin
classID := Class_AXChat_4nb;
Result := S_OK ;
end ;

function TAXChat_4nb.PersistPropBagInitNew : HResult ; stdcall;
begin
Result := S_OK ;
end ;

function TAXChat_4nb.PersistPropBagLoad(const pPropBag:
IPropertyBag ; const pErrorLog:IErrorLog) : HResult ; stdcall;
var
OV1 : OleVariant ;
OV2 : OleVariant ;
OV3 : OleVariant ;
OV4 : OleVariant ;
OV5 : OleVariant ;
OV6 : OleVariant ;
OV7 : OleVariant ;
OV8 : OleVariant ;
OV9 : OleVariant ;
OV10: OleVariant ;
OV11: OleVariant ;
OV12: OleVariant ;
OV13: OleVariant ;
begin
if pPropBag.Read('name',OV1,pErrorLog)=S_OK then begin
ParamUserName := WideString(OV1);
end ;
if pPropBag.Read('sex',OV2,pErrorLog)=S_OK then begin
ParamSex := WideString(OV2);
end ;
if pPropBag.Read('age',OV3,pErrorLog)=S_OK then begin
ParamAge := WideString(OV3);
end ;
if pPropBag.Read('local',OV4,pErrorLog)=S_OK then begin
ParamLocal := WideString(OV4);
end ;
if pPropBag.Read('manImage',OV5,pErrorLog)=S_OK then begin
ParamManImage:= WideString(OV5);
end ;
if pPropBag.Read('ServerIP',OV6,pErrorLog)=S_OK then begin
ParamServerIP:= WideString(OV6);
end ;
if pPropBag.Read('HttpFileURL',OV7,pErrorLog)=S_OK then begin
ParamHttpFileURL:= WideString(OV7);
end ;
if pPropBag.Read('CompanyName',OV8,pErrorLog)=S_OK then begin
ParamCompanyName:= WideString(OV8);
end ;
if pPropBag.Read('ProjectKind',OV9,pErrorLog)=S_OK then begin
ParamProjectKind:= WideString(OV9);
end ;
if pPropBag.Read('ProjectKindCaption',OV10,pErrorLog)=S_OK then begin
ParamInstallDlgCaption:= WideString(OV10);
end ;
if pPropBag.Read('ExecZipName',OV11,pErrorLog)=S_OK then begin
ParamExecZipName:= WideString(OV11);
end ;
if pPropBag.Read('ExecName',OV12,pErrorLog)=S_OK then begin
ParamExecName:= WideString(OV12);
end ;
if pPropBag.Read('DataZipName',OV13,pErrorLog)=S_OK then begin
ParamDataZipName:= WideString(OV13);
end ;

Result := S_OK ;

end ;

function TAXChat_4nb.PersistPropBagSave(const pPropBag:IPropertyBag ;
   fClearDirty:BOOL ; fAveAllProperties:BOOL) : HResult ; stdcall ;
var
OV1 : OleVariant ;
OV2 : OleVariant ;
OV3 : OleVariant ;
OV4 : OleVariant ;
OV5 : OleVariant ;
OV6 : OleVariant ;
OV7 : OleVariant ;
OV8 : OleVariant ;
OV9 : OleVariant ;
OV10 : OleVariant ;
OV11 : OleVariant ;
OV12 : OleVariant ;
OV13 : OleVariant ;

begin
OV1 := ParamUserName;
pPropBag.Write('name',OV1);

OV2 := ParamSex;
pPropBag.Write('sex',OV2);

OV3 := ParamAge;
pPropBag.Write('age',OV3);

OV4 := ParamLocal;
pPropBag.Write('local',OV4);

OV5 := ParamManImage;
pPropBag.Write('manImage',OV5);

OV6 := ParamServerIP;
pPropBag.Write('ServerIP',OV6);

OV7 := ParamHttpFileURL;
pPropBag.Write('HttpFileURL',OV7);

OV8 := ParamCompanyName;
pPropBag.Write('CompanyName',OV8);

OV9 := ParamProjectKind;
pPropBag.Write('ProjectKind',OV9);

OV10 := ParamInstallDlgCaption;
pPropBag.Write('ProjectKindCaption',OV10);

OV11 := ParamExecZipName;
pPropBag.Write('ExecZipName',OV11);

OV12 := ParamExecName;
pPropBag.Write('ExecName',OV12);

OV13 := ParamDataZipName;
pPropBag.Write('DataZipName',OV13);

Result := S_OK ;
end ;


// IObjectSafety의 method들의 구현부..
function TAXChat_4nb.ObjectSafetyGetInterfaceSafetyOptions(const IID:
  TIID; pdwSupportedOptions,
  pdwEnabledOptions: PDWORD): HResult; stdcall;
begin
Result := S_OK ;
end ;

function TAXChat_4nb.ObjectSafetySetInterfaceSafetyOptions(const IID:
  TIID; dwOptionSetMask, dwEnabledOptions: DWORD): HResult; stdcall;
begin
Result := S_OK ;
end ;
//<=================

procedure TAXChat_4nb.EventSinkChanged(const EventSink: IUnknown);
begin
FEvents := EventSink as IAXChat_4nbEvents;
end;

procedure TAXChat_4nb.Initialize;
begin
inherited Initialize;
OnActivate := ActivateEvent;
OnClick := ClickEvent;
OnCreate := CreateEvent;
OnDblClick := DblClickEvent;
OnDeactivate := DeactivateEvent;
OnDestroy := DestroyEvent;
OnKeyPress := KeyPressEvent;
OnPaint := PaintEvent;
end;

function TAXChat_4nb.Get_Active: WordBool;
begin
Result := Active;
end;

function TAXChat_4nb.Get_AutoScroll: WordBool;
begin
Result := AutoScroll;
end;

function TAXChat_4nb.Get_AutoSize: WordBool;
begin
Result := AutoSize;
end;

function TAXChat_4nb.Get_AxBorderStyle: TxActiveFormBorderStyle;
begin
Result := Ord(AxBorderStyle);
end;

function TAXChat_4nb.Get_Caption: WideString;
begin
Result := WideString(Caption);
end;

function TAXChat_4nb.Get_Color: OLE_COLOR;
begin
Result := OLE_COLOR(Color);
end;

function TAXChat_4nb.Get_Cursor: Smallint;
begin
Result := Smallint(Cursor);
end;

function TAXChat_4nb.Get_DoubleBuffered: WordBool;
begin
Result := DoubleBuffered;
end;

function TAXChat_4nb.Get_DropTarget: WordBool;
begin
Result := DropTarget;
end;

function TAXChat_4nb.Get_Enabled: WordBool;
begin
Result := Enabled;
end;

function TAXChat_4nb.Get_Font: IFontDisp;
begin
GetOleFont(Font, Result);
end;

function TAXChat_4nb.Get_HelpFile: WideString;
begin
Result := WideString(HelpFile);
end;

function TAXChat_4nb.Get_KeyPreview: WordBool;
begin
Result := KeyPreview;
end;

function TAXChat_4nb.Get_PixelsPerInch: Integer;
begin
Result := PixelsPerInch;
end;

function TAXChat_4nb.Get_PrintScale: TxPrintScale;
begin
Result := Ord(PrintScale);
end;

function TAXChat_4nb.Get_Scaled: WordBool;
begin
Result := Scaled;
end;

function TAXChat_4nb.Get_Visible: WordBool;
begin
Result := Visible;
end;

function TAXChat_4nb.Get_VisibleDockClientCount: Integer;
begin
Result := VisibleDockClientCount;
end;

procedure TAXChat_4nb._Set_Font(const Value: IFontDisp);
begin
SetOleFont(Font, Value);
end;

procedure TAXChat_4nb.ActivateEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnActivate;
end;

procedure TAXChat_4nb.ClickEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnClick;
end;

procedure TAXChat_4nb.CreateEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnCreate;
end;

procedure TAXChat_4nb.DblClickEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnDblClick;
end;

procedure TAXChat_4nb.DeactivateEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnDeactivate;
end;

procedure TAXChat_4nb.DestroyEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnDestroy;
end;

procedure TAXChat_4nb.KeyPressEvent(Sender: TObject; var Key: Char);
var
TempKey: Smallint;
begin
TempKey := Smallint(Key);
if FEvents <> nil then FEvents.OnKeyPress(TempKey);
Key := Char(TempKey);
end;

procedure TAXChat_4nb.PaintEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnPaint;
end;

procedure TAXChat_4nb.Set_AutoScroll(Value: WordBool);
begin
AutoScroll := Value;
end;

procedure TAXChat_4nb.Set_AutoSize(Value: WordBool);
begin
AutoSize := Value;
end;

procedure TAXChat_4nb.Set_AxBorderStyle(Value: TxActiveFormBorderStyle);
begin
AxBorderStyle := TActiveFormBorderStyle(Value);
end;

procedure TAXChat_4nb.Set_Caption(const Value: WideString);
begin
Caption := TCaption(Value);
end;

procedure TAXChat_4nb.Set_Color(Value: OLE_COLOR);
begin
Color := TColor(Value);
end;

procedure TAXChat_4nb.Set_Cursor(Value: Smallint);
begin
Cursor := TCursor(Value);
end;

procedure TAXChat_4nb.Set_DoubleBuffered(Value: WordBool);
begin
DoubleBuffered := Value;
end;

procedure TAXChat_4nb.Set_DropTarget(Value: WordBool);
begin
DropTarget := Value;
end;

procedure TAXChat_4nb.Set_Enabled(Value: WordBool);
begin
Enabled := Value;
end;

procedure TAXChat_4nb.Set_Font(var Value: IFontDisp);
begin
SetOleFont(Font, Value);
end;

procedure TAXChat_4nb.Set_HelpFile(const Value: WideString);
begin
HelpFile := String(Value);
end;

procedure TAXChat_4nb.Set_KeyPreview(Value: WordBool);
begin
KeyPreview := Value;
end;

procedure TAXChat_4nb.Set_PixelsPerInch(Value: Integer);
begin
PixelsPerInch := Value;
end;

procedure TAXChat_4nb.Set_PrintScale(Value: TxPrintScale);
begin
PrintScale := TPrintScale(Value);
end;

procedure TAXChat_4nb.Set_Scaled(Value: WordBool);
begin
Scaled := Value;
end;

procedure TAXChat_4nb.Set_Visible(Value: WordBool);
begin
Visible := Value;
end;
function TAXChat_4nb.GetDOM:string;
var
pIOleObject : IOleObject;
pIOleClient : IOleClientSite;
pIOleContainer : IOleContainer;
pDOC : IHTMLDocument2;
pUnk : IUnknown;
begin
result := '';
pUnk := ComObject;
if Assigned( pUnk ) then begin
if SUCCEEDED(pUnk.QueryInterface(IOleObject, pIOleObject)) and
     Assigned( pIOleObject ) then begin
  if SUCCEEDED(pIOleObject.GetClientSite(pIOleClient)) and
      Assigned( pIOleClient ) then begin
   if SUCCEEDED(pIOleClient.GetContainer(pIOleContainer)) and
       Assigned( pIOleContainer ) then begin
    if SUCCEEDED( pIOleContainer.QueryInterface( IHTMLDocument2,
        pDOC )) and Assigned( pDOC ) then begin
     // result := pDOC.Get_url;
     // showmessage(pDOC.Get_title);
     // showmessage(pDOC.Get_domain);
     result :=pDOC.Get_domain;
     // pDOC.Set_url('http://www.4000king.pe.kr/');
     // pDOC how points to an object which implements IHTMLDocument2
     exit;
    end;
   end;
  end;
end;
end;
end;

procedure TAXChat_4nb.ActiveXformCreateinit(var msg:TMessage);
begin
ExecuteInstallDlg;
end;

procedure TAXChat_4nb.Button1Click(Sender: TObject);
begin
ExecuteInstallDlg;
end;

procedure TAXChat_4nb.ActiveFormCreate(Sender: TObject);
begin
// 초기 파라미터 인식을 위한 메세지 보내기
PostMessage(handle, USER_ACTIVEFORM_START, 0, 0);

end;
procedure TAXChat_4nb.ExecuteInstallDlg;
var
installdlg : Tinstalldlg;
// ExecuteLocation:string;
begin
CompanyName:=ChangeBlankChar(trim(ParamCompanyName));
ProgramDir:=CompanyName;
ProjectKind:=ChangeBlankChar(trim(ParamProjectKind));
InstallFormCaption:=ParamInstallDlgCaption;
HTTPFileURL:=CheckHttpFileURL(trim(ParamHttpFileURL));

ExecuteZipFilename:= trim(ParamExecZipName);
ExecuteFilename   := trim(ParamExecName);
DataZipFilename   := trim(ParamDataZipName);

sParam:= '';
sParam:=ChangeBlankChar(trim(ParamUserName)) +' '
  +ChangeBlankChar(trim(ParamSex))+' '
  +ChangeBlankChar(trim(ParamAge))+' '
  +ChangeBlankChar(trim(ParamLocal))+' '
  +ChangeBlankChar(trim(ParamManImage))+' '
  +ChangeBlankChar(trim(ParamServerIP));

// Website 보안
{ ExecuteLocation:=GetDOM;
if (ExecuteLocation<>'www.4nb.co.kr') then begin
showmessage('본 제품은 http://www.4nb.co.kr/ 에서만'+#13+' 실행되도록 설계되었습니다.');
exit;
end;}
// <=============

installdlg := nil;
installdlg := Tinstalldlg.Create(installdlg);
installdlg.caption:=InstallFormCaption;

try
installdlg.Showmodal;
finally
installdlg.Free;
end;
end;

initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
TAXChat_4nb,
Class_AXChat_4nb,
1,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
end.