VB icon

CoCreateGuid Example

Email
Submitted on: 7/28/2017 2:45:13 PM
By: Nicholas Forystek  
Level: Advanced
User Rating: Unrated
Compatibility: VB 6.0
Views: 1298
author picture
 
     This is just a way I decided to use CoCreateGuid after a closer look at someones example that I had been using. I don't know that there really is in difference if difference besides the obvious I'm allocating it in global memory, (use of global memory API etc..). I believe in GUID's should be heard and not seen. As in only in development or temporary situations, that they don't play fair spotted. So there's this code.
 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!
				
'**************************************
' Name: CoCreateGuid Example
' Description:This is just a way I decided to use CoCreateGuid after a closer look at someones example that I had been using. I don't know that there really is in difference if difference besides the obvious I'm allocating it in global memory, (use of global memory API etc..). I believe in GUID's should be heard and not seen. As in only in development or temporary situations, that they don't play fair spotted.So there's this code.
' 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
D1 As Byte '1
E1 As Byte '1
F6(5) As Byte '6
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
Private Function HiInt(ByVal lParam As Long) As Integer
If (lParam And &HFFFF&) > &H7FFF Then
HiInt = (lParam And &HFFFF&) - &H10000
Else
HiInt = lParam And &HFFFF&
End If
End Function
Private Function LoInt(ByVal lParam As Long) As Integer
LoInt = (lParam And &HFFFF0000) \ &H10000
End Function
Private Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H100 And &HFF&
End Function
Private Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function
Private Function SwitchByte(ByRef val As Integer) As Byte
Static toggle As Long
If Not toggle Then
SwitchByte = HiByte(val)
Else
SwitchByte = LoByte(val)
End If
toggle = (-CInt(CBool(toggle)) + -1) + -CInt(Not CBool(-toggle + -1))
End Function
Private Function SwitchInt(ByRef val As Long) As Integer
Static toggle As Long
If Not toggle Then
SwitchInt = HiInt(val)
Else
SwitchInt = LoInt(val)
End If
toggle = (-CInt(CBool(toggle)) + -1) + -CInt(Not CBool(-toggle + -1))
End Function
Public Function GUID() As String
Dim lpGuid As Long
lpGuid = GlobalAlloc(GMEM_MOVEABLE And VarPtr(lpGuid), 4)
If lpGuid <> 0 Then
Dim lcGuid As Long
lcGuid = GlobalLock(lpGuid)
If lcGuid = lpGuid Then
Static lgGuid As GuidType
If CoCreateGuid(VarPtr(lgGuid)) = 0 Then
RtlMoveMemory lgGuid, ByVal lpGuid, 4&
GUID = GUID & Padding(2, Hex(SwitchByte(SwitchInt(lgGuid.A4))), "0")
GUID = GUID & Padding(2, Hex(SwitchByte(SwitchInt(lgGuid.A4))), "0")
 
GUID = GUID & Padding(2, Hex(SwitchByte(SwitchInt(lgGuid.A4))), "0")
GUID = GUID & Padding(2, Hex(SwitchByte(SwitchInt(lgGuid.A4))), "0")
GUID = GUID & "-"
GUID = GUID & Padding(2, Hex(SwitchByte(lgGuid.B2)), "0")
GUID = GUID & Padding(2, Hex(SwitchByte(lgGuid.B2)), "0")
GUID = GUID & "-"
GUID = GUID & Padding(2, Hex(SwitchByte(lgGuid.c2)), "0")
GUID = GUID & Padding(2, Hex(SwitchByte(lgGuid.c2)), "0")
GUID = GUID & "-"
GUID = GUID & Padding(2, Hex(lgGuid.D1), "0")
GUID = GUID & Padding(2, Hex(lgGuid.E1), "0")
GUID = GUID & "-"
GUID = GUID & Padding(2, Hex(lgGuid.F6(0)), "0")
GUID = GUID & Padding(2, Hex(lgGuid.F6(1)), "0")
GUID = GUID & Padding(2, Hex(lgGuid.F6(2)), "0")
GUID = GUID & Padding(2, Hex(lgGuid.F6(3)), "0")
GUID = GUID & Padding(2, Hex(lgGuid.F6(4)), "0")
GUID = GUID & Padding(2, Hex(lgGuid.F6(5)), "0")
End If
End If
GlobalUnlock lcGuid
GlobalFree lpGuid
Else
Debug.Print "Error: GlobalAlloc " & Err.Number & " " & Err.Description
End If
End Function
Public Function IsGuid(ByVal Value As Variant) As Boolean
If Not (Len(Value) = 36) And (InStr(Value, ".") = 0) Then
IsGuid = False
Else
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 = "----")
If IsGuid Then
tmp = Value
For cnt = 1 To 4
IsGuid = IsGuid And ((Len(Left(tmp, InStr(tmp, "-") - 1)) Mod 2) = 0)
tmp = Mid(tmp, InStr(tmp, "-") + 1)
Next
IsGuid = IsGuid And ((Len(tmp) Mod 2) = 0)
End If
End If
End Function


Other 11 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.