Attribute VB_Name = "basGuids"
'-----------------------------------------------------------------------------
'   basGuid
'
'   GUID utilities, very useful for both COM and replication work in Access.
'   Jet, and SQL Server. You may use this code in your applications, just
'   make sure you keep the (c) notice and don't publish it anywhere as
'   your own.
'
'   Copyright (c) 1999 Trigeminal Software, Inc. All Rights Reserved.
'-----------------------------------------------------------------------------
Option Compare Binary
Option Explicit

' Some constants for IUnknownOfStGuidClass
Public Const CLSCTX_INPROC_SERVER = 1
Public Const CLSCTX_INPROC_HANDLER = 2
Public Const CLSCTX_LOCAL_SERVER = 4

' Note that although Variants now have
' a VT_GUID type, this type is unsupported in VBA,
' so we must define our own here that will have the same
' binary layout as all GUIDs are expected by COM to
' have.
Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

' Some useful functions for GUID work, borrowed from COM
' NOTE: StringFromGUID2 is identical in what it does to the other ole32.dll
' functions StringFromIID and StringFromCLSID. Therefore, they are not
' defined here
Public Declare Function StringFromGUID2 Lib "ole32.dll" (rclsid As GUID, ByVal lpsz As Long, ByVal cbMax As Long) As Long
Public Declare Function CLSIDFromString Lib "ole32.dll" (pstCLS As Long, clsid As GUID) As Long
Public Declare Function CoCreateGuid Lib "ole32.dll" (rclsid As GUID) As Long
Public Declare Function IsEqualGUID Lib "ole32.dll" (rguid1 As GUID, rguid2 As GUID) As Long
Public Declare Function CoCreateInstance Lib "ole32.dll" (rclsid As GUID, pUnkOuter As Any, ByVal dwClsContext As Long, riid As GUID, ppvObj As IUnknown) As Long
Public Declare Function CLSIDFromProgID Lib "ole32.dll" (ByVal lpszProgID As Long, pclsid As GUID) As Long
 
'------------------------------------------------------------
'   StGuidFromGuid
'
'   Converts a binary GUID to a canonical (string) GUID.
'------------------------------------------------------------
Public Function StGuidFromGuid(rclsid As GUID) As String
    Dim rc As Long
    Dim stGuid As String

    ' 39 chars  for the GUID plus room for the Null char
    stGuid = String$(40, vbNullChar)
    rc = StringFromGUID2(rclsid, StrPtr(stGuid), Len(stGuid) - 1)
    StGuidFromGuid = Left$(stGuid, rc - 1)
End Function

'------------------------------------------------------------
'   StJetGuidFromGuid
'
'   Converts a binary GUID to a canonical (string) GUID in
'   Jet format, used by ADO and DAO, since Jet can implicitly
'   convert these to binary format as needed for query
'   expressions. Example of this format:
'
'   {guid {361AA560-4FB1-11D3-AAE0-00104BA31425} }
'------------------------------------------------------------
Public Function StJetGuidFromGuid(rclsid As GUID) As String
    Dim stGuid As String

    stGuid = StGuidFromGuid(rclsid)
    If Len(stGuid) > 0 Then
        StJetGuidFromGuid = "{guid " & stGuid & "}"
    End If
End Function

'------------------------------------------------------------
'   GuidFromStGuid
'
'   Converts a canonical (string) GUID to a binary GUID. This
'   function will also handle "Jet" GUIDs (see above in the
'   StJetGuidFromGuid function for details on this format)
'------------------------------------------------------------
Public Function GuidFromStGuid(ByVal stGuid As String) As GUID
    Dim rc As Long

    If Left$(stGuid, 7) = "{guid {" Then
        If Right$(stGuid, 2) = "}}" Then
            stGuid = Mid$(stGuid, 7, 38)
        End If
    End If
    rc = CLSIDFromString(ByVal StrPtr(stGuid), GuidFromStGuid)
End Function

'------------------------------------------------------------
'   FIsEqualGuid
'
'   Returns True is both GUIDs are equal
'------------------------------------------------------------
Public Function FIsEqualGuid(guid1 As GUID, guid2 As GUID) As Boolean
    FIsEqualGuid = CBool(IsEqualGUID(guid1, guid2))
