Has anyone got a clue how to write an URL Moniker?
I am trying to use the Intenet Explorer to display HTML files that I pull out of a OLE2 structured storage file. Microsoft does s.th very similar in their Infoviewer 5 (comes with the MSDN): If you have the MSDN installed an type something like
mk:@ivt:activex/start.htm
IE will display the file start.htm from the knowledgebase file activex.ivt.
I already have found out that "ivt" in the above URL is registered in the registry and seems to be an URL Moniker. And from the MSDN I found out that I need to write an URL Moniker server.
Before I waste my time re-inventing the wheel: has somebody out there already written one?
Best regards,
Freter
Here's the unit and project, below are the registry keys to set.
// BOC //
unit _MyMoniker;
interface
uses
Windows, Classes, ComObj, ActiveX;
const
CLSID_MyCustomMoniker: TGUID = (
D1:$556F12A1; D2:$DE94; D3:$11D1; D4:($B4, $EA, $00, $00, $E8, $2D, $8A, $65));
Str_CLSID_MyCustomMoniker = '{556F12A1-DE94-11D1-B4EA-
CLSID_NULL: TGUID = (D1:0; D2:0; D3:0; D4:(0, 0, 0, 0, 0, 0, 0, 0));
const
IsDebug = false;
OutStr = '<HTML>An error occured while parsing the URL<BR><B>%s</B><BR>Reques
FileSystemBase = 'c:';
type
TMyCustomMoniker = class(TComObject, IParseDisplayName, IMoniker)
private
FOutStr,
FErrorStr,
FFileName,
FRequestURL : string;
FOLEOutStr : POLEStr;
FHash : Longint;
protected
// IUnknown interface
function ObjAddRef: Integer; override; stdcall;
function ObjQueryInterface(const IID: TGUID; out Obj): Integer; override; stdcall;
function ObjRelease: Integer; override; stdcall;
// IParseDisplayName interface
function IParseDisplayName.ParseDis
function IParseDisplayNameParseDisp
out chEaten: Longint; out mkOut: IMoniker): HResult; stdcall;
// IPersist interface
function GetClassID(out classID: TCLSID): HResult; stdcall;
// IPersistStream interface
function IsDirty: HResult; stdcall;
function Load(const stm: IStream): HResult; stdcall;
function Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;
function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
// IMoniker interface
function BindToObject(const bc: IBindCtx; const mkToLeft: IMoniker;
const iidResult: TIID; out vResult): HResult; stdcall;
function BindToStorage(const bc: IBindCtx; const mkToLeft: IMoniker;
const iid: TIID; out vObj): HResult; stdcall;
function Reduce(const bc: IBindCtx; dwReduceHowFar: Longint;
mkToLeft: PIMoniker; out mkReduced: IMoniker): HResult; stdcall;
function ComposeWith(const mkRight: IMoniker; fOnlyIfNotGeneric: BOOL;
out mkComposite: IMoniker): HResult; stdcall;
function Enum(fForward: BOOL; out enumMoniker: IEnumMoniker): HResult;
stdcall;
function IsEqual(const mkOtherMoniker: IMoniker): HResult; stdcall;
function Hash(out dwHash: Longint): HResult; stdcall;
function IsRunning(const bc: IBindCtx; const mkToLeft: IMoniker;
const mkNewlyRunning: IMoniker): HResult; stdcall;
function GetTimeOfLastChange(const bc: IBindCtx; const mkToLeft: IMoniker;
out filetime: TFileTime): HResult; stdcall;
function Inverse(out mk: IMoniker): HResult; stdcall;
function CommonPrefixWith(const mkOther: IMoniker;
out mkPrefix: IMoniker): HResult; stdcall;
function RelativePathTo(const mkOther: IMoniker;
out mkRelPath: IMoniker): HResult; stdcall;
function GetDisplayName(const bc: IBindCtx; const mkToLeft: IMoniker;
out pszDisplayName: POleStr): HResult; stdcall;
function ParseDisplayName(const bc: IBindCtx; const mkToLeft: IMoniker;
pszDisplayName: POleStr; out chEaten: Longint;
out mkOut: IMoniker): HResult; stdcall;
function IsSystemMoniker(out dwMksys: Longint): HResult; stdcall;
end;
TMyStream = class(TComObject, IStream)
private
FTheStream : TMemoryStream;
FStatStg : TStatStg;
Fmtime,
Fctime,
Fatime : TFileTime;
protected
function Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult;
stdcall;
function Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult;
stdcall;
function Seek(dlibMove: Largeint; dwOrigin: Longint;
out libNewPosition: Largeint): HResult; stdcall;
function SetSize(libNewSize: Largeint): HResult; stdcall;
function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
out cbWritten: Largeint): HResult; stdcall;
function Commit(grfCommitFlags: Longint): HResult; stdcall;
function Revert: HResult; stdcall;
function LockRegion(libOffset: Largeint; cb: Largeint;
dwLockType: Longint): HResult; stdcall;
function UnlockRegion(libOffset: Largeint; cb: Largeint;
dwLockType: Longint): HResult; stdcall;
function Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult;
stdcall;
function Clone(out stm: IStream): HResult; stdcall;
public
constructor Create;
destructor Destroy; override;
end;
implementation
uses ComServ, SysUtils;
const
DebugFile = 'c:\debug.txt';
var
F : Text;
procedure WriteDebug(S : string);
begin
if IsDebug then
begin
AssignFile(F, DebugFile);
Append(F);
writeln(F, FormatDateTime('dddd, mmmm d, yyyy', Date)
+ FormatDateTime(' hh:mm:ss', Time) + ': ' + S);
CloseFile(F);
end;
end;
//////////////////////////
// IUnknown interface
function TMyCustomMoniker.ObjAddRef
begin
Result := inherited ObjAddRef;
writedebug(Format('ObjAddR
end;
function TMyCustomMoniker.ObjQueryI
var StrBuf : POleStr;
begin
StringFromCLSID(IID, StrBuf);
writedebug(Format('ObjQuer
Result := inherited ObjQueryInterface(IID, Obj);
end;
function TMyCustomMoniker.ObjReleas
begin
Result := inherited ObjRelease;
writedebug(Format('ObjRele
end;
// IParseDisplayName interface
function TMyCustomMoniker.IParseDis
out chEaten: Longint; out mkOut: IMoniker): HResult;
var Index : Integer;
begin
writedebug(Format('IParseD
bc.RegisterObjectBound(Sel
mkOut := Self;
FErrorStr := '';
FFileName := '';
FRequestURL := WideCharToString(pszDispla
chEaten := Length(FRequestURL) * 2;
// interpretation
Index := Pos('/', FRequestURL);
if Index <> 0
then FFileName := FileSystemBase + Copy(FRequestURL, Index, Length(FRequestURL) - Index + 1)
else FErrorStr := 'Invalid request';
Result := S_OK;
end;
// IPersist interface
function TMyCustomMoniker.GetClassI
begin
writedebug('GetClassID');
classID := CLSID_MyCustomMoniker;
Result := S_OK;
end;
// IPersistStream interface
function TMyCustomMoniker.IsDirty: HResult;
begin
writedebug('IsDirty');
Result := S_FALSE;
end;
function TMyCustomMoniker.Load(cons
begin
writedebug('Load');
Result := E_FAIL;
end;
function TMyCustomMoniker.Save(cons
begin
writedebug('Save');
stm._AddRef;
GetMem(FOLEOutStr, Length(FOutStr) * 2);
try
StringToWideChar(FOutStr, FOLEOutStr, Length(FOutStr) * 2);
Result := stm.Write(FOLEOutStr, Length(FOutStr) * 2, nil);
finally
FreeMem(FOLEOutStr, Length(FOutStr) * 2);
stm._Release;
end;
end;
function TMyCustomMoniker.GetSizeMa
begin
writedebug('GetSizeMax');
cbSize := Length(FOutStr) * 2;
Result := S_OK;
end;
// IMoniker interface
function TMyCustomMoniker.BindToObj
const iidResult: TIID; out vResult): HResult;
var StrBuf : POleStr;
begin
StringFromCLSID(iidResult,
writedebug(Format('BindToO
IMoniker(vResult) := Self;
Result := S_OK;
end;
function TMyCustomMoniker.BindToSto
const iid: TIID; out vObj): HResult;
var StrBuf : POleStr;
TmpStream : TMemoryStream;
NewStream : TMyStream;
begin
StringFromCLSID(iid, StrBuf);
writedebug(Format('BindToS
IUnknown(vObj) := nil;
Result := MK_E_NOSTORAGE;
if mkToLeft = nil
then writedebug('mkToLef = NULL');
if IsEqualIID(iid, IStream) then
begin
NewStream := TMyStream.Create;
if FFileName <> '' then
begin
TmpStream := TMemoryStream.Create;
try
try
TmpStream.LoadFromFile(FFi
NewStream.FTheStream.LoadF
except
FErrorStr := Format('File %s not found', [FFileName]);
end;
finally
TmpStream.Free;
end;
end;
if FErrorStr <> '' then
begin
FOutStr := Format(OutStr, [FErrorStr, FRequestURL]);
NewStream.FTheStream.Write
end;
NewStream.FTheStream.Seek(
bc.RegisterObjectBound(New
IStream(vObj) := NewStream;
Result := S_OK;
end;
end;
function TMyCustomMoniker.Reduce(co
mkToLeft: PIMoniker; out mkReduced: IMoniker): HResult;
begin
writedebug(Format('Reduce how far: %d', [dwReduceHowFar]));
mkReduced := Self;
Result := MK_S_REDUCED_TO_SELF;
end;
function TMyCustomMoniker.ComposeWi
out mkComposite: IMoniker): HResult;
begin
writedebug('ComposeWith');
Result := E_UNEXPECTED;
end;
function TMyCustomMoniker.Enum(fFor
begin
writedebug('Enum');
enumMoniker := nil;
Result := S_OK;
end;
function TMyCustomMoniker.IsEqual(c
begin
Result := S_FALSE;
if mkOtherMoniker = IMoniker(Self)
then Result := S_OK;
writedebug(Format('IsEqual
end;
function TMyCustomMoniker.Hash(out dwHash: Longint): HResult;
begin
writedebug(Format('Hash %d', [dwHash]));
FHash := dwHash;
Result := S_OK;
end;
function TMyCustomMoniker.IsRunning
const mkNewlyRunning: IMoniker): HResult;
begin
writedebug('IsRunning');
Result := S_OK;
end;
function TMyCustomMoniker.GetTimeOf
out filetime: TFileTime): HResult;
begin
writedebug('GetTimeOfLastC
filetime.dwLowDateTime := 0;
filetime.dwHighDateTime := 0;
Result := E_NOTIMPL;
end;
function TMyCustomMoniker.Inverse(o
begin
writedebug('Inverse');
Result := E_NOTIMPL;
end;
function TMyCustomMoniker.CommonPre
begin
writedebug('CommonPrefixWi
Result := S_OK;
end;
function TMyCustomMoniker.RelativeP
begin
writedebug('RelativePathTo
mkRelPath := mkOther;
Result := MK_S_HIM;
end;
function TMyCustomMoniker.GetDispla
out pszDisplayName: POleStr): HResult;
begin
writedebug('GetDisplayName
Result := E_NOTIMPL;
end;
function TMyCustomMoniker.ParseDisp
pszDisplayName: POleStr; out chEaten: Longint;
out mkOut: IMoniker): HResult;
begin
writedebug(Format('ParseDi
chEaten := Length(WideCharToString(ps
mkOut := Self;
Result := S_OK;
end;
function TMyCustomMoniker.IsSystemM
begin
writedebug('IsSystemMonike
dwMksys := MKSYS_NONE;
Result := S_FALSE;
end;
//////////////////////////
constructor TMyStream.Create;
begin
// inherited Create;
writedebug('Stream.Create'
FTheStream := TMemoryStream.Create;
GetSystemTimeAsFileTime(Fm
GetSystemTimeAsFileTime(Fc
GetSystemTimeAsFileTime(Fa
end;
destructor TMyStream.Destroy;
begin
writedebug('Stream.Destroy
FTheStream.Free;
end;
function TMyStream.Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult;
var cbRead : LongInt;
begin
writedebug('Stream.Read');
Result := S_OK;
try
cbRead := FTheStream.Read(pv^, cb);
if pcbRead <> nil
then pcbRead^ := cbRead;
if cbRead = 0
then Result := S_FALSE
else GetSystemTimeAsFileTime(Fa
except
Result := S_FALSE;
end;
end;
function TMyStream.Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult;
var cbWritten : LongInt;
begin
writedebug('Stream.Write')
Result := S_OK;
try
cbWritten := FTheStream.Write(pv^, cb);
if pcbWritten <> nil
then pcbWritten^ := cbWritten;
GetSystemTimeAsFileTime(Fa
GetSystemTimeAsFileTime(Fm
except
Result := STG_E_CANTSAVE;
end;
end;
function TMyStream.Seek(dlibMove: Largeint; dwOrigin: Longint;
out libNewPosition: Largeint): HResult;
begin
writedebug('Stream.Seek');
Result := S_OK;
try
libNewPosition := FTheStream.Seek(Trunc(Int(
except
Result := STG_E_INVALIDFUNCTION;
end;
end;
function TMyStream.SetSize(libNewSi
begin
writedebug('Stream.SetSize
Result := S_OK;
try
FTheStream.SetSize(Trunc(I
GetSystemTimeAsFileTime(Fc
except
Result := STG_E_MEDIUMFULL;
end;
end;
function TMyStream.CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
out cbWritten: Largeint): HResult;
var Buffer : PChar;
cb_Written : LargeInt;
begin
writedebug('Stream.CopyTo'
GetMem(Buffer, Trunc(Int(cb)));
Result := S_OK;
try
try
cbRead := FTheStream.Read(Buffer^, Trunc(Int(cb)));
stm.Write(Buffer, Trunc(Int(cb)), @cb_Written);
cbWritten := cb_Written;
GetSystemTimeAsFileTime(Fa
except
Result := STG_E_MEDIUMFULL;
end;
finally
FreeMem(Buffer, Trunc(Int(cb)));
end;
end;
function TMyStream.Commit(grfCommit
begin
writedebug('Stream.Commit'
Result := S_OK;
end;
function TMyStream.Revert: HResult;
begin
writedebug('Stream.Revert'
Result := S_OK;
end;
function TMyStream.LockRegion(libOf
dwLockType: Longint): HResult;
begin
writedebug('Stream.LockReg
Result := STG_E_INVALIDFUNCTION;
end;
function TMyStream.UnlockRegion(lib
dwLockType: Longint): HResult;
begin
writedebug('Stream.UnlockR
Result := STG_E_INVALIDFUNCTION;
end;
function TMyStream.Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult;
begin
writedebug('Stream.Stat');
with FStatStg do
begin
if grfStatFlag = STATFLAG_DEFAULT
then lstrcpyW(pwcsName, 'Test');
dwType := STGTY_LOCKBYTES;
cbSize := FTheStream.Size;
mtime := Fmtime;
ctime := Fctime;
atime := Fatime;
grfMode := 0;
grfLocksSupported := 0;
clsid := CLSID_NULL;
grfStateBits := 0;
end;
statstg := FStatStg;
Result := S_OK;
end;
function TMyStream.Clone(out stm: IStream): HResult;
begin
writedebug('Stream.Clone')
Result := STG_E_INVALIDPOINTER;
end;
//////////////////////////
initialization
begin
if IsDebug then
begin
AssignFile(F, DebugFile);
Rewrite(F);
CloseFile(F);
end;
TComObjectFactory.Create(C
end;
end.
// project source
library MyMoniker;
uses
ComServ,
_MyMoniker in '_MyMoniker.pas';
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;
{$R *.RES}
begin
end.
// EOC //
OK, here the registry keys. Save them in a .reg file and double-click to merge them. I assumed the project's DLL resists in D:\Program Files, change the value accordingly.
The name of the moniker, slashmoniker in this case, can be changed by changing all
HKEY_CLASSES_ROOT\SlashMon
and
HKEY_CLASSES_ROOT\SlashMon
keys and the default values of
HKEY_CLASSES_ROOT\CLSID\{5
HKEY_CLASSES_ROOT\CLSID\{5
and
HKEY_CLASSES_ROOT\SlashMon
It's not that difficult.
// BOC //
REGEDIT4
[HKEY_CLASSES_ROOT\SlashMo
@="Slash's IE Moniker"
[HKEY_CLASSES_ROOT\SlashMo
@="{556F12A1-DE94-11D1-B4E
[HKEY_CLASSES_ROOT\SlashMo
@="SlashMoniker.1"
[HKEY_CLASSES_ROOT\SlashMo
@="Slash's IE Moniker V1"
[HKEY_CLASSES_ROOT\SlashMo
@="{556F12A1-DE94-11D1-B4E
[HKEY_CLASSES_ROOT\CLSID\{
@="Slash's IE Moniker V1"
[HKEY_CLASSES_ROOT\CLSID\{
"ThreadingModel"="Apartmen
@="D:\\Program Files\\MyMoniker.dll"
[HKEY_CLASSES_ROOT\CLSID\{
@="SlashMoniker.1"
[HKEY_CLASSES_ROOT\CLSID\{
@="1"
[HKEY_CLASSES_ROOT\CLSID\{
@="SlashMoniker"
// EOC //
If you have any questions, just ask.
Slash/d003303