'************************************** ' Name: CoCreateGuid Example '************************************** 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 Declare Function VarPtr Lib "msvbvm60.dll" (var As Any) As Long Private Function Padding(ByVal Length As Long, ByVal Value As String, Optional ByVal PadWith As Variant) As String If IsMissing(PadWith) Then PadWith = " " 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 Variant) As Boolean If IsMissing(Acolyte) Then Acolyte = True 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