End Function

'------------------------------------------------------------
'   FIsEqualStGuid
'
'   Returns True is both string vals are canonical GUIDs
'   and they are equal
'------------------------------------------------------------
Public Function FIsEqualStGuid(stGuid1 As String, stGuid2 As String) As Boolean
    If FStIsGuid(stGuid1) Then
        If FStIsGuid(stGuid2) Then
            FIsEqualStGuid = CBool(IsEqualGUID(GuidFromStGuid(stGuid1), GuidFromStGuid(stGuid2)))
        End If
    End If
End Function

'------------------------------------------------------------
'   FStIsGuid
'
'   Tells you whether a string is a GUID. Also handles Jet
'   GUIDs (see StJetGuidFromGuid for details on this
'   format)
'------------------------------------------------------------
Public Function FStIsGuid(ByVal stGuidCand As String) As Boolean
    Dim rclsid As GUID
    If (Len(stGuidCand) > 0) Then
        If Left$(stGuidCand, 7) = "{guid {" Then
            If Right$(stGuidCand, 2) = "}}" Then
                stGuidCand = Mid$(stGuidCand, 7, 38)
            End If
        End If
        FStIsGuid = (CLSIDFromString(ByVal StrPtr(stGuidCand), rclsid) = 0)
    End If
End Function

'------------------------------------------------------------
'   GuidGen
'
'   Generates a new GUID, returning it in binary format
'------------------------------------------------------------
Public Function GuidGen() As GUID
    Dim rclsid As GUID

    If CoCreateGuid(rclsid) = 0 Then
        GuidGen = rclsid
    End If
End Function

'------------------------------------------------------------
'   StGuidGen
'
'   Generates a new GUID, returning it in canonical
'   (string) format
'------------------------------------------------------------
Public Function StGuidGen() As String
    Dim rclsid As GUID

    If CoCreateGuid(rclsid) = 0 Then
        StGuidGen = StGuidFromGuid(rclsid)
    End If
End Function

'----------------------------------------------------------------------
'   GuidNull
'
'   Returns a binary version of a Null GUID, i.e.
'   {00000000-0000-0000-0000-000000000000}
'----------------------------------------------------------------------
Public Function GuidNull() As GUID
    GuidNull = GuidFromStGuid(vbNullString)
End Function

'----------------------------------------------------------------------
'   StGuidNull
'
'   Returns a canonical Null GUID, i.e.
'   {00000000-0000-0000-0000-000000000000}
'----------------------------------------------------------------------
Public Function StGuidNull() As String
    StGuidNull = StGuidFromGuid(GuidNull())
End Function

'----------------------------------------------------------------------
'   ClsidFromStProgId
'
'   Given a ProgID, such as "Synch35.Synchronizer, returns its
'   CLSID in binary GUID form (if you need string form, you can
'   use StGuidFromGuid to convert
'----------------------------------------------------------------------
Public Function ClsidFromStProgId(stProgId As String) As GUID
    Call CLSIDFromProgID(StrPtr(stProgId), ClsidFromStProgId)
End Function

'----------------------------------------------------------------------
'   IUnknownOfStGuidClass
'
'   Given a string containing the clsid of an object, return an
'   IUnknown pointer to it (this can subsequently be set to a
'   typed variable of the right obj type using the Set statement.
'   Just a useful misc. COM function that makes use of GUIDs.
'----------------------------------------------------------------------
Public Function IUnknownOfStGuidClass(stClass As String) As IUnknown
    Dim rclsid As GUID
    Dim IID_IUnknown As GUID
    Dim pvObj As IUnknown
    Dim hr As Long
    
    rclsid = GuidFromStGuid(stClass)
    
    ' Build IUnknown Guid, since that is the interface
    ' we are going to try and get.
    With IID_IUnknown
       .Data4(0) = &HC0
       .Data4(7) = &H46
    End With
    
    ' Get instance of object from classid passed in
    hr = CoCreateInstance(rclsid, ByVal 0&, CLSCTX_INPROC_SERVER, IID_IUnknown, pvObj)
    
    If (hr = 0) Then
        Set IUnknownOfStGuidClass = pvObj
    Else
        Err.Raise hr
    End If
End Function