MODULE ComObject;
(**
project = "BlackBox"
organization = "www.oberon.ch"
contributors = "Oberon microsystems"
version = "System/Rsrc/About"
copyright = "System/Rsrc/About"
license = "Docu/BB-License"
changes = ""
issues = ""
**)
IMPORT
SYSTEM, COM, WinApi, WinOle, ComTools;
CONST
ObjectID = "{00010001-1000-11cf-adf0-444553540000}";
streamStr = "CONTENTS";
cbFormat = 200H;
TYPE
IClassFactory = POINTER TO RECORD (WinOle.IClassFactory) END;
Object = POINTER TO RECORD (COM.IUnknown)
ioo: IOleObject;
ido: IDataObject;
ips: IPersistStorage;
ics: WinOle.IOleClientSite;
idah: WinOle.IDataAdviseHolder;
ioah: WinOle.IOleAdviseHolder;
isg: WinOle.IStorage;
ism: WinOle.IStream;
w, h: INTEGER
END;
IOleObject = POINTER TO RECORD (WinOle.IOleObject)
obj: Object
END;
IDataObject = POINTER TO RECORD (WinOle.IDataObject)
obj: Object
END;
IPersistStorage = POINTER TO RECORD (WinOle.IPersistStorage)
obj: Object
END;
VAR
locks: INTEGER;
token: INTEGER;
PROCEDURE PictureOf (obj: Object): WinApi.HMETAFILEPICT;
VAR dc: WinApi.HDC; mf: WinApi.HMETAFILE; mp: WinApi.PtrMETAFILEPICT;
rc: WinApi.RECT; res: INTEGER; h: WinApi.HMETAFILEPICT; oldb, oldp: WinApi.HGDIOBJ;
BEGIN
dc := WinApi.CreateMetaFileW(NIL);
IF dc # 0 THEN
res := WinApi.SetMapMode(dc, WinApi.MM_ANISOTROPIC);
res := WinApi.SetWindowOrgEx(dc, 0, 0, NIL);
res := WinApi.SetWindowExtEx(dc, 20, 20, NIL);
oldb := WinApi.SelectObject(dc, WinApi.GetStockObject(WinApi.NULL_BRUSH));
oldp := WinApi.SelectObject(dc, WinApi.CreatePen(WinApi.PS_SOLID, 1, 0));
res := WinApi.Ellipse(dc, 2, 2, 18, 18);
res := WinApi.Ellipse(dc, 6, 6, 8, 8);
res := WinApi.Ellipse(dc, 12, 6, 14, 8);
res := WinApi.Ellipse(dc, 8, 8, 12, 12);
res := WinApi.Ellipse(dc, 6, 14, 14, 16);
res := WinApi.SelectObject(dc, oldb);
res := WinApi.DeleteObject(WinApi.SelectObject(dc, oldp));
mf := WinApi.CloseMetaFile(dc);
IF mf # 0 THEN
h := WinApi.GlobalAlloc(WinApi.GMEM_DDESHARE + WinApi.GMEM_MOVEABLE,
SIZE(WinApi.METAFILEPICT));
IF h # 0 THEN
mp := SYSTEM.VAL(WinApi.PtrMETAFILEPICT, WinApi.GlobalLock(h));
mp.hMF := mf;
mp.mm := WinApi.MM_ANISOTROPIC;
mp.xExt := obj.w; mp.yExt := obj.h;
res := WinApi.GlobalUnlock(h);
RETURN h
ELSE res := WinApi.DeleteMetaFile(mf)
END
END
END;
RETURN 0
END PictureOf;
(* ---------- IClassFactory ---------- *)
PROCEDURE (this: IClassFactory) CreateInstance (outer: COM.IUnknown; IN iid: COM.GUID;
OUT int: COM.IUnknown): COM.RESULT;
VAR res: COM.RESULT; new: Object;
BEGIN
IF outer = NIL THEN
NEW(new);
IF new # NIL THEN
NEW(new.ioo, new); NEW(new.ido, new); NEW(new.ips, new);
IF (new.ioo # NIL) & (new.ido # NIL) & (new.ips # NIL) THEN
new.ioo.obj := new;
new.ido.obj := new;
new.ips.obj := new;
res := new.QueryInterface(iid, int)
ELSE res := WinApi.E_OUTOFMEMORY
END
ELSE res := WinApi.E_OUTOFMEMORY
END
ELSE res := WinApi.CLASS_E_NOAGGREGATION
END;
RETURN res
END CreateInstance;
PROCEDURE (this: IClassFactory) LockServer (lock: WinApi.BOOL): COM.RESULT;
BEGIN
IF lock # 0 THEN INC(locks) ELSE DEC(locks) END;
RETURN WinApi.S_OK
END LockServer;
(* ---------- Object ---------- *)
PROCEDURE (this: Object) QueryInterface (IN iid: COM.GUID; OUT int: COM.IUnknown): COM.RESULT;
BEGIN
IF COM.QUERY(this, iid, int)
OR COM.QUERY(this.ioo, iid, int)
OR COM.QUERY(this.ido, iid, int)
OR COM.QUERY(this.ips, iid, int) THEN RETURN WinApi.S_OK
ELSE RETURN WinApi.E_NOINTERFACE
END
END QueryInterface;
(* ---------- IOleObject ---------- *)
PROCEDURE (this: IOleObject) SetClientSite (site: WinOle.IOleClientSite): COM.RESULT;
BEGIN
this.obj.ics := site;
RETURN WinApi.S_OK
END SetClientSite;
PROCEDURE (this: IOleObject) GetClientSite (OUT site: WinOle.IOleClientSite): COM.RESULT;
BEGIN
site := this.obj.ics;
RETURN WinApi.S_OK
END GetClientSite;
PROCEDURE (this: IOleObject) SetHostNames (app, obj: WinApi.PtrWSTR): COM.RESULT;
BEGIN
RETURN WinApi.S_OK
END SetHostNames;
PROCEDURE (this: IOleObject) Close (saveOption: INTEGER): COM.RESULT;
BEGIN
RETURN WinApi.S_OK
END Close;
PROCEDURE (this: IOleObject) SetMoniker (which: INTEGER; mk: WinOle.IMoniker): COM.RESULT;
BEGIN
RETURN WinApi.E_NOTIMPL
END SetMoniker;
PROCEDURE (this: IOleObject) GetMoniker (assign, which: INTEGER; OUT mk: WinOle.IMoniker): COM.RESULT;
BEGIN
RETURN WinApi.E_NOTIMPL
END GetMoniker;
PROCEDURE (this: IOleObject) InitFromData (obj: WinOle.IDataObject; creation: WinApi.BOOL;
reserved: INTEGER): COM.RESULT;
BEGIN
RETURN WinApi.E_NOTIMPL
END InitFromData;
PROCEDURE (this: IOleObject) GetClipboardData (reserved: INTEGER; OUTobj: WinOle.IDataObject):
COM.RESULT;
BEGIN
RETURN WinApi.E_NOTIMPL
END GetClipboardData;
PROCEDURE (this: IOleObject) DoVerb (verb: INTEGER; IN msg: WinApi.MSG; activeSite: WinOle.IOleClientSite;
index: INTEGER; parent: WinApi.HWND; IN posRect: WinApi.RECT):
COM.RESULT;
BEGIN
IF verb < 0 THEN RETURN WinApi.S_OK
ELSE RETURN WinApi.OLEOBJ_E_NOVERBS
END
END DoVerb;
PROCEDURE (this: IOleObject) EnumVerbs (OUT enum: WinOle.IEnumOLEVERB): COM.RESULT;
BEGIN
RETURN WinApi.OLEOBJ_E_NOVERBS
END EnumVerbs;
PROCEDURE (this: IOleObject) Update (): COM.RESULT;
BEGIN
RETURN WinApi.S_OK
END Update;
PROCEDURE (this: IOleObject) IsUpToDate (): COM.RESULT;
BEGIN
RETURN WinApi.S_OK
END IsUpToDate;
PROCEDURE (this: IOleObject) GetUserClassID (OUT id: COM.GUID): COM.RESULT;
BEGIN
id := ObjectID;
RETURN WinApi.S_OK
END GetUserClassID;
PROCEDURE (this: IOleObject) GetUserType (form: INTEGER; OUT type: WinApi.PtrWSTR): COM.RESULT;
BEGIN
RETURN WinApi.OLE_S_USEREG
END GetUserType;
PROCEDURE (this: IOleObject) SetExtent (aspect: SET; IN size: WinApi.SIZE): COM.RESULT;
VAR res: COM.RESULT;
BEGIN
IF aspect * WinOle.DVASPECT_CONTENT # {} THEN
this.obj.w := size.cx; this.obj.h := size.cy;
RETURN WinApi.S_OK
ELSE RETURN WinApi.E_FAIL
END
END SetExtent;
PROCEDURE (this: IOleObject) GetExtent (aspect: SET; OUT size: WinApi.SIZE): COM.RESULT;
BEGIN
IF aspect * WinOle.DVASPECT_CONTENT # {} THEN
size.cx := this.obj.w; size.cy := this.obj.h;
RETURN WinApi.S_OK
ELSE RETURN WinApi.E_FAIL
END
END GetExtent;
PROCEDURE (this: IOleObject) Advise (sink: WinOle.IAdviseSink; OUT connection: INTEGER): COM.RESULT;
VAR res: COM.RESULT;
BEGIN
IF this.obj.ioah = NIL THEN
res := WinOle.CreateOleAdviseHolder(this.obj.ioah);
IF res < 0 THEN RETURN res END
END;
RETURN this.obj.ioah.Advise(sink, connection)
END Advise;
PROCEDURE (this: IOleObject) Unadvise (connection: INTEGER): COM.RESULT;
BEGIN
IF this.obj.ioah # NIL THEN
RETURN this.obj.ioah.Unadvise(connection)
ELSE RETURN WinApi.E_FAIL
END
END Unadvise;
PROCEDURE (this: IOleObject) EnumAdvise (OUT enum: WinOle.IEnumSTATDATA): COM.RESULT;
BEGIN
IF this.obj.ioah # NIL THEN
RETURN this.obj.ioah.EnumAdvise(enum)
ELSE RETURN WinApi.E_FAIL
END
END EnumAdvise;
PROCEDURE (this: IOleObject) GetMiscStatus (aspect: SET; OUT status: SET): COM.RESULT;
BEGIN
RETURN WinApi.OLE_S_USEREG
END GetMiscStatus;
PROCEDURE (this: IOleObject) SetColorScheme (IN pal: WinApi.LOGPALETTE): COM.RESULT;
BEGIN
RETURN WinApi.E_NOTIMPL
END SetColorScheme;
(* ---------- IDataObject ---------- *)
PROCEDURE (this: IDataObject) GetData (IN format: WinOle.FORMATETC;
OUT medium: WinOle.STGMEDIUM): COM.RESULT;
VAR res: COM.RESULT;
BEGIN
res := this.QueryGetData(format);
IF res = WinApi.S_OK THEN
ComTools.GenMetafileMedium(PictureOf(this.obj), NIL, medium);
RETURN WinApi.S_OK
ELSE RETURN res
END
END GetData;
PROCEDURE (this: IDataObject) GetDataHere (IN format: WinOle.FORMATETC;
VAR medium: WinOle.STGMEDIUM): COM.RESULT;
BEGIN
RETURN WinApi.DV_E_FORMATETC
END GetDataHere;
PROCEDURE (this: IDataObject) QueryGetData (IN format: WinOle.FORMATETC): COM.RESULT;
BEGIN
IF format.dwAspect * WinOle.DVASPECT_CONTENT = {} THEN RETURN WinApi.DV_E_DVASPECT
ELSIF format.cfFormat # WinApi.CF_METAFILEPICT THEN RETURN WinApi.DV_E_FORMATETC
ELSIF format.tymed * WinOle.TYMED_MFPICT = {} THEN RETURN WinApi.DV_E_TYMED
ELSE RETURN WinApi.S_OK
END
END QueryGetData;
PROCEDURE (this: IDataObject) GetCanonicalFormatEtc (IN formatIn: WinOle.FORMATETC;
OUT formatOut: WinOle.FORMATETC): COM.RESULT;
BEGIN
RETURN WinApi.DATA_S_SAMEFORMATETC
END GetCanonicalFormatEtc;
PROCEDURE (this: IDataObject) SetData (IN format: WinOle.FORMATETC;
IN medium: WinOle.STGMEDIUM; release: WinApi.BOOL): COM.RESULT;
BEGIN
RETURN WinApi.DV_E_FORMATETC
END SetData;
PROCEDURE (this: IDataObject) EnumFormatEtc (direction: SET; OUT enum: WinOle.IEnumFORMATETC):
COM.RESULT;
BEGIN
RETURN WinApi.OLE_S_USEREG
END EnumFormatEtc;
PROCEDURE (this: IDataObject) DAdvise (IN format: WinOle.FORMATETC; flags: SET;
advSink: WinOle.IAdviseSink; OUT connection: INTEGER): COM.RESULT;
VAR res: COM.RESULT;
BEGIN
IF this.obj.idah = NIL THEN
res := WinOle.CreateDataAdviseHolder(this.obj.idah);
IF res < 0 THEN RETURN res END
END;
RETURN this.obj.idah.Advise(this, format, flags, advSink, connection)
END DAdvise;
PROCEDURE (this: IDataObject) DUnadvise (connection: INTEGER): COM.RESULT;
BEGIN
IF this.obj.idah # NIL THEN
RETURN this.obj.idah.Unadvise(connection)
ELSE RETURN WinApi.E_FAIL
END
END DUnadvise;
PROCEDURE (this: IDataObject) EnumDAdvise (OUTenum: WinOle.IEnumSTATDATA): COM.RESULT;
BEGIN
IF this.obj.idah # NIL THEN
RETURN this.obj.idah.EnumAdvise(enum)
ELSE RETURN WinApi.E_FAIL
END
END EnumDAdvise;
(* ---------- IPersistStorage ---------- *)
PROCEDURE (this: IPersistStorage) GetClassID (OUT id: COM.GUID): COM.RESULT;
BEGIN
id := ObjectID;
RETURN WinApi.S_OK
END GetClassID;
PROCEDURE (this: IPersistStorage) IsDirty (): COM.RESULT;
BEGIN
RETURN WinApi.S_FALSE
END IsDirty;
PROCEDURE (this: IPersistStorage) InitNew (stg: WinOle.IStorage): COM.RESULT;
VAR res: COM.RESULT; ps: WinApi.PtrWSTR;
BEGIN
IF stg # NIL THEN
res := stg.CreateStream(streamStr,
WinOle.STGM_DIRECT + WinOle.STGM_CREATE
+ WinOle.STGM_READWRITE + WinOle.STGM_SHARE_EXCLUSIVE,
0, 0, this.obj.ism);
IF res >= 0 THEN
res := WinOle.OleRegGetUserType(ObjectID, WinOle.USERCLASSTYPE_SHORT, ps);
res := WinOle.WriteFmtUserTypeStg(stg, cbFormat, ps);
ComTools.FreeString(ps);
this.obj.isg := stg;
this.obj.w := 5000;
this.obj.h := 5000;
RETURN WinApi.S_OK
ELSE RETURN res
END
ELSE RETURN WinApi.E_POINTER
END
END InitNew;
PROCEDURE (this: IPersistStorage) Load (stg: WinOle.IStorage): COM.RESULT;
VAR res: COM.RESULT;
BEGIN
IF stg # NIL THEN
res := stg.OpenStream(streamStr, 0,
WinOle.STGM_DIRECT + WinOle.STGM_READWRITE
+ WinOle.STGM_SHARE_EXCLUSIVE,
0, this.obj.ism);
IF res >= 0 THEN
res := this.obj.ism.Read(SYSTEM.ADR(this.obj.w), 4, NIL);
res := this.obj.ism.Read(SYSTEM.ADR(this.obj.h), 4, NIL);
IF res >= 0 THEN
this.obj.isg := stg;
RETURN WinApi.S_OK
END
END;
RETURN WinApi.STG_E_READFAULT
ELSE RETURN WinApi.E_POINTER
END
END Load;
PROCEDURE (this: IPersistStorage) Save (stg: WinOle.IStorage; sameAsLoad: WinApi.BOOL): COM.RESULT;
VAR stm: WinOle.IStream; res: COM.RESULT; ps: WinApi.PtrWSTR;
BEGIN
IF sameAsLoad # 0 THEN
stm := this.obj.ism;
res := stm.Seek(0, WinOle.STREAM_SEEK_SET, NIL)
ELSIF stg # NIL THEN
res := stg.CreateStream(streamStr,
WinOle.STGM_DIRECT + WinOle.STGM_CREATE
+ WinOle.STGM_WRITE + WinOle.STGM_SHARE_EXCLUSIVE,
0, 0, stm);
IF res < 0 THEN RETURN res END;
res := WinOle.OleRegGetUserType(ObjectID, WinOle.USERCLASSTYPE_SHORT, ps);
res := WinOle.WriteFmtUserTypeStg(stg, cbFormat, ps);
ComTools.FreeString(ps);
ELSE RETURN WinApi.E_POINTER
END;
res := stm.Write(SYSTEM.ADR(this.obj.w), 4, NIL);
res := stm.Write(SYSTEM.ADR(this.obj.h), 4, NIL);
IF res < 0 THEN RETURN WinApi.STG_E_WRITEFAULT
ELSE RETURN WinApi.S_OK
END
END Save;
PROCEDURE (this: IPersistStorage) SaveCompleted (new: WinOle.IStorage): COM.RESULT;
VAR res: COM.RESULT;
BEGIN
IF new # NIL THEN
res := new.OpenStream(streamStr, 0,
WinOle.STGM_DIRECT + WinOle.STGM_READWRITE
+ WinOle.STGM_SHARE_EXCLUSIVE,
0, this.obj.ism);
IF res >= 0 THEN this.obj.isg := new;
ELSE RETURN res
END
END;
IF this.obj.ioah # NIL THEN res := this.obj.ioah.SendOnSave() END;
RETURN WinApi.S_OK
END SaveCompleted;
PROCEDURE (this: IPersistStorage) HandsOffStorage (): COM.RESULT;
BEGIN
this.obj.ism := NIL; this.obj.isg := NIL;
RETURN WinApi.S_OK
END HandsOffStorage;
(* ---------- commands ---------- *)
PROCEDURE Register*;
VAR res: COM.RESULT; factory: IClassFactory;
BEGIN
NEW(factory);
res := WinOle.CoRegisterClassObject(ObjectID, factory,
WinOle.CLSCTX_LOCAL_SERVER, WinOle.REGCLS_MULTIPLEUSE, token);
END Register;
PROCEDURE Unregister*;
VAR res: COM.RESULT;
BEGIN
IF (token # 0) & (locks = 0) THEN res := WinOle.CoRevokeClassObject(token) END
END Unregister;
END ComObject.
ComObject.Register
ComObject.Unregister
-----------------------------------------------------------------------------------------------------------------
REGEDIT
HKEY_CLASSES_ROOT\BlackBox.Object = BlackBox Object
HKEY_CLASSES_ROOT\BlackBox.Object\CLSID = {00010001-1000-11cf-adf0-444553540000}
HKEY_CLASSES_ROOT\BlackBox.Object\Insertable
HKEY_CLASSES_ROOT\CLSID\{00010001-1000-11cf-adf0-444553540000} = BlackBox Object
HKEY_CLASSES_ROOT\CLSID\{00010001-1000-11cf-adf0-444553540000}\ProgID = BlackBox.Object
HKEY_CLASSES_ROOT\CLSID\{00010001-1000-11cf-adf0-444553540000}\LocalServer32 = C:\BlackBox\BlackBox.exe
HKEY_CLASSES_ROOT\CLSID\{00010001-1000-11cf-adf0-444553540000}\InProcHandler32 = ole32.dll
HKEY_CLASSES_ROOT\CLSID\{00010001-1000-11cf-adf0-444553540000}\Insertable
HKEY_CLASSES_ROOT\CLSID\{00010001-1000-11cf-adf0-444553540000}\DefaultIcon = C:\BlackBox\BlackBox.exe,0
HKEY_CLASSES_ROOT\CLSID\{00010001-1000-11cf-adf0-444553540000}\DataFormats\GetSet\0 = 3,1,32,1
HKEY_CLASSES_ROOT\CLSID\{00010001-1000-11cf-adf0-444553540000}\MiscStatus = 16
HKEY_CLASSES_ROOT\CLSID\{00010001-1000-11cf-adf0-444553540000}\AuxUserType\2 = BlackBox Object
HKEY_CLASSES_ROOT\CLSID\{00010001-1000-11cf-adf0-444553540000}\AuxUserType\3 = BlackBox
-----------------------------------------------------------------------------------------------------------------