• Home
 » 
• VB function enhancement
 » 
• CoCreateGuid Example

CoCreateGuid Example

by Nicholas Forystek
Category: VB function enhancement
Compatability: Visual Basic 4.0 (32-bit)
Difficulty: Advanced
Date Added: Fri 12 February 2021
Rating: (0 Votes)

Globally Unique Identifier generate function as well as a IsGuid() function to test if the GUID is a string representation seemingly of one. Updated to copy and paste run in the vb4 debugger if the msvbvm60.dll is on the system.

'**************************************
' 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


Download this snippet    Add to My Saved Code

CoCreateGuid Example Comments

No comments have been posted about CoCreateGuid Example. Why not be the first to post a comment about CoCreateGuid Example.

Post your comment

Subject:

Message:

0/1000 characters