Account Login Username:
Active Server Pages Coding Standards Complete Applications Custom Controls/Forms/Menus Data Structures Databases/Data Access/DAO/ADO DDE Debugging and Error Handling DirectX Encryption Files/File Controls/Input/Output Games Graphics Internet/HTML Jokes/Humor Libraries Math/Dates Microsoft Office Apps/VBA Miscellaneous Object Oriented Programming (OOP) OLE/COM/DCOM/Active-X Registry Sound/MP3 String Manipulation VB function enhancement Windows API Call/Explanation Windows CE Windows System Services
by Nicholas Forystek (14 Submissions) Category: VB function enhancementCompatability: Visual Basic 4.0 (32-bit)Difficulty: Advanced Date Added: Fri 12th 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 ExplicitOption Compare BinaryOption Private ModulePrivate Type GuidType '16A4 As Long '4B2 As Integer '2C2 As Integer '2D8(0 To 7) As Byte '8End TypePrivate Declare Function CoCreateGuid Lib "ole32" (ByVal pGuid As Long) As LongPrivate Const GPTR = &H40Private Const GMEM_MOVEABLE = &H2Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPrivate 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 LongPrivate Function Padding(ByVal Length As Long, ByVal Value As String, Optional ByVal PadWith As Variant) As StringIf IsMissing(PadWith) Then PadWith = " "Padding = String(Abs((Length * Len(PadWith)) - (Len(Value) \ Len(PadWith))), PadWith) & ValueEnd FunctionPublic Function GUID() As StringDim lpGuid As LonglpGuid = GlobalAlloc(GMEM_MOVEABLE And VarPtr(lpGuid), 4)If lpGuid <> 0 ThenDim lgGuid As GuidTypeDim toggle As IntegerIf CoCreateGuid(VarPtr(lgGuid)) = 0 ThenRtlMoveMemory lgGuid, ByVal lpGuid, 4&Dim lcGuid As LonglcGuid = GlobalLock(lpGuid)If lcGuid = lpGuid ThenDim ba(0 To 15) As Byte '16RtlMoveMemory ByVal VarPtr(ba(0)), ByVal VarPtr(lgGuid.A4) + 0, 16RtlMoveMemory ByVal VarPtr(ba(0)), ByVal VarPtr(ba(1)), 1RtlMoveMemory ByVal VarPtr(ba(1)), ByVal VarPtr(lgGuid.A4) + 1, 15RtlMoveMemory ByVal VarPtr(ba(1)), ByVal VarPtr(ba(2)), 1RtlMoveMemory ByVal VarPtr(ba(2)), ByVal VarPtr(lgGuid.A4) + 2, 14RtlMoveMemory ByVal VarPtr(ba(2)), ByVal VarPtr(ba(3)), 1RtlMoveMemory ByVal VarPtr(ba(3)), ByVal VarPtr(lgGuid.A4) + 3, 13RtlMoveMemory ByVal VarPtr(ba(3)), ByVal VarPtr(ba(4)), 1GlobalUnlock lcGuidRtlMoveMemory ByVal VarPtr(ba(4)), ByVal VarPtr(lgGuid.B2) + 0, 12RtlMoveMemory ByVal VarPtr(ba(4)), ByVal VarPtr(ba(5)), 1RtlMoveMemory ByVal VarPtr(ba(5)), ByVal VarPtr(lgGuid.B2) + 1, 11RtlMoveMemory ByVal VarPtr(ba(5)), ByVal VarPtr(ba(6)), 1lcGuid = GlobalLock(lpGuid)RtlMoveMemory ByVal VarPtr(ba(6)), ByVal VarPtr(lgGuid.C2) + 0, 10RtlMoveMemory ByVal VarPtr(ba(6)), ByVal VarPtr(ba(7)), 1RtlMoveMemory ByVal VarPtr(ba(7)), ByVal VarPtr(lgGuid.C2) + 1, 9RtlMoveMemory ByVal VarPtr(ba(7)), ByVal VarPtr(ba(8)), 1GlobalUnlock lcGuidRtlMoveMemory ByVal VarPtr(ba(7)), ByVal VarPtr(lgGuid.D8(0)), 1RtlMoveMemory ByVal VarPtr(ba(8)), ByVal VarPtr(ba(9)), 1RtlMoveMemory ByVal VarPtr(ba(6)), ByVal VarPtr(lgGuid.D8(1)), 1RtlMoveMemory ByVal VarPtr(ba(9)), ByVal VarPtr(ba(10)), 1lcGuid = GlobalLock(lpGuid)RtlMoveMemory ByVal VarPtr(ba(5)), ByVal VarPtr(lgGuid.D8(2)), 1RtlMoveMemory ByVal VarPtr(ba(10)), ByVal VarPtr(ba(11)), 1RtlMoveMemory ByVal VarPtr(ba(4)), ByVal VarPtr(lgGuid.D8(3)), 1RtlMoveMemory ByVal VarPtr(ba(11)), ByVal VarPtr(ba(12)), 1RtlMoveMemory ByVal VarPtr(ba(3)), ByVal VarPtr(lgGuid.D8(4)), 1RtlMoveMemory ByVal VarPtr(ba(12)), ByVal VarPtr(ba(13)), 1RtlMoveMemory ByVal VarPtr(ba(2)), ByVal VarPtr(lgGuid.D8(5)), 1RtlMoveMemory ByVal VarPtr(ba(13)), ByVal VarPtr(ba(14)), 1RtlMoveMemory ByVal VarPtr(ba(1)), ByVal VarPtr(lgGuid.D8(6)), 1RtlMoveMemory ByVal VarPtr(ba(14)), ByVal VarPtr(ba(15)), 1RtlMoveMemory ByVal VarPtr(ba(0)), ByVal VarPtr(lgGuid.D8(7)), 1RtlMoveMemory ByVal VarPtr(ba(15)), ByVal VarPtr(ba(0)), 0GlobalUnlock lcGuidEnd IfGUID = 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 IfGlobalFree lpGuidElseDebug.Print "Error: GlobalAlloc " & Err.Number & " " & Err.DescriptionEnd IfEnd FunctionPublic Function IsGuid(ByVal Value As Variant, Optional ByVal Acolyte As Variant) As BooleanIf IsMissing(Acolyte) Then Acolyte = TrueIf Not (Len(Value) = 36) And (InStr(Value, ".") = 0) ThenIsGuid = FalseElseIf Mid(Value, 9, 1) = "-" And _ Mid(Value, 14, 1) = "-" And _ Mid(Value, 19, 1) = "-" And _Mid(Value, 24, 1) = "-" ThenDim tmp As Varianttmp = ValueDim cnt As ByteFor cnt = Asc("0") To Asc("9")tmp = Replace(tmp, Chr(cnt), "")NextFor cnt = Asc("A") To Asc("F")tmp = Replace(UCase(tmp), Chr(cnt), "")NextIsGuid = (tmp = "----") Or (tmp = "---")End IfEnd FunctionPublic Sub Main()Do While TrueDebug.Print GUIDDoEventsLoopEnd Sub
Download this snippet Add to My Saved Code
No comments have been posted about CoCreateGuid Example. Why not be the first to post a comment about CoCreateGuid Example.
0/1000 characters