VB icon

CoCreateGuid Example

Email
Submitted on: 9/22/2018 12:40:41 AM
By: Nicholas Forystek  
Level: Advanced
User Rating: Unrated
Compatibility: VB 4.0 (32-bit), VB 5.0, VB 6.0
Views: 7106
author picture
 
     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.
 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
				
'**************************************
' 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. Updated to copy and paste run in the vb4 debugger if the msvbvm60.dll is on the system.
' By: Nicholas Forystek
'**************************************

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


Other 20 submission(s) by this author

 


Report Bad Submission
Use this form to tell us if this entry should be deleted (i.e contains no code, is a virus, etc.).
This submission should be removed because:

Your Vote

What do you think of this code (in the Advanced category)?
(The code with your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor (See voting log ...)
 

Other User Comments


 There are no comments on this submission.
 

Add Your Feedback
Your feedback will be posted below and an email sent to the author. Please remember that the author was kind enough to share this with you, so any criticisms must be stated politely, or they will be deleted. (For feedback not related to this particular code, please click here instead.)
 

To post feedback, first please login.