'************************************** ' Name: CoCreateGuid Example ' Description:Globally Unique Identifier ' generate function as well as a IsGuid() ' function to test if the GUID is a string ' representation seemingly of one. ' By: Nicholas Forystek ' ' ' Inputs:None ' ' Returns:None ' 'Assumes:None ' 'Side Effects:None '************************************** Option Explicit Option Compare Binary Option Private Module Private Type GuidType '16 A4 As Long '4 B2 As Integer '2 C2 As Integer '2 D8(0 To 7) As Byte '8 End Type Private Declare Function CoCreateGuid Lib "ole32" (ByVal pGuid As Long) As Long Private Const GPTR = &H40 Private Const GMEM_MOVEABLE = &H2 Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Sub RtlMoveMemory Lib "kernel32" (Left As Any, Pass As Any, ByVal Right As Long) Private Function Padding(ByVal Length As Long, ByVal Value As String, Optional ByVal PadWith As String = " ") As String Padding = String(Abs((Length * Len(PadWith)) - (Len(Value) \ Len(PadWith))), PadWith) & Value End Function Public Function GUID() As String Dim lpGuid As Long lpGuid = GlobalAlloc(GMEM_MOVEABLE And VarPtr(lpGuid), 4) If lpGuid <> 0 Then Dim lgGuid As GuidType Dim toggle As Integer If CoCreateGuid(VarPtr(lgGuid)) = 0 Then RtlMoveMemory lgGuid, ByVal lpGuid, 4& Dim lcGuid As Long lcGuid = GlobalLock(lpGuid) If lcGuid = lpGuid Then Dim ba(0 To 15) As Byte '16 RtlMoveMemory ByVal VarPtr(ba(0)), ByVal VarPtr(lgGuid.A4) + 0, 16 RtlMoveMemory ByVal VarPtr(ba(0)), ByVal VarPtr(ba(1)), 1 RtlMoveMemory ByVal VarPtr(ba(1)), ByVal VarPtr(lgGuid.A4) + 1, 15 RtlMoveMemory ByVal VarPtr(ba(1)), ByVal VarPtr(ba(2)), 1 RtlMoveMemory ByVal VarPtr(ba(2)), ByVal VarPtr(lgGuid.A4) + 2, 14 RtlMoveMemory ByVal VarPtr(ba(2)), ByVal VarPtr(ba(3)), 1 RtlMoveMemory ByVal VarPtr(ba(3)), ByVal VarPtr(lgGuid.A4) + 3, 13 RtlMoveMemory ByVal VarPtr(ba(3)), ByVal VarPtr(ba(4)), 1 GlobalUnlock lcGuid RtlMoveMemory ByVal VarPtr(ba(4)), ByVal VarPtr(lgGuid.B2) + 0, 12 RtlMoveMemory ByVal VarPtr(ba(4)), ByVal VarPtr(ba(5)), 1 RtlMoveMemory ByVal VarPtr(ba(5)), ByVal VarPtr(lgGuid.B2) + 1, 11 RtlMoveMemory ByVal VarPtr(ba(5)), ByVal VarPtr(ba(6)), 1 lcGuid = GlobalLock(lpGuid) RtlMoveMemory ByVal VarPtr(ba(6)), ByVal VarPtr(lgGuid.C2) + 0, 10 RtlMoveMemory ByVal VarPtr(ba(6)), ByVal VarPtr(ba(7)), 1 RtlMoveMemory ByVal VarPtr(ba(7)), ByVal VarPtr(lgGuid.C2) + 1, 9 RtlMoveMemory ByVal VarPtr(ba(7)), ByVal VarPtr(ba(8)), 1 GlobalUnlock lcGuid RtlMoveMemory ByVal VarPtr(ba(7)), ByVal VarPtr(lgGuid.D8(0)), 1 RtlMoveMemory ByVal VarPtr(ba(8)), ByVal VarPtr(ba(9)), 1 RtlMoveMemory ByVal VarPtr(ba(6)), ByVal VarPtr(lgGuid.D8(1)), 1 RtlMoveMemory ByVal VarPtr(ba(9)), ByVal VarPtr(ba(10)), 1 lcGuid = GlobalLock(lpGuid) RtlMoveMemory ByVal VarPtr(ba(5)), ByVal VarPtr(lgGuid.D8(2)), 1 RtlMoveMemory ByVal VarPtr(ba(10)), ByVal VarPtr(ba(11)), 1 RtlMoveMemory ByVal VarPtr(ba(4)), ByVal VarPtr(lgGuid.D8(3)), 1 RtlMoveMemory ByVal VarPtr(ba(11)), ByVal VarPtr(ba(12)), 1 RtlMoveMemory ByVal VarPtr(ba(3)), ByVal VarPtr(lgGuid.D8(4)), 1 RtlMoveMemory ByVal VarPtr(ba(12)), ByVal VarPtr(ba(13)), 1 RtlMoveMemory ByVal VarPtr(ba(2)), ByVal VarPtr(lgGuid.D8(5)), 1 RtlMoveMemory ByVal VarPtr(ba(13)), ByVal VarPtr(ba(14)), 1 RtlMoveMemory ByVal VarPtr(ba(1)), ByVal VarPtr(lgGuid.D8(6)), 1 RtlMoveMemory ByVal VarPtr(ba(14)), ByVal VarPtr(ba(15)), 1 RtlMoveMemory ByVal VarPtr(ba(0)), ByVal VarPtr(lgGuid.D8(7)), 1 RtlMoveMemory ByVal VarPtr(ba(15)), ByVal VarPtr(ba(0)), 0 GlobalUnlock lcGuid End If GUID = Padding(2, Hex(ba(0)), "0") & _ Padding(2, Hex(ba(1)), "0") & _ Padding(2, Hex(ba(2)), "0") & _ Padding(2, Hex(ba(3)), "0") & _ "-" & _ Padding(2, Hex(ba(4)), "0") & _ Padding(2, Hex(ba(5)), "0") & _ "-" & _ Padding(2, Hex(ba(6)), "0") & _ Padding(2, Hex(ba(7)), "0") & _ "-" & _ Padding(2, Hex(ba(8)), "0") & _ Padding(2, Hex(ba(9)), "0") & _ "-" & _ Padding(2, Hex(ba(10)), "0") & _ Padding(2, Hex(ba(11)), "0") & _ Padding(2, Hex(ba(12)), "0") & _ Padding(2, Hex(ba(13)), "0") & _ Padding(2, Hex(ba(14)), "0") & _ Padding(2, Hex(ba(15)), "0") End If GlobalFree lpGuid Else Debug.Print "Error: GlobalAlloc " & Err.Number & " " & Err.Description End If End Function Public Function IsGuid(ByVal Value As Variant, Optional ByVal Acolyte As Boolean = True) As Boolean If Not (Len(Value) = 36) And (InStr(Value, ".") = 0) Then IsGuid = False ElseIf Mid(Value, 9, 1) = "-" And _ Mid(Value, 14, 1) = "-" And _ Mid(Value, 19, 1) = "-" And _ Mid(Value, 24, 1) = "-" Then Dim tmp As Variant tmp = Value Dim cnt As Byte For cnt = Asc("0") To Asc("9") tmp = Replace(tmp, Chr(cnt), "") Next For cnt = Asc("A") To Asc("F") tmp = Replace(UCase(tmp), Chr(cnt), "") Next IsGuid = (tmp = "----") Or (tmp = "---") End If End Function Public Sub Main() Do While True Debug.Print GUID DoEvents Loop End Sub