|
-
Nov 23rd, 2009, 12:39 AM
#1
Thread Starter
Frenzied Member
VB6 - Random GUID Generator
It makes type 4 GUID (fully random) rather that type 1 (time based) or type 2 (network hardware based).
Filename is: GUIDgenerator.bas
Source is:
Code:
Attribute VB_Name = "GUIDgenerator"
Private MyGUID(35) As Byte
Private DashNum As Byte
Private FourNum As Byte
Public Sub GenInit()
Randomize
FourNum = Asc("4")
DashNum = Asc("-")
End Sub
Public Function GenGUID() As String
For i = 0 To 7
MyGUID(i) = Asc(Hex(Int(16 * Rnd())))
Next i
For i = 9 To 12
MyGUID(i) = Asc(Hex(Int(16 * Rnd())))
Next i
For i = 15 To 17
MyGUID(i) = Asc(Hex(Int(16 * Rnd())))
Next i
For i = 19 To 22
MyGUID(i) = Asc(Hex(Int(16 * Rnd())))
Next i
For i = 24 To 35
MyGUID(i) = Asc(Hex(Int(16 * Rnd())))
Next i
MyGUID(8) = DashNum
MyGUID(13) = DashNum
MyGUID(14) = FourNum
MyGUID(18) = DashNum
MyGUID(23) = DashNum
GenGUID = "{" & StrConv(MyGUID, vbUnicode) & "}"
End Function
Copy this code and paste it into a text file, save it, and rename it GUIDgenerator.bas
and you can start implementing GUIDs in your VB6 programs.
Last edited by Ben321; Nov 23rd, 2009 at 12:48 AM.
-
Nov 24th, 2009, 12:01 AM
#2
Re: VB6 - Random GUID Generator
here's a beter way:
Code:
Option Explicit
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Sub CoCreateGuid Lib "ole32.dll" (ByRef pguid As Guid)
Private Declare Function StringFromGUID2 Lib "ole32.dll" (ByVal rguid As Long, ByVal lpsz As Long, ByVal cchMax As Long) As Long
Private Function GetGUID() As String
Dim MyGUID As Guid
Dim GUIDByte() As Byte
Dim GuidLen As Long
CoCreateGuid MyGUID
ReDim GUIDByte(80)
GuidLen = StringFromGUID2(VarPtr(MyGUID.Data1), VarPtr(GUIDByte(0)), UBound(GUIDByte))
GetGUID = Left(GUIDByte, GuidLen)
End Function
Private Sub Form_Load()
Debug.Print GetGUID
End Sub
Last edited by CVMichael; Nov 24th, 2009 at 12:07 AM.
-
Nov 2nd, 2021, 03:45 AM
#3
Junior Member
Re: VB6 - Random GUID Generator
If you turn the code example above on debug.print generating loop, it is repeating the 13th character a "4." I'm not sure that matters too much, but in the interest of "unique" I tried thwarting it, and it usually moved around sometimes whole portions some just couple character repeating, until I decided GlobalLock must be appropriate because it's how I solved mine from repeating portions of the Guid. Here's the repeating "4" debug output, followed by how I use CoCreateGuid() and a sample of it's output:
{830E7F38-1429-4311-9263-961789103EC3}
{346177DB-CF60-4C09-B270-A1D9B7DCFD97}
{63B26A6B-3DCB-485B-940D-C0358D2FEF33}
{065C1892-21C1-4E5B-AEC6-C330A7C87736}
{E55EAE34-9E4E-4F8A-B8A5-8A5827D5872F}
{A33B75FE-D2DF-4C50-B984-E4F653995FD8}
{9F0C5520-175E-4EBE-9DC7-402BAF1E9393}
{D2243966-4E02-446D-B53A-A6C5D32CBEF5}
{5053FD63-16FB-4D91-B1B5-2C45BF36AF36}
{80F71DA7-06CA-4D89-96FF-D019399AD38A}
{88B929C9-BE86-487F-AFA3-8DACA6ECD1FD}
{E8B69C44-215E-4777-8B7A-A02BDBE3F706}
{84B70282-FCA4-45B4-8622-CE42D768DB2C}
{DA95BB8F-9216-4353-86D5-E37F1C9E35CA}
{025F4B7D-7E89-4FA5-9975-C406F699B5CB}
{1A68C855-B980-4A13-BFCB-105007D0FC34}
{4B169D69-45A9-4A81-9F58-C502D84D8F3A}
{3A64FDA1-39BD-4A4A-9B27-A6CC53B1A8E3}
{F0F4DFC2-E44F-4872-85B5-956C3B721C1B}
{65D393D2-B4EB-4E53-96FF-45C01B75AA13}
{AFC7CFEB-88B9-45CF-B635-42B62873ABA8}
{2A30AD8E-40C5-47AE-A842-EEC3DE71CFF4}
{CCD730C8-C51C-4425-8185-C9B8688C337F}
{A7A863CC-4EA6-453F-A72B-8CD1ECB49D88}
{5FBE297C-691F-4495-B47E-A87B941DA291}
{87583562-856F-4433-98DC-54C9042F4B10}
{3C2A2915-42A0-4422-84A4-CD8C99396BA3}
{D1FA80F7-D160-4EA0-AA96-53F1CE1DD6FA}
{9FDFF39E-7017-475D-8352-431B54466C52}
{059BB976-3037-4973-9ECD-A39318BFA9CC}
{43052402-1EEA-44F9-8667-B2964B6195F7}
{9A8AB81A-187F-4877-B7E1-1C622C5C54B4}
{1243167B-22E6-4E26-A4AC-34EB6CC1CB3C}
{AABF412A-3C3A-40B8-950D-ACDA3F7BA38B}
{7B8AEBA6-D24D-4201-A0B0-0C666719D604}
{9D299802-3EB0-44F0-A283-E5BBF996C18B}
{2BA291E1-2467-454E-AA6F-941EC725F701}
{9EB2EC12-3BE6-4BA1-A14F-9B3B1A97C12C}
{4BEB51F3-0500-42F9-867C-FD8903C7656A}
{96FD3D8C-D519-4728-9041-42448A2C978B}
{0159F701-2D72-4DF2-965E-19628821DDB0}
{6EF39FFA-0BD9-4C72-8D24-61AD5FCF45FC}
{5A2FCE2F-A30E-4E62-8676-E3F00D66022F}
{8F14518E-1F9E-4879-B094-5ABCF3A6848F}
{048AEDD9-14C1-4804-99A6-4B1D77F623FB}
{5032C82E-504F-44F0-AAA9-3CC7EF5D9C78}
{D142684E-EBC7-45A9-B914-6491A6E876FC}
{8B3BCCAE-92EA-4721-8856-5166D607EBF0}
{47BEBE13-90EC-49D7-8A0B-0E9336C0800D}
{C5C8BF85-096A-4A9C-8DE9-7B04D0CBC7F2}
{FEBF6196-2C1A-46AA-9DC3-F349D5D9C17E}
{13962E94-DE50-4CC6-9A27-027B9CF68527}
{DED88609-3290-4B30-89CF-BFAC3D5A2753}
{4460CAC0-3187-48E1-AAB4-D1FCF59623A8}
{5B66ADA4-9B77-4968-B9B6-39191143A795}
{F6D99238-40C2-419E-9488-A15A052A929A}
{01681D77-0302-46CE-9BA9-07B9A07105AF}
{33AD0079-C6B5-4AEE-A55A-647E9AA49BA2}
{7F78692D-DF1B-4CF5-AE66-B3798F1259AC}
{F786123E-7217-474C-879C-1A45B16D8ED3}
{B40DFA52-855A-4C8E-8C37-99CEBE9FDC5B}
{FAA30911-6ABF-4754-BC04-ABDD535334EC}
{97962233-71FE-4BAC-BBE8-5B4359EE115A}
{51A7E962-B438-434F-9E77-6B7FD90CA211}
{0C28424B-F7DF-4CB5-AAF2-29DECB8B8A44}
{486A6464-316B-4EA7-AB96-FA5F68D5E57A}
{8368313F-BED4-49AD-BCE9-C4C9503A71AF}
{2B54F2F2-6A4B-4C9B-B934-C34C96251BB6}
{5AB21148-9873-42AF-83DC-222B56E52AF8}
{7FB0C309-DD7B-454D-B668-AAF76E5D1298}
Code:
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 Declare Sub RtlMoveMemory Lib "kernel32" (Left As Any, Pass As Any, ByVal Right As Long)
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 Const GMEM_MOVEABLE = &H2
Public Function GUID() As String
Dim lpGuid As Long
Dim lcGuid As Long
lpGuid = GlobalAlloc(GMEM_MOVEABLE And VarPtr(lpGuid), LenB(lpGuid))
If lpGuid <> 0 Then
Dim lgGuid As GuidType
If CoCreateGuid(VarPtr(lgGuid)) = 0 Then
RtlMoveMemory lgGuid, ByVal lpGuid, LenB(lpGuid)
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
End If
GlobalFree lpGuid
lpGuid = ((UBound(ba) + 1) / 4)
For lcGuid = 1 To (UBound(ba) + 1)
GUID = GUID & Left(Hex(ba(lcGuid - 1)) & "0", 2)
If ((lcGuid Mod lpGuid) = 0) Then
lpGuid = IIf(((lpGuid * lcGuid) = (UBound(ba) + 1)), (lpGuid / 2), _
IIf((lpGuid <= (UBound(ba) + 1) / 2), ((UBound(ba) + 1) / lpGuid), lpGuid))
If (lcGuid < (UBound(ba) + 1)) Then GUID = GUID & "-"
End If
Next
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 cnt As Byte
For cnt = Asc("0") To Asc("9")
Value = Replace(Value, Chr(cnt), "")
Next
For cnt = Asc("A") To Asc("F")
Value = Replace(Value, Chr(cnt), "")
Next
IsGuid = (Value = "----")
End If
End Function
Public Function IsClsid(ByVal Value As Variant) As Boolean
If Left(Value, 1) = "{" And Right(Value, 1) = "}" Then
Value = Mid(Value, 2, Len(Value) - 2)
IsClsid = (IsGuid(UCase(Value)) And (Not IsGuid(LCase(Value))))
End If
End Function
Public Sub Main()
Do While True
Debug.Print GUID
DoEvents
Loop
End Sub
3E88BA16-10E6-0DB0-0DE6-1016BA883E3E
78E5256A-4FFC-F1B8-F1FC-4F6A25E57878
901B4BFE-D6FC-2FA0-2FFC-D6FE4B1B9090
590CC90A-B4D1-B9B2-B9D1-B40AC90C5959
E8D79150-2F22-4B8A-4B22-2F5091D7E8E8
72E4CB00-489B-08B3-089B-4800CBE47272
ED5727A5-78AB-24BD-24AB-78A52757EDED
13740DAE-1B77-228E-2277-1BAE0D741313
904E3EC4-0765-C882-C865-07C43E4E9090
0DF8FEA7-1282-6CB4-6C82-12A7FEF80D0D
5883BEB1-D5B0-BAA1-BAB0-D5B1BE835858
9E102C20-B33F-91A3-913F-B3202C109E9E
3E244A5D-AC41-6AAD-6A41-AC5D4A243E3E
12837846-BB85-C2A7-C285-BB4678831212
A3688CE0-37F8-02AD-02F8-37E08C68A3A3
21B83776-90D8-5DB2-5DD8-907637B82121
8C98102D-D10C-EF90-EF0C-D12D10988C8C
DB5C3E9C-D30A-02A9-020A-D39C3E5CDBDB
9CF22DE0-B1EF-4E8E-4EEF-B1E02DF29C9C
E2E292D8-8D43-9A9F-9A43-8DD892E2E2E2
BE06D014-1EE9-4590-45E9-1E14D006BEBE
5AD491B7-311F-DCAA-DC1F-31B791D45A5A
EEDBE48E-644D-A086-A04D-648EE4DBEEEE
FFD32764-004A-4A8F-4A4A-006427D3FFFF
921EC980-06FE-6397-63FE-0680C91E9292
C79432E1-76DB-98B3-98DB-76E13294C7C7
43F3284A-2AC9-FBB8-FBC9-2A4A28F34343
9757218A-B8D9-829B-82D9-B88A21579797
11D1A27B-958F-E793-E78F-957BA2D11111
23AA8DCE-3958-2689-2658-39CE8DAA2323
D0FA8020-AC0B-B483-B40B-AC2080FAD0D0
B946C612-D380-8292-8280-D312C646B9B9
21825882-903F-FB9D-FB3F-908258822121
1A822F07-C24D-9BAF-9B4D-C2072F821A1A
47F6DC79-6F55-C389-C355-6F79DCF64747
528A8E5F-9A85-BDAB-BD85-9A5F8E8A5252
3736FF46-4CC3-408B-40C3-4C46FF363737
6500E11B-BD68-F184-F168-BD1BE1006565
CD573377-F05F-6AA0-6A5F-F0773357CDCD
F93C0631-C75A-4DA4-4D5A-C731063CF9F9
15EE7DBF-2B23-1596-1523-2BBF7DEE1515
DFC738D4-2EDE-A393-A3DE-2ED438C7DFDF
C50799AD-F9CF-B8A5-B8CF-F9AD9907C5C5
55148371-92C2-64A1-64C2-927183145555
1AC7D91E-A287-45B4-4587-A21ED9C71A1A
CB27E281-8C70-51AC-5170-8C81E227CBCB
60187068-754D-6B8B-6B4D-756870186060
691D51A8-7108-E2B2-E208-71A8511D6969
A8C21BC9-BA91-34A0-3491-BAC91BC2A8A8
ED129F77-DF07-469F-4607-DF779F12EDED
2CEFFDAD-565A-CF8D-CF5A-56ADFDEF2C2C
A9936CF3-1026-C79C-C726-10F36C93A9A9
743BF09F-236C-698C-696C-239FF03B7474
0B139B7C-CB85-19BC-1985-CB7C9B130B0B
ED54E418-DDAB-8DA9-8DAB-DD18E454EDED
FE242243-51CC-73B5-73CC-51432224FEFE
14978E7F-C74F-8FBA-8F4F-C77F8E971414
25A90783-76F2-A293-A2F2-768307A92525
E5F5FD8D-CB74-D3A6-D374-CB8DFDF5E5E5
28E58043-556E-71A5-716E-554380E52828
7AE6C135-5106-1ABC-1A06-5135C1E67A7A
E3796926-DB64-F190-F164-DB266979E3E3
6088E30F-2FF3-B391-B3F3-2F0FE3886060
A96D6D66-C32E-BC95-BC2E-C3666D6DA9A9
17F2973C-6FF8-708C-70F8-6F3C97F21717
B368E77B-DC9B-4FB6-4F9B-DC7BE768B3B3
0D6D28D8-5C42-EB87-EB42-5CD8286D0D0D
4C7ABF50-919C-D789-D79C-9150BF7A4C4C
5444787C-8744-3B83-3B44-877C78445454
C48485CB-C8DA-ED88-EDDA-C8CB8584C4C4
B407979A-BA51-5D93-5D51-BA9A9707B4B4
6F3A0C43-A608-5788-5708-A6430C3A6F6F
F21BE81C-F151-CBB2-CB51-F11CE81BF2F2
1D42F039-D1C6-CF97-CFC6-D139F0421D1D
5FE53F50-5AA8-64B6-64A8-5A503FE55F5F
6E697BD5-8173-C684-C673-81D57B696E6E
A7B9CF4F-326F-F89C-F86F-324FCFB9A7A7
19F6AA84-36E8-32A1-32E8-3684AAF61919
37226100-2135-47AB-4735-210061223737
2DCFD2C0-80F3-1FA1-1FF3-80C0D2CF2D2D
1B78C72A-8559-8491-8459-852AC7781B1B
66DA6CE5-3FD3-DDB6-DDD3-3FE56CDA6666
CCB4F675-D0B4-3C9F-3CB4-D075F6B4CCCC
D228D6CE-855B-BDAE-BD5B-85CED628D2D2
441635E6-BBA6-C8BD-C8A6-BBE635164444
016B9A7E-5A8B-5FBA-5F8B-5A7E9A6B0101
3DDC7F89-A30C-B1B7-B10C-A3897FDC3D3D
7B7BD56B-414F-C593-C54F-416BD57B7B7B
2D37BBC7-30C5-4681-46C5-30C7BB372D2D
C9EC4150-9FF1-1E84-1EF1-9F5041ECC9C9
14FAEA45-7F5C-3FA9-3F5C-7F45EAFA1414
76BCC719-66E6-EE9F-EEE6-6619C7BC7676
0AE0B7D8-3992-F681-F692-39D8B7E00A0A
05029271-6D5E-3AB5-3A5E-6D7192020505
48F45B32-DC73-D582-D573-DC325BF44848
0EAE8062-E37F-1D92-1D7F-E36280AE0E0E
ED4CA781-DC65-0D81-0D65-DC81A74CEDED
CDD2E414-D9CC-56A3-56CC-D914E4D2CDCD
706643D7-6C65-8C8C-8C65-6CD743667070
B8EAEAB0-0F02-3691-3602-0FB0EAEAB8B8
A36844ED-FC59-AFA3-AF59-FCED4468A3A3
16F790DD-74D9-3B92-3BD9-74DD90F71616
444F894C-049E-75B6-759E-044C894F4444
Come to think of it, the 2 at the end of the function name StringFromGUID2 makes me think their not so certain they have it correct the first time, and "Co" in CoCreateGuid() I think means cooperative so ole32 can't be doing any more then that part, because it's combinations of location that make it global unique, I think that's why I charge it to GlobalLock() too. Any shorter way of CoCreateGuid() like the first post, but not repeating portions on the Guid from one to the next in rapid debug.print rate (easier to see it repeat), like the second post, I would have to scrap both these for it!
Last edited by nforystek; Nov 2nd, 2021 at 07:07 PM.
-
Nov 2nd, 2021, 09:13 AM
#4
Re: VB6 - Random GUID Generator
The 4 is deliberately placed at this location -- it marks the format of UUID generated. You can read the article in the Wikipedia for more info.
Co in CoCreateGuid comes from COM, not cooperative nor collocation nor corruption.
cheers,
</wqw>
-
Nov 2nd, 2021, 07:50 PM
#5
Junior Member
Re: VB6 - Random GUID Generator
Oh...I'm under the impression we aren't suppose to see them anyway. It in essence wont happen then. Like I'm not sure, it could be fame, eventually, seeing too many of them. Unique in time as well.
Here's PoolID code, wont repeat as long as in memory, unload it and load it again has a high potential to repeat, (uses an encryption I wrote, it may use a book size key and put it to one byte if you reverse the password and data, useful for other encryption combos, it could be useful in SSL as a crimp check to non SSL web, so https has to match the http, and the crimp per website in a ring would tighten the allocated stress into small and large vice versa to another for a validity check, but I'm not that good, I don't even have it written in C, and dare I say that theory could allow VB to 100% serialize objects w/o knowing them, I dare say, my father is a bloat, busted his head spilling out customer data, they forced to arrive in a dream, well not really a dream but a unconscious state, force to be present to watch him fail security, just because I program, considerably present, I got to sit out actually see data, noted why VB obj can't serialize, RC+DS+NC=WON)
PoolID.cls
Code:
Option Explicit
Option Compare Binary
Public Enum TimedSums
NoTiming = 0
CheckSums = 1
BoundSums = 2
End Enum
Private Dividen As Single
Private LastGen As Single
Private Const Bit1 As Byte = &H1
Private Const Bit2 As Byte = &H2
Private Const Bit3 As Byte = &H4
Private Const Bit4 As Byte = &H8
Private Const Bit5 As Byte = &H10
Private Const Bit6 As Byte = &H20
Private Const Bit7 As Byte = &H40
Private Const Bit8 As Byte = &H80
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private SumCheck As TimedSums
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Static Property Get Pacerate() As TimedSums
Pacerate = SumCheck
End Property
Public Static Property Let Pacerate(ByRef nval As TimedSums)
SumCheck = nval
End Property
Public Function Generate(Optional ByVal ParaPhrase As String = "*") As String
Dim tick As Long
Dim start As Single
Dim ohmz As String
Dim dash As Byte
Static sum As Boolean
If (SumCheck = NoTiming) Then
ohmz = EncryptString(CStr(Timer \ Dividen), CStr(GetTickCount \ Dividen), False)
ohmz = EncryptString(ParaPhrase, EncryptString(CStr(Timer), ohmz, False), False)
ohmz = EncryptString( _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)), ohmz, True)
dash = 1 + Int(2 + ((8 - 2) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
dash = dash + Int(3 + ((9 - 3) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
dash = dash + Int(3 + ((9 - 3) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
dash = dash + Int(3 + ((7 - 3) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
If Not (dash Mod 2 = 0) Then ohmz = StrReverse(ohmz)
Generate = ohmz
ElseIf (SumCheck = CheckSums) Then
start = Timer
tick = GetTickCount
ohmz = EncryptString(CStr(Timer \ Dividen), CStr(GetTickCount \ Dividen), False)
ohmz = EncryptString(ParaPhrase, EncryptString(CStr(Timer), ohmz, False), False)
ohmz = EncryptString( _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)), ohmz, True)
dash = 1 + Int(2 + ((8 - 2) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
dash = dash + Int(3 + ((9 - 3) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
dash = dash + Int(3 + ((9 - 3) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
dash = dash + Int(3 + ((7 - 3) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
If Not (dash Mod 2 = 0) Then ohmz = StrReverse(ohmz)
Generate = ohmz
tick = CSng(GetTickCount - tick)
start = CSng(Timer - start)
If Not sum Then
sum = True
Static tsu As Single
Static eta As Single
If tsu > 0 Then Sleep tsu
eta = eta - 1
If (eta < 0) Then
tsu = eta
eta = CheckSum(ParaPhrase)
End If
sum = False
End If
LastGen = LastGen + Sqr(tick * start)
ElseIf (SumCheck = BoundSums) Then
If Not sum Then
sum = True
Sleep CheckSum(ParaPhrase)
sum = False
End If
start = Timer
tick = GetTickCount
ohmz = EncryptString(CStr(Timer \ Dividen), CStr(GetTickCount \ Dividen), False)
ohmz = EncryptString(ParaPhrase, EncryptString(CStr(Timer), ohmz, False), False)
ohmz = EncryptString( _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)) & Int((9 * Rnd)) & Int((9 * Rnd)) & _
Int((9 * Rnd)), ohmz, True)
dash = 1 + Int(2 + ((8 - 2) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
dash = dash + Int(3 + ((9 - 3) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
dash = dash + Int(3 + ((9 - 3) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
dash = dash + Int(3 + ((7 - 3) * Rnd))
ohmz = Left(ohmz, dash - 1) & "-" & Mid(ohmz, dash)
If Not (dash Mod 2 = 0) Then ohmz = StrReverse(ohmz)
Generate = ohmz
tick = CSng(GetTickCount - tick)
start = CSng(Timer - start)
LastGen = LastGen + Sqr(tick * start)
End If
End Function
Private Function CheckSum(Optional ByVal ParaPhrase As String = "*") As Single
Dim ohmz As String
Dim hert As String
Dim temp As String
Dim tick As Long
Dim start As Single
If (SumCheck = NoTiming) Then
start = Timer
tick = GetTickCount
hert = EncryptString(CStr(start \ Dividen), CStr(GetTickCount \ Dividen), False)
ohmz = EncryptString(ParaPhrase, EncryptString(CStr(Timer), hert, False), False)
hert = DecryptString(ohmz, hert, False)
tick = CSng(GetTickCount - tick)
start = CSng(Timer - start)
CheckSum = Sqr(tick * start)
ElseIf (SumCheck = CheckSums) Then
start = Timer
tick = GetTickCount
Do
hert = EncryptString(CStr(start \ Dividen), CStr(GetTickCount \ Dividen), False)
ohmz = EncryptString(ParaPhrase, EncryptString(CStr(Timer), hert, False), False)
Static toggle As Boolean
toggle = Not toggle
If toggle Then hert = StrReverse(hert)
hert = DecryptString(ohmz, hert, False)
Loop Until hert = ParaPhrase
tick = CSng(GetTickCount - tick)
start = CSng(Timer - start)
If toggle Then
LastGen = 0
Generate Generate
CheckSum = LastGen
Else
CheckSum = Sqr(tick * start)
End If
ElseIf (SumCheck = BoundSums) Then
start = Timer
tick = GetTickCount
Static tolerance As Single
If tolerance <= 0 Then tolerance = 0.3543
Do Until hert = ParaPhrase Or (Timer - start) >= tolerance
hert = EncryptString(CStr(Timer \ Dividen), CStr(GetTickCount \ Dividen), False)
ohmz = EncryptString(ParaPhrase, EncryptString(CStr(Timer), hert, False), False)
hert = DecryptString(ohmz, hert, False)
Loop
If Not (hert = ParaPhrase) And (Timer - start) >= tolerance Then
tolerance = 0.0103
ElseIf tolerance < 0.3543 Then
tolerance = tolerance + 0.0199
End If
tick = CSng(GetTickCount - tick)
start = CSng(Timer - start)
If Sqr(tick * start) - LastGen < 0 Then
LastGen = 0
Generate Generate
CheckSum = Sqr(tick * start)
ElseIf LastGen > 0 Then
CheckSum = Sqr(tick * start) - LastGen
LastGen = (Sqr(tick * start) - LastGen) + Sqr(tick * start)
End If
End If
End Function
Private Sub Class_Initialize()
Dividen = GetTickCount / Timer
End Sub
Private Sub Class_Terminate()
Randomize
End Sub
Private Function EncryptString(ByVal Text As String, ByVal Key As String, Optional ByVal OutputInHex As Boolean = True) As String
If Len(Text) < 1 Or Len(Key) < 1 Then
Err.Raise 8, "NTCipher10.NCode", "Both length of Text and Key in characters, must be non zero."
Else
EncryptString = StrConv(EnKrimpt(StrConv(Text, vbFromUnicode), StrConv(Key, vbFromUnicode)), vbUnicode)
If OutputInHex = True Then EncryptString = HexEncodeData(EncryptString)
End If
End Function
Private Function DecryptString(ByVal Text As String, ByVal Key As String, Optional ByVal IsTextInHex As Boolean = True) As String
If Len(Text) < 1 Or Len(Key) < 1 Then
Err.Raise 8, "NTCipher10.NCode", "Both length of Text and Key in characters, must be non zero."
Else
If IsTextInHex = True Then Text = HexDecodeData(Text)
DecryptString = StrConv(DeKrimpt(StrConv(Text, vbFromUnicode), StrConv(Key, vbFromUnicode)), vbUnicode)
End If
End Function
Private Function HexEncodeData(ByVal d As String) As String
Dim s As String
Dim l As Long
Dim i As Long
Dim n As String
l = Len(d)
If l > 0 Then
For i = 1 To l
n = Hex(Asc(Mid(d, i, 1)))
If Len(n) < 2 Then
s = s & "0" & n
Else
s = s & n
End If
Next
End If
HexEncodeData = s
End Function
Private Function HexDecodeData(ByVal d As String) As String
Dim s As String
Dim l As Long
Dim i As Long
l = Len(d)
If l > 0 Then
For i = 1 To l Step 2
s = s & Chr(Val("&H" & Mid(d, i, 2)))
Next
End If
HexDecodeData = s
End Function
Private Function EnKrimpt(Info() As Byte, Seed() As Byte) As Byte()
Dim pin As Byte
Dim swp As Byte
Dim cap As Boolean
Dim cnt1 As Long
Dim cnt2 As Long
Dim lbi As Long
Dim ubi As Long
Dim lbs As Long
Dim ubs As Long
lbi = LBound(Info)
ubi = UBound(Info)
lbs = LBound(Seed)
ubs = UBound(Seed)
BitByte(pin, Bit1) = BitByte(Seed(lbs), Bit6) Or BitByte(Seed(ubs), Bit2)
BitByte(pin, Bit2) = BitByte(Seed(ubs), Bit4) Or BitByte(Seed(lbs), Bit1)
BitByte(pin, Bit3) = BitByte(Seed(lbs), Bit8) Or BitByte(Seed(ubs), Bit5)
BitByte(pin, Bit4) = BitByte(Seed(ubs), Bit7) Or BitByte(Seed(lbs), Bit3)
cap = (BitByte(pin, Bit1) Or BitByte(pin, Bit2)) And (BitByte(pin, Bit3) Or BitByte(pin, Bit4))
For cnt1 = lbs To ubs
For cnt2 = lbi To ubi
Select Case (-BitByte(Seed(cnt1), Bit1)) & (-BitByte(Seed(cnt1), Bit2)) & (-BitByte(Info(cnt2), Bit1)) & (-BitByte(Info(cnt2), Bit2))
Case "0011"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = False
Case "0000"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = True
Case "0010"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = True
Case "0001"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = False
Case "1111"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = False
Case "1100"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = False
Case "1110"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = True
Case "1101"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = True
Case "1011"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = True
Case "1000"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = True
Case "1010"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = False
Case "1001"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = False
Case "0111"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = False
Case "0100"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = True
Case "0110"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = True
Case "0101"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = False
End Select
Next
Next
For cnt1 = lbi To ubi
Select Case (-BitByte(pin, Bit1)) & (-BitByte(pin, Bit2)) & (-BitByte(Info(cnt1), Bit3)) & (-BitByte(Info(cnt1), Bit4))
Case "0011"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = False
Case "0000"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = True
Case "0010"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = True
Case "0001"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = False
Case "1111"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = False
Case "1100"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = False
Case "1110"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = True
Case "1101"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = True
Case "1011"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = True
Case "1000"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = True
Case "1010"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = False
Case "1001"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = False
Case "0111"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = False
Case "0100"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = True
Case "0110"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = True
Case "0101"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = False
End Select
Next
BitByte(swp, Bit1) = BitByte(Info(lbi), IIf(cap, Bit5, Bit6))
BitByte(swp, Bit2) = BitByte(Info(lbi), IIf(cap, Bit6, Bit7))
BitByte(swp, Bit3) = BitByte(Info(lbi), IIf(cap, Bit7, Bit8))
BitByte(swp, Bit4) = BitByte(Info(lbi), IIf(cap, Bit8, Bit5))
For cnt1 = lbi To ubi - 1
BitByte(Info(cnt1), IIf(cap, Bit6, Bit5)) = BitByte(Info(cnt1 + 1), IIf(cap, Bit5, Bit6))
BitByte(Info(cnt1), IIf(cap, Bit7, Bit6)) = BitByte(Info(cnt1 + 1), IIf(cap, Bit6, Bit7))
BitByte(Info(cnt1), IIf(cap, Bit8, Bit7)) = BitByte(Info(cnt1 + 1), IIf(cap, Bit7, Bit8))
BitByte(Info(cnt1), IIf(cap, Bit5, Bit8)) = BitByte(Info(cnt1 + 1), IIf(cap, Bit8, Bit5))
Next
BitByte(Info(ubi), IIf(cap, Bit6, Bit5)) = BitByte(swp, Bit1)
BitByte(Info(ubi), IIf(cap, Bit7, Bit6)) = BitByte(swp, Bit2)
BitByte(Info(ubi), IIf(cap, Bit8, Bit7)) = BitByte(swp, Bit3)
BitByte(Info(ubi), IIf(cap, Bit5, Bit8)) = BitByte(swp, Bit4)
EnKrimpt = Info
End Function
Private Function DeKrimpt(Info() As Byte, Seed() As Byte) As Byte()
Dim pin As Byte
Dim swp As Byte
Dim cap As Boolean
Dim cnt1 As Long
Dim cnt2 As Long
Dim lbi As Long
Dim ubi As Long
Dim lbs As Long
Dim ubs As Long
lbi = LBound(Info)
ubi = UBound(Info)
lbs = LBound(Seed)
ubs = UBound(Seed)
BitByte(pin, Bit1) = BitByte(Seed(lbs), Bit6) Or BitByte(Seed(ubs), Bit2)
BitByte(pin, Bit2) = BitByte(Seed(ubs), Bit4) Or BitByte(Seed(lbs), Bit1)
BitByte(pin, Bit3) = BitByte(Seed(lbs), Bit8) Or BitByte(Seed(ubs), Bit5)
BitByte(pin, Bit4) = BitByte(Seed(ubs), Bit7) Or BitByte(Seed(lbs), Bit3)
cap = (BitByte(pin, Bit1) Or BitByte(pin, Bit2)) And (BitByte(pin, Bit3) Or BitByte(pin, Bit4))
BitByte(swp, Bit1) = BitByte(Info(ubi), IIf(cap, Bit6, Bit5))
BitByte(swp, Bit2) = BitByte(Info(ubi), IIf(cap, Bit7, Bit6))
BitByte(swp, Bit3) = BitByte(Info(ubi), IIf(cap, Bit8, Bit7))
BitByte(swp, Bit4) = BitByte(Info(ubi), IIf(cap, Bit5, Bit8))
For cnt1 = ubi To (lbi + 1) Step -1
BitByte(Info(cnt1), IIf(cap, Bit5, Bit6)) = BitByte(Info(cnt1 - 1), IIf(cap, Bit6, Bit5))
BitByte(Info(cnt1), IIf(cap, Bit6, Bit7)) = BitByte(Info(cnt1 - 1), IIf(cap, Bit7, Bit6))
BitByte(Info(cnt1), IIf(cap, Bit7, Bit8)) = BitByte(Info(cnt1 - 1), IIf(cap, Bit8, Bit7))
BitByte(Info(cnt1), IIf(cap, Bit8, Bit5)) = BitByte(Info(cnt1 - 1), IIf(cap, Bit5, Bit8))
Next
BitByte(Info(lbi), IIf(cap, Bit5, Bit6)) = BitByte(swp, Bit1)
BitByte(Info(lbi), IIf(cap, Bit6, Bit7)) = BitByte(swp, Bit2)
BitByte(Info(lbi), IIf(cap, Bit7, Bit8)) = BitByte(swp, Bit3)
BitByte(Info(lbi), IIf(cap, Bit8, Bit5)) = BitByte(swp, Bit4)
For cnt1 = lbi To ubi
Select Case (-BitByte(Info(cnt1), Bit3)) & (-BitByte(Info(cnt1), Bit4)) & (-BitByte(pin, Bit1)) & (-BitByte(pin, Bit2))
Case "0000"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = True
Case "1100"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = False
Case "0100"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = False
Case "1000"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = True
Case "0011"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = True
Case "1011"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = False
Case "0111"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = False
Case "1111"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = True
Case "0110"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = True
Case "1110"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = False
Case "0010"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = False
Case "1010"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = True
Case "1001"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = True
Case "0101"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = False
Case "1101"
BitByte(Info(cnt1), Bit3) = True
BitByte(Info(cnt1), Bit4) = False
Case "0001"
BitByte(Info(cnt1), Bit3) = False
BitByte(Info(cnt1), Bit4) = True
End Select
Next
For cnt1 = ubs To lbs Step -1
For cnt2 = lbi To ubi
Select Case (-BitByte(Info(cnt2), Bit1)) & (-BitByte(Info(cnt2), Bit2)) & (-BitByte(Seed(cnt1), Bit1)) & (-BitByte(Seed(cnt1), Bit2))
Case "0000"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = True
Case "1100"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = False
Case "0100"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = False
Case "1000"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = True
Case "0011"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = True
Case "1011"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = False
Case "0111"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = False
Case "1111"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = True
Case "0110"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = True
Case "1110"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = False
Case "0010"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = False
Case "1010"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = True
Case "1001"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = True
Case "0101"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = False
Case "1101"
BitByte(Info(cnt2), Bit1) = True
BitByte(Info(cnt2), Bit2) = False
Case "0001"
BitByte(Info(cnt2), Bit1) = False
BitByte(Info(cnt2), Bit2) = True
End Select
Next
Next
DeKrimpt = Info
End Function
Private Property Let BitByte(ByRef bThis As Byte, ByRef bBit As Byte, ByRef nValue As Boolean)
If (bThis And bBit) And (Not nValue) Then
bThis = bThis - bBit
ElseIf (Not (bThis And bBit)) And nValue Then
bThis = bThis Or bBit
End If
End Property
Private Property Get BitByte(ByRef bThis As Byte, ByRef bBit As Byte) As Boolean
BitByte = (bThis And bBit)
End Property
Last edited by nforystek; Nov 2nd, 2021 at 08:13 PM.
-
Nov 3rd, 2021, 05:21 AM
#6
Re: VB6 - Random GUID Generator
 Originally Posted by nforystek
(uses an encryption I wrote, it may use a book size key and put it to one byte if you reverse the password and data, useful for other encryption combos, it could be useful in SSL as a crimp check to non SSL web, so https has to match the http, and the crimp per website in a ring would tighten the allocated stress into small and large vice versa to another for a validity check, but I'm not that good, I don't even have it written in C, and dare I say that theory could allow VB to 100% serialize objects w/o knowing them, I dare say, my father is a bloat, busted his head spilling out customer data, they forced to arrive in a dream, well not really a dream but a unconscious state, force to be present to watch him fail security, just because I program, considerably present, I got to sit out actually see data, noted why VB obj can't serialize, RC+DS+NC=WON)
WAT? Is this some kind of AI chat-bot generated?
And no, EnKrimption is nowhere near SSL strength, nor even anything used in https and/or any reasonable computer-based crypto system.
cheers,
</wqw>
-
Nov 4th, 2021, 03:57 PM
#7
Junior Member
Re: VB6 - Random GUID Generator
Crimping was everywhere in the 80's it was way more powerful then the internet SSL it was AquaNet VSSL, (Vidal Salon Style by LO'REAL), best hair style ever too!
-
Nov 4th, 2021, 04:23 PM
#8
Re: VB6 - Random GUID Generator
Originally Posted by nforystek
Crimping was everywhere in the 80's it was way more powerful then the internet SSL it was AquaNet VSSL, (Vidal Salon Style by LO'REAL), best hair style ever too!
I don't know what's going on.
https://github.com/yereverluvinunclebert
Skillset: VMS,DOS,Windows Sysadmin from 1985, fault-tolerance, VaxCluster, Alpha,Sparc. DCL,QB,VBDOS- VB6,.NET, PHP,NODE.JS, Graphic Design, Project Manager, CMS, Quad Electronics. classic cars & m'bikes. Artist in water & oils. Historian.
By the power invested in me, all the threads I start are battle free zones - no arguing about the benefits of VB6 over .NET here please. Happiness must reign.
-
Nov 4th, 2021, 04:34 PM
#9
Re: VB6 - Random GUID Generator
Keep in mind that I'm not a VB6 developer, so I am not sure if a create GUID method exists and you're providing an alternative.
However, if such a method does not exist, wouldn't it be easier to simply leverage the HidD_GetHidGuid method (documentation)?
-
Nov 7th, 2021, 08:09 AM
#10
Re: VB6 - Random GUID Generator
Originally Posted by dday9
if such a method does not exist, wouldn't it be easier to simply leverage the HidD_GetHidGuid method ( documentation)?
This would give you a single, specific GUID - not a new (random and unique) one.
Pointing out existing APIs for that task is right of course - but that was done already in #2.
Olaf
-
Nov 8th, 2021, 12:25 PM
#11
Re: VB6 - Random GUID Generator
Originally Posted by Schmidt
This would give you a single, specific GUID - not a new (random and unique) one.
Pointing out existing APIs for that task is right of course - but that was done already in #2.
Olaf
You're correct that I referenced the wrong API, I misread the documentation.
-
Nov 8th, 2021, 11:45 PM
#12
Junior Member
Re: VB6 - Random GUID Generator
Originally Posted by wqweto
The 4 is deliberately placed at this location -- it marks the format of UUID generated. You can read the article in the Wikipedia for more info.
Co in CoCreateGuid comes from COM, not cooperative nor collocation nor corruption.
cheers,
</wqw>
I guess I still don't believe, here's why:
Their uniqueness does not depend on a central registration authority or coordination between the parties generating them, unlike most other numbering schemes. While the probability that a UUID will be duplicated is not zero, it is close enough to zero to be negligible
That doesn't make sense, like... "really?" I think what you have here is the difficulty and wide use of it, at the fault level of we need them to represent their acronym, GUID, or even UUID. The use of "Negligible" repeats the first mention about the probability is not zero duplication, then continues to say it is close enough to be that, the fault.
Also about the repeat, if you attempt other ways then what I posted, I found that, the most simple are always repeating somewhere in the visible strand sometimes large section by the "-" separator and if you try enough, down to one character is as close as you can get but lies that issue it's self is repeating a portion.
Um, if Co means com, which likely hood is, yeah I suppose your right, but why not the full last letter, and com is COM not Co like it's a beginning of a word longer. Also, in ole32, there isn't much com, as the advent of ole is sort of old school Com. For instance too, CoFreeUnusedLibraries, cooperative does the whole system's.
I'm not saying my generating is perfect, something that I tried, in also it must be random, was that I would not need to pad any hex conversion with a "0" so that each section would not start with "0's" first so it's just straight forward separated by section is a full hex value not just 1 byte at a time equals two hex character. That is something I know it must be, for some reason I just feel like it's right and I didn't achieve it.
Random is a hugely dependent thing on global in the CMOS timing. So it makes sense that it would act the same, in repeats, but even with CoCreateGuid the same will happen any way you try to do it thus far I noticed if just the type record manipulated to hex, I don't found pushing it around in that fashion with the global locks to be cure the repeat nature, and if you do run the examples, posted above on a straight repeat debug.print and vastly watch the trails go by it really impacts the thought different then repeat ones.
Oh but in all I think your probably telling me something that is said all over. HOWEVER, there is a little something that like makes me think people don't have information right and where possibly do you find information on it if people didn't develop it, i.e. what is "reserved" in a structure? Why does info not exist on what this really is? Feeling like it's for something just not now? Why is it there? Must be something like they got the interface and not the documentation and so that portion is just "reserved." Don't know. Is ole like that? from a operating system never found real you can get called OS2?
I was just being silly on that crimp reply, it's a hair iron for a hair style large with florescent jacket valley girls in the 90's. Not 80's oops.
-
Nov 8th, 2021, 11:58 PM
#13
Junior Member
Re: VB6 - Random GUID Generator
Check out the PoolID sample output (I think it is pretty cool, repeats when unloaded and loaded another object to generate but not if the same object stays in memory generating)
63-686D6F6-B6D68-6B-6C6C696A6A6C6B6D
6C6-36F63-6E6-F63-6A6C6A6A6363686963
E6D6A6C686C63-6B6A-6E6E-6B6D6A-6E696
69-6B6E-6D6-86B-6D6D6A6E6D6C6A6B6F69
636D636-F6C6-86B636-E6A6D-6F6D6F636D
6A6C-6E6A68-6868-686F-6A6A6F6863686A
86C69696C68686C6F-636-86-36A6F6A-6B6
B6A6A6D6E6868-636D-6B696B6-86-F68636
E6C6B6F6B6B6B-636A-69-636E6E-6A636D6
C686C6C6A636E636D6B68-696D6-A6-36-96
B69696B636B636A-6B-636-86368-6C6F6C6
6C6C-6A-6D6C6-B69-636D6E6B6E6D6E6F6D
C6A6E6D6D686F69-6A636-86-8636E6D-6D6
6C-6E686-36E6B-6A6D-6F6D6C6F686C696E
C696E69686E63-636-86E6-A63696-9686E6
686E-6C6E-6E6B6C6-C6B6A-696A68686D63
E6E6B6C686B6C6F-6C6C6-B6B6D69-6B6-B6
6A686A6-A6B6-B6B-6F6C-636B6C63636D6E
686B6F6-A6D-6A6-86D-6B6B696F6F6E6E6B
86F6B6E6E6D6C6D696D-686B-6D69-6C6-A6
6368686-36D-6B6F6E6-F6E6D-6A6F696D69
A6B636A6C6E6D-6D-686-E6C6D6F-696E6E6
6B-6A-696A6F-6C-6E6C6E696C6368636B6E
6E6-C686-36A6F6C-6A-636E6D696B6E6868
6C6-A686B63-6968-6E-6A6E69686E6D6D68
6D-6F686F6-B6E-63-6C6F6D6B68636C6363
686-B6-3686D-6C6C-6D6363686C6B6E6A6F
696D6-B686-96C696C-6C63-6B6863686F69
6F6-86F-68-6368-696E6B6E6D6E686C6B6E
6A6D-6D-6A6F696-F63-6F6E6A696F6C686B
3686E6C6A6B6D69-6F6-A696C6-36969-6B6
E6D6E6F6F6963-6B6F-6D6869-6F6F-6C6B6
6C-636D6-C6C-6C-686A6D6B6E6D6968686D
6B696F6-8636E-6C6E69-686D-6E696C6C6F
68686-B636B6-86C-6F-6E69686E6A686E6E
A6E6F6F6F6D6869-696-36B6363-696E-6B6
B6D696C636E6A63-6E-6C6F68-69636-96A6
6E696-86-F6F6-B6369-636863636B686F63
6F686F6-9696C6B-6F6C6-36B-636C6E6C6A
6C6C6-36E-6D696-C6C6E-6B6F696E696E6A
6C6B6-863636D-686B6-36C68-6F636B6A63
A686D6D6C686A-6F6E-6D-6D6F6B6-B6B6F6
6A6F636-D6A-6A6D-6F6A-6C696B6B6A686C
636E-6F6D-636E6D6-E6969-6A6963636C6B
6E636E6-86A6D-6D-6B-636C6A6A6C63696B
B686B6E686E6868686D-6D6-E6-C6-D69696
6A6963-686A6-F6D6-F636F-6B6A6C6A636D
96A6A636B6D696C63-6B6-36-86D6-A6B686
F6E6C636E686F6F6863-6A-6D69-686-B6E6
696C6E6-36E6F-6E6C686-A6E-6E6A6B6D6C
6F6A6F-6E696B6-96B6B6B-6B-6D636B6A6F
6A-6C69696-B6A-6E-6D6A6C6B686A686A6D
6C6C6D-6D6E-6B68696-D696D-6A636C696A
56D696D6D6A6A6766-6668-6B6B-646-D6A6
566646D6A656769-6B686-46A-6D6A-646B6
68-6A6A676-5686968-666B-6967646D646A
B67656A6D686D-64-686A646-768686-B686
4686A6666656967-6569-6B656A-6B6-D6B6
7646665686D6B64-6A6-D646A64-6B656-76
66A69686D6B-6666-696B6-96D6D6-569656
646B-666-566-6A-646B65676D6B6766666A
6A6968-64646-76-669-6B6469656D69646D
The rules on the dashes are can't be another dash under two characters from the edges or themselves.
-
Nov 11th, 2021, 09:57 AM
#14
Hyperactive Member
Re: VB6 - Random GUID Generator
here is my code:
Code:
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function CoCreateGuid Lib "ole32" (ptrGuid As Any) As Long
Private Declare Function StringFromGUID2 Lib "ole32" (rguid As Any, ByVal lpsz As Long, ByVal cchMax As Long) As Long
Public Function GetGUID() As String
Dim myGUID As GUID
CoCreateGuid myGUID
GetGUID = String$(38, vbNullChar)
StringFromGUID2 myGUID, StrPtr(GetGUID), 39
End Function
-
Nov 21st, 2021, 07:04 PM
#15
Lively Member
Re: VB6 - Random GUID Generator
Here is my guid code, its a small module that handles alot of different GUID needs.
Note that CoCreateGuid calls these api functions to create guids.
Code:
Option Explicit
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'same as guid
'note: if you have a reference to oleexp.tlb typelib you will need to comment this out
Public Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'NOTE: GUID,UUID,IID etc are all the same 16 byte data structure just with differing names
' and can be freely interchanged...
'these two are the same but the uuid's are name differently
Public Declare Function UuidCreate Lib "rpcrt4.dll" (pUUID As UUID) As Long
Public Declare Function GuidCreate Lib "rpcrt4.dll" Alias "UuidCreate" (pguid As GUID) As Long
'these two are the same but the uuid's are name differently
Public Declare Function UuidCreateSequential Lib "rpcrt4.dll" (pUUID As UUID) As Long
Public Declare Function GuidCreateSequential Lib "rpcrt4.dll" Alias "UuidCreateSequential" (pguid As GUID) As Long
Public Declare Function UuidCompare Lib "rpcrt4.dll" (pUuid1 As UUID, pUuid2 As UUID, ByRef Status As Long) As Long
Public Declare Function GuidCompare Lib "rpcrt4.dll" Alias "UuidCompare" (pGuid1 As GUID, pGuid2 As GUID, ByRef Status As Long) As Long
Public Declare Function UuidEqual Lib "rpcrt4.dll" (pUuid1 As UUID, pUuid2 As UUID, ByRef Status As Long) As Long
Public Declare Function GuidEqual Lib "rpcrt4.dll" Alias "UuidEqual" (pGuid1 As GUID, pGuid2 As GUID, ByRef Status As Long) As Long
Public Declare Function UuidFromString Lib "rpcrt4.dll" Alias "UuidFromStringA" (StringUuid As String, pUUID As UUID) As Long
Public Declare Function GuidFromString Lib "rpcrt4.dll" Alias "UuidFromStringA" (StringUuid As Long, pguid As GUID) As Long
Public Declare Function UuidHash Lib "rpcrt4.dll" (pUUID As UUID, Status As Long) As Integer
Public Declare Function GuidHash Lib "rpcrt4.dll" Alias "UuidHash" (pguid As GUID, Status As Long) As Integer
Public Declare Function UuidIsNil Lib "rpcrt4.dll" (pUUID As UUID, Status As Long) As Long
Public Declare Function GuidIsNil Lib "rpcrt4.dll" Alias "UuidIsNil" (pguid As GUID, Status As Long) As Long
'note: return string must be freed with rpcstringfree
Public Declare Function UuidToString Lib "rpcrt4.dll" Alias "UuidToStringA" (pUUID As UUID, StringUuid As Long) As Long
Public Declare Function GuidToString Lib "rpcrt4.dll" Alias "UuidToStringA" (pguid As GUID, StringUuid As Long) As Long
Public Declare Function RpcStringFree Lib "rpcrt4.dll" Alias "RpcStringFreeA" (pStr As Long) As Long
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) As Long
Public Declare Function IsEqualIID Lib "ole32" Alias "IsEqualGUID" (riid1 As UUID, riid2 As UUID) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
'set blnGlobalUnique to True if you absolutely need a unique guid to the planet (its slower)
Function CreateGUID(Optional ByVal blnGlobalUnique As Boolean) As GUID
Dim ret As Long
If blnGlobalUnique Then
ret = GuidCreate(CreateGUID)
Else
ret = GuidCreateSequential(CreateGUID)
End If
End Function
Function CreateUUID(Optional ByVal blnGlobalUnique As Boolean) As UUID
RtlMoveMemory CreateUUID, CreateGUID(blnGlobalUnique), Len(CreateUUID)
End Function
Function CreateGUIDString(Optional ByVal blnGlobalUnique As Boolean, Optional ByVal IncludeBraces As Boolean = True) As String
CreateGUIDString = VBGUIDToString(CreateGUID(blnGlobalUnique), IncludeBraces)
End Function
Function CreateUUIDString(Optional ByVal blnGlobalUnique As Boolean, Optional ByVal IncludeBraces As Boolean = True) As String
CreateUUIDString = VBGUIDToString(CreateGUID(blnGlobalUnique), IncludeBraces)
End Function
'VB only code for converting a guid to string (allows you to remove 4 api calls)
'just as fast as api version, use either as personal preference dictates
Public Function VBGUIDToString(pguid As GUID, Optional bIncludeBraces As Boolean = True) As String
'optimized version coded by Lewis Miller
'compiled app 1 million calls = .634 milliseconds
'i do have a fast machine so times will vary
Dim S As String
Dim L As Long 'saves 11 calls to Len()
'by precalculating positions we save 2 string concat operations
Dim Pos1 As Long, Pos2 As Long, Pos3 As Long, Pos4 As Long
Dim Pos5 As Long, Pos6 As Long, Pos7 As Long, Pos8 As Long
Dim Pos9 As Long, Pos10 As Long, Pos11 As Long, AddOn As Long
If bIncludeBraces Then
VBGUIDToString = "{00000000-0000-0000-0000-000000000000}"
AddOn = 1
Else
VBGUIDToString = "00000000-0000-0000-0000-000000000000"
End If
'we could put these in the If statement twice and save 11 Addition operations
'but adding 2 ints is so fast that is is pretty inconsequential and saves code space
Pos1 = 9 + AddOn
Pos2 = 14 + AddOn
Pos3 = 19 + AddOn
Pos4 = 22 + AddOn
Pos5 = 24 + AddOn
Pos6 = 27 + AddOn
Pos7 = 29 + AddOn
Pos8 = 31 + AddOn
Pos9 = 33 + AddOn
Pos10 = 35 + AddOn
Pos11 = 37 + AddOn
With pguid
S = Hex$(.Data1)
L = Len(S)
Mid(VBGUIDToString, Pos1 - L, L) = S
S = Hex$(.Data2)
L = Len(S)
Mid(VBGUIDToString, Pos2 - L, L) = S
S = Hex$(.Data3)
L = Len(S)
Mid(VBGUIDToString, Pos3 - L, L) = S
S = Hex$(.Data4(0))
L = Len(S)
Mid(VBGUIDToString, Pos4 - L, L) = S
S = Hex$(.Data4(1))
L = Len(S)
Mid(VBGUIDToString, Pos5 - L, L) = S
S = Hex$(.Data4(2))
L = Len(S)
Mid(VBGUIDToString, Pos6 - L, L) = S
S = Hex$(.Data4(3))
L = Len(S)
Mid(VBGUIDToString, Pos7 - L, L) = S
S = Hex$(.Data4(4))
L = Len(S)
Mid(VBGUIDToString, Pos8 - L, L) = S
S = Hex$(.Data4(5))
L = Len(S)
Mid(VBGUIDToString, Pos9 - L, L) = S
S = Hex$(.Data4(6))
L = Len(S)
Mid(VBGUIDToString, Pos10 - L, L) = S
S = Hex$(.Data4(7))
L = Len(S)
Mid(VBGUIDToString, Pos11 - L, L) = S
End With
End Function
'convert uuid to string, simply calls vbguidtostring
Public Function VBUUIDToString(pUUID As UUID, Optional bIncludeBraces As Boolean = True) As String
VBUUIDToString = VBGUIDToString(UUIDtoGUID(pUUID), bIncludeBraces)
End Function
'api version of convert guid to string, using the vb version allows you to remove 4 api calls
Public Function ApiGUIDToString(pguid As GUID, Optional ByVal bIncludeBraces As Boolean = True) As String
Dim ret As Long
Dim sPtr As Long
ret = GuidToString(pguid, sPtr)
'possible return values
' If RET = RPC_S_OK Then 'all good
' If RET = RPC_S_UUID_LOCAL_ONLY Then 'gauranteed local unique only
' If RET = RPC_S_UUID_NO_ADDRESS Then 'no MAC network address, not certain to be globaly unique
'we just check if a string was returned
If sPtr Then
ApiGUIDToString = Space$(lstrlen(sPtr))
RtlMoveMemory ByVal ApiGUIDToString, ByVal sPtr, Len(ApiGUIDToString)
Call RpcStringFree(sPtr)
End If
'note: not needed , string guids are case-insensitive
'ApiGuidToString = UCase$(ApiGuidToString)
If bIncludeBraces Then
ApiGUIDToString = "{" & ApiGUIDToString & "}"
End If
End Function
'convert uuid to string with api, calls apiguidtostring
Public Function ApiUUIDToString(pUUID As UUID, Optional ByVal bIncludeBraces As Boolean = True) As String
ApiUUIDToString = ApiGUIDToString(UUIDtoGUID(pUUID), bIncludeBraces)
End Function
'convert UUID to GUID and vice versa
Function GUIDtoUUID(pguid As GUID) As UUID
RtlMoveMemory GUIDtoUUID, pguid, Len(pguid)
End Function
Function UUIDtoGUID(pUUID As UUID) As GUID
RtlMoveMemory UUIDtoGUID, pUUID, Len(pUUID)
End Function
'uuidfromstring requires that there are no braces
Function ApiStringtoUUID(ByVal pStrUUID As String) As UUID
Dim ret As Long
If Left$(pStrUUID, 1) = "{" Then 'we can assume also a right brace
pStrUUID = Mid$(pStrUUID, 2, Len(pStrUUID) - 2)
End If
ret = UuidFromString(ByVal pStrUUID, ApiStringtoUUID)
End Function
Function ApiStringtoGUID(ByVal StrGUID As String) As GUID
ApiStringtoGUID = UUIDtoGUID(ApiStringtoUUID(StrGUID))
End Function
Last edited by vbLewis; Nov 21st, 2021 at 07:23 PM.
Reason: missing api call
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote
