I just dug up this ol thing from my collection of code that I've written; Honestly I'm surprised I wrote it myself. I document some of it's history in the class itself. the modified date on the file as it exists on my previous hard drive is "Wednesday, ?December ?21, ?2005, ??12:22:44 PM" which is probably the last time I worked on it.
In either case, the inevitable question is what does it do? Well, it's a small (as far as I'm concerned) class that is designed to register and unregister objects from the windows "Running Object Table".
Code-wise, this allows for constructs such as:
Set PreviousApp=GetObject( ,"MyApplication.Application")
One of the "limitations" (although I don't consider it a limitation) is that you need to be using it in a ActiveX EXE project in order for it to be useful. Personally all but my most trivial applications has been a ActiveX EXE anyway, so no great loss there. The essential idea is pretty simple; it uses some of the COM exposed functions in order to register, and revoke an object from the running object table. The complications arise however with regards to the fact that COM API's are notoriously finicky about how you pass them parameters, so I have to do some messy COM stuff with regards to direct memory copies and String Pointer manipulation (which in this case is pretty amateur compared to the amount of that type of stuff I've had to do in BCFile in order to support the Unicode File manipulation functions). Anyway, here is the Class module in it's entirety. Most of it is self-contained; however, as described in the comments in the header it will require an reference to the "Typelib information" library. Most computers have this somewhere already as a result of windows installation.
Option Explicit
'///////////////////////////////////
'clsROTsupport
'adds support for the Running-Object-Table for Visual Basic Objects.
'(This will allow the use of GetObject() within clients to retrieve running instances)
'Created: Monday, December 5th, 2005
'Author: Michael Burgwin
'Requirements: TypeLib Information DLL (tlbinf32.dll) provided on the VB6 CD.
'Comments:
' This entire idea was inspired when I wrote a neat little
'program that let's you edit text-files, OLE documents, and such (BASeEditor)
'I wanted to allow for easy access to it's features by external applications,
'like Word,excel, Powerpoint, etc.
'This meant I wanted GetObject Support. Rather then having a number of instances
'of the program running simultaneously for each client, it would be better if
'the client could simply retrieve a previously running instance.
'Usage:
'To register a Object in the Running Object Table, call
'the "ExposeObject" Method.
'In Client VB applications using the GetObject Function, Omitting the
'First argument entirely and given that objects progID will return the same
'instance of the object you registered.
'IMPORTANT:
'remember to call RevokeObject before you destroy the instance of the object. Otherwise,
'the client application could crash when it tries to use it again.
'In addition, you should use the Locked Property.
'Declarations
'declare the stuff we're going to use.
Private Const ACTIVEOBJECT_STRONG As Long = &H0
Private Const ACTIVEOBJECT_WEAK As Long = &H1
'For ROT support...
Private Declare Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByRef pvReserved As Any) As Long
Private Declare Function RegisterActiveObject Lib "oleaut32.dll" (ByVal Punk As Long, ByVal rclsid As Long, _
ByVal dwFlags As Long, ByRef pdwRegister As Long) As Long
Private Declare Function CoLockObjectExternal Lib "ole32.dll" (ByVal Punk As Long, ByVal fLock As Long, _
ByVal fLastUnlockReleases As Long) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function CLSIDFromProgID _
Lib "ole32.dll" (ByVal lpszProgID As Long, _
pCLSID As GUID) As Long
Private Declare Function progIDfromCLSID _
Lib "ole32.dll" Alias "ProgIDFromCLSID" (pCLSID As GUID, lpszProgID As Long) As Long
Private Declare Function StringFromCLSID _
Lib "ole32.dll" (pCLSID As GUID, lpszProgID As Long) As Long
Private Declare Function CLSIDFromString _
Lib "ole32.dll" (ByVal lpszProgID As Long, _
pCLSID As GUID) As Long
Private Declare Sub CLSIDFromProgIDEx Lib "ole32.dll" _
(ByVal lpszProgID As Long, ByVal lpclsid As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private MvarExposedObject As Object
Private isExposing As Boolean
Private mvarCookie As Long
Private mvarLocked As Boolean
Public Sub ExposeObject(Vdata As Object)
Set MvarExposedObject = Vdata
'Exposes the object in the ROT.
Expose
End Sub
Public Sub RevokeObject()
If mvarCookie = 0 Then Exit Sub
Debug.Print "revoking ROT object, cookie=" & mvarCookie
RevokeActiveObject mvarCookie, 0
End Sub
Private Sub Expose()
'exposes object in MvarExposedObject.
Dim Iinfo As InterfaceInfo, Punk As IUnknown
Dim PrId As String, retval As Long
Dim grabguid As GUID
Set Iinfo = TLIApplication.InterfaceInfoFromObject(MvarExposedObject)
'we need the GUID structure.
PrId = Iinfo.Parent.Name & "." & IIf(Left$(Iinfo.Name, 1) = "_", Mid$(Iinfo.Name, 2), Iinfo.Name)
Call CLSIDFromProgID(StrPtr(PrId), grabguid)
'now that we have the guid, we need to use the pointer.
retval = RegisterActiveObject(ObjPtr(MvarExposedObject), VarPtr(grabguid), _
ACTIVEOBJECT_WEAK, mvarCookie)
Debug.Print retval
End Sub
Private Function getpunkPtr() As Long
Dim iunk As IUnknown
Set iunk = MvarExposedObject
getpunkPtr = ObjPtr(iunk)
End Function
Public Property Let Locked(ByVal Vdata As Boolean)
'if they are the same, who cares?
'locks/unlocks the entry in the ROT.
'should be called when the Object being exposed
'has a Visible representation, such as an Application Object's window.
'tell the COM API to lock/unlock the ROT moniker.
If mvarLocked = Vdata Then Exit Property
mvarLocked = Vdata
Call CoLockObjectExternal(ObjPtr(MvarExposedObject), Abs(CInt(mvarLocked)), 0)
End Property
Public Property Get Locked() As Boolean
Locked = mvarLocked
End Property
Private Function GetCLSID(ByVal progID As String) As String
Dim strProgID As String * 255
Dim pprogid As Long
Dim udtclsid As GUID
Dim strCLSID As String * 255
Dim pCLSID As Long
Dim lngRet As Long
Dim strtemp As String
Dim I As Integer
strtemp = progID
'Take a ProgID.
'Get CLSID.
lngRet = CLSIDFromProgID(StrPtr(strtemp), udtclsid)
'Display CLSID elements.
'Convert CLSID to a string and get the pointer back.
lngRet = StringFromCLSID(udtclsid, pCLSID)
'Get the CLSID string and display it.
StringFromPointer pCLSID, strCLSID
GetCLSID = Trim$(Replace$(strCLSID, NC, ""))
'Reinitialize the CLSID.
With udtclsid
.Data1 = 0
.Data2 = 0
.Data3 = 0
For I = 0 To 7
.Data4(I) = 0
Next
End With
End Function
Private Function GetProgID(ByVal CLSID As String) As String
'retrieve the progID of a given CLSID
'use the OLE API.
'it's actually a LOT more annoying then it should be.
'algorithm:
'first, strip out the special formatting characters, such as "{","}" and "-"
'then,using this string, iterate through every two characters, converting the two values into a
'Hexadecimal Byte and storing it int oa byte array.
'use the MemoryCopy Function to copy this Byte Data into the GUID variable.
'(So far, it appears that the resulting values for the first DWORD,WORD, and WORD have somehow been swapped.
'for example, a guid of:
' {22BB2698-0904-4D38-B340-6E10B0D5A240}
' would, after turning into a string and back again:
' {9826BB22-0409-384D-B340-6E10B0D5A240}
'I realize I obviously made a mistake (unless there is a bug in OLE32.dll, which is about a 0.001% chance)
'but right now I simply call a simple little stub that swaps them back into the correct order.
'make a call to the StringFromCLSID() function, using this created GUID
Dim originalinput As String
Dim strtemp As String, sRet As String
Dim Spointer As Long
Dim useme As GUID
Dim TmpLng As Long, lngtest As Long
Dim strtest As String, lngRet As Long
Dim TmpInt As Long
Dim I As Long, Element As Long
Dim ByteArr(16) As Byte 'used to copy GUID structure.
originalinput = CLSID
On Error GoTo 0
'this is what we need to change.
'this data is not valid. we need to get the actual GUID for the CLSID.
With useme
.Data1 = 0
.Data2 = 0
.Data3 = 0
For I = 0 To 7
.Data4(I) = 0
Next
End With
strtemp = CLSID
strtemp = Replace$(strtemp, "{", "")
strtemp = Replace$(strtemp, "}", "")
strtemp = Replace$(strtemp, "-", "")
'go through every WORD, or byte, and copy the denoted hex value.
Element = 0
For I = 1 To Len(strtemp) Step 2
'for some reason, all sections except the last one are frigged.
'they seems the bytes are reversed.
ByteArr(Element) = Val("&H" & Mid$(strtemp, I, 2))
Debug.Print Mid$(strtemp, I, 2);
Element = Element + 1
Next I
FixBytes ByteArr()
Debug.Print ""
Debug.Print strtemp
'fix the bytes. for some reason, my code screws it up or something.
'now that we have the bytes of the data, we can do a Copymemory into the structure.
CopyMemory useme, ByteArr(0), Len(useme)
'phew. hope that works...
'{Data1-Data2-Data3-Data4}
' DWORD-WORD-WORD-WORD-WORD & DWORD
lngtest = 0
Call StringFromCLSID(useme, lngtest)
Call StringFromPointer(lngtest, strtest)
strtest = Replace(strtest, NC, "")
strtest = Trim$(strtest)
Debug.Assert strtest = originalinput
lngRet = progIDfromCLSID(useme, Spointer)
'create each succesive value, and place it into the byte array.
'spointer is pointer to the string data.
sRet = Space$(255)
Call StringFromPointer(Spointer, sRet)
GetProgID = Trim$(Replace$(sRet, NC, ""))
'return the string.
Exit Function
Err.Raise 13, "cRotSupport.GetProgID", "Invalid CLSID string format."
' Resume
End Function
Private Function GuidFromObject(ObjFrom As Object) As GUID
'Private Declare Function CLSIDFromString _
' Lib "ole32.dll" (ByVal lpszProgID As Long, _
' pCLSID As GUID) As Long
Dim tmpret As GUID
Dim strptre As String
Dim Iinfo As InterfaceInfo
Set Iinfo = InterfaceInfoFromObject(ObjFrom)
strptre = Iinfo.Parent.Name & "." & Iinfo.Name
Call CLSIDFromString(StrPtr(strptre), tmpret)
GuidFromObject = tmpret
End Function
'This function takes a pointer to a Unicode string, a string buffer
'and place the bytes in the Visual Basic string buffer.
Private Sub FixBytes(Bytesfix() As Byte)
Dim I As Long
Dim tmpbyte As Byte
'fixes the bytes by swapping the following:
'Byte 1 withbyte 4
'byte 2 with byte 3
'byte 5 with byte 6
'byte 7 with byte 8
For I = 0 To 1
tmpbyte = Bytesfix(I)
Bytesfix(I) = Bytesfix(3 - I)
Bytesfix(3 - I) = tmpbyte
Next I
'that fixes the first DWORD value.
'now, the two words....
tmpbyte = Bytesfix(4)
Bytesfix(4) = Bytesfix(5)
Bytesfix(5) = tmpbyte
tmpbyte = Bytesfix(6)
Bytesfix(6) = Bytesfix(7)
Bytesfix(7) = tmpbyte
End Sub
Private Sub StringFromPointer(pOLESTR As Long, strOut As String)
Dim ByteArray(255) As Byte
Dim intTemp As Integer
Dim intCount As Integer
Dim I As Integer
intTemp = 1
'Walk the string and retrieve the first byte of each WORD.
While intTemp <> 0
CopyMemory intTemp, ByVal pOLESTR + I, 2
ByteArray(intCount) = intTemp
intCount = intCount + 1
I = I + 2
Wend
'Copy the byte array to our string.
strOut = Space$(255)
CopyMemory ByVal strOut, ByteArray(0), intCount
End Sub
Private Sub Class_Terminate()
RevokeObject
End Sub